Oberon/V2/OCE

MODULE OCE; (*NW 7.6.87 / 5.3.91*) IMPORT SYSTEM, OCS, OCT, OCC; CONST (*instruction format prefixes*) F6 = 4EH; F7 = 0CEH; F9 = 3EH; F11 = 0BEH; (*frequent operation codes: 5C, 5D, 5F = MOVQi, 14, 15, 17 = MOVi, 27 = ADDR*) (*object and item modes*) Var = 1; VarX = 2; Ind = 3; IndX = 4; RegI = 5; RegX = 6; Abs = 7; Con = 8; Stk = 9; Coc = 10; Reg = 11; Fld = 12; Typ = 13; (*structure forms*) Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6; Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12; Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17; VAR inxchk*: BOOLEAN; log: INTEGER; (*side effect of mant*) lengcode: ARRAY 18 OF INTEGER; intSet, realSet: SET; PROCEDURE inverted(x: LONGINT): LONGINT; BEGIN (*inverted sense of condition code*) IF ODD(x) THEN RETURN x-1 ELSE RETURN x+1 END END inverted; PROCEDURE load(VAR x: OCT.Item); VAR y: OCT.Item; BEGIN IF x.mode < Reg THEN y := x; OCC.GetReg(x); IF (y.mode = Con) & (-8 <= y.a0) & (y.a0 <= 7) THEN OCC.PutF2(lengcode[x.typ.form] + 5CH, y.a0, x) 			ELSE OCC.PutF4(lengcode[x.typ.form] + 14H, x, y) 			END ELSIF x.mode > Reg THEN OCS.Mark(126) END END load; PROCEDURE loadX(VAR x: OCT.Item); VAR y: OCT.Item; BEGIN IF x.mode <= Reg THEN y := x; OCC.GetReg(x); IF (y.mode = Con) & (-8 <= y.a0) & (y.a0 <= 7) THEN OCC.PutF2(5FH, y.a0, x) 			ELSE OCC.Put(F7, lengcode[x.typ.form] + 1CH, x, y) (*MOVXiD*) END ELSIF x.mode > Reg THEN OCS.Mark(126) END END loadX; PROCEDURE loadF(VAR x: OCT.Item); VAR y: OCT.Item; BEGIN IF x.mode < Reg THEN y := x; OCC.GetFReg(x); OCC.Put(F11, lengcode[x.typ.form] + 4, x, y) (*MOVf*) ELSIF x.mode > Reg THEN OCS.Mark(126) END END loadF; PROCEDURE loadB(VAR x: OCT.Item); (*Coc-Mode*) VAR L0, L1: LONGINT; BEGIN IF (x.a1 = 0) & (x.a2 = 0) THEN L0 := x.a0; OCC.GetReg(x); OCC.PutF2(3CH, L0, x) 		ELSE OCC.PutF0(inverted(x.a0)); OCC.PutWord(x.a2); L0 := OCC.pc - 2; OCC.FixLink(x.a1); OCC.GetReg(x); OCC.PutF2(5CH, 1, x); OCC.PutF0(14); L1 := OCC.pc; OCC.PutWord(0); OCC.FixLink(L0); OCC.PutF2(5CH, 0, x); OCC.fixup(L1) END END loadB; PROCEDURE loadAdr(VAR x: OCT.Item); VAR y: OCT.Item; BEGIN IF x.mode < Con THEN y := x; OCC.GetReg(x); IF (y.mode = Ind) & (y.a1 = 0) THEN y.mode := Var; OCC.PutF4(17H, x, y) 			ELSE OCC.PutF4(27H, x, y); x.a1 := 0 END ; x.mode := RegI; x.obj := NIL ELSE OCS.Mark(127) END END loadAdr; PROCEDURE setCC(VAR x: OCT.Item; cc: LONGINT); BEGIN x.typ := OCT.booltyp; x.mode := Coc; x.a0 := cc; x.a1 := 0; x.a2 := 0 END setCC; PROCEDURE cmp(L: INTEGER; VAR x, y: OCT.Item); BEGIN IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OCC.PutF2(L+1CH, y.a0, x) (*CMPQi*) ELSE OCC.PutF4(L+4, x, y) (*CMPi*) END END cmp; PROCEDURE add(L: INTEGER; VAR x, y: OCT.Item); BEGIN IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OCC.PutF2(L+0CH, y.a0, x) (*ADDQi*) ELSE OCC.PutF4(L, x, y) (*ADDi*) END END add; PROCEDURE sub(L: INTEGER; VAR x, y: OCT.Item); BEGIN IF (y.mode = Con) & (y.a0 <= 8) & (y.a0 >= -7) THEN OCC.PutF2(L+0CH, -y.a0, x) (*ADDQi*) ELSE OCC.PutF4(L+20H, x, y) (*SUBi*) END END sub; PROCEDURE mant(x: LONGINT): LONGINT; (*x DIV 2^log*) BEGIN log := 0; IF x > 0 THEN WHILE ~ODD(x) DO x := x DIV 2; INC(log) END END ; RETURN x 	END mant; PROCEDURE SetIntType*(VAR x: OCT.Item); VAR v: LONGINT; BEGIN v := x.a0; IF (-80H <= v) & (v <= 7FH) THEN x.typ := OCT.sinttyp ELSIF (-8000H <= v) & (v <= 7FFFH) THEN x.typ := OCT.inttyp ELSE x.typ := OCT.linttyp END END SetIntType; PROCEDURE AssReal*(VAR x: OCT.Item; y: REAL); BEGIN SYSTEM.PUT(SYSTEM.ADR(x.a0), y) 	END AssReal; PROCEDURE AssLReal*(VAR x: OCT.Item; y: LONGREAL); BEGIN SYSTEM.PUT(SYSTEM.ADR(x.a0), y) 	END AssLReal; PROCEDURE Index*(VAR x, y: OCT.Item); VAR f, n: INTEGER; i: LONGINT; eltyp: OCT.Struct; y1, z: OCT.Item; BEGIN f := y.typ.form; IF ~(f IN intSet) THEN OCS.Mark(80); y.typ := OCT.inttyp END ; IF x.typ = NIL THEN HALT(80) END ; IF x.typ.form = Array THEN eltyp := x.typ.BaseTyp; n := x.typ.n; 			IF eltyp = NIL THEN HALT(81) END ; IF y.mode = Con THEN IF (0 <= y.a0) & (y.a0 < n) THEN i := y.a0 * eltyp.size ELSE OCS.Mark(81); i := 0 END ; IF x.mode = Var THEN INC(x.a0, i) 				ELSIF (x.mode = Ind) OR (x.mode = RegI) THEN INC(x.a1, i); x.obj := NIL ELSE loadAdr(x); x.a1 := i 				END ELSE IF inxchk THEN (*z = bound descr*) z.mode := Var; z.a0 := x.typ.adr; z.lev := -x.typ.mno; IF y.mode = Reg THEN y1 := y ELSE OCC.GetReg(y1) END ; IF f = SInt THEN OCC.Put(F7, 10H, y1, y); y := y1 END ; (*MOVXBW*) OCC.Put(0EEH, SHORT(y1.a0)*8+1, y, z); OCC.PutF1(0D2H) (*CHECK, FLAG*) ELSE IF f = LInt THEN load(y) ELSE loadX(y) END ; y1 := y 				END ; f := x.mode; IF x.mode = Var THEN x.mode := VarX; x.a2 := y1.a0 				ELSIF x.mode = Ind THEN x.mode := IndX; x.a2 := y1.a0 				ELSIF x.mode = RegI THEN x.mode := RegX; x.a2 := y1.a0 				ELSIF x.mode IN {VarX, IndX, RegX} THEN z.mode := Con; z.typ := OCT.inttyp; z.a0 := (x.typ.size DIV eltyp.size) - 1; OCC.Put(2EH, SHORT(x.a2)*8+5, y1, z) (*INDEX*) ELSE loadAdr(x); x.mode := RegX; x.a1 := 0; x.a2 := y1.a0 				END END ; x.typ := eltyp ELSIF x.typ.form = DynArr THEN IF inxchk THEN z.mode := Var; z.a0 := x.a0 + x.typ.adr; z.lev := x.lev; IF y.mode = Reg THEN y1 := y ELSE OCC.GetReg(y1) END ; IF f = SInt THEN IF y.mode = Con THEN y.typ := OCT.inttyp ELSE OCC.Put(F7, 10H, y1, y); y := y1 					END END ; OCC.Put(0EEH, SHORT(y1.a0)*8+1, y, z); OCC.PutF1(0D2H) (*CHECK, FLAG*) ELSE IF f = LInt THEN load(y) ELSE loadX(y) END ; y1 := y 			END ; IF x.mode IN {Var, Ind} THEN x.mode := IndX; x.a2 := y1.a0 			ELSIF x.mode = RegI THEN x.mode := RegX; x.a2 := y1.a0 			ELSIF x.mode IN {IndX, RegX} THEN z.mode := Var; z.a0 := x.a0 + x.typ.adr; z.lev := x.lev; OCC.Put(2EH, SHORT(x.a2)*8+5, y1, z) (*INDEX*) ELSE loadAdr(x); x.mode := RegX; x.a1 := 0; x.a2 := y1.a0 			END ; x.typ := x.typ.BaseTyp ELSE OCS.Mark(82) END END Index; PROCEDURE Field*(VAR x: OCT.Item; y: OCT.Object); BEGIN (*x.typ.form = Record*) IF (y # NIL) & (y.mode = Fld) THEN IF x.mode = Var THEN INC(x.a0, y.a0) ELSIF (x.mode = Ind) OR (x.mode = RegI) THEN INC(x.a1, y.a0) ELSE loadAdr(x); x.mode := RegI; x.a1 := y.a0 			END ; x.typ := y.typ; x.obj := NIL ELSE OCS.Mark(83); x.typ := OCT.undftyp; x.mode := Var END END Field; PROCEDURE DeRef*(VAR x: OCT.Item); BEGIN IF x.typ.form = Pointer THEN IF (x.mode = Var) & (x.lev >= 0) THEN x.mode := Ind ELSE load(x); x.mode := RegI END ; x.typ := x.typ.BaseTyp; x.obj := OCC.wasderef ELSE OCS.Mark(84) END ; x.a1 := 0 END DeRef; PROCEDURE TypTest*(VAR x, y: OCT.Item; test: BOOLEAN); PROCEDURE GTT(t0, t1: OCT.Struct; varpar: BOOLEAN); VAR t: OCT.Struct; xt, tdes, p: OCT.Item; BEGIN IF t0 # t1 THEN t := t1; REPEAT t := t.BaseTyp UNTIL (t = NIL) OR (t = t0); IF t # NIL THEN x.typ := y.typ; IF OCC.typchk OR test THEN xt := x; 						IF varpar THEN xt.mode := Ind; xt.a0 := x.a0+4 ELSIF (x.mode = Var) & (x.lev >= 0) THEN xt.mode := Ind; xt.a1 := -4; load(xt); xt.mode := RegI ELSE load(xt); p := xt; p.mode := RegI; p.a1 := -4; OCC.PutF4(17H, xt, p); (*MOVD -4(xt), xt *) xt.mode := RegI END ; xt.a1 := t1.n * 4; tdes.mode := Var; tdes.lev := -t1.mno; tdes.a0 := t1.adr; OCC.PutF4(7, tdes, xt); (*CMPD*) IF ~test THEN OCC.PutF0(0); OCC.PutDisp(4); OCC.PutF1(0F2H); OCC.PutByte(18) ELSE setCC(x, 0) END END ELSE OCS.Mark(85); IF test THEN x.typ := OCT.booltyp END END ELSIF test THEN setCC(x, 14) END END GTT; BEGIN IF x.typ.form = Pointer THEN IF y.typ.form = Pointer THEN GTT(x.typ.BaseTyp, y.typ.BaseTyp, FALSE) ELSE OCS.Mark(86) END ELSIF (x.typ.form = Record) & (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) & (y.typ.form = Record) THEN GTT(x.typ, y.typ, TRUE) ELSE OCS.Mark(87) END END TypTest; PROCEDURE In*(VAR x, y: OCT.Item); VAR f: INTEGER; BEGIN f := x.typ.form; IF (f IN intSet) & (y.typ.form = Set) THEN IF y.mode = Con THEN load(y) END ; OCC.PutF4(lengcode[f]+34H, y, x); setCC(x, 8) (*TBITi*) ELSE OCS.Mark(92); x.mode := Reg END ; x.typ := OCT.booltyp END In; PROCEDURE Set0*(VAR x, y: OCT.Item); VAR one: LONGINT; BEGIN x.mode := Reg; x.a0 := 0; x.typ := OCT.settyp; IF y.typ.form IN intSet THEN IF y.mode = Con THEN x.mode := Con; IF (0 <= y.a0) & (y.a0 < 32) THEN one := 1; x.a0 := SYSTEM.LSH(one, y.a0) ELSE OCS.Mark(202) END ELSE OCC.GetReg(x); OCC.PutF2(5FH, 1, x); OCC.Put(F6, 17H, x, y) (*LSHD*) END ELSE OCS.Mark(93) END END Set0; PROCEDURE Set1*(VAR x, y, z: OCT.Item); VAR s: LONGINT; BEGIN x.mode := Reg; x.a0 := 0; x.typ := OCT.settyp; IF (y.typ.form IN intSet) & (z.typ.form IN intSet) THEN IF y.mode = Con THEN IF (0 <= y.a0) & (y.a0 < 32) THEN y.typ := OCT.settyp; s := -1; y.a0 := SYSTEM.LSH(s, y.a0); IF z.mode = Con THEN x.mode := Con; IF (y.a0 <= z.a0) & (z.a0 < 32) THEN s := -2; x.a0 := y.a0-SYSTEM.LSH(s, z.a0) ELSE OCS.Mark(202); x.a0 := 0 END ELSIF y.a0 = -1 THEN OCC.GetReg(x); OCC.PutF2(5FH, -2, x); OCC.Put(F6, 17H, x, z); OCC.Put(F6, 37H, x, x) (*LSHD, COMD*) ELSE OCC.GetReg(x); OCC.PutF4(17H, x, y); OCC.GetReg(y); OCC.PutF2(5FH, -2, y); OCC.Put(F6, 17H, y, z); OCC.PutF4(0BH, x, y) 					END ELSE OCS.Mark(202) END ELSE OCC.GetReg(x); OCC.PutF2(5FH, -1, x); OCC.Put(F6, 17H, x, y); IF z.mode = Con THEN IF (0 <= z.a0) & (z.a0 < 32) THEN y.typ := OCT.settyp; y.mode := Con; s := -2; y.a0 := SYSTEM.LSH(s, z.a0) ELSE OCS.Mark(202) END ELSE OCC.GetReg(y); OCC.PutF2(5FH, -2, y); OCC.Put(F6, 17H, y, z) (*LSHD*) END ; OCC.PutF4(0BH, x, y) (*BICD*) END ELSE OCS.Mark(93) END END Set1; PROCEDURE MOp*(op: INTEGER; VAR x: OCT.Item); VAR f, L: INTEGER; a: LONGINT; y: OCT.Item; BEGIN f := x.typ.form; CASE op OF 				5: (*&*) IF x.mode = Coc THEN OCC.PutF0(inverted(x.a0)); OCC.PutWord(x.a2); x.a2 := OCC.pc-2; OCC.FixLink(x.a1) ELSIF (x.typ.form = Bool) & (x.mode # Con) THEN OCC.PutF2(1CH, 1, x); setCC(x, 0); OCC.PutF0(1); OCC.PutWord(x.a2); x.a2 := OCC.pc-2; OCC.FixLink(x.a1) ELSIF x.typ.form # Bool THEN OCS.Mark(94); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 0 END | 6: (*+*) 				IF ~(f IN intSet + realSet) THEN OCS.Mark(96) END | 7: (*-*) 				y := x; L := lengcode[f]; IF f IN intSet THEN IF x.mode = Con THEN x.a0 := -x.a0; SetIntType(x) ELSE OCC.GetReg(x); OCC.Put(F6, L+20H, x, y) (*NEGi*) END ELSIF f IN realSet THEN OCC.GetFReg(x); OCC.Put(F11, L+14H, x, y) (*NEGf*) ELSIF f = Set THEN OCC.GetReg(x); OCC.Put(F6, 37H, x, y) (*COMD*) ELSE OCS.Mark(97) END | 8: (*OR*) IF x.mode = Coc THEN OCC.PutF0(x.a0); OCC.PutWord(x.a1); x.a1 := OCC.pc-2; OCC.FixLink(x.a2) ELSIF (x.typ.form = Bool) & (x.mode # Con) THEN OCC.PutF2(1CH, 1, x); setCC(x, 0); OCC.PutF0(0); OCC.PutWord(x.a1); x.a1 := OCC.pc-2; OCC.FixLink(x.a2) ELSIF x.typ.form # Bool THEN OCS.Mark(95); x.mode := Con; x.typ := OCT.booltyp; x.a0 := 1 END | 9 .. 14: (*relations*) IF x.mode = Coc THEN loadB(x) END | 32: (*~*) 				IF x.typ.form = Bool THEN IF x.mode = Coc THEN x.a0 := inverted(x.a0); a := x.a1; x.a1 := x.a2; x.a2 := a 					ELSE OCC.PutF2(1CH, 0, x); setCC(x, 0) END ELSE OCS.Mark(98) END END END MOp; PROCEDURE convert1(VAR x: OCT.Item; typ: OCT.Struct); VAR y: OCT.Item; op: INTEGER; BEGIN IF x.mode # Con THEN y := x; 			IF typ.form = Int THEN op := 10H ELSE op := lengcode[x.typ.form] + 1CH END; IF x.mode < Reg THEN OCC.GetReg(x) END ; OCC.Put(F7, op, x, y) (*MOVij*) END ; x.typ := typ END convert1; PROCEDURE convert2(VAR x: OCT.Item; typ: OCT.Struct); VAR y: OCT.Item; BEGIN y := x; OCC.GetFReg(x); (*MOVif*) OCC.Put(F9, lengcode[typ.form]*4 + lengcode[x.typ.form], x, y); x.typ := typ END convert2; PROCEDURE convert3(VAR x: OCT.Item); VAR y: OCT.Item; BEGIN y := x; 		IF x.mode < Reg THEN OCC.GetFReg(x) END ; OCC.Put(F9, 1BH, x, y); x.typ := OCT.lrltyp (*MOVFL*) END convert3; PROCEDURE Op*(op: INTEGER; VAR x, y: OCT.Item); VAR f, g, L: INTEGER; p, q, r: OCT.Struct; PROCEDURE strings: BOOLEAN; BEGIN RETURN ((((f=Array) OR (f=DynArr)) & (x.typ.BaseTyp.form=Char)) OR (f=String)) & ((((g=Array) OR (g=DynArr)) & (y.typ.BaseTyp.form=Char)) OR (g=String)) END strings PROCEDURE CompStrings(cc: INTEGER; Q: BOOLEAN); VAR z: OCT.Item; BEGIN z.mode := Reg; z.a0 := 2; IF f = DynArr THEN OCC.DynArrAdr(z, x) 			ELSE OCC.PutF4(27H, z, x) 			END ; z.a0 := 1; IF g = DynArr THEN OCC.DynArrAdr(z, y) 			ELSE OCC.PutF4(27H, z, y) 			END ; z.a0 := 0; OCC.PutF2(5FH, -1, z); (*MOVQD -1, R0*) z.a0 := 4; OCC.PutF2(5FH, 0, z); (*MOVQD 0, R4*) OCC.PutF1(14); OCC.PutF1(4); OCC.PutF1(6); (*CMPSB 6*) IF Q THEN (*compare also with zero byte*) OCC.PutF0(9); OCC.PutDisp(5); (*BFC*) z.mode := RegI; z.a0 := 2; z.a1 := 0; OCC.PutF2(1CH, 0, z) (*CMPQB*) END ; setCC(x, cc) END CompStrings PROCEDURE CompBool(cc: INTEGER); BEGIN IF y.mode = Coc THEN loadB(y) END ; OCC.PutF4(4, x, y); setCC(x, cc) END CompBool; BEGIN IF x.typ # y.typ THEN g := y.typ.form; CASE x.typ.form OF 					Undef: | SInt: IF g = Int THEN convert1(x, y.typ) ELSIF g = LInt THEN convert1(x, y.typ) ELSIF g = Real THEN convert2(x, y.typ) ELSIF g = LReal THEN convert2(x, y.typ) ELSE OCS.Mark(100) END | Int: IF g = SInt THEN convert1(y, x.typ) ELSIF g = LInt THEN convert1(x, y.typ) ELSIF g = Real THEN convert2(x, y.typ) ELSIF g = LReal THEN convert2(x, y.typ) ELSE OCS.Mark(100) END | LInt: IF g = SInt THEN convert1(y, x.typ) ELSIF g = Int THEN convert1(y, x.typ) ELSIF g = Real THEN convert2(x, y.typ) ELSIF g = LReal THEN convert2(x, y.typ) ELSE OCS.Mark(100) END | Real: IF g = SInt THEN convert2(y, x.typ) ELSIF g = Int THEN convert2(y, x.typ) ELSIF g = LInt THEN convert2(y, x.typ) ELSIF g = LReal THEN convert3(x) ELSE OCS.Mark(100) END | LReal: IF g = SInt THEN convert2(y, x.typ) ELSIF g = Int THEN convert2(y, x.typ) ELSIF g = LInt THEN convert2(y, x.typ) ELSIF g = Real THEN convert3(y) ELSE OCS.Mark(100) END | NilTyp:   IF g # Pointer THEN OCS.Mark(100) END | Pointer: IF g = Pointer THEN p := x.typ.BaseTyp; q := y.typ.BaseTyp; IF (p.form = Record) & (q.form = Record) THEN IF p.n < q.n THEN r := p; p := q; q := r END; WHILE (p # q) & (p # NIL) DO p := p.BaseTyp END; IF p = NIL THEN OCS.Mark(100) END ELSE OCS.Mark(100) END ELSIF g # NilTyp THEN OCS.Mark(100) END | ProcTyp: IF g # NilTyp THEN OCS.Mark(100) END | Array, DynArr, String: | Byte, Bool, Char, Set, NoTyp, Record: OCS.Mark(100) END END ; f := x.typ.form; g := y.typ.form; L := lengcode[f]; CASE op OF 				1: IF f IN intSet THEN (***) IF (x.mode = Con) & (y.mode = Con) THEN (*ovfl test missing*) x.a0 := x.a0 * y.a0; SetIntType(x) ELSIF (x.mode = Con) & (mant(x.a0) = 1) THEN x.a0 := log; x.typ := OCT.sinttyp; load(y); OCC.Put(F6, L+4, y, x); (*ASHi*) x := y 						ELSIF (y.mode = Con) & (mant(y.a0) = 1) THEN y.a0 := log; y.typ := OCT.sinttyp; load(x); OCC.Put(F6, L+4, x, y) (*ASHi*) ELSE load(x); OCC.Put(F7, L+20H, x, y) (*MULi*) END ELSIF f IN realSet THEN loadF(x); OCC.Put(F11, 30H+L, x, y) (*MULf*) ELSIF f = Set THEN load(x); OCC.PutF4(2BH, x, y) (*ANDD*) ELSIF f # Undef THEN OCS.Mark(101) END | 2: IF f IN realSet THEN (*/*) loadF(x); OCC.Put(F11, 20H+L, x, y) (*DIVf*) ELSIF f IN intSet THEN convert2(x, OCT.realtyp); convert2(y, OCT.realtyp); OCC.Put(F11, 21H, x, y) (*DIVF*) ELSIF f = Set THEN load(x); OCC.PutF4(3BH, x, y) (*XORD*) ELSIF f # Undef THEN OCS.Mark(102) END | 3: IF f IN intSet THEN (*DIV*) IF (x.mode = Con) & (y.mode = Con) THEN IF y.a0 # 0 THEN x.a0 := x.a0 DIV y.a0; SetIntType(x) ELSE OCS.Mark(205) END ELSIF (y.mode = Con) & (mant(y.a0) = 1) THEN y.a0 := -log; y.typ := OCT.sinttyp; load(x); OCC.Put(F6, L+4, x, y) (*ASHi*) ELSE load(x); OCC.Put(F7, L+3CH, x, y) (*DIVi*) END ELSIF f # Undef THEN OCS.Mark(103) END | 4: IF f IN intSet THEN (*MOD*) IF (x.mode = Con) & (y.mode = Con) THEN IF y.a0 # 0 THEN x.a0 := x.a0 MOD y.a0; x.typ := y.typ ELSE OCS.Mark(205) END ELSIF (y.mode = Con) & (mant(y.a0) = 1) THEN y.a0 := ASH(-1, log); load(x); OCC.PutF4(L+8, x, y) (*BICi*) ELSE load(x); OCC.Put(F7, L+38H, x, y) (*MODi*) END ELSIF f # Undef THEN OCS.Mark(104) END | 5: IF y.mode # Coc THEN (*&*) IF y.mode = Con THEN IF y.a0 = 1 THEN setCC(y, 14) ELSE setCC(y, 15) END ELSIF y.mode <= Reg THEN OCC.PutF2(1CH, 1, y); setCC(y, 0) ELSE OCS.Mark(94); setCC(y, 0) END END ; IF x.mode = Con THEN IF x.a0 = 0 THEN OCC.FixLink(y.a1); OCC.FixLink(y.a2); setCC(y, 15) END ; setCC(x, 0) END; IF y.a2 # 0 THEN x.a2 := OCC.MergedLinks(x.a2, y.a2) END ; x.a0 := y.a0; x.a1 := y.a1 			| 6: IF f IN intSet THEN (*+*) IF (x.mode = Con) & (y.mode = Con) THEN INC(x.a0, y.a0); SetIntType(x) (*ovfl test missing*) ELSE load(x); add(L, x, y) 					END ELSIF f IN realSet THEN loadF(x); OCC.Put(F11, L, x, y) (*ADDf*) ELSIF f = Set THEN IF (x.mode = Con) & (y.mode = Con) THEN x.a0 := SYSTEM.VAL (LONGINT, SYSTEM.VAL(SET, x.a0) + SYSTEM.VAL(SET, y.a0)) ELSE load(x); OCC.PutF4(1BH, x, y) (*ORD*) END ELSIF f # Undef THEN OCS.Mark(105) END | 7: IF f IN intSet THEN (*-*) IF (x.mode = Con) & (y.mode = Con) THEN DEC(x.a0, y.a0); SetIntType(x) (*ovfl test missing*) ELSE load(x); sub(L, x, y) 					END ELSIF f IN realSet THEN loadF(x); OCC.Put(F11, 10H+L, x, y) (*SUBf*) ELSIF f = Set THEN load(x); OCC.PutF4(0BH, x, y) (*BICD*) ELSIF f # Undef THEN OCS.Mark(106) END | 8: IF y.mode # Coc THEN (*OR*) IF y.mode = Con THEN IF y.a0 = 1 THEN setCC(y, 14) ELSE setCC(y, 15) END ELSIF y.mode <= Reg THEN OCC.PutF2(1CH, 1, y); setCC(y, 0) ELSE OCS.Mark(95); setCC(y, 0) END END ; IF x.mode = Con THEN IF x.a0 = 1 THEN OCC.FixLink(y.a1); OCC.FixLink(y.a2); setCC(y, 14) END ; setCC(x, 0) END ; IF y.a1 # 0 THEN x.a1 := OCC.MergedLinks(x.a1, y.a1) END ; x.a0 := y.a0; x.a2 := y.a2 			| 9: IF f IN {Undef, Char..LInt, Set, NilTyp, Pointer, ProcTyp} THEN cmp(L, x, y); setCC(x, 0) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 0) ELSIF f = Bool THEN CompBool(0) ELSIF strings THEN CompStrings(0, TRUE) ELSE OCS.Mark(107) END |10: IF f IN {Undef, Char..LInt, Set, NilTyp, Pointer, ProcTyp} THEN cmp(L, x, y); setCC(x, 1) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 1) ELSIF f = Bool THEN CompBool(1) ELSIF strings THEN CompStrings(1, TRUE) ELSE OCS.Mark(107) END |11: IF f IN intSet THEN cmp(L, x, y); setCC(x, 6) ELSIF f = Char THEN cmp(0, x, y); setCC(x, 4) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 6) ELSIF strings THEN CompStrings(4, FALSE) ELSE OCS.Mark(108) END |12: IF f IN intSet THEN cmp(L, x, y); setCC(x, 13) ELSIF f = Char THEN cmp(0, x, y); setCC(x, 11) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 13) ELSIF strings THEN CompStrings(11, TRUE) ELSE OCS.Mark(108) END |13: IF f IN intSet THEN cmp(L, x, y); setCC(x, 12) ELSIF f = Char THEN cmp(0, x, y); setCC(x, 10) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 12) ELSIF strings THEN CompStrings(10, TRUE) ELSE OCS.Mark(108) END |14: IF f IN intSet THEN cmp(L, x, y); setCC(x, 7) ELSIF f = Char THEN cmp(0, x, y); setCC(x, 5) ELSIF f IN realSet THEN OCC.Put(F11, 8+L, x, y); setCC(x, 7) ELSIF strings THEN CompStrings(5, FALSE) ELSE OCS.Mark(108) END END END Op; PROCEDURE StPar1*(VAR x: OCT.Item; fctno: INTEGER); VAR f, L: INTEGER; s: LONGINT; y: OCT.Item; BEGIN f := x.typ.form; CASE fctno OF 				0: (*HALT*) IF (f = SInt) & (x.mode = Con) THEN IF x.a0 >= 20 THEN OCC.PutF1(0F2H); OCC.PutByte(x.a0) (*BPT*) ELSE OCS.Mark(218) END ELSE OCS.Mark(217) END ; x.typ := OCT.notyp | 1: (*NEW*) y.mode := Reg; IF f = Pointer THEN y.a0 := 0; OCC.PutF4(27H, y, x); x.typ := x.typ.BaseTyp; f := x.typ.form; IF x.typ.size > 7FFF80H THEN OCS.Mark(227) ELSIF f = Record THEN y.a0 := 1; x.mode := Var; x.lev := -x.typ.mno; x.a0 := x.typ.adr; OCC.PutF4(17H, y, x); OCC.PutF1(0E2H); OCC.PutByte(0) (*SVC 0*) ELSIF f = Array THEN y.a0 := 2; x.a0 := x.typ.size; x.mode := Con; x.typ := OCT.linttyp; OCC.PutF4(17H, y, x); OCC.PutF1(0E2H); OCC.PutByte(1) (*SVC 1*) ELSE OCS.Mark(111) END ELSE OCS.Mark(111) END ; x.typ := OCT.notyp | 2: (*CC*) IF (f = SInt) & (x.mode = Con) THEN IF (0 <= x.a0) & (x.a0 < 16) THEN setCC(x, x.a0) ELSE OCS.Mark(219) END ELSE OCS.Mark(217) END | 3: (*ABS*) y := x; L := lengcode[f]; IF f IN intSet THEN OCC.GetReg(x); OCC.Put(F6, 30H+L, x, y) (*ABSi*) ELSIF f IN realSet THEN OCC.GetFReg(x); OCC.Put(F11, 34H+L, x, y) (*ABSf*) ELSE OCS.Mark(111) END | 4: (*CAP*) y.mode := Con; y.typ := OCT.chartyp; y.a0 := 5FH; IF f = Char THEN load(x); OCC.PutF4(28H, x, y) (*ANDB*) ELSE OCS.Mark(111); x.typ := OCT.chartyp END | 5: (*ORD*) IF (f = Char) OR (f = Byte) THEN (*MOVZBW*) IF x.mode # Con THEN y := x; OCC.GetReg(x); OCC.Put(F7, 14H, x, y) END ELSE OCS.Mark(111) END ; x.typ := OCT.inttyp | 6: (*ENTIER*) IF f IN realSet THEN y := x; OCC.GetReg(x); OCC.Put(F9, lengcode[f]*4 + 3BH, x, y) (*FLOORfD*) ELSE OCS.Mark(111) END ; x.typ := OCT.linttyp | 7: (*SIZE*) IF x.mode = Typ THEN x.a0 := x.typ.size ELSE OCS.Mark(110); x.a0 := 1 END ; x.mode := Con; SetIntType(x) | 8: (*ODD*) IF f IN intSet THEN y.mode := Con; y.typ := OCT.sinttyp; y.a0 := 0; OCC.PutF4(34H, x, y) (*TBITB 0*) ELSE OCS.Mark(111) END ; setCC(x, 8) | 9: (*ADR*) IF f = DynArr THEN y := x; OCC.GetReg(x); OCC.DynArrAdr(x, y) 				ELSE loadAdr(x); x.mode := Reg END ; x.typ := OCT.linttyp | 10: (*MIN*) IF x.mode = Typ THEN x.mode := Con; CASE f OF 							Bool, Char: x.a0 := 0 | SInt: x.a0 := -80H | Int: x.a0 := -8000H | LInt: x.a0 := 80000000H | Real: x.a0 := 0FF7FFFFFH | LReal: x.a0 := 0FFFFFFFFH; x.a1 := 0FFEFFFFFH | Set: x.a0 := 0; x.typ := OCT.inttyp | Undef, NilTyp .. Record: OCS.Mark(111) END ELSE OCS.Mark(110) END | 11: (*MAX*) IF x.mode = Typ THEN x.mode := Con; CASE f OF 							Bool: x.a0 := 1 | Char: x.a0 := 0FFH | SInt: x.a0 := 7FH | Int: x.a0 := 7FFFH | LInt: x.a0 := 7FFFFFFFH | Real: x.a0 := 7F7FFFFFH | LReal: x.a0 := 0FFFFFFFFH; x.a1 := 7FEFFFFFH | Set: x.a0 := 31; x.typ := OCT.inttyp | Undef, NilTyp .. Record: OCS.Mark(111) END ELSE OCS.Mark(110) END | | 12: (*CHR*) IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark(111) END ; IF (x.mode = VarX) OR (x.mode = IndX) THEN load(x) END ; x.typ := OCT.chartyp | 13: (*SHORT*) IF f = LInt THEN (*range test missing*) IF (x.mode = VarX) OR (x.mode = IndX) THEN load(x) ELSIF x.mode = Con THEN SetIntType(x); IF x.typ.form = LInt THEN OCS.Mark(203) END END ; x.typ := OCT.inttyp ELSIF f = LReal THEN (*MOVLF*) y := x; OCC.GetFReg(x); OCC.Put(F9, 16H, x, y); x.typ := OCT.realtyp ELSIF f = Int THEN (*range test missing*) IF (x.mode = VarX) OR (x.mode = IndX) THEN load(x) ELSIF x.mode = Con THEN SetIntType(x); IF x.typ.form # SInt THEN OCS.Mark(203) END END ; x.typ := OCT.sinttyp ELSE OCS.Mark(111) END | 14: (*LONG*) IF f = Int THEN convert1(x, OCT.linttyp) ELSIF f = Real THEN convert3(x) ELSIF f = SInt THEN convert1(x, OCT.inttyp) ELSIF f = Char THEN y := x; OCC.GetReg(x); OCC.Put(F7, 18H, x, y); x.typ := OCT.linttyp (*MOVZBD*) ELSE OCS.Mark(111) END | 15: (*OVFL*) IF (f = Bool) & (x.mode = Con) THEN (*BICPSRB 10H*) OCC.PutF1(7CH); OCC.PutF1(SHORT(x.a0)*2 + 0A1H); OCC.PutF1(10H) ELSE OCS.Mark(111) END ; x.typ := OCT.notyp | 16,17: (*INC DEC*) IF x.mode >= Con THEN OCS.Mark(112) ELSIF ~(f IN intSet) THEN OCS.Mark(111) END | 18,19: (*INCL EXCL*) IF x.mode >= Con THEN OCS.Mark(112) ELSIF x.typ # OCT.settyp THEN OCS.Mark(111); x.typ := OCT.settyp END | 20: (*LEN*) IF (f # DynArr) & (f # Array) THEN OCS.Mark(131) END | 21: (*ASH*) IF f = LInt THEN load(x) ELSIF f IN intSet THEN loadX(x); x.typ := OCT.linttyp ELSE OCS.Mark(111) END | 22, 23: (*LSH ROT*) IF f IN {Char, SInt, Int, LInt, Set} THEN load(x) ELSE OCS.Mark(111) END | 24,25,26: (*GET, PUT, BIT*) IF (f IN intSet) & (x.mode = Con) THEN x.mode := Abs ELSIF f = LInt THEN IF (x.mode = Var) & (x.lev >= 0) THEN x.mode := Ind; x.a1 := 0 ELSE load(x); x.mode := RegI; x.a1 := 0 END ELSE OCS.Mark(111) END | 27: (*VAL*) IF x.mode # Typ THEN OCS.Mark(110) END | 28: (*SYSTEM.NEW*) IF (f = Pointer) & (x.mode < Con) THEN y.mode := Reg; y.a0 := 0; OCC.PutF4(27H, y, x); ELSE OCS.Mark(111) END | 29: (*COPY*) IF (((f=Array) OR (f=DynArr)) & (x.typ.BaseTyp.form = Char)) OR (f = String) THEN y.mode := Reg; y.a0 := 1; IF f = DynArr THEN OCC.DynArrAdr(y, x) 					ELSE OCC.PutF4(27H, y, x) 					END ELSE OCS.Mark(111) END | 30: (*MOVE*) IF f = LInt THEN y.mode := Reg; y.a0 := 1; OCC.PutF4(17H, y, x) 				ELSE OCS.Mark(111) END END END StPar1; PROCEDURE StPar2*(VAR p, x: OCT.Item; fctno: INTEGER); VAR f, L: INTEGER; y, z: OCT.Item; typ: OCT.Struct; BEGIN f := x.typ.form; IF fctno < 16 THEN OCS.Mark(64); RETURN END ; CASE fctno OF 				16, 17: (*INC DEC*) IF x.typ # p.typ THEN IF (x.mode = Con) & (x.typ.form IN intSet) THEN x.typ := p.typ ELSE OCS.Mark(111) END END ; L := lengcode[p.typ.form]; IF fctno = 16 THEN add(L, p, x) ELSE sub(L, p, x) END ; p.typ := OCT.notyp | 18: (*INCL*) Set0(y, x); OCC.PutF4(1BH, p, y); p.typ := OCT.notyp (*ORD*) | 19: (*EXCL*) Set0(y, x); OCC.PutF4(0BH, p, y); p.typ := OCT.notyp (*BICD*) | 20: (*LEN*) IF (x.mode = Con) & (f = SInt) THEN L := SHORT(x.a0); typ := p.typ; WHILE (L > 0) & (typ.form IN {DynArr, Array}) DO 						typ := typ.BaseTyp; DEC(L) END; IF (L # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark(132) ELSE IF typ.form = DynArr THEN p.mode := Var; p.typ := OCT.linttyp; INC(p.a0, typ.adr); load(p); OCC.PutF2(0FH, 1, p) (* ADDQD 1, p *) ELSE p := x; p.a0 := typ.n; SetIntType(p) END END ELSE OCS.Mark(111) END | 21, 22, 23: (*ASH LSH ROT*) IF f IN intSet THEN IF fctno = 21 THEN L := 4 ELSIF fctno = 22 THEN L := 14H ELSE L := 0 END ; IF (x.mode = VarX) OR (x.mode = IndX) THEN load(x) END ; x.typ := OCT.sinttyp; OCC.Put(F6, lengcode[p.typ.form]+L, p, x) 				ELSE OCS.Mark(111) END | 24: (*GET*) IF x.mode >= Con THEN OCS.Mark(112) ELSIF f IN {Undef..LInt, Set, Pointer, ProcTyp} THEN OCC.PutF4(lengcode[f]+14H, x, p) 				ELSIF f IN realSet THEN OCC.Put(F11, lengcode[f]+4, x, p) (*MOVf*) END ; p.typ := OCT.notyp | 25: (*PUT*) IF f IN {Undef..LInt, Set, Pointer, ProcTyp} THEN OCC.PutF4(lengcode[f]+14H, p, x) 				ELSIF f IN realSet THEN OCC.Put(F11, lengcode[f]+4, p, x) (*MOVf*) END ; p.typ := OCT.notyp | 26: (*BIT*) IF f IN intSet THEN OCC.PutF4(lengcode[f] + 34H, p, x) (*TBITi*) ELSE OCS.Mark(111) END ; setCC(p, 8) | 27: (*VAL*) x.typ := p.typ; p := x 			| 28: (*SYSTEM.NEW*) y.mode := Reg; y.a0 := 2; IF f = LInt THEN OCC.PutF4(17H, y, x) 				ELSIF f = Int THEN OCC.Put(F7, 1DH, y, x) (*MOVXWD*) ELSIF f = SInt THEN OCC.Put(F7, 1CH, y, x) (*MOVXBD*) ELSE OCS.Mark(111) END ; OCC.PutF1(0E2H); OCC.PutByte(1); (*SVC 1*) p.typ := OCT.notyp | 29: (*COPY*) IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN y.mode := Reg; y.a0 := 2; y.a1 := 0; IF f = DynArr THEN p := x; OCC.DynArrAdr(y, x); y.a0 := 0; p.mode := Var; INC(p.a0, p.typ.adr); OCC.PutF4(17H, y, p) 					ELSE OCC.PutF4(27H, y, x); y.a0 := 0; p.mode := Con; p.typ := OCT.inttyp; p.a0:= x.typ.size-1; OCC.Put(F7, 19H, y, p); (*MOVZWD*) END; y.a0 := 4; OCC.PutF2(5FH, 0, y); (*MOVQD*) OCC.PutF1(14); OCC.PutF1(0); OCC.PutF1(6); (*MOVSB*) y.mode := RegI; y.a0 := 2; OCC.PutF2(5CH, 0, y) (*MOVQB*) ELSE OCS.Mark(111) END ; p.typ := OCT.notyp | 30: (*MOVE*) IF f = LInt THEN y.mode := Reg; y.a0 := 2; OCC.PutF4(17H, y, x) 				ELSE OCS.Mark(111) END END END StPar2; PROCEDURE StPar3*(VAR p, x: OCT.Item; fctno: INTEGER); VAR f: INTEGER; y: OCT.Item; BEGIN f := x.typ.form; IF fctno = 30 THEN (*MOVE*) y.mode := Reg; y.a0 := 0; IF f = Int THEN OCC.Put(F7, 1DH, y, x) 			ELSIF f = SInt THEN OCC.Put(F7, 1CH, y, x) 			ELSIF f = LInt THEN OCC.PutF4(17H, y, x) 			ELSE OCS.Mark(111) END ; OCC.PutF1(14); OCC.PutF1(0); OCC.PutF1(0); p.typ := OCT.notyp (*MOVSB*) ELSE OCS.Mark(64) END END StPar3; PROCEDURE StFct*(VAR p: OCT.Item; fctno, parno: INTEGER); BEGIN IF fctno >= 16 THEN IF (fctno = 16) & (parno = 1) THEN (*INC*) OCC.PutF2(lengcode[p.typ.form]+0CH, 1, p); p.typ := OCT.notyp ELSIF (fctno = 17) & (parno = 1) THEN (*DEC*) OCC.PutF2(lengcode[p.typ.form]+0CH, -1, p); p.typ := OCT.notyp ELSIF (fctno = 20) & (parno = 1) THEN (*LEN*) IF p.typ.form = DynArr THEN p.mode := Var; INC(p.a0, p.typ.adr); p.typ := OCT.linttyp; load(p); OCC.PutF2(0FH, 1, p) (*ADDQD 1 p*) ELSE p.mode := Con; p.a0 := p.typ.n; SetIntType(p) END ELSIF (parno < 2) OR (fctno = 30) & (parno < 3) THEN OCS.Mark(65) END ELSIF parno < 1 THEN OCS.Mark(65) END END StFct; BEGIN intSet := {SInt, Int, LInt}; realSet := {Real, LReal}; lengcode[Undef] := 0; lengcode[Byte] := 0; lengcode[Bool] := 0; lengcode[Char] := 0; lengcode[SInt] := 0; lengcode[Int] := 1; lengcode[LInt] := 3; lengcode[Real] := 1; lengcode[LReal] := 0; lengcode[Set] := 3; lengcode[String] := 0; lengcode[NilTyp] := 3; lengcode[ProcTyp] := 3; lengcode[Pointer] := 3; lengcode[Array] := 1; lengcode[DynArr] := 1; lengcode[Record] := 1 END OCE.