mirror of
https://github.com/vishapoberon/compiler.git
synced 2026-04-06 07:32:24 +00:00
Fix line endings.
This commit is contained in:
David Brown
parent
c64a75bd78
commit
a9b273e30a
15 changed files with 5328 additions and 5328 deletions
File diff suppressed because it is too large
Load diff
|
|
@ -1,146 +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.
|
||||
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.
|
||||
|
|
|
|||
|
|
@ -1,447 +1,447 @@
|
|||
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).
|
||||
Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
|
||||
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;
|
||||
SProc* = 6; SFunc* = 7; Mod* = 8;
|
||||
|
||||
(* form values*)
|
||||
Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
|
||||
Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
|
||||
String* = 11; Array* = 12; Record* = 13;
|
||||
|
||||
TYPE Object* = POINTER TO ObjDesc;
|
||||
Module* = POINTER TO ModDesc;
|
||||
Type* = POINTER TO TypeDesc;
|
||||
|
||||
ObjDesc*= RECORD
|
||||
class*, lev*, exno*: INTEGER;
|
||||
expo*, rdo*: BOOLEAN; (*exported / read-only*)
|
||||
next*, dsc*: Object;
|
||||
type*: Type;
|
||||
name*: ORS.Ident;
|
||||
val*: LONGINT
|
||||
END ;
|
||||
|
||||
ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
|
||||
|
||||
TypeDesc* = RECORD
|
||||
form*, ref*, mno*: INTEGER; (*ref is only used for import/export*)
|
||||
nofpar*: INTEGER; (*for procedures, extension level for records*)
|
||||
len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*)
|
||||
dsc*, typobj*: Object;
|
||||
base*: Type; (*for arrays, records, pointers*)
|
||||
size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
|
||||
END ;
|
||||
|
||||
(* Object classes and the meaning of "val":
|
||||
class val
|
||||
----------
|
||||
Var address
|
||||
Par address
|
||||
Const value
|
||||
Fld offset
|
||||
Typ type descriptor (TD) address
|
||||
SProc inline code number
|
||||
SFunc inline code number
|
||||
Mod key
|
||||
|
||||
Type forms and the meaning of "dsc" and "base":
|
||||
form dsc base
|
||||
------------------------
|
||||
Pointer - type of dereferenced object
|
||||
Proc params result type
|
||||
Array - type of elements
|
||||
Record fields extension *)
|
||||
|
||||
VAR topScope*, universe, system*: Object;
|
||||
byteType*, boolType*, charType*: Type;
|
||||
intType*, realType*, setType*, nilType*, noType*, strType*: Type;
|
||||
nofmod, Ref: INTEGER;
|
||||
typtab: ARRAY maxTypTab OF Type;
|
||||
|
||||
PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*)
|
||||
VAR new, x: Object;
|
||||
BEGIN x := topScope;
|
||||
WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
|
||||
IF x.next = NIL THEN
|
||||
NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
|
||||
x.next := new; obj := new
|
||||
ELSE obj := x.next; ORS.Mark("mult def")
|
||||
END
|
||||
END NewObj;
|
||||
|
||||
PROCEDURE thisObj*(): Object;
|
||||
VAR s, x: Object;
|
||||
BEGIN s := topScope;
|
||||
REPEAT x := s.next;
|
||||
WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
|
||||
s := s.dsc
|
||||
UNTIL (x # NIL) OR (s = NIL);
|
||||
RETURN x
|
||||
END thisObj;
|
||||
|
||||
PROCEDURE thisimport*(mod: Object): Object;
|
||||
VAR obj: Object;
|
||||
BEGIN
|
||||
IF mod.rdo THEN
|
||||
IF mod.name[0] # 0X THEN
|
||||
obj := mod.dsc;
|
||||
WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
|
||||
ELSE obj := NIL
|
||||
END
|
||||
ELSE obj := NIL
|
||||
END ;
|
||||
RETURN obj
|
||||
END thisimport;
|
||||
|
||||
PROCEDURE thisfield*(rec: Type): Object;
|
||||
VAR fld: Object;
|
||||
BEGIN fld := rec.dsc;
|
||||
WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
|
||||
RETURN fld
|
||||
END thisfield;
|
||||
|
||||
PROCEDURE OpenScope*;
|
||||
VAR s: Object;
|
||||
BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
|
||||
END OpenScope;
|
||||
|
||||
PROCEDURE CloseScope*;
|
||||
BEGIN topScope := topScope.dsc
|
||||
END CloseScope;
|
||||
|
||||
(*------------------------------- Import ---------------------------------*)
|
||||
|
||||
PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
|
||||
VAR i, j: INTEGER;
|
||||
BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*)
|
||||
WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
|
||||
REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
|
||||
FName[i] := 0X
|
||||
END MakeFileName;
|
||||
|
||||
PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
|
||||
VAR mod: Module; obj, obj1: Object;
|
||||
BEGIN obj1 := topScope; obj := obj1.next; (*search for module*)
|
||||
WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
|
||||
IF obj = NIL THEN (*insert new module*)
|
||||
NEW(mod); mod.class := Mod; mod.rdo := FALSE;
|
||||
mod.name := name; mod.orgname := orgname; mod.val := key;
|
||||
mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
|
||||
obj1.next := mod; obj := mod
|
||||
ELSE (*module already present*)
|
||||
IF non THEN ORS.Mark("invalid import order") END
|
||||
END ;
|
||||
RETURN obj
|
||||
END ThisModule;
|
||||
|
||||
PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
|
||||
VAR b: BYTE;
|
||||
BEGIN Files.ReadByte(R, b);
|
||||
(*IF b < 80H THEN x := b ELSE x := 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);
|
||||
VAR key: LONGINT;
|
||||
ref, class, mno, form, np, readonly: INTEGER;
|
||||
new, fld, par, obj, mod, impmod: Object;
|
||||
t: Type;
|
||||
name, modname: ORS.Ident;
|
||||
BEGIN Read(R, ref);
|
||||
IF ref < 0 THEN T := typtab[-ref] (*already read*)
|
||||
ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
|
||||
Read(R, form); t.form := form;
|
||||
IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
|
||||
ELSIF form = Array THEN
|
||||
InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
|
||||
ELSIF form = Record THEN
|
||||
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.ReadNum(R, t.size);
|
||||
Read(R, class);
|
||||
WHILE class # 0 DO (*fields*)
|
||||
NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
|
||||
IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
|
||||
Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class)
|
||||
END ;
|
||||
t.dsc := obj
|
||||
ELSIF form = Proc THEN
|
||||
InType(R, thismod, t.base);
|
||||
obj := NIL; np := 0; Read(R, class);
|
||||
WHILE class # 0 DO (*parameters*)
|
||||
NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1;
|
||||
InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
|
||||
END ;
|
||||
t.dsc := obj; t.nofpar := np; t.size := 4
|
||||
END ;
|
||||
Files.ReadString(R, modname);
|
||||
IF modname[0] # 0X THEN (*re-import*)
|
||||
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.typobj := obj; T := t
|
||||
END ;
|
||||
typtab[ref] := T
|
||||
END
|
||||
END
|
||||
END InType;
|
||||
|
||||
PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
|
||||
VAR key: LONGINT; class, k: INTEGER;
|
||||
obj: Object; t: Type;
|
||||
thismod: Object;
|
||||
modname, fname: ORS.Ident;
|
||||
F: Files.File; R: Files.Rider;
|
||||
BEGIN
|
||||
IF modid1 = "SYSTEM" THEN
|
||||
thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
|
||||
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.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 ;
|
||||
Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
|
||||
InType(R, thismod, obj.type); obj.lev := -thismod.lev;
|
||||
IF class = Typ THEN
|
||||
t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*)
|
||||
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) ELSE Files.ReadNum(R, obj.val) END
|
||||
ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
|
||||
END
|
||||
END ;
|
||||
obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
|
||||
END ;
|
||||
ELSE ORS.Mark("import not available")
|
||||
END
|
||||
END
|
||||
END Import;
|
||||
|
||||
(*-------------------------------- Export ---------------------------------*)
|
||||
|
||||
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
|
||||
BEGIN
|
||||
(*Files.WriteByte(R, x)*)
|
||||
Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *)
|
||||
END Write;
|
||||
|
||||
PROCEDURE OutType(VAR R: Files.Rider; t: Type);
|
||||
VAR obj, mod, fld: Object;
|
||||
|
||||
PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
|
||||
VAR cl: INTEGER;
|
||||
BEGIN
|
||||
IF n > 0 THEN
|
||||
OutPar(R, par.next, n-1); cl := par.class;
|
||||
Write(R, cl);
|
||||
IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
|
||||
OutType(R, par.type)
|
||||
END
|
||||
END OutPar;
|
||||
|
||||
PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
|
||||
VAR fld: Object; i, n: LONGINT;
|
||||
BEGIN
|
||||
IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
|
||||
ELSIF typ.form = Record THEN fld := typ.dsc;
|
||||
WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
|
||||
ELSIF typ.form = Array THEN i := 0; n := typ.len;
|
||||
WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
|
||||
END
|
||||
END FindHiddenPointers;
|
||||
|
||||
BEGIN
|
||||
IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
|
||||
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 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 ;
|
||||
IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
|
||||
Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
|
||||
fld := t.dsc;
|
||||
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) (*offset*)
|
||||
END ;
|
||||
fld := fld.next
|
||||
END ;
|
||||
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.WriteString(R, obj.name)
|
||||
ELSE ORS.Mark("re-export not found"); Write(R, 0)
|
||||
END
|
||||
ELSE Write(R, 0)
|
||||
END
|
||||
END
|
||||
END OutType;
|
||||
|
||||
PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
|
||||
VAR x, sum, oldkey: LONGINT;
|
||||
obj, obj0: Object;
|
||||
filename: ORS.Ident;
|
||||
F, F1: Files.File; R, R1: Files.Rider;
|
||||
BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
|
||||
F := Files.New(filename); Files.Set(R, F, 0);
|
||||
Files.WriteInt(R, 0); (*placeholder*)
|
||||
Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
|
||||
Files.WriteString(R, modid); Write(R, versionkey);
|
||||
obj := topScope.next;
|
||||
WHILE obj # NIL DO
|
||||
IF obj.expo THEN
|
||||
Write(R, obj.class); Files.WriteString(R, obj.name);
|
||||
OutType(R, obj.type);
|
||||
IF obj.class = Typ THEN
|
||||
IF obj.type.form = Record THEN
|
||||
obj0 := topScope.next; (*check whether this is base of previously declared pointer types*)
|
||||
WHILE obj0 # obj DO
|
||||
IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
|
||||
obj0 := obj0.next
|
||||
END
|
||||
END ;
|
||||
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)
|
||||
ELSE Files.WriteNum(R, obj.val)
|
||||
END
|
||||
ELSIF obj.class = Var THEN
|
||||
Files.WriteNum(R, obj.exno);
|
||||
IF obj.type.form = String THEN
|
||||
Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H
|
||||
END
|
||||
END
|
||||
END ;
|
||||
obj := obj.next
|
||||
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; 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) ELSE oldkey := sum+1 END ;
|
||||
IF sum # oldkey THEN
|
||||
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
|
||||
END
|
||||
END Export;
|
||||
|
||||
PROCEDURE Init*;
|
||||
BEGIN topScope := universe; nofmod := 1
|
||||
END Init;
|
||||
|
||||
PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
|
||||
VAR tp: Type;
|
||||
BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
|
||||
typtab[ref] := tp; RETURN tp
|
||||
END type;
|
||||
|
||||
PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
|
||||
VAR obj: Object;
|
||||
BEGIN
|
||||
NEW(obj);
|
||||
(*obj.name := name; *)
|
||||
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;
|
||||
|
||||
BEGIN
|
||||
byteType := type(Byte, Int, 1);
|
||||
boolType := type(Bool, Bool, 1);
|
||||
charType := type(Char, Char,1);
|
||||
intType := type(Int, Int, 4);
|
||||
realType := type(Real, Real, 4);
|
||||
setType := type(Set, Set,4);
|
||||
nilType := type(NilTyp, NilTyp, 4);
|
||||
noType := type(NoTyp, NoTyp, 4);
|
||||
strType := type(String, String, 8);
|
||||
|
||||
(*initialize universe with data types and in-line procedures;
|
||||
LONGINT is synonym to INTEGER, LONGREAL to REAL.
|
||||
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);
|
||||
enter("ADC", SFunc, intType, 112);
|
||||
enter("ROR", SFunc, intType, 92);
|
||||
enter("ASR", SFunc, intType, 82);
|
||||
enter("LSL", SFunc, intType, 72);
|
||||
enter("LEN", SFunc, intType, 61);
|
||||
enter("CHR", SFunc, charType, 51);
|
||||
enter("ORD", SFunc, intType, 41);
|
||||
enter("FLT", SFunc, realType, 31);
|
||||
enter("FLOOR", SFunc, intType, 21);
|
||||
enter("ODD", SFunc, boolType, 11);
|
||||
enter("ABS", SFunc, intType, 1);
|
||||
enter("LED", SProc, noType, 81); (*procedures*)
|
||||
enter("UNPK", SProc, noType, 72);
|
||||
enter("PACK", SProc, noType, 62);
|
||||
enter("NEW", SProc, noType, 51);
|
||||
enter("ASSERT", SProc, noType, 41);
|
||||
enter("EXCL", SProc, noType, 32);
|
||||
enter("INCL", SProc, noType, 22);
|
||||
enter("DEC", SProc, noType, 11);
|
||||
enter("INC", SProc, noType, 1);
|
||||
enter("SET", Typ, setType, 0); (*types*)
|
||||
enter("BOOLEAN", Typ, boolType, 0);
|
||||
enter("BYTE", Typ, byteType, 0);
|
||||
enter("CHAR", Typ, charType, 0);
|
||||
enter("LONGREAL", Typ, realType, 0);
|
||||
enter("REAL", Typ, realType, 0);
|
||||
enter("LONGINT", Typ, intType, 0);
|
||||
enter("INTEGER", Typ, intType, 0);
|
||||
topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
|
||||
|
||||
system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*)
|
||||
enter("H", SFunc, intType, 201); (*functions*)
|
||||
enter("COND", SFunc, boolType, 191);
|
||||
enter("SIZE", SFunc, intType, 181);
|
||||
enter("ADR", SFunc, intType, 171);
|
||||
enter("VAL", SFunc, intType, 162);
|
||||
enter("REG", SFunc, intType, 151);
|
||||
enter("BIT", SFunc, boolType, 142);
|
||||
enter("LDREG", SProc, noType, 142); (*procedures*)
|
||||
enter("LDPSR", SProc, noType, 131);
|
||||
enter("COPY", SProc, noType, 123);
|
||||
enter("PUT", SProc, noType, 112);
|
||||
enter("GET", SProc, noType, 102);
|
||||
END ORB.
|
||||
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).
|
||||
Handling of import and export, i.e. reading and writing of "symbol files" is done by procedures
|
||||
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;
|
||||
SProc* = 6; SFunc* = 7; Mod* = 8;
|
||||
|
||||
(* form values*)
|
||||
Byte* = 1; Bool* = 2; Char* = 3; Int* = 4; Real* = 5; Set* = 6;
|
||||
Pointer* = 7; NilTyp* = 8; NoTyp* = 9; Proc* = 10;
|
||||
String* = 11; Array* = 12; Record* = 13;
|
||||
|
||||
TYPE Object* = POINTER TO ObjDesc;
|
||||
Module* = POINTER TO ModDesc;
|
||||
Type* = POINTER TO TypeDesc;
|
||||
|
||||
ObjDesc*= RECORD
|
||||
class*, lev*, exno*: INTEGER;
|
||||
expo*, rdo*: BOOLEAN; (*exported / read-only*)
|
||||
next*, dsc*: Object;
|
||||
type*: Type;
|
||||
name*: ORS.Ident;
|
||||
val*: LONGINT
|
||||
END ;
|
||||
|
||||
ModDesc* = RECORD (ObjDesc) orgname*: ORS.Ident END ;
|
||||
|
||||
TypeDesc* = RECORD
|
||||
form*, ref*, mno*: INTEGER; (*ref is only used for import/export*)
|
||||
nofpar*: INTEGER; (*for procedures, extension level for records*)
|
||||
len*: LONGINT; (*for arrays, len < 0 => open array; for records: adr of descriptor*)
|
||||
dsc*, typobj*: Object;
|
||||
base*: Type; (*for arrays, records, pointers*)
|
||||
size*: LONGINT; (*in bytes; always multiple of 4, except for Byte, Bool and Char*)
|
||||
END ;
|
||||
|
||||
(* Object classes and the meaning of "val":
|
||||
class val
|
||||
----------
|
||||
Var address
|
||||
Par address
|
||||
Const value
|
||||
Fld offset
|
||||
Typ type descriptor (TD) address
|
||||
SProc inline code number
|
||||
SFunc inline code number
|
||||
Mod key
|
||||
|
||||
Type forms and the meaning of "dsc" and "base":
|
||||
form dsc base
|
||||
------------------------
|
||||
Pointer - type of dereferenced object
|
||||
Proc params result type
|
||||
Array - type of elements
|
||||
Record fields extension *)
|
||||
|
||||
VAR topScope*, universe, system*: Object;
|
||||
byteType*, boolType*, charType*: Type;
|
||||
intType*, realType*, setType*, nilType*, noType*, strType*: Type;
|
||||
nofmod, Ref: INTEGER;
|
||||
typtab: ARRAY maxTypTab OF Type;
|
||||
|
||||
PROCEDURE NewObj*(VAR obj: Object; id: ORS.Ident; class: INTEGER); (*insert new Object with name id*)
|
||||
VAR new, x: Object;
|
||||
BEGIN x := topScope;
|
||||
WHILE (x.next # NIL) & (x.next.name # id) DO x := x.next END ;
|
||||
IF x.next = NIL THEN
|
||||
NEW(new); new.name := id; new.class := class; new.next := NIL; new.rdo := FALSE; new.dsc := NIL;
|
||||
x.next := new; obj := new
|
||||
ELSE obj := x.next; ORS.Mark("mult def")
|
||||
END
|
||||
END NewObj;
|
||||
|
||||
PROCEDURE thisObj*(): Object;
|
||||
VAR s, x: Object;
|
||||
BEGIN s := topScope;
|
||||
REPEAT x := s.next;
|
||||
WHILE (x # NIL) & (x.name # ORS.id) DO x := x.next END ;
|
||||
s := s.dsc
|
||||
UNTIL (x # NIL) OR (s = NIL);
|
||||
RETURN x
|
||||
END thisObj;
|
||||
|
||||
PROCEDURE thisimport*(mod: Object): Object;
|
||||
VAR obj: Object;
|
||||
BEGIN
|
||||
IF mod.rdo THEN
|
||||
IF mod.name[0] # 0X THEN
|
||||
obj := mod.dsc;
|
||||
WHILE (obj # NIL) & (obj.name # ORS.id) DO obj := obj.next END
|
||||
ELSE obj := NIL
|
||||
END
|
||||
ELSE obj := NIL
|
||||
END ;
|
||||
RETURN obj
|
||||
END thisimport;
|
||||
|
||||
PROCEDURE thisfield*(rec: Type): Object;
|
||||
VAR fld: Object;
|
||||
BEGIN fld := rec.dsc;
|
||||
WHILE (fld # NIL) & (fld.name # ORS.id) DO fld := fld.next END ;
|
||||
RETURN fld
|
||||
END thisfield;
|
||||
|
||||
PROCEDURE OpenScope*;
|
||||
VAR s: Object;
|
||||
BEGIN NEW(s); s.class := Head; s.dsc := topScope; s.next := NIL; topScope := s
|
||||
END OpenScope;
|
||||
|
||||
PROCEDURE CloseScope*;
|
||||
BEGIN topScope := topScope.dsc
|
||||
END CloseScope;
|
||||
|
||||
(*------------------------------- Import ---------------------------------*)
|
||||
|
||||
PROCEDURE MakeFileName*(VAR FName: ORS.Ident; name, ext: ARRAY OF CHAR);
|
||||
VAR i, j: INTEGER;
|
||||
BEGIN i := 0; j := 0; (*assume name suffix less than 4 characters*)
|
||||
WHILE (i < ORS.IdLen-5) & (name[i] > 0X) DO FName[i] := name[i]; INC(i) END ;
|
||||
REPEAT FName[i]:= ext[j]; INC(i); INC(j) UNTIL ext[j] = 0X;
|
||||
FName[i] := 0X
|
||||
END MakeFileName;
|
||||
|
||||
PROCEDURE ThisModule(name, orgname: ORS.Ident; non: BOOLEAN; key: LONGINT): Object;
|
||||
VAR mod: Module; obj, obj1: Object;
|
||||
BEGIN obj1 := topScope; obj := obj1.next; (*search for module*)
|
||||
WHILE (obj # NIL) & (obj.name # name) DO obj1 := obj; obj := obj1.next END ;
|
||||
IF obj = NIL THEN (*insert new module*)
|
||||
NEW(mod); mod.class := Mod; mod.rdo := FALSE;
|
||||
mod.name := name; mod.orgname := orgname; mod.val := key;
|
||||
mod.lev := nofmod; INC(nofmod); mod.type := noType; mod.dsc := NIL; mod.next := NIL;
|
||||
obj1.next := mod; obj := mod
|
||||
ELSE (*module already present*)
|
||||
IF non THEN ORS.Mark("invalid import order") END
|
||||
END ;
|
||||
RETURN obj
|
||||
END ThisModule;
|
||||
|
||||
PROCEDURE Read(VAR R: Files.Rider; VAR x: INTEGER);
|
||||
VAR b: BYTE;
|
||||
BEGIN Files.ReadByte(R, b);
|
||||
(*IF b < 80H THEN x := b ELSE x := 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);
|
||||
VAR key: LONGINT;
|
||||
ref, class, mno, form, np, readonly: INTEGER;
|
||||
new, fld, par, obj, mod, impmod: Object;
|
||||
t: Type;
|
||||
name, modname: ORS.Ident;
|
||||
BEGIN Read(R, ref);
|
||||
IF ref < 0 THEN T := typtab[-ref] (*already read*)
|
||||
ELSE NEW(t); T := t; typtab[ref] := t; t.mno := thismod.lev;
|
||||
Read(R, form); t.form := form;
|
||||
IF form = Pointer THEN InType(R, thismod, t.base); t.size := 4
|
||||
ELSIF form = Array THEN
|
||||
InType(R, thismod, t.base); Files.ReadNum(R, t.len); Files.ReadNum(R, t.size)
|
||||
ELSIF form = Record THEN
|
||||
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.ReadNum(R, t.size);
|
||||
Read(R, class);
|
||||
WHILE class # 0 DO (*fields*)
|
||||
NEW(fld); fld.class := class; Files.ReadString(R, fld.name);
|
||||
IF fld.name[0] # 0X THEN fld.expo := TRUE; InType(R, thismod, fld.type) ELSE fld.expo := FALSE; fld.type := nilType END ;
|
||||
Files.ReadNum(R, fld.val); fld.next := obj; obj := fld; Read(R, class)
|
||||
END ;
|
||||
t.dsc := obj
|
||||
ELSIF form = Proc THEN
|
||||
InType(R, thismod, t.base);
|
||||
obj := NIL; np := 0; Read(R, class);
|
||||
WHILE class # 0 DO (*parameters*)
|
||||
NEW(par); par.class := class; Read(R, readonly); par.rdo := readonly = 1;
|
||||
InType(R, thismod, par.type); par.next := obj; obj := par; INC(np); Read(R, class)
|
||||
END ;
|
||||
t.dsc := obj; t.nofpar := np; t.size := 4
|
||||
END ;
|
||||
Files.ReadString(R, modname);
|
||||
IF modname[0] # 0X THEN (*re-import*)
|
||||
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.typobj := obj; T := t
|
||||
END ;
|
||||
typtab[ref] := T
|
||||
END
|
||||
END
|
||||
END InType;
|
||||
|
||||
PROCEDURE Import*(VAR modid, modid1: ORS.Ident);
|
||||
VAR key: LONGINT; class, k: INTEGER;
|
||||
obj: Object; t: Type;
|
||||
thismod: Object;
|
||||
modname, fname: ORS.Ident;
|
||||
F: Files.File; R: Files.Rider;
|
||||
BEGIN
|
||||
IF modid1 = "SYSTEM" THEN
|
||||
thismod := ThisModule(modid, modid1, TRUE, key); DEC(nofmod);
|
||||
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.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 ;
|
||||
Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
NEW(obj); obj.class := class; Files.ReadString(R, obj.name);
|
||||
InType(R, thismod, obj.type); obj.lev := -thismod.lev;
|
||||
IF class = Typ THEN
|
||||
t := obj.type; t.typobj := obj; Read(R, k); (*fixup bases of previously declared pointer types*)
|
||||
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) ELSE Files.ReadNum(R, obj.val) END
|
||||
ELSIF class = Var THEN Files.ReadNum(R, obj.val); obj.rdo := TRUE
|
||||
END
|
||||
END ;
|
||||
obj.next := thismod.dsc; thismod.dsc := obj; Read(R, class)
|
||||
END ;
|
||||
ELSE ORS.Mark("import not available")
|
||||
END
|
||||
END
|
||||
END Import;
|
||||
|
||||
(*-------------------------------- Export ---------------------------------*)
|
||||
|
||||
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
|
||||
BEGIN
|
||||
(*Files.WriteByte(R, x)*)
|
||||
Files.WriteByte(R, SHORT(SHORT(x))) (* voc adaptation by noch *)
|
||||
END Write;
|
||||
|
||||
PROCEDURE OutType(VAR R: Files.Rider; t: Type);
|
||||
VAR obj, mod, fld: Object;
|
||||
|
||||
PROCEDURE OutPar(VAR R: Files.Rider; par: Object; n: INTEGER);
|
||||
VAR cl: INTEGER;
|
||||
BEGIN
|
||||
IF n > 0 THEN
|
||||
OutPar(R, par.next, n-1); cl := par.class;
|
||||
Write(R, cl);
|
||||
IF par.rdo THEN Write(R, 1) ELSE Write(R, 0) END ;
|
||||
OutType(R, par.type)
|
||||
END
|
||||
END OutPar;
|
||||
|
||||
PROCEDURE FindHiddenPointers(VAR R: Files.Rider; typ: Type; offset: LONGINT);
|
||||
VAR fld: Object; i, n: LONGINT;
|
||||
BEGIN
|
||||
IF (typ.form = Pointer) OR (typ.form = NilTyp) THEN Write(R, Fld); Write(R, 0); Files.WriteNum(R, offset)
|
||||
ELSIF typ.form = Record THEN fld := typ.dsc;
|
||||
WHILE fld # NIL DO FindHiddenPointers(R, fld.type, fld.val + offset); fld := fld.next END
|
||||
ELSIF typ.form = Array THEN i := 0; n := typ.len;
|
||||
WHILE i < n DO FindHiddenPointers(R, typ.base, typ.base.size * i + offset); INC(i) END
|
||||
END
|
||||
END FindHiddenPointers;
|
||||
|
||||
BEGIN
|
||||
IF t.ref > 0 THEN (*type was already output*) Write(R, -t.ref)
|
||||
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 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 ;
|
||||
IF obj # NIL THEN Files.WriteNum(R, obj.exno) ELSE Write(R, 0) END ;
|
||||
Files.WriteNum(R, t.nofpar); Files.WriteNum(R, t.size);
|
||||
fld := t.dsc;
|
||||
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) (*offset*)
|
||||
END ;
|
||||
fld := fld.next
|
||||
END ;
|
||||
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.WriteString(R, obj.name)
|
||||
ELSE ORS.Mark("re-export not found"); Write(R, 0)
|
||||
END
|
||||
ELSE Write(R, 0)
|
||||
END
|
||||
END
|
||||
END OutType;
|
||||
|
||||
PROCEDURE Export*(VAR modid: ORS.Ident; VAR newSF: BOOLEAN; VAR key: LONGINT);
|
||||
VAR x, sum, oldkey: LONGINT;
|
||||
obj, obj0: Object;
|
||||
filename: ORS.Ident;
|
||||
F, F1: Files.File; R, R1: Files.Rider;
|
||||
BEGIN Ref := Record + 1; MakeFileName(filename, modid, ".smb");
|
||||
F := Files.New(filename); Files.Set(R, F, 0);
|
||||
Files.WriteInt(R, 0); (*placeholder*)
|
||||
Files.WriteInt(R, 0); (*placeholder for key to be inserted at the end*)
|
||||
Files.WriteString(R, modid); Write(R, versionkey);
|
||||
obj := topScope.next;
|
||||
WHILE obj # NIL DO
|
||||
IF obj.expo THEN
|
||||
Write(R, obj.class); Files.WriteString(R, obj.name);
|
||||
OutType(R, obj.type);
|
||||
IF obj.class = Typ THEN
|
||||
IF obj.type.form = Record THEN
|
||||
obj0 := topScope.next; (*check whether this is base of previously declared pointer types*)
|
||||
WHILE obj0 # obj DO
|
||||
IF (obj0.type.form = Pointer) & (obj0.type.base = obj.type) & (obj0.type.ref > 0) THEN Write(R, obj0.type.ref) END ;
|
||||
obj0 := obj0.next
|
||||
END
|
||||
END ;
|
||||
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)
|
||||
ELSE Files.WriteNum(R, obj.val)
|
||||
END
|
||||
ELSIF obj.class = Var THEN
|
||||
Files.WriteNum(R, obj.exno);
|
||||
IF obj.type.form = String THEN
|
||||
Files.WriteNum(R, obj.val DIV 10000H); obj.val := obj.val MOD 10000H
|
||||
END
|
||||
END
|
||||
END ;
|
||||
obj := obj.next
|
||||
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; 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) ELSE oldkey := sum+1 END ;
|
||||
IF sum # oldkey THEN
|
||||
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
|
||||
END
|
||||
END Export;
|
||||
|
||||
PROCEDURE Init*;
|
||||
BEGIN topScope := universe; nofmod := 1
|
||||
END Init;
|
||||
|
||||
PROCEDURE type(ref, form: INTEGER; size: LONGINT): Type;
|
||||
VAR tp: Type;
|
||||
BEGIN NEW(tp); tp.form := form; tp.size := size; tp.ref := ref; tp.base := NIL;
|
||||
typtab[ref] := tp; RETURN tp
|
||||
END type;
|
||||
|
||||
PROCEDURE enter(name: ARRAY OF CHAR; cl: INTEGER; type: Type; n: LONGINT);
|
||||
VAR obj: Object;
|
||||
BEGIN
|
||||
NEW(obj);
|
||||
(*obj.name := name; *)
|
||||
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;
|
||||
|
||||
BEGIN
|
||||
byteType := type(Byte, Int, 1);
|
||||
boolType := type(Bool, Bool, 1);
|
||||
charType := type(Char, Char,1);
|
||||
intType := type(Int, Int, 4);
|
||||
realType := type(Real, Real, 4);
|
||||
setType := type(Set, Set,4);
|
||||
nilType := type(NilTyp, NilTyp, 4);
|
||||
noType := type(NoTyp, NoTyp, 4);
|
||||
strType := type(String, String, 8);
|
||||
|
||||
(*initialize universe with data types and in-line procedures;
|
||||
LONGINT is synonym to INTEGER, LONGREAL to REAL.
|
||||
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);
|
||||
enter("ADC", SFunc, intType, 112);
|
||||
enter("ROR", SFunc, intType, 92);
|
||||
enter("ASR", SFunc, intType, 82);
|
||||
enter("LSL", SFunc, intType, 72);
|
||||
enter("LEN", SFunc, intType, 61);
|
||||
enter("CHR", SFunc, charType, 51);
|
||||
enter("ORD", SFunc, intType, 41);
|
||||
enter("FLT", SFunc, realType, 31);
|
||||
enter("FLOOR", SFunc, intType, 21);
|
||||
enter("ODD", SFunc, boolType, 11);
|
||||
enter("ABS", SFunc, intType, 1);
|
||||
enter("LED", SProc, noType, 81); (*procedures*)
|
||||
enter("UNPK", SProc, noType, 72);
|
||||
enter("PACK", SProc, noType, 62);
|
||||
enter("NEW", SProc, noType, 51);
|
||||
enter("ASSERT", SProc, noType, 41);
|
||||
enter("EXCL", SProc, noType, 32);
|
||||
enter("INCL", SProc, noType, 22);
|
||||
enter("DEC", SProc, noType, 11);
|
||||
enter("INC", SProc, noType, 1);
|
||||
enter("SET", Typ, setType, 0); (*types*)
|
||||
enter("BOOLEAN", Typ, boolType, 0);
|
||||
enter("BYTE", Typ, byteType, 0);
|
||||
enter("CHAR", Typ, charType, 0);
|
||||
enter("LONGREAL", Typ, realType, 0);
|
||||
enter("REAL", Typ, realType, 0);
|
||||
enter("LONGINT", Typ, intType, 0);
|
||||
enter("INTEGER", Typ, intType, 0);
|
||||
topScope := NIL; OpenScope; topScope.next := system; universe := topScope;
|
||||
|
||||
system := NIL; (* initialize "unsafe" pseudo-module SYSTEM*)
|
||||
enter("H", SFunc, intType, 201); (*functions*)
|
||||
enter("COND", SFunc, boolType, 191);
|
||||
enter("SIZE", SFunc, intType, 181);
|
||||
enter("ADR", SFunc, intType, 171);
|
||||
enter("VAL", SFunc, intType, 162);
|
||||
enter("REG", SFunc, intType, 151);
|
||||
enter("BIT", SFunc, boolType, 142);
|
||||
enter("LDREG", SProc, noType, 142); (*procedures*)
|
||||
enter("LDPSR", SProc, noType, 131);
|
||||
enter("COPY", SProc, noType, 123);
|
||||
enter("PUT", SProc, noType, 112);
|
||||
enter("GET", SProc, noType, 102);
|
||||
END ORB.
|
||||
|
|
|
|||
2268
src/voc07R/ORG.Mod
2268
src/voc07R/ORG.Mod
File diff suppressed because it is too large
Load diff
1994
src/voc07R/ORP.Mod
1994
src/voc07R/ORP.Mod
File diff suppressed because it is too large
Load diff
|
|
@ -1,325 +1,325 @@
|
|||
MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*)
|
||||
IMPORT SYSTEM, Texts := CompatTexts, Oberon; (* CompatTexts is voc adaptation by noch *)
|
||||
|
||||
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.
|
||||
Recognises all Oberon keywords and skips comments. The keywords are
|
||||
recorded in a table.
|
||||
Get(sym) delivers next symbol from input text with Reader R.
|
||||
Mark(msg) records error and delivers error message with Writer W.
|
||||
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;
|
||||
NKW = 34; (*nof keywords*)
|
||||
maxExp = 38; stringBufSize = 256;
|
||||
|
||||
(*lexical symbols*)
|
||||
null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
|
||||
and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
|
||||
neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
|
||||
in* = 15; is* = 16; arrow* = 17; period* = 18;
|
||||
char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
|
||||
nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
|
||||
lbrace* = 30; ident* = 31;
|
||||
if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
|
||||
comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
|
||||
rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
|
||||
to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;
|
||||
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;
|
||||
|
||||
TYPE Ident* = ARRAY IdLen OF CHAR;
|
||||
|
||||
VAR ival*, slen*: LONGINT; (*results of Get*)
|
||||
rval*: REAL;
|
||||
id*: Ident; (*for identifiers*)
|
||||
str*: ARRAY stringBufSize OF CHAR;
|
||||
errcnt*: INTEGER;
|
||||
|
||||
ch: CHAR; (*last character read*)
|
||||
errpos: LONGINT;
|
||||
R: Texts.Reader;
|
||||
W: Texts.Writer;
|
||||
k: INTEGER;
|
||||
KWX: ARRAY 10 OF INTEGER;
|
||||
keyTab: ARRAY NKW OF
|
||||
RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
|
||||
|
||||
PROCEDURE CopyId*(VAR ident: Ident);
|
||||
BEGIN ident := id
|
||||
END CopyId;
|
||||
|
||||
PROCEDURE Pos*(): LONGINT;
|
||||
BEGIN RETURN Texts.Pos(R) - 1
|
||||
END Pos;
|
||||
|
||||
PROCEDURE Mark*(msg: ARRAY OF CHAR);
|
||||
VAR p: LONGINT;
|
||||
BEGIN p := Pos();
|
||||
IF (p > errpos) & (errcnt < 25) THEN
|
||||
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; (* voc adaptation by noch *)
|
||||
END ;
|
||||
INC(errcnt); errpos := p + 4
|
||||
END Mark;
|
||||
|
||||
PROCEDURE Identifier(VAR sym: INTEGER);
|
||||
VAR i, k: INTEGER;
|
||||
BEGIN i := 0;
|
||||
REPEAT
|
||||
IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
|
||||
Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
|
||||
id[i] := 0X;
|
||||
IF i < 10 THEN k := KWX[i-1]; (*search for keyword*)
|
||||
WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
|
||||
IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
|
||||
ELSE sym := ident
|
||||
END
|
||||
END Identifier;
|
||||
|
||||
PROCEDURE String;
|
||||
VAR i: INTEGER;
|
||||
BEGIN i := 0; Texts.Read(R, ch);
|
||||
WHILE ~R.eot & (ch # 22X) DO
|
||||
IF ch >= " " THEN
|
||||
IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
END ;
|
||||
str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
|
||||
END String;
|
||||
|
||||
PROCEDURE HexString;
|
||||
VAR i, m, n: INTEGER;
|
||||
BEGIN i := 0; Texts.Read(R, ch);
|
||||
WHILE ~R.eot & (ch # "$") DO
|
||||
WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*)
|
||||
IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
|
||||
ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
|
||||
ELSE m := 0; Mark("hexdig expected")
|
||||
END ;
|
||||
Texts.Read(R, ch);
|
||||
IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
|
||||
ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
|
||||
ELSE n := 0; Mark("hexdig expected")
|
||||
END ;
|
||||
IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
|
||||
Texts.Read(R, ch)
|
||||
END ;
|
||||
Texts.Read(R, ch); slen := i (*no 0X appended!*)
|
||||
END HexString;
|
||||
|
||||
PROCEDURE Ten(e: LONGINT): REAL;
|
||||
VAR x, t: REAL;
|
||||
BEGIN x := 1.0; t := 10.0;
|
||||
WHILE e > 0 DO
|
||||
IF ODD(e) THEN x := t * x END ;
|
||||
t := t * t; e := e DIV 2
|
||||
END ;
|
||||
RETURN x
|
||||
END Ten;
|
||||
|
||||
PROCEDURE Number(VAR sym: INTEGER);
|
||||
CONST max = 2147483647 (*2^31 - 1*);
|
||||
VAR i, k, e, n, s, h: LONGINT; x: REAL;
|
||||
d: ARRAY 16 OF INTEGER;
|
||||
negE: BOOLEAN;
|
||||
BEGIN ival := 0; i := 0; n := 0; k := 0;
|
||||
REPEAT
|
||||
IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
|
||||
Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
|
||||
IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*)
|
||||
REPEAT h := d[i];
|
||||
IF h >= 10 THEN h := h-7 END ;
|
||||
k := k*10H + h; INC(i) (*no overflow check*)
|
||||
UNTIL i = n;
|
||||
IF ch = "X" THEN sym := char;
|
||||
IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
|
||||
ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
|
||||
ELSE sym := int; ival := k
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
ELSIF ch = "." THEN
|
||||
Texts.Read(R, ch);
|
||||
IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*)
|
||||
REPEAT
|
||||
IF d[i] < 10 THEN
|
||||
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*)
|
||||
(*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 ;
|
||||
IF (ch = "E") OR (ch = "D") THEN (*scale factor*)
|
||||
Texts.Read(R, ch); s := 0;
|
||||
IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
|
||||
ELSE negE := FALSE;
|
||||
IF ch = "+" THEN Texts.Read(R, ch) END
|
||||
END ;
|
||||
IF (ch >= "0") & (ch <= "9") THEN
|
||||
REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch >"9");
|
||||
IF negE THEN e := e-s ELSE e := e+s END
|
||||
ELSE Mark("digit?")
|
||||
END
|
||||
END ;
|
||||
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; Mark("too large") END
|
||||
END ;
|
||||
sym := real; rval := x
|
||||
END
|
||||
ELSE (*decimal integer*)
|
||||
REPEAT
|
||||
IF d[i] < 10 THEN
|
||||
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
|
||||
END
|
||||
END Number;
|
||||
|
||||
PROCEDURE comment;
|
||||
BEGIN Texts.Read(R, ch);
|
||||
REPEAT
|
||||
WHILE ~R.eot & (ch # "*") DO
|
||||
IF ch = "(" THEN Texts.Read(R, ch);
|
||||
IF ch = "*" THEN comment END
|
||||
ELSE Texts.Read(R, ch)
|
||||
END
|
||||
END ;
|
||||
WHILE ch = "*" DO Texts.Read(R, ch) END
|
||||
UNTIL (ch = ")") OR R.eot;
|
||||
IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
|
||||
END comment;
|
||||
|
||||
PROCEDURE Get*(VAR sym: INTEGER);
|
||||
BEGIN
|
||||
REPEAT
|
||||
WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
|
||||
IF ch < "A" THEN
|
||||
IF ch < "0" THEN
|
||||
IF ch = 22X THEN String; sym := string
|
||||
ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
|
||||
ELSIF ch = "$" THEN HexString; sym := string
|
||||
ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
|
||||
ELSIF ch = "(" THEN Texts.Read(R, ch);
|
||||
IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
|
||||
ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
|
||||
ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
|
||||
ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
|
||||
ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
|
||||
ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
|
||||
ELSIF ch = "." THEN Texts.Read(R, ch);
|
||||
IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
|
||||
ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
|
||||
ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
|
||||
END
|
||||
ELSIF ch < ":" THEN Number(sym)
|
||||
ELSIF ch = ":" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END
|
||||
ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
|
||||
ELSIF ch = "<" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
|
||||
ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
|
||||
ELSIF ch = ">" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
|
||||
ELSE (* ? @ *) Texts.Read(R, ch); sym := null
|
||||
END
|
||||
ELSIF ch < "[" THEN Identifier(sym)
|
||||
ELSIF ch < "a" THEN
|
||||
IF ch = "[" THEN sym := lbrak
|
||||
ELSIF ch = "]" THEN sym := rbrak
|
||||
ELSIF ch = "^" THEN sym := arrow
|
||||
ELSE (* _ ` *) sym := null
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
ELSIF ch < "{" THEN Identifier(sym) ELSE
|
||||
IF ch = "{" THEN sym := lbrace
|
||||
ELSIF ch = "}" THEN sym := rbrace
|
||||
ELSIF ch = "|" THEN sym := bar
|
||||
ELSIF ch = "~" THEN sym := not
|
||||
ELSIF ch = 7FX THEN sym := upto
|
||||
ELSE sym := null
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
END
|
||||
UNTIL sym # null
|
||||
END Get;
|
||||
|
||||
PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
|
||||
BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
|
||||
END Init;
|
||||
|
||||
PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
|
||||
BEGIN
|
||||
(*keyTab[k].id := name; *)
|
||||
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;
|
||||
EnterKW(if, "IF");
|
||||
EnterKW(do, "DO");
|
||||
EnterKW(of, "OF");
|
||||
EnterKW(or, "OR");
|
||||
EnterKW(to, "TO");
|
||||
EnterKW(in, "IN");
|
||||
EnterKW(is, "IS");
|
||||
EnterKW(by, "BY");
|
||||
KWX[2] := k;
|
||||
EnterKW(end, "END");
|
||||
EnterKW(nil, "NIL");
|
||||
EnterKW(var, "VAR");
|
||||
EnterKW(div, "DIV");
|
||||
EnterKW(mod, "MOD");
|
||||
EnterKW(for, "FOR");
|
||||
KWX[3] := k;
|
||||
EnterKW(else, "ELSE");
|
||||
EnterKW(then, "THEN");
|
||||
EnterKW(true, "TRUE");
|
||||
EnterKW(type, "TYPE");
|
||||
EnterKW(case, "CASE");
|
||||
KWX[4] := k;
|
||||
EnterKW(elsif, "ELSIF");
|
||||
EnterKW(false, "FALSE");
|
||||
EnterKW(array, "ARRAY");
|
||||
EnterKW(begin, "BEGIN");
|
||||
EnterKW(const, "CONST");
|
||||
EnterKW(until, "UNTIL");
|
||||
EnterKW(while, "WHILE");
|
||||
KWX[5] := k;
|
||||
EnterKW(record, "RECORD");
|
||||
EnterKW(repeat, "REPEAT");
|
||||
EnterKW(return, "RETURN");
|
||||
EnterKW(import, "IMPORT");
|
||||
EnterKW(module, "MODULE");
|
||||
KWX[6] := k;
|
||||
EnterKW(pointer, "POINTER");
|
||||
KWX[7] := k; KWX[8] := k;
|
||||
EnterKW(procedure, "PROCEDURE");
|
||||
KWX[9] := k
|
||||
END ORS.
|
||||
MODULE ORS; (* NW 19.9.93 / 1.4.2014 Scanner in Oberon-07*)
|
||||
IMPORT SYSTEM, Texts := CompatTexts, Oberon; (* CompatTexts is voc adaptation by noch *)
|
||||
|
||||
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.
|
||||
Recognises all Oberon keywords and skips comments. The keywords are
|
||||
recorded in a table.
|
||||
Get(sym) delivers next symbol from input text with Reader R.
|
||||
Mark(msg) records error and delivers error message with Writer W.
|
||||
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;
|
||||
NKW = 34; (*nof keywords*)
|
||||
maxExp = 38; stringBufSize = 256;
|
||||
|
||||
(*lexical symbols*)
|
||||
null = 0; times* = 1; rdiv* = 2; div* = 3; mod* = 4;
|
||||
and* = 5; plus* = 6; minus* = 7; or* = 8; eql* = 9;
|
||||
neq* = 10; lss* = 11; leq* = 12; gtr* = 13; geq* = 14;
|
||||
in* = 15; is* = 16; arrow* = 17; period* = 18;
|
||||
char* = 20; int* = 21; real* = 22; false* = 23; true* = 24;
|
||||
nil* = 25; string* = 26; not* = 27; lparen* = 28; lbrak* = 29;
|
||||
lbrace* = 30; ident* = 31;
|
||||
if* = 32; while* = 34; repeat* = 35; case* = 36; for* = 37;
|
||||
comma* = 40; colon* = 41; becomes* = 42; upto* = 43; rparen* = 44;
|
||||
rbrak* = 45; rbrace* = 46; then* = 47; of* = 48; do* = 49;
|
||||
to* = 50; by* = 51; semicolon* = 52; end* = 53; bar* = 54;
|
||||
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;
|
||||
|
||||
TYPE Ident* = ARRAY IdLen OF CHAR;
|
||||
|
||||
VAR ival*, slen*: LONGINT; (*results of Get*)
|
||||
rval*: REAL;
|
||||
id*: Ident; (*for identifiers*)
|
||||
str*: ARRAY stringBufSize OF CHAR;
|
||||
errcnt*: INTEGER;
|
||||
|
||||
ch: CHAR; (*last character read*)
|
||||
errpos: LONGINT;
|
||||
R: Texts.Reader;
|
||||
W: Texts.Writer;
|
||||
k: INTEGER;
|
||||
KWX: ARRAY 10 OF INTEGER;
|
||||
keyTab: ARRAY NKW OF
|
||||
RECORD sym: INTEGER; id: ARRAY 12 OF CHAR END;
|
||||
|
||||
PROCEDURE CopyId*(VAR ident: Ident);
|
||||
BEGIN ident := id
|
||||
END CopyId;
|
||||
|
||||
PROCEDURE Pos*(): LONGINT;
|
||||
BEGIN RETURN Texts.Pos(R) - 1
|
||||
END Pos;
|
||||
|
||||
PROCEDURE Mark*(msg: ARRAY OF CHAR);
|
||||
VAR p: LONGINT;
|
||||
BEGIN p := Pos();
|
||||
IF (p > errpos) & (errcnt < 25) THEN
|
||||
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; (* voc adaptation by noch *)
|
||||
END ;
|
||||
INC(errcnt); errpos := p + 4
|
||||
END Mark;
|
||||
|
||||
PROCEDURE Identifier(VAR sym: INTEGER);
|
||||
VAR i, k: INTEGER;
|
||||
BEGIN i := 0;
|
||||
REPEAT
|
||||
IF i < IdLen-1 THEN id[i] := ch; INC(i) END ;
|
||||
Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "Z") & (ch < "a") OR (ch > "z");
|
||||
id[i] := 0X;
|
||||
IF i < 10 THEN k := KWX[i-1]; (*search for keyword*)
|
||||
WHILE (id # keyTab[k].id) & (k < KWX[i]) DO INC(k) END ;
|
||||
IF k < KWX[i] THEN sym := keyTab[k].sym ELSE sym := ident END
|
||||
ELSE sym := ident
|
||||
END
|
||||
END Identifier;
|
||||
|
||||
PROCEDURE String;
|
||||
VAR i: INTEGER;
|
||||
BEGIN i := 0; Texts.Read(R, ch);
|
||||
WHILE ~R.eot & (ch # 22X) DO
|
||||
IF ch >= " " THEN
|
||||
IF i < stringBufSize-1 THEN str[i] := ch; INC(i) ELSE Mark("string too long") END ;
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
END ;
|
||||
str[i] := 0X; INC(i); Texts.Read(R, ch); slen := i
|
||||
END String;
|
||||
|
||||
PROCEDURE HexString;
|
||||
VAR i, m, n: INTEGER;
|
||||
BEGIN i := 0; Texts.Read(R, ch);
|
||||
WHILE ~R.eot & (ch # "$") DO
|
||||
WHILE (ch = " ") OR (ch = 9X) OR (ch = 0DX) DO Texts.Read(R, ch) END ; (*skip*)
|
||||
IF ("0" <= ch) & (ch <= "9") THEN m := ORD(ch) - 30H
|
||||
ELSIF ("A" <= ch) & (ch <= "F") THEN m := ORD(ch) - 37H
|
||||
ELSE m := 0; Mark("hexdig expected")
|
||||
END ;
|
||||
Texts.Read(R, ch);
|
||||
IF ("0" <= ch) & (ch <= "9") THEN n := ORD(ch) - 30H
|
||||
ELSIF ("A" <= ch) & (ch <= "F") THEN n := ORD(ch) - 37H
|
||||
ELSE n := 0; Mark("hexdig expected")
|
||||
END ;
|
||||
IF i < stringBufSize THEN str[i] := CHR(m*10H + n); INC(i) ELSE Mark("string too long") END ;
|
||||
Texts.Read(R, ch)
|
||||
END ;
|
||||
Texts.Read(R, ch); slen := i (*no 0X appended!*)
|
||||
END HexString;
|
||||
|
||||
PROCEDURE Ten(e: LONGINT): REAL;
|
||||
VAR x, t: REAL;
|
||||
BEGIN x := 1.0; t := 10.0;
|
||||
WHILE e > 0 DO
|
||||
IF ODD(e) THEN x := t * x END ;
|
||||
t := t * t; e := e DIV 2
|
||||
END ;
|
||||
RETURN x
|
||||
END Ten;
|
||||
|
||||
PROCEDURE Number(VAR sym: INTEGER);
|
||||
CONST max = 2147483647 (*2^31 - 1*);
|
||||
VAR i, k, e, n, s, h: LONGINT; x: REAL;
|
||||
d: ARRAY 16 OF INTEGER;
|
||||
negE: BOOLEAN;
|
||||
BEGIN ival := 0; i := 0; n := 0; k := 0;
|
||||
REPEAT
|
||||
IF n < 16 THEN d[n] := ORD(ch)-30H; INC(n) ELSE Mark("too many digits"); n := 0 END ;
|
||||
Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "F");
|
||||
IF (ch = "H") OR (ch = "R") OR (ch = "X") THEN (*hex*)
|
||||
REPEAT h := d[i];
|
||||
IF h >= 10 THEN h := h-7 END ;
|
||||
k := k*10H + h; INC(i) (*no overflow check*)
|
||||
UNTIL i = n;
|
||||
IF ch = "X" THEN sym := char;
|
||||
IF k < 100H THEN ival := k ELSE Mark("illegal value"); ival := 0 END
|
||||
ELSIF ch = "R" THEN sym := real; rval := SYSTEM.VAL(REAL, k)
|
||||
ELSE sym := int; ival := k
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
ELSIF ch = "." THEN
|
||||
Texts.Read(R, ch);
|
||||
IF ch = "." THEN (*double dot*) ch := 7FX; (*decimal integer*)
|
||||
REPEAT
|
||||
IF d[i] < 10 THEN
|
||||
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*)
|
||||
(*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 ;
|
||||
IF (ch = "E") OR (ch = "D") THEN (*scale factor*)
|
||||
Texts.Read(R, ch); s := 0;
|
||||
IF ch = "-" THEN negE := TRUE; Texts.Read(R, ch)
|
||||
ELSE negE := FALSE;
|
||||
IF ch = "+" THEN Texts.Read(R, ch) END
|
||||
END ;
|
||||
IF (ch >= "0") & (ch <= "9") THEN
|
||||
REPEAT s := s*10 + ORD(ch)-30H; Texts.Read(R, ch)
|
||||
UNTIL (ch < "0") OR (ch >"9");
|
||||
IF negE THEN e := e-s ELSE e := e+s END
|
||||
ELSE Mark("digit?")
|
||||
END
|
||||
END ;
|
||||
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; Mark("too large") END
|
||||
END ;
|
||||
sym := real; rval := x
|
||||
END
|
||||
ELSE (*decimal integer*)
|
||||
REPEAT
|
||||
IF d[i] < 10 THEN
|
||||
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
|
||||
END
|
||||
END Number;
|
||||
|
||||
PROCEDURE comment;
|
||||
BEGIN Texts.Read(R, ch);
|
||||
REPEAT
|
||||
WHILE ~R.eot & (ch # "*") DO
|
||||
IF ch = "(" THEN Texts.Read(R, ch);
|
||||
IF ch = "*" THEN comment END
|
||||
ELSE Texts.Read(R, ch)
|
||||
END
|
||||
END ;
|
||||
WHILE ch = "*" DO Texts.Read(R, ch) END
|
||||
UNTIL (ch = ")") OR R.eot;
|
||||
IF ~R.eot THEN Texts.Read(R, ch) ELSE Mark("unterminated comment") END
|
||||
END comment;
|
||||
|
||||
PROCEDURE Get*(VAR sym: INTEGER);
|
||||
BEGIN
|
||||
REPEAT
|
||||
WHILE ~R.eot & (ch <= " ") DO Texts.Read(R, ch) END;
|
||||
IF ch < "A" THEN
|
||||
IF ch < "0" THEN
|
||||
IF ch = 22X THEN String; sym := string
|
||||
ELSIF ch = "#" THEN Texts.Read(R, ch); sym := neq
|
||||
ELSIF ch = "$" THEN HexString; sym := string
|
||||
ELSIF ch = "&" THEN Texts.Read(R, ch); sym := and
|
||||
ELSIF ch = "(" THEN Texts.Read(R, ch);
|
||||
IF ch = "*" THEN sym := null; comment ELSE sym := lparen END
|
||||
ELSIF ch = ")" THEN Texts.Read(R, ch); sym := rparen
|
||||
ELSIF ch = "*" THEN Texts.Read(R, ch); sym := times
|
||||
ELSIF ch = "+" THEN Texts.Read(R, ch); sym := plus
|
||||
ELSIF ch = "," THEN Texts.Read(R, ch); sym := comma
|
||||
ELSIF ch = "-" THEN Texts.Read(R, ch); sym := minus
|
||||
ELSIF ch = "." THEN Texts.Read(R, ch);
|
||||
IF ch = "." THEN Texts.Read(R, ch); sym := upto ELSE sym := period END
|
||||
ELSIF ch = "/" THEN Texts.Read(R, ch); sym := rdiv
|
||||
ELSE Texts.Read(R, ch); (* ! % ' *) sym := null
|
||||
END
|
||||
ELSIF ch < ":" THEN Number(sym)
|
||||
ELSIF ch = ":" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := becomes ELSE sym := colon END
|
||||
ELSIF ch = ";" THEN Texts.Read(R, ch); sym := semicolon
|
||||
ELSIF ch = "<" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := leq ELSE sym := lss END
|
||||
ELSIF ch = "=" THEN Texts.Read(R, ch); sym := eql
|
||||
ELSIF ch = ">" THEN Texts.Read(R, ch);
|
||||
IF ch = "=" THEN Texts.Read(R, ch); sym := geq ELSE sym := gtr END
|
||||
ELSE (* ? @ *) Texts.Read(R, ch); sym := null
|
||||
END
|
||||
ELSIF ch < "[" THEN Identifier(sym)
|
||||
ELSIF ch < "a" THEN
|
||||
IF ch = "[" THEN sym := lbrak
|
||||
ELSIF ch = "]" THEN sym := rbrak
|
||||
ELSIF ch = "^" THEN sym := arrow
|
||||
ELSE (* _ ` *) sym := null
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
ELSIF ch < "{" THEN Identifier(sym) ELSE
|
||||
IF ch = "{" THEN sym := lbrace
|
||||
ELSIF ch = "}" THEN sym := rbrace
|
||||
ELSIF ch = "|" THEN sym := bar
|
||||
ELSIF ch = "~" THEN sym := not
|
||||
ELSIF ch = 7FX THEN sym := upto
|
||||
ELSE sym := null
|
||||
END ;
|
||||
Texts.Read(R, ch)
|
||||
END
|
||||
UNTIL sym # null
|
||||
END Get;
|
||||
|
||||
PROCEDURE Init*(T: Texts.Text; pos: LONGINT);
|
||||
BEGIN errpos := pos; errcnt := 0; Texts.OpenReader(R, T, pos); Texts.Read(R, ch)
|
||||
END Init;
|
||||
|
||||
PROCEDURE EnterKW(sym: INTEGER; name: ARRAY OF CHAR);
|
||||
BEGIN
|
||||
(*keyTab[k].id := name; *)
|
||||
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;
|
||||
EnterKW(if, "IF");
|
||||
EnterKW(do, "DO");
|
||||
EnterKW(of, "OF");
|
||||
EnterKW(or, "OR");
|
||||
EnterKW(to, "TO");
|
||||
EnterKW(in, "IN");
|
||||
EnterKW(is, "IS");
|
||||
EnterKW(by, "BY");
|
||||
KWX[2] := k;
|
||||
EnterKW(end, "END");
|
||||
EnterKW(nil, "NIL");
|
||||
EnterKW(var, "VAR");
|
||||
EnterKW(div, "DIV");
|
||||
EnterKW(mod, "MOD");
|
||||
EnterKW(for, "FOR");
|
||||
KWX[3] := k;
|
||||
EnterKW(else, "ELSE");
|
||||
EnterKW(then, "THEN");
|
||||
EnterKW(true, "TRUE");
|
||||
EnterKW(type, "TYPE");
|
||||
EnterKW(case, "CASE");
|
||||
KWX[4] := k;
|
||||
EnterKW(elsif, "ELSIF");
|
||||
EnterKW(false, "FALSE");
|
||||
EnterKW(array, "ARRAY");
|
||||
EnterKW(begin, "BEGIN");
|
||||
EnterKW(const, "CONST");
|
||||
EnterKW(until, "UNTIL");
|
||||
EnterKW(while, "WHILE");
|
||||
KWX[5] := k;
|
||||
EnterKW(record, "RECORD");
|
||||
EnterKW(repeat, "REPEAT");
|
||||
EnterKW(return, "RETURN");
|
||||
EnterKW(import, "IMPORT");
|
||||
EnterKW(module, "MODULE");
|
||||
KWX[6] := k;
|
||||
EnterKW(pointer, "POINTER");
|
||||
KWX[7] := k; KWX[8] := k;
|
||||
EnterKW(procedure, "PROCEDURE");
|
||||
KWX[9] := k
|
||||
END ORS.
|
||||
|
|
|
|||
|
|
@ -1,251 +1,251 @@
|
|||
MODULE ORTool; (*NW 18.2.2013*)
|
||||
IMPORT SYSTEM, Files, Texts, Oberon, ORB;
|
||||
VAR W: Texts.Writer;
|
||||
Form: INTEGER; (*result of ReadType*)
|
||||
mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*)
|
||||
|
||||
PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER);
|
||||
VAR b: BYTE;
|
||||
BEGIN Files.ReadByte(R, b);
|
||||
IF b < 80H THEN n := b ELSE n := b - 100H END
|
||||
END Read;
|
||||
|
||||
PROCEDURE ReadType(VAR R: Files.Rider);
|
||||
VAR key, len, lev, size, off: INTEGER;
|
||||
ref, mno, class, form, readonly: INTEGER;
|
||||
name, modname: ARRAY 32 OF CHAR;
|
||||
BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "[");
|
||||
IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1)
|
||||
ELSE Texts.WriteInt(W, ref, 1);
|
||||
Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1);
|
||||
IF form = ORB.Pointer THEN ReadType(R)
|
||||
ELSIF form = ORB.Array THEN
|
||||
ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size);
|
||||
Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1);
|
||||
Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1)
|
||||
ELSIF form = ORB.Record THEN
|
||||
ReadType(R); (*base type*)
|
||||
Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1);
|
||||
Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1);
|
||||
Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1);
|
||||
Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class);
|
||||
WHILE class # 0 DO (*fields*)
|
||||
Files.ReadString(R, name);
|
||||
IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R)
|
||||
ELSE Texts.WriteString(W, " --")
|
||||
END ;
|
||||
Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, "}")
|
||||
ELSIF form = ORB.Proc THEN
|
||||
ReadType(R); Texts.Write(W, "("); Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly);
|
||||
IF readonly = 1 THEN Texts.Write(W, "#") END ;
|
||||
ReadType(R); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, ")")
|
||||
END ;
|
||||
Files.ReadString(R, modname);
|
||||
IF modname[0] # 0X THEN
|
||||
Files.ReadInt(R, key); Files.ReadString(R, name);
|
||||
Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name);
|
||||
Texts.WriteHex(W, key)
|
||||
END
|
||||
END ;
|
||||
Form := form; Texts.Write(W, "]")
|
||||
END ReadType;
|
||||
|
||||
PROCEDURE DecSym*; (*decode symbol file*)
|
||||
VAR class, typno, k: INTEGER;
|
||||
name: ARRAY 32 OF CHAR;
|
||||
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
|
||||
Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s);
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
F := Files.Old(S.s);
|
||||
IF F # NIL THEN
|
||||
Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k);
|
||||
Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k);
|
||||
Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*)
|
||||
IF class = ORB.versionkey THEN
|
||||
Texts.WriteLn(W); Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
|
||||
ReadType(R);
|
||||
IF class = ORB.Typ THEN
|
||||
Texts.Write(W, "("); Read(R, class);
|
||||
WHILE class # 0 DO (*pointer base fixup*)
|
||||
Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, ")")
|
||||
ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN
|
||||
Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*)
|
||||
END ;
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
Read(R, class)
|
||||
END
|
||||
ELSE Texts.WriteString(W, " bad symfile version")
|
||||
END
|
||||
ELSE Texts.WriteString(W, " not found")
|
||||
END ;
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
|
||||
END
|
||||
END DecSym;
|
||||
|
||||
(* ---------------------------------------------------*)
|
||||
|
||||
PROCEDURE WriteReg(r: LONGINT);
|
||||
BEGIN Texts.Write(W, " ");
|
||||
IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1)
|
||||
ELSIF r = 12 THEN Texts.WriteString(W, "MT")
|
||||
ELSIF r = 13 THEN Texts.WriteString(W, "SB")
|
||||
ELSIF r = 14 THEN Texts.WriteString(W, "SP")
|
||||
ELSE Texts.WriteString(W, "LNK")
|
||||
END
|
||||
END WriteReg;
|
||||
|
||||
PROCEDURE opcode(w: LONGINT);
|
||||
VAR k, op, u, a, b, c: LONGINT;
|
||||
BEGIN
|
||||
k := w DIV 40000000H MOD 4;
|
||||
a := w DIV 1000000H MOD 10H;
|
||||
b := w DIV 100000H MOD 10H;
|
||||
op := w DIV 10000H MOD 10H;
|
||||
u := w DIV 20000000H MOD 2;
|
||||
IF k = 0 THEN
|
||||
Texts.WriteString(W, mnemo0[op]);
|
||||
IF u = 1 THEN Texts.Write(W, "'") END ;
|
||||
WriteReg(a); WriteReg(b); WriteReg(w MOD 10H)
|
||||
ELSIF k = 1 THEN
|
||||
Texts.WriteString(W, mnemo0[op]);
|
||||
IF u = 1 THEN Texts.Write(W, "'") END ;
|
||||
WriteReg(a); WriteReg(b); w := w MOD 10000H;
|
||||
IF w >= 8000H THEN w := w - 10000H END ;
|
||||
Texts.WriteInt(W, w, 7)
|
||||
ELSIF k = 2 THEN (*LDR/STR*)
|
||||
IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ;
|
||||
WriteReg(a); WriteReg(b); w := w MOD 100000H;
|
||||
IF w >= 80000H THEN w := w - 100000H END ;
|
||||
Texts.WriteInt(W, w, 8)
|
||||
ELSIF k = 3 THEN (*Branch instr*)
|
||||
Texts.Write(W, "B");
|
||||
IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
|
||||
Texts.WriteString(W, mnemo1[a]);
|
||||
IF u = 0 THEN WriteReg(w MOD 10H) ELSE
|
||||
w := w MOD 100000H;
|
||||
IF w >= 80000H THEN w := w - 100000H END ;
|
||||
Texts.WriteInt(W, w, 8)
|
||||
END
|
||||
END
|
||||
END opcode;
|
||||
|
||||
PROCEDURE Sync(VAR R: Files.Rider);
|
||||
VAR ch: CHAR;
|
||||
BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W)
|
||||
END Sync;
|
||||
|
||||
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
|
||||
BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *)
|
||||
END Write;
|
||||
|
||||
PROCEDURE DecObj*; (*decode object file*)
|
||||
VAR class, i, n, key, size, fix, adr, data, len: INTEGER;
|
||||
ch: CHAR;
|
||||
name: ARRAY 32 OF CHAR;
|
||||
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
|
||||
Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s);
|
||||
IF F # NIL THEN
|
||||
Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*)
|
||||
Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name);
|
||||
WHILE name[0] # 0X DO
|
||||
Texts.Write(W, 9X); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); n := n DIV 4; i := 0;
|
||||
WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ;
|
||||
Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "strings"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ;
|
||||
Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "code"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO
|
||||
Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data);
|
||||
Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "commands:"); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name);
|
||||
WHILE name[0] # 0X DO
|
||||
Texts.Write(W, 9X); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "entries"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO
|
||||
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i)
|
||||
END ;
|
||||
Texts.WriteLn(W);
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr);
|
||||
WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ;
|
||||
Texts.WriteLn(W);
|
||||
(* Sync(R); *)
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.Read(R, ch);
|
||||
IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END
|
||||
(* Sync(R); *)
|
||||
ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W)
|
||||
END ;
|
||||
Texts.Append(Oberon.Log, W.buf)
|
||||
END
|
||||
END DecObj;
|
||||
|
||||
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013");
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
mnemo0[0] := "MOV";
|
||||
mnemo0[1] := "LSL";
|
||||
mnemo0[2] := "ASR";
|
||||
mnemo0[3] := "ROR";
|
||||
mnemo0[4] := "AND";
|
||||
mnemo0[5] := "ANN";
|
||||
mnemo0[6] := "IOR";
|
||||
mnemo0[7] := "XOR";
|
||||
mnemo0[8] := "ADD";
|
||||
mnemo0[9] := "SUB";
|
||||
mnemo0[10] := "MUL";
|
||||
mnemo0[11] := "DIV";
|
||||
mnemo0[12] := "FAD";
|
||||
mnemo0[13] := "FSB";
|
||||
mnemo0[14] := "FML";
|
||||
mnemo0[15] := "FDV";
|
||||
mnemo1[0] := "MI ";
|
||||
mnemo1[8] := "PL";
|
||||
mnemo1[1] := "EQ ";
|
||||
mnemo1[9] := "NE ";
|
||||
mnemo1[2] := "LS ";
|
||||
mnemo1[10] := "HI ";
|
||||
mnemo1[5] := "LT ";
|
||||
mnemo1[13] := "GE ";
|
||||
mnemo1[6] := "LE ";
|
||||
mnemo1[14] := "GT ";
|
||||
mnemo1[15] := "NO ";
|
||||
END ORTool.
|
||||
MODULE ORTool; (*NW 18.2.2013*)
|
||||
IMPORT SYSTEM, Files, Texts, Oberon, ORB;
|
||||
VAR W: Texts.Writer;
|
||||
Form: INTEGER; (*result of ReadType*)
|
||||
mnemo0, mnemo1: ARRAY 16, 4 OF CHAR; (*mnemonics*)
|
||||
|
||||
PROCEDURE Read(VAR R: Files.Rider; VAR n: INTEGER);
|
||||
VAR b: BYTE;
|
||||
BEGIN Files.ReadByte(R, b);
|
||||
IF b < 80H THEN n := b ELSE n := b - 100H END
|
||||
END Read;
|
||||
|
||||
PROCEDURE ReadType(VAR R: Files.Rider);
|
||||
VAR key, len, lev, size, off: INTEGER;
|
||||
ref, mno, class, form, readonly: INTEGER;
|
||||
name, modname: ARRAY 32 OF CHAR;
|
||||
BEGIN Read(R, ref); Texts.Write(W, " "); Texts.Write(W, "[");
|
||||
IF ref < 0 THEN Texts.Write(W, "^"); Texts.WriteInt(W, -ref, 1)
|
||||
ELSE Texts.WriteInt(W, ref, 1);
|
||||
Read(R, form); Texts.WriteString(W, " form = "); Texts.WriteInt(W, form, 1);
|
||||
IF form = ORB.Pointer THEN ReadType(R)
|
||||
ELSIF form = ORB.Array THEN
|
||||
ReadType(R); Files.ReadNum(R, len); Files.ReadNum(R, size);
|
||||
Texts.WriteString(W, " len = "); Texts.WriteInt(W, len, 1);
|
||||
Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1)
|
||||
ELSIF form = ORB.Record THEN
|
||||
ReadType(R); (*base type*)
|
||||
Files.ReadNum(R, off); Texts.WriteString(W, " exno = "); Texts.WriteInt(W, off, 1);
|
||||
Files.ReadNum(R, off); Texts.WriteString(W, " extlev = "); Texts.WriteInt(W, off, 1);
|
||||
Files.ReadNum(R, size); Texts.WriteString(W, " size = "); Texts.WriteInt(W, size, 1);
|
||||
Texts.Write(W, " "); Texts.Write(W, "{"); Read(R, class);
|
||||
WHILE class # 0 DO (*fields*)
|
||||
Files.ReadString(R, name);
|
||||
IF name[0] # 0X THEN Texts.Write(W, " "); Texts.WriteString(W, name); ReadType(R)
|
||||
ELSE Texts.WriteString(W, " --")
|
||||
END ;
|
||||
Files.ReadNum(R, off); Texts.WriteInt(W, off, 4); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, "}")
|
||||
ELSIF form = ORB.Proc THEN
|
||||
ReadType(R); Texts.Write(W, "("); Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
Texts.WriteString(W, " class = "); Texts.WriteInt(W, class, 1); Read(R, readonly);
|
||||
IF readonly = 1 THEN Texts.Write(W, "#") END ;
|
||||
ReadType(R); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, ")")
|
||||
END ;
|
||||
Files.ReadString(R, modname);
|
||||
IF modname[0] # 0X THEN
|
||||
Files.ReadInt(R, key); Files.ReadString(R, name);
|
||||
Texts.Write(W, " "); Texts.WriteString(W, modname); Texts.Write(W, "."); Texts.WriteString(W, name);
|
||||
Texts.WriteHex(W, key)
|
||||
END
|
||||
END ;
|
||||
Form := form; Texts.Write(W, "]")
|
||||
END ReadType;
|
||||
|
||||
PROCEDURE DecSym*; (*decode symbol file*)
|
||||
VAR class, typno, k: INTEGER;
|
||||
name: ARRAY 32 OF CHAR;
|
||||
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
|
||||
Texts.WriteString(W, "OR-decode "); Texts.WriteString(W, S.s);
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
F := Files.Old(S.s);
|
||||
IF F # NIL THEN
|
||||
Files.Set(R, F, 0); Files.ReadInt(R, k); Files.ReadInt(R, k);
|
||||
Files.ReadString(R, name); Texts.WriteString(W, name); Texts.WriteHex(W, k);
|
||||
Read(R, class); Texts.WriteInt(W, class, 3); (*sym file version*)
|
||||
IF class = ORB.versionkey THEN
|
||||
Texts.WriteLn(W); Read(R, class);
|
||||
WHILE class # 0 DO
|
||||
Texts.WriteInt(W, class, 4); Files.ReadString(R, name); Texts.Write(W, " "); Texts.WriteString(W, name);
|
||||
ReadType(R);
|
||||
IF class = ORB.Typ THEN
|
||||
Texts.Write(W, "("); Read(R, class);
|
||||
WHILE class # 0 DO (*pointer base fixup*)
|
||||
Texts.WriteString(W, " ->"); Texts.WriteInt(W, class, 4); Read(R, class)
|
||||
END ;
|
||||
Texts.Write(W, ")")
|
||||
ELSIF (class = ORB.Const) OR (class = ORB.Var) THEN
|
||||
Files.ReadNum(R, k); Texts.WriteInt(W, k, 5); (*Reals, Strings!*)
|
||||
END ;
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
Read(R, class)
|
||||
END
|
||||
ELSE Texts.WriteString(W, " bad symfile version")
|
||||
END
|
||||
ELSE Texts.WriteString(W, " not found")
|
||||
END ;
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
|
||||
END
|
||||
END DecSym;
|
||||
|
||||
(* ---------------------------------------------------*)
|
||||
|
||||
PROCEDURE WriteReg(r: LONGINT);
|
||||
BEGIN Texts.Write(W, " ");
|
||||
IF r < 12 THEN Texts.WriteString(W, " R"); Texts.WriteInt(W, r MOD 10H, 1)
|
||||
ELSIF r = 12 THEN Texts.WriteString(W, "MT")
|
||||
ELSIF r = 13 THEN Texts.WriteString(W, "SB")
|
||||
ELSIF r = 14 THEN Texts.WriteString(W, "SP")
|
||||
ELSE Texts.WriteString(W, "LNK")
|
||||
END
|
||||
END WriteReg;
|
||||
|
||||
PROCEDURE opcode(w: LONGINT);
|
||||
VAR k, op, u, a, b, c: LONGINT;
|
||||
BEGIN
|
||||
k := w DIV 40000000H MOD 4;
|
||||
a := w DIV 1000000H MOD 10H;
|
||||
b := w DIV 100000H MOD 10H;
|
||||
op := w DIV 10000H MOD 10H;
|
||||
u := w DIV 20000000H MOD 2;
|
||||
IF k = 0 THEN
|
||||
Texts.WriteString(W, mnemo0[op]);
|
||||
IF u = 1 THEN Texts.Write(W, "'") END ;
|
||||
WriteReg(a); WriteReg(b); WriteReg(w MOD 10H)
|
||||
ELSIF k = 1 THEN
|
||||
Texts.WriteString(W, mnemo0[op]);
|
||||
IF u = 1 THEN Texts.Write(W, "'") END ;
|
||||
WriteReg(a); WriteReg(b); w := w MOD 10000H;
|
||||
IF w >= 8000H THEN w := w - 10000H END ;
|
||||
Texts.WriteInt(W, w, 7)
|
||||
ELSIF k = 2 THEN (*LDR/STR*)
|
||||
IF u = 1 THEN Texts.WriteString(W, "STR ") ELSE Texts.WriteString(W, "LDR") END ;
|
||||
WriteReg(a); WriteReg(b); w := w MOD 100000H;
|
||||
IF w >= 80000H THEN w := w - 100000H END ;
|
||||
Texts.WriteInt(W, w, 8)
|
||||
ELSIF k = 3 THEN (*Branch instr*)
|
||||
Texts.Write(W, "B");
|
||||
IF ODD(w DIV 10000000H) THEN Texts.Write(W, "L") END ;
|
||||
Texts.WriteString(W, mnemo1[a]);
|
||||
IF u = 0 THEN WriteReg(w MOD 10H) ELSE
|
||||
w := w MOD 100000H;
|
||||
IF w >= 80000H THEN w := w - 100000H END ;
|
||||
Texts.WriteInt(W, w, 8)
|
||||
END
|
||||
END
|
||||
END opcode;
|
||||
|
||||
PROCEDURE Sync(VAR R: Files.Rider);
|
||||
VAR ch: CHAR;
|
||||
BEGIN Files.Read(R, ch); Texts.WriteString(W, "Sync "); Texts.Write(W, ch); Texts.WriteLn(W)
|
||||
END Sync;
|
||||
|
||||
PROCEDURE Write(VAR R: Files.Rider; x: INTEGER);
|
||||
BEGIN Files.WriteByte(R, x) (* -128 <= x < 128 *)
|
||||
END Write;
|
||||
|
||||
PROCEDURE DecObj*; (*decode object file*)
|
||||
VAR class, i, n, key, size, fix, adr, data, len: INTEGER;
|
||||
ch: CHAR;
|
||||
name: ARRAY 32 OF CHAR;
|
||||
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
|
||||
Texts.WriteString(W, "decode "); Texts.WriteString(W, S.s); F := Files.Old(S.s);
|
||||
IF F # NIL THEN
|
||||
Files.Set(R, F, 0); Files.ReadString(R, name); Texts.WriteLn(W); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, key); Texts.WriteHex(W, key); Read(R, class); Texts.WriteInt(W, class, 4); (*version*)
|
||||
Files.ReadInt(R, size); Texts.WriteInt(W, size, 6); Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "imports:"); Texts.WriteLn(W); Files.ReadString(R, name);
|
||||
WHILE name[0] # 0X DO
|
||||
Texts.Write(W, 9X); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, key); Texts.WriteHex(W, key); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "type descriptors"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); n := n DIV 4; i := 0;
|
||||
WHILE i < n DO Files.ReadInt(R, data); Texts.WriteHex(W, data); INC(i) END ;
|
||||
Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "data"); Files.ReadInt(R, data); Texts.WriteInt(W, data, 6); Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "strings"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO Files.Read(R, ch); Texts.Write(W, ch); INC(i) END ;
|
||||
Texts.WriteLn(W);
|
||||
Texts.WriteString(W, "code"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO
|
||||
Files.ReadInt(R, data); Texts.WriteInt(W, i, 4); Texts.Write(W, 9X); Texts.WriteHex(W, data);
|
||||
Texts.Write(W, 9X); opcode(data); Texts.WriteLn(W); INC(i)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "commands:"); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name);
|
||||
WHILE name[0] # 0X DO
|
||||
Texts.Write(W, 9X); Texts.WriteString(W, name);
|
||||
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 5); Texts.WriteLn(W);
|
||||
Files.ReadString(R, name)
|
||||
END ;
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "entries"); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, n); i := 0;
|
||||
WHILE i < n DO
|
||||
Files.ReadInt(R, adr); Texts.WriteInt(W, adr, 6); INC(i)
|
||||
END ;
|
||||
Texts.WriteLn(W);
|
||||
(* Sync(R); *)
|
||||
Texts.WriteString(W, "pointer refs"); Texts.WriteLn(W); Files.ReadInt(R, adr);
|
||||
WHILE adr # -1 DO Texts.WriteInt(W, adr, 6); Files.ReadInt(R, adr) END ;
|
||||
Texts.WriteLn(W);
|
||||
(* Sync(R); *)
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixP = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixD = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "fixT = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.ReadInt(R, data); Texts.WriteString(W, "entry = "); Texts.WriteInt(W, data, 8); Texts.WriteLn(W);
|
||||
Files.Read(R, ch);
|
||||
IF ch # "O" THEN Texts.WriteString(W, "format eror"); Texts.WriteLn(W) END
|
||||
(* Sync(R); *)
|
||||
ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W)
|
||||
END ;
|
||||
Texts.Append(Oberon.Log, W.buf)
|
||||
END
|
||||
END DecObj;
|
||||
|
||||
BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "ORTool 18.2.2013");
|
||||
Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf);
|
||||
mnemo0[0] := "MOV";
|
||||
mnemo0[1] := "LSL";
|
||||
mnemo0[2] := "ASR";
|
||||
mnemo0[3] := "ROR";
|
||||
mnemo0[4] := "AND";
|
||||
mnemo0[5] := "ANN";
|
||||
mnemo0[6] := "IOR";
|
||||
mnemo0[7] := "XOR";
|
||||
mnemo0[8] := "ADD";
|
||||
mnemo0[9] := "SUB";
|
||||
mnemo0[10] := "MUL";
|
||||
mnemo0[11] := "DIV";
|
||||
mnemo0[12] := "FAD";
|
||||
mnemo0[13] := "FSB";
|
||||
mnemo0[14] := "FML";
|
||||
mnemo0[15] := "FDV";
|
||||
mnemo1[0] := "MI ";
|
||||
mnemo1[8] := "PL";
|
||||
mnemo1[1] := "EQ ";
|
||||
mnemo1[9] := "NE ";
|
||||
mnemo1[2] := "LS ";
|
||||
mnemo1[10] := "HI ";
|
||||
mnemo1[5] := "LT ";
|
||||
mnemo1[13] := "GE ";
|
||||
mnemo1[6] := "LE ";
|
||||
mnemo1[14] := "GT ";
|
||||
mnemo1[15] := "NO ";
|
||||
END ORTool.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue