[_CD4_]<dragon>Modula>M2FImpl.mesa!1

FILE: M2FImpl.mesa

Modula-2 Code-Generator Part 1

Last Edited by: Gutknecht, September 18, 1985 0:21:48 am PDT

DIRECTORY

M2D USING [StrForm, VarPtr, StrPtr, EnumPtr, RangePtr, ArrayPtr, notyp, inttyp, cardtyp, dbltyp, realtyp, lrltyp, chartyp, bitstyp],

M2G USING [GenSingSet, PrepAss, GenAssign],

M2H USING [ItemPtr, Item, Load, LoadStk, LoadAdrStk, GenOp],

M2I USING [PutOB, PutRR, PutRJB],

M2S USING [Mark],

M2F;

M2FImpl : CEDAR PROGRAM

IMPORTS M2D, M2I, M2H, M2G, M2S

EXPORTS M2F =

BEGIN OPEN M2F;

LIB: CARDINAL = 222B; RAND: CARDINAL = 301B; RSUB: CARDINAL = 305B; RXOR: CARDINAL = 310B; RJLB: CARDINAL = 342B;

err: PROC [n: CARDINAL] = { M2S.Mark [n] };

SRTest: PROC [x: M2H.ItemPtr] =

{ IF (x^.typ # NIL) AND (x^.typ^.form = Range) THEN

{ range: M2D.RangePtr ← NARROW [x^.typ^.ext]; x^.typ ← range^.BaseTyp }};

GenStParam: PUBLIC PROC [p, x: M2H.ItemPtr, fctno, parno: CARDINAL] =

{ restyp: M2D.StrPtr; f: M2D.StrForm;

u: M2H.ItemPtr ← NEW [M2H.Item]; v: M2H.ItemPtr ← NEW [M2H.Item];

IF fctno < 20 THEN

IF parno = 0 THEN -- first parameter --

{ restyp ← p^.obj^.typ;

SELECT fctno FROM

0, 1 => {};

2 => { SRTest [x]; -- ABS --

IF x^.typ = M2D.inttyp THEN

{ M2H.LoadStk [x]; M2I.PutRJB [RJLB, 0, 0, 1, 0, 0, 6];

M2I.PutRR [RSUB, 1, 1, 1, 0, 12, 0, 12]; restyp ← M2D.inttyp }

ELSE IF x^.typ = M2D.realtyp THEN

{ M2H.Load [x]; restyp ← M2D.realtyp }

ELSE err [144] };

3 => { SRTest [x]; -- CAP --

IF x^.typ = M2D.chartyp THEN { M2H.LoadStk [x];

M2I.PutOB [LIB, 137B]; M2I.PutRR [RAND, 1, 1, 1, 0, 13, 14, 13] }

ELSE err [144] };

4 => { SRTest [x]; -- FLOAT --

IF x^.typ = M2D.cardtyp THEN M2H.Load [x] ELSE err [144] };

5 => { SRTest [x]; -- ODD --

IF (x^.typ = M2D.cardtyp) OR (x^.typ = M2D.inttyp) THEN

{ M2H.LoadStk [x];

M2I.PutOB [LIB, 1B]; M2I.PutRR [RAND, 1, 1, 1, 0, 13, 14, 13] }

ELSE err [144] };

6 => { SRTest [x]; -- ORD --

IF (x^.typ^.form <= Card) OR (x^.typ^.form = Enum) THEN M2H.Load [x]

ELSE err [144] };

7 => { -- TRUNC --

IF x^.typ = M2D.realtyp THEN M2H.Load [x] ELSE err [144] };

8 => { IF (x^.mode = typMd) OR (x^.mode = varMd) THEN

x^.val.I ← x^.typ^.size -- SIZE, TSIZE --

ELSE { err [145]; x^.val.I ← 1 };

x^.mode ← conMd; restyp ← M2D.cardtyp };

9 => {};

10 => { M2H.LoadAdrStk [x]; x^.mode ← stkMd -- ADR --};

11 => { IF x^.mode = typMd THEN -- MIN --

{ x^.mode ← conMd; restyp ← x^.typ;

SELECT x^.typ^.form FROM

Bool => { x^.val.B ← FALSE };

Char => { x^.val.Ch ← 0C };

Int => { x^.val.C ← 100000B };

Card => { x^.val.C ← 0 };

Real => { x^.val.D0 ← 177577B; x^.val.D1 ← 177777B };

Double => { x^.val.D0 ← 100000B; x^.val.D1 ← 0 };

Enum => { x^.val.C ← 0 };

Range => { range: M2D.RangePtr ← NARROW [x^.typ^.ext];

x^.val.I ← range^.min }

ENDCASE => err [144] }

ELSE err [145] };

12 => {IF x^.mode = typMd THEN -- MAX --

{ x^.mode ← conMd; restyp ← x^.typ;

SELECT x^.typ^.form FROM

Bool => { x^.val.B ← TRUE };

Char => { x^.val.Ch ← 377C };

Int => { x^.val.C ← 77777B };

Card => { x^.val.C ← 177777B };

Real => { x^.val.D0 ← 77577B; x^.val.D1 ← 177777B };

Double => { x^.val.D0 ← 77777B; x^.val.D1 ← 177777B };

Enum => { enum: M2D.EnumPtr ← NARROW [x^.typ^.ext];

x^.val.C ← enum^.NofConst - 1 };

Range => { range: M2D.RangePtr ← NARROW [x^.typ^.ext];

x^.val.I ← range^.max }

ENDCASE => err [144] }

ELSE err [145] };

13 => { IF (x^.mode = varMd) AND (x^.typ^.form = Array) THEN -- HIGH --

{ array: M2D.ArrayPtr ← NARROW [x^.typ^.ext];

IF array^.dyn THEN

{ var: M2D.VarPtr ← NARROW [x^.obj^.ext];

M2I.PutRR [RSUB, 1, 0, 1, 0, 15, var^.cell+1, 1]; -- SIZE-1

x^.mode ← stkMd; restyp ← M2D.cardtyp }

ELSE { range: M2D.RangePtr ← NARROW [array^.IndexTyp^.ext];

x^.mode ← conMd; x^.val.I ← range^.max;

restyp ← array^.IndexTyp }}

ELSE err [144] };

14 => { SRTest [x]; -- CHR --

IF (x^.typ # M2D.cardtyp) AND (x^.typ # M2D.inttyp) THEN err [144];

restyp ← M2D.chartyp };

15 => { SRTest [x]; -- LONG --

IF x^.typ^.form = Int THEN {}

ELSE IF x^.typ^.form = Card THEN {}

ELSE IF x^.typ^.form = Real THEN {restyp ← M2D.lrltyp }};

16, 17 => { f ← x^.typ^.form; -- INC, DEC --

IF (f <= Double) OR (f = Range) OR (f = Enum) THEN

{ SRTest [x]; M2G.PrepAss [x]; restyp ← x^.typ }

ELSE err [144] };

18, 19 => { IF x^.typ^.form = Set THEN -- INCL, EXCL --

{ M2G.PrepAss [x]; restyp ← x^.typ }

ELSE err [144] };

20 => { SRTest [x]; -- SHIFT --

IF (x^.typ = M2D.cardtyp) OR (x^.typ = M2D.inttyp) THEN M2H.Load [x]

ELSE err [144] }

ENDCASE;

p^ ← x^; p^.typ ← restyp }

ELSE

IF parno = 1 THEN-- second parameter --

IF fctno = 16 THEN -- INC --

{ u^ ← p^; M2H.Load [u]; M2H.Load [x];

M2H.GenOp [plus, u, x]; M2G.GenAssign [p, u] }

ELSE IF fctno = 17 THEN -- DEC --

{ u^ ← p^; M2H.Load [u]; M2H.Load [x];

M2H.GenOp [minus, u, x]; M2G.GenAssign [p, u] }

ELSE IF fctno = 18 THEN -- INCL --

{ u^ ← p^; v^.typ ← p^.typ; M2G.GenSingSet [v, x];

M2H.LoadStk [v]; M2H.GenOp [plus, u, v]; M2G.GenAssign [p, u];

p^.typ ← M2D.notyp }

ELSE IF fctno = 19 THEN -- EXCL --

{ u^ ← p^; v^.typ ← p^.typ; M2G.GenSingSet [v, x];

M2H.LoadStk [v]; M2I.PutRR [RXOR, 1,1,1,0, 12, 6, 12];

M2H.GenOp [times, u, v]; M2G.GenAssign [p, u];

p^.typ ← M2D.notyp }

ELSE IF fctno = 20 THEN -- SHIFT --

{ SRTest [p]; SRTest [x];

IF (x^.typ = M2D.cardtyp) OR (x^.typ = M2D.inttyp) THEN

x^.typ ← M2D.chartyp

ELSE err [144];

IF (p^.typ # M2D.inttyp) AND (p^.typ # M2D.cardtyp) AND (p^.typ # M2D.bitstyp) AND (p^.typ # M2D.dbltyp) THEN err [144] }

ELSE err [64]

ELSE err [64] };

GenStFct: PUBLIC PROC [p: M2H.ItemPtr, fctno, parno: CARDINAL] =

{ x: M2H.ItemPtr ← NEW [M2H.Item]; u: M2H.ItemPtr ← NEW [M2H.Item];

IF parno < 1 THEN err [65]

ELSE IF fctno = 16 THEN -- INC --

{ IF parno = 1 THEN { x^.mode ← conMd; x^.typ ← M2D.inttyp; x^.val.C ← 1;

u^ ← p^; M2H.Load [u]; M2H.Load [x]; M2H.GenOp [plus, u, x];

M2G.GenAssign [p, u] };

p^.typ ← M2D.notyp }

ELSE IF fctno = 17 THEN -- DEC --

{ IF parno = 1 THEN { x^.mode ← conMd; x^.typ ← M2D.inttyp; x^.val.C ← 1;

u^ ← p^; M2H.Load [u]; M2H.Load [x]; M2H.GenOp [minus, u, x];

M2G.GenAssign [p, u] };

p^.typ ← M2D.notyp }

ELSE IF (fctno > 17) AND (parno < 2) THEN err [65] };

END.