ð#Syntax10.Scn.FntßyßyMODULE Compiler; (*NW 7.6.87 / 21.8.92 / 14.12.93*) IMPORT SYSTEM, Texts, TextFrames, Viewers, Oberon, OBS, OBT, OBC, OBE, OBH; CONST NofCases = 128; ModNameLen = 20; MaxRecs = 32; RecDescSize = 8; AdrSize = 4; ProcSize = 4; PtrSize = 4; XParOrg = 12; LParOrg = 8; LDataSize = 2000H; (*symbol values*) times = 1; slash = 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; comma = 19; colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24; of = 25; then = 26; do = 27; to = 28; lparen = 29; lbrak = 30; lbrace = 31; not = 32; becomes = 33; number = 34; nil = 35; string = 36; ident = 37; semicolon = 38; bar = 39; end = 40; else = 41; elsif = 42; until = 43; if = 44; case = 45; while = 46; repeat = 47; loop = 48; with = 49; exit = 50; return = 51; for = 52; by = 53; array = 54; record = 55; pointer = 56; begin = 57; const = 58; type = 59; var = 60; procedure = 61; import = 62; module = 63; (*object and item modes*) Var = 1; Ind = 3; Con = 8; Stk = 9; Stk0 = 10; Fld = 13; Typ = 14; LProc = 15; SProc = 16; CProc = 17; IProc = 18; Mod = 19; (*structure forms*) Undef = 0; 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; intSet = {4 .. 6}; labeltyps = {3 .. 6}; VAR W: Texts.Writer; sym, nofrecs: INTEGER; newSF: BOOLEAN; dsize: LONGINT; LoopLevel, ExitNo: INTEGER; LoopExit: ARRAY 16 OF INTEGER; PROCEDURE^ Type(VAR typ: OBT.Struct); PROCEDURE^ FormalType(VAR typ: OBT.Struct); PROCEDURE^ Expression(VAR x: OBT.Item); PROCEDURE^ Block(VAR dsize: LONGINT); PROCEDURE CheckSym(s: INTEGER); BEGIN IF sym = s THEN OBS.Get(sym) ELSE OBS.Mark(s) END END CheckSym; PROCEDURE qualident(VAR x: OBT.Item); VAR mnolev: INTEGER; obj: OBT.Object; BEGIN (*sym = ident*) OBT.Find(obj, mnolev); OBS.Get(sym); IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN OBS.Get(sym); mnolev := SHORT(-obj.a0); IF sym = ident THEN OBT.FindImport(obj, obj); OBS.Get(sym) ELSE OBS.Mark(10); obj := NIL END END ; x.lev := mnolev; x.obj := obj; IF obj # NIL THEN x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0; x.a1 := obj.a1 ELSE OBS.Mark(0); x.mode := Var; x.typ := OBT.undftyp; x.a0 := 0; x.obj := NIL END END qualident; PROCEDURE ConstExpression(VAR x: OBT.Item); BEGIN Expression(x); IF x.mode # Con THEN OBS.Mark(50); x.mode := Con; x.typ := OBT.inttyp; x.a0 := 1 END END ConstExpression; PROCEDURE NewStr(form: INTEGER): OBT.Struct; VAR typ: OBT.Struct; BEGIN NEW(typ); typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0; typ.BaseTyp := OBT.undftyp; typ.strobj := NIL; RETURN typ END NewStr; PROCEDURE CheckMark(VAR mk: BOOLEAN); BEGIN OBS.Get(sym); IF sym = times THEN IF OBC.level = 0 THEN mk := TRUE ELSE mk := FALSE; OBS.Mark(47) END ; OBS.Get(sym) ELSE mk := FALSE END END CheckMark; PROCEDURE CheckUndefPointerTypes; VAR obj: OBT.Object; BEGIN obj := OBT.topScope.next; WHILE obj # NIL DO IF obj.mode = Undef THEN OBS.Mark(48) END ; obj := obj.next END END CheckUndefPointerTypes; PROCEDURE RecordType(VAR typ: OBT.Struct); VAR adr, size: LONGINT; fld, fld0, fld1: OBT.Object; ftyp, btyp: OBT.Struct; base: OBT.Item; BEGIN adr := 0; typ := NewStr(Record); typ.BaseTyp := NIL; typ.extlev := 0; IF sym = lparen THEN OBS.Get(sym); (*record extension*) IF sym = ident THEN qualident(base); IF (base.mode = Typ) & (base.typ.form = Record) THEN typ.BaseTyp := base.typ; typ.extlev := base.typ.extlev + 1; adr := base.typ.size ELSE OBS.Mark(52) END ELSE OBS.Mark(10) END ; CheckSym(rparen) END ; OBT.OpenScope(0); fld := NIL; fld1 := OBT.topScope; LOOP IF sym = ident THEN LOOP IF sym = ident THEN IF typ.BaseTyp # NIL THEN OBT.FindField(typ.BaseTyp, fld0); IF fld0 # NIL THEN OBS.Mark(1) END END ; OBT.Insert(OBS.name, fld); CheckMark(fld.marked); fld.mode := Fld ELSE OBS.Mark(10) END ; IF sym = comma THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(19) ELSE EXIT END END ; CheckSym(colon); Type(ftyp); size := ftyp.size; btyp := ftyp; WHILE btyp.form = Array DO btyp := btyp.BaseTyp END ; IF btyp.size >= 4 THEN INC(adr, (-adr) MOD 4) ELSIF btyp.size = 2 THEN INC(adr, adr MOD 2) END ; WHILE fld1.next # NIL DO fld1 := fld1.next; fld1.typ := ftyp; fld1.a0 := adr; INC(adr, size) END END ; IF sym = semicolon THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(38) ELSE EXIT END END ; typ.size := (-adr) MOD 4 + adr; typ.mno := 0; typ.link := OBT.topScope.next; CheckUndefPointerTypes; OBT.CloseScope; IF OBC.level = 0 THEN INC(dsize, (-dsize) MOD 4 + 4); typ.adr := -dsize END ; OBC.RegisterRecType(typ) END RecordType; PROCEDURE ArrayType(VAR typ: OBT.Struct); VAR x: OBT.Item; f, n: INTEGER; BEGIN typ := NewStr(Array); ConstExpression(x); f := x.typ.form; IF f IN intSet THEN IF x.a0 <= 0 THEN x.a0 := 1; OBS.Mark(63) END ELSE OBS.Mark(51); x.a0 := 1 END ; IF sym = of THEN OBS.Get(sym); Type(typ.BaseTyp) ELSIF sym = comma THEN OBS.Get(sym); ArrayType(typ.BaseTyp) ELSE OBS.Mark(34) END ; typ.size := x.a0 * typ.BaseTyp.size END ArrayType; PROCEDURE FormalParameters(VAR resTyp: OBT.Struct; VAR psize: LONGINT); VAR mode: SHORTINT; adr, size: LONGINT; res: OBT.Item; par, par1: OBT.Object; typ: OBT.Struct; BEGIN par1 := OBT.topScope; adr := 0; IF (sym = ident) OR (sym = var) THEN LOOP IF sym = var THEN OBS.Get(sym); mode := Ind ELSE mode := Var END ; LOOP IF sym = ident THEN OBT.Insert(OBS.name, par); OBS.Get(sym); par.mode := mode ELSE OBS.Mark(10) END ; IF sym = comma THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(19) ELSIF sym = var THEN OBS.Mark(19); OBS.Get(sym) ELSE EXIT END END ; CheckSym(colon); FormalType(typ); IF mode = Ind THEN (*VAR param*) IF typ.form = Record THEN size := RecDescSize ELSIF typ.form = DynArr THEN size := typ.size ELSE size := AdrSize END ELSE size := (-typ.size) MOD 4 + typ.size END ; WHILE par1.next # NIL DO par1 := par1.next; par1.typ := typ; DEC(adr, size); par1.a0 := adr END ; IF sym = semicolon THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(38) ELSE EXIT END END END ; psize := psize - adr; par := OBT.topScope.next; WHILE par # NIL DO INC(par.a0, psize); par := par.next END ; CheckSym(rparen); IF sym = colon THEN OBS.Get(sym); resTyp := OBT.undftyp; IF sym = ident THEN qualident(res); IF res.mode = Typ THEN IF (res.typ.form <= ProcTyp) & (res.typ.form # NoTyp) THEN resTyp := res.typ ELSE OBS.Mark(54) END ELSE OBS.Mark(52) END ELSE OBS.Mark(10) END ELSE resTyp := OBT.notyp END END FormalParameters; PROCEDURE ProcType(VAR typ: OBT.Struct); VAR psize: LONGINT; BEGIN typ := NewStr(ProcTyp); typ.size := ProcSize; IF sym = lparen THEN OBS.Get(sym); OBT.OpenScope(OBC.level); psize := XParOrg; FormalParameters(typ.BaseTyp, psize); typ.link := OBT.topScope.next; OBT.CloseScope ELSE typ.BaseTyp := OBT.notyp; typ.link := NIL END END ProcType; PROCEDURE HasPtr(typ: OBT.Struct): BOOLEAN; VAR fld: OBT.Object; BEGIN IF typ.form = Pointer THEN RETURN TRUE ELSIF typ.form = Array THEN RETURN HasPtr(typ.BaseTyp) ELSIF typ.form = Record THEN IF (typ.BaseTyp # NIL) & HasPtr(typ.BaseTyp) THEN RETURN TRUE END ; fld := typ.link; WHILE fld # NIL DO IF (fld.name = "") OR HasPtr(fld.typ) THEN RETURN TRUE END ; fld := fld.next END END ; RETURN FALSE END HasPtr; PROCEDURE SetPtrBase(ptyp, btyp: OBT.Struct); BEGIN IF (btyp.form = Record) OR (btyp.form = Array) & ~HasPtr(btyp.BaseTyp) THEN ptyp.BaseTyp := btyp ELSE ptyp.BaseTyp := OBT.undftyp; OBS.Mark(57) END END SetPtrBase; PROCEDURE Type(VAR typ: OBT.Struct); VAR lev: INTEGER; obj: OBT.Object; x: OBT.Item; BEGIN typ := OBT.undftyp; IF sym < lparen THEN OBS.Mark(12); REPEAT OBS.Get(sym) UNTIL sym >= lparen END ; IF sym = ident THEN qualident(x); IF x.mode = Typ THEN typ := x.typ; IF typ = OBT.notyp THEN OBS.Mark(58) END ELSE OBS.Mark(52) END ELSIF sym = array THEN OBS.Get(sym); ArrayType(typ) ELSIF sym = record THEN OBS.Get(sym); RecordType(typ); CheckSym(end) ELSIF sym = pointer THEN OBS.Get(sym); typ := NewStr(Pointer); typ.link := NIL; typ.size := PtrSize; CheckSym(to); IF sym = ident THEN OBT.Find(obj, lev); IF obj = NIL THEN (*forward ref*) OBT.Insert(OBS.name, obj); typ.BaseTyp := OBT.undftyp; obj.mode := Undef; obj.typ := typ; OBS.Get(sym) ELSE qualident(x); IF x.mode = Typ THEN SetPtrBase(typ, x.typ) ELSE typ.BaseTyp := OBT.undftyp; OBS.Mark(52) END END ELSE Type(x.typ); SetPtrBase(typ, x.typ) END ELSIF sym = procedure THEN OBS.Get(sym); ProcType(typ) ELSE OBS.Mark(12) END ; IF (sym < semicolon) OR (else < sym) THEN OBS.Mark(15); WHILE (sym <= ident) OR (else < sym) & (sym < begin) DO OBS.Get(sym) END END END Type; PROCEDURE FormalType(VAR typ: OBT.Struct); VAR x: OBT.Item; typ0: OBT.Struct; a, s: LONGINT; BEGIN typ := OBT.undftyp; a := 0; WHILE sym = array DO OBS.Get(sym); CheckSym(of); INC(a, 4) END ; IF sym = ident THEN qualident(x); IF x.mode = Typ THEN typ := x.typ; IF typ = OBT.notyp THEN OBS.Mark(58) END ELSE OBS.Mark(52) END ELSIF sym = procedure THEN OBS.Get(sym); ProcType(typ) ELSE OBS.Mark(10) END ; s := a + 8; WHILE a > 0 DO typ0 := NewStr(DynArr); typ0.BaseTyp := typ; typ0.size := s-a; typ0.adr := typ0.size-4; typ0.mno := 0; typ := typ0; DEC(a, 4) END END FormalType; PROCEDURE selector(VAR x: OBT.Item); VAR fld: OBT.Object; y: OBT.Item; BEGIN LOOP IF sym = lbrak THEN OBS.Get(sym); LOOP IF (x.typ # NIL) & (x.typ.form = Pointer) THEN OBE.DeRef(x) END ; Expression(y); OBE.Index(x, y); IF sym = comma THEN OBS.Get(sym) ELSE EXIT END END ; CheckSym(rbrak) ELSIF sym = period THEN OBS.Get(sym); IF sym = ident THEN IF x.typ # NIL THEN IF x.typ.form = Pointer THEN OBE.DeRef(x) END ; IF x.typ.form = Record THEN OBT.FindField(x.typ, fld); OBE.Field(x, fld) ELSE OBS.Mark(53) END ELSE OBS.Mark(52) END ; OBS.Get(sym) ELSE OBS.Mark(10) END ELSIF sym = arrow THEN OBS.Get(sym); OBE.DeRef(x) ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN OBS.Get(sym); IF sym = ident THEN qualident(y); IF y.mode = Typ THEN OBE.TypTest(x, y, FALSE) ELSE OBS.Mark(52) END ELSE OBS.Mark(10) END ; CheckSym(rparen) ELSE EXIT END END END selector; PROCEDURE IsParam(obj: OBT.Object): BOOLEAN; BEGIN RETURN (obj # NIL) & (obj.mode <= Ind) & (obj.a0 >= 0) (*!*) END IsParam; PROCEDURE ActualParameters(VAR x: OBT.Item; fpar: OBT.Object); VAR apar: OBT.Item; R: SET; BEGIN IF sym # rparen THEN R := OBC.UsedRegisters(); LOOP Expression(apar); IF IsParam(fpar) THEN OBH.Param(apar, fpar); fpar := fpar.next ELSE OBS.Mark(64) END ; OBC.FreeRegs(R); IF sym = comma THEN OBS.Get(sym) ELSIF (lparen <= sym) & (sym <= ident) THEN OBS.Mark(19) ELSE EXIT END END END ; IF IsParam(fpar) THEN OBS.Mark(65) END END ActualParameters; PROCEDURE StandProcCall(VAR x: OBT.Item); VAR y: OBT.Item; m, n: INTEGER; BEGIN m := SHORT(x.a0); n := 0; IF sym = lparen THEN OBS.Get(sym); IF sym # rparen THEN LOOP IF n = 0 THEN Expression(x); OBE.StPar1(x, m); n := 1 ELSIF n = 1 THEN Expression(y); OBE.StPar2(x, y, m); n := 2 ELSIF n = 2 THEN Expression(y); OBE.StPar3(x, y, m); n := 3 ELSE OBS.Mark(64); Expression(y) END ; IF sym = comma THEN OBS.Get(sym) ELSIF (lparen <= sym) & (sym <= ident) THEN OBS.Mark(19) ELSE EXIT END END ; CheckSym(rparen) ELSE OBS.Get(sym) END ; OBE.StFct(x, m, n) ELSE OBS.Mark(29) END END StandProcCall; PROCEDURE Element(VAR x: OBT.Item); VAR e1, e2: OBT.Item; BEGIN Expression(e1); IF sym = upto THEN OBS.Get(sym); Expression(e2); OBE.Set1(x, e1, e2) ELSE OBE.Set0(x, e1) END ; END Element; PROCEDURE Sets(VAR x: OBT.Item); VAR y: OBT.Item; BEGIN x.typ := OBT.settyp; y.typ := OBT.settyp; IF sym # rbrace THEN Element(x); LOOP IF sym = comma THEN OBS.Get(sym) ELSIF (lparen <= sym) & (sym <= ident) THEN OBS.Mark(19) ELSE EXIT END ; Element(y); OBE.Op(plus, x, y) (*x := x+y*) END ELSE x.mode := Con; x.a0 := 0 END ; CheckSym(rbrace) END Sets; PROCEDURE Factor(VAR x: OBT.Item); VAR fpar: OBT.Object; gR, fR: SET; BEGIN IF sym < lparen THEN OBS.Mark(13); REPEAT OBS.Get(sym) UNTIL sym >= lparen END ; IF sym = ident THEN qualident(x); selector(x); IF x.mode = SProc THEN StandProcCall(x) ELSIF sym = lparen THEN OBS.Get(sym); OBH.PrepCall(x, fpar); OBC.SaveRegisters(gR, fR, x); ActualParameters(x, fpar); OBH.Call(x); OBC.RestoreRegisters(gR, fR, x); CheckSym(rparen) END ELSIF sym = number THEN OBS.Get(sym); x.mode := Con; CASE OBS.numtyp OF 1: x.typ := OBT.chartyp; x.a0 := OBS.intval | 2: x.a0 := OBS.intval; OBE.SetIntType(x) | 3: x.typ := OBT.realtyp; SYSTEM.PUT(SYSTEM.ADR(x.a0), OBS.realval) | 4: x.typ := OBT.lrltyp; SYSTEM.PUT(SYSTEM.ADR(x.a0), OBS.lrlval) END ELSIF sym = string THEN x.typ := OBT.stringtyp; x.mode := Con; OBC.AllocString(OBS.name, x); OBS.Get(sym) ELSIF sym = nil THEN OBS.Get(sym); x.typ := OBT.niltyp; x.mode := Con; x.a0 := 0 ELSIF sym = lparen THEN OBS.Get(sym); Expression(x); CheckSym(rparen) ELSIF sym = lbrak THEN OBS.Get(sym); OBS.Mark(29); Expression(x); CheckSym(rparen) ELSIF sym = lbrace THEN OBS.Get(sym); Sets(x) ELSIF sym = not THEN OBS.Get(sym); Factor(x); OBE.MOp(not, x) ELSE OBS.Mark(13); OBS.Get(sym); x.typ := OBT.undftyp; x.mode := Var; x.a0 := 0 END END Factor; PROCEDURE Term(VAR x: OBT.Item); VAR y: OBT.Item; mulop: INTEGER; BEGIN Factor(x); WHILE (times <= sym) & (sym <= and) DO mulop := sym; OBS.Get(sym); IF mulop = and THEN OBE.MOp(and, x) END ; Factor(y); OBE.Op(mulop, x, y) END END Term; PROCEDURE SimpleExpression(VAR x: OBT.Item); VAR y: OBT.Item; addop: INTEGER; BEGIN IF sym = minus THEN OBS.Get(sym); Term(x); OBE.MOp(minus, x) ELSIF sym = plus THEN OBS.Get(sym); Term(x); OBE.MOp(plus, x) ELSE Term(x) END ; WHILE (plus <= sym) & (sym <= or) DO addop := sym; OBS.Get(sym); IF addop = or THEN OBE.MOp(or, x) END ; Term(y); OBE.Op(addop, x, y) END END SimpleExpression; PROCEDURE Expression(VAR x: OBT.Item); VAR y: OBT.Item; relation: INTEGER; BEGIN SimpleExpression(x); IF (eql <= sym) & (sym <= geq) THEN relation := sym; OBS.Get(sym); IF x.typ.form = Bool THEN OBE.MOp(relation, x) END ; SimpleExpression(y); OBE.Op(relation, x, y) ELSIF sym = in THEN OBS.Get(sym); SimpleExpression(y); OBE.In(x, y) ELSIF sym = is THEN IF x.mode >= Typ THEN OBS.Mark(112) END ; OBS.Get(sym); IF sym = ident THEN qualident(y); IF y.mode = Typ THEN OBE.TypTest(x, y, TRUE) ELSE OBS.Mark(52) END ELSE OBS.Mark(10) END END END Expression; PROCEDURE ProcedureDeclaration; VAR proc, proc1, par: OBT.Object; L1: INTEGER; mode: SHORTINT; body: BOOLEAN; psize, dsize: LONGINT; BEGIN dsize := 0; proc := NIL; body := TRUE; IF (sym # ident) & (OBC.level = 0) THEN IF sym = times THEN mode := LProc; OBS.Mark(10) ELSIF sym = arrow THEN (*forward*) mode := LProc; body := FALSE ELSIF sym = plus THEN mode := IProc ELSIF sym = minus THEN mode := CProc; body := FALSE ELSE mode := LProc; OBS.Mark(10) END ; OBS.Get(sym) ELSE mode := LProc END ; IF sym = ident THEN IF OBC.level = 0 THEN OBT.Find(proc1, L1) ELSE proc1 := NIL END; IF (proc1 # NIL) & (proc1.mode = LProc) & (proc1.a0 = 0) THEN (*there exists a corresponding forward declaration*) OBT.Remove(proc1); OBT.Insert(OBS.name, proc); CheckMark(proc.marked); mode := LProc; OBC.FixLink(proc1.a1) ELSE IF proc1 # NIL THEN OBS.Mark(1); proc1 := NIL END ; OBT.Insert(OBS.name, proc); CheckMark(proc.marked) END ; proc.mode := mode; proc.typ := OBT.notyp; proc.a0 := 0; proc.a1 := 0; proc.dsc := NIL; INC(OBC.level); OBT.OpenScope(OBC.level); IF (mode = LProc) & (OBC.level = 1) THEN psize := LParOrg ELSE psize := XParOrg END ; IF sym = lparen THEN OBS.Get(sym); FormalParameters(proc.typ, psize); proc.dsc := OBT.topScope.next END ; IF proc1 # NIL THEN (*forward*) OBH.CompareParLists(proc.dsc, proc1.dsc); IF proc.typ # proc1.typ THEN OBS.Mark(118) END END ; IF mode = CProc THEN IF sym = number THEN proc.a0 := OBS.intval; OBS.Get(sym) ELSE OBS.Mark(17) END END ; IF body THEN CheckSym(semicolon); proc.a0 := OBC.pc; OBT.topScope.typ := proc.typ; OBT.topScope.a1 := mode*10000H + psize; (*for RETURN statements*) OBH.Enter(mode, L1); par := proc.dsc; WHILE par # NIL DO (*code for dynamic array value parameters*) IF (par.typ.form = DynArr) & (par.mode = Var) THEN OBH.CopyDynArray(par.a0, par.typ) END ; par := par.next END ; Block(dsize); proc.dsc := OBT.topScope.next; IF proc.typ = OBT.notyp THEN OBH.Return(proc.mode, psize) ELSE OBH.Trap(17) END ; IF OBE.inxloc > 0 THEN OBC.FixLink(OBE.inxloc); OBC.PutF1(0F2H); OBC.PutByte(15) END ; IF OBE.tchkloc > 0 THEN OBC.FixLink(OBE.tchkloc); OBC.PutF1(0F2H); OBC.PutByte(17) END ; IF dsize >= LDataSize THEN OBS.Mark(209); dsize := 0 END ; IF OBH.clrchk & (dsize < 4) THEN dsize := 4 END ; OBC.FixupWith(L1, dsize); proc.a2 := OBC.pc; IF sym = ident THEN IF OBS.name # proc.name THEN OBS.Mark(4) END ; OBS.Get(sym) ELSE OBS.Mark(10) END END ; DEC(OBC.level); OBT.CloseScope END END ProcedureDeclaration; PROCEDURE CaseLabelList(LabelForm: INTEGER; VAR n: INTEGER; VAR tab: ARRAY OF OBH.LabelRange); VAR x, y: OBT.Item; i, f: INTEGER; BEGIN IF ~(LabelForm IN labeltyps) THEN OBS.Mark(61) END ; LOOP ConstExpression(x); f := x.typ.form; IF f IN intSet THEN IF LabelForm < f THEN OBS.Mark(60) END ELSIF f # LabelForm THEN OBS.Mark(60) END ; IF sym = upto THEN OBS.Get(sym); ConstExpression(y); IF (y.typ.form # f) & ~((f IN intSet) & (y.typ.form IN intSet)) THEN OBS.Mark(60) END ; IF y.a0 < x.a0 THEN OBS.Mark(63); y.a0 := x.a0 END ELSE y := x END ; (*enter label range into ordered table*) i := n; IF i < NofCases THEN LOOP IF i = 0 THEN EXIT END ; IF tab[i-1].low <= y.a0 THEN IF tab[i-1].high >= x.a0 THEN OBS.Mark(62) END ; EXIT END ; tab[i] := tab[i-1]; DEC(i) END ; tab[i].low := SHORT(x.a0); tab[i].high := SHORT(y.a0); tab[i].label := OBC.pc; INC(n) ELSE OBS.Mark(213) END ; IF sym = comma THEN OBS.Get(sym) ELSIF (sym = number) OR (sym = ident) THEN OBS.Mark(19) ELSE EXIT END END END CaseLabelList; PROCEDURE StatSeq; VAR fpar: OBT.Object; xtyp: OBT.Struct; x, x0, y, z: OBT.Item; L0, L1, ExitIndex: INTEGER; PROCEDURE CasePart; VAR x: OBT.Item; n, L0, L1, L2, L3: INTEGER; tab: ARRAY NofCases OF OBH.LabelRange; BEGIN n := 0; L3 := 0; Expression(x); OBH.CaseIn(x, L0, L1); OBC.FreeRegs({}); CheckSym(of); LOOP IF sym < bar THEN CaseLabelList(x.typ.form, n, tab); CheckSym(colon); StatSeq; OBH.FJ(L3) END ; IF sym = bar THEN OBS.Get(sym) ELSE EXIT END END ; L2 := OBC.pc; IF sym = else THEN OBS.Get(sym); StatSeq; OBH.FJ(L3) ELSE OBH.Trap(16) END ; OBH.CaseOut(L0, L1, L2, L3, n, tab) END CasePart; BEGIN LOOP IF sym < ident THEN OBS.Mark(14); REPEAT OBS.Get(sym) UNTIL sym >= ident END ; IF sym = ident THEN qualident(x); selector(x); IF sym = becomes THEN OBS.Get(sym); Expression(y); OBH.Assign(x, y, FALSE) ELSIF sym = eql THEN OBS.Mark(33); OBS.Get(sym); Expression(y); OBH.Assign(x, y, FALSE) ELSIF x.mode = SProc THEN StandProcCall(x); IF x.typ.form # NoTyp THEN OBS.Mark(55) END ELSE OBH.PrepCall(x, fpar); IF sym = lparen THEN OBS.Get(sym); ActualParameters(x, fpar); CheckSym(rparen) ELSIF IsParam(fpar) THEN OBS.Mark(65) END ; OBH.Call(x); IF x.typ.form # NoTyp THEN OBS.Mark(55) END END ELSIF sym = if THEN OBS.Get(sym); Expression(x); OBH.CFJ(x, L0); OBC.FreeRegs({}); CheckSym(then); StatSeq; L1 := 0; WHILE sym = elsif DO OBS.Get(sym); OBH.FJ(L1); OBC.FixLink(L0); Expression(x); OBH.CFJ(x, L0); OBC.FreeRegs({}); CheckSym(then); StatSeq END ; IF sym = else THEN OBS.Get(sym); OBH.FJ(L1); OBC.FixLink(L0); StatSeq ELSE OBC.FixLink(L0) END ; OBC.FixLink(L1); CheckSym(end) ELSIF sym = case THEN OBS.Get(sym); CasePart; CheckSym(end) ELSIF sym = while THEN OBS.Get(sym); L1 := OBC.pc; Expression(x); OBH.CFJ(x, L0); OBC.FreeRegs({}); CheckSym(do); StatSeq; OBH.BJ(L1); OBC.FixLink(L0); CheckSym(end) ELSIF sym = repeat THEN OBS.Get(sym); L0 := OBC.pc; StatSeq; IF sym = until THEN OBS.Get(sym); Expression(x); OBH.CBJ(x, L0) ELSE OBS.Mark(43) END ELSIF sym = loop THEN OBS.Get(sym); ExitIndex := ExitNo; INC(LoopLevel); L0 := OBC.pc; StatSeq; OBH.BJ(L0); DEC(LoopLevel); WHILE ExitNo > ExitIndex DO DEC(ExitNo); OBC.fixup(LoopExit[ExitNo]) END ; CheckSym(end) ELSIF sym = for THEN OBS.Get(sym); IF sym = ident THEN qualident(x); IF ~(x.typ.form IN {SInt, Int, LInt}) THEN OBS.Mark(91) END ; IF sym = becomes THEN OBS.Get(sym); Expression(y); OBH.Assign(x, y, FALSE); CheckSym(to); Expression(y); IF y.mode # Con THEN (*temp var for limit*) z.mode := Stk; z.typ := x.typ; OBH.Assign(z, y, TRUE); y.mode := Stk0 END ; IF sym = by THEN OBS.Get(sym); ConstExpression(z) ELSE z.mode := Con; z.a0 := 1 END ; L0 := OBC.pc; x0 := x; z.typ := x.typ; IF z.a0 > 0 THEN OBE.Op(leq, x0, y) ELSIF z.a0 < 0 THEN OBE.Op(geq, x0, y) ELSE OBS.Mark(99) END ; OBH.CFJ(x0, L1); CheckSym(do); StatSeq; CheckSym(end); OBE.Inc(x, z); OBH.BJ(L0); OBC.FixLink(L1); IF y.mode = Stk0 THEN OBH.AdjustSP(-AdrSize) END ELSE OBS.Mark(33) END ELSE OBS.Mark(10) END ELSIF sym = with THEN OBS.Get(sym); x.obj := NIL; xtyp := NIL; IF sym = ident THEN qualident(x); CheckSym(colon); IF sym = ident THEN qualident(y); IF y.mode = Typ THEN IF x.obj # NIL THEN xtyp := x.typ; OBE.TypTest(x, y, FALSE); x.obj.typ := x.typ ELSE OBS.Mark(130) END ELSE OBS.Mark(52) END ELSE OBS.Mark(10) END ELSE OBS.Mark(10) END ; CheckSym(do); OBC.FreeRegs({}); StatSeq; CheckSym(end); IF xtyp # NIL THEN x.obj.typ := xtyp END ELSIF sym = exit THEN OBS.Get(sym); OBH.FJ(L0); IF LoopLevel = 0 THEN OBS.Mark(45) ELSIF ExitNo < 16 THEN LoopExit[ExitNo] := L0; INC(ExitNo) ELSE OBS.Mark(214) END ELSIF sym = return THEN OBS.Get(sym); IF OBC.level > 0 THEN IF sym < semicolon THEN Expression(x); OBH.Result(x, OBT.topScope.typ) ELSIF OBT.topScope.typ.form # NoTyp THEN OBS.Mark(124) END ; OBH.Return(SHORT(OBT.topScope.a1 DIV 10000H), SHORT(OBT.topScope.a1)) ELSE (*return from module body*) IF sym < semicolon THEN Expression(x); OBS.Mark(124) END ; OBH.Return(LProc, LParOrg) END END ; OBC.FreeRegs({}); IF sym = semicolon THEN OBS.Get(sym) ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN OBS.Mark(38) ELSE EXIT END END END StatSeq; PROCEDURE Block(VAR dsize: LONGINT); VAR typ, forward: OBT.Struct; obj, first: OBT.Object; x: OBT.Item; L0: INTEGER; size: LONGINT; mk: BOOLEAN; id0: ARRAY 32 OF CHAR; BEGIN obj := OBT.topScope; WHILE obj.next # NIL DO obj := obj.next END ; LOOP IF sym = const THEN OBS.Get(sym); WHILE sym = ident DO COPY(OBS.name, id0); CheckMark(mk); IF sym = eql THEN OBS.Get(sym); ConstExpression(x) ELSIF sym = becomes THEN OBS.Mark(9); OBS.Get(sym); ConstExpression(x) ELSE OBS.Mark(9) END ; OBT.Insert(id0, obj); obj.mode := Con; obj.typ := x.typ; obj.a0 := x.a0; obj.a1 := x.a1; obj.marked := mk; CheckSym(semicolon) END END ; IF sym = type THEN OBS.Get(sym); WHILE sym = ident DO typ := OBT.undftyp; OBT.InsertType(OBS.name, obj); forward := obj.typ; obj.mode := Typ; obj.typ := OBT.notyp; CheckMark(obj.marked); IF sym = eql THEN OBS.Get(sym); Type(typ) ELSIF (sym = becomes) OR (sym = colon) THEN OBS.Mark(9); OBS.Get(sym); Type(typ) ELSE OBS.Mark(9) END ; obj.typ := typ; IF typ.strobj = NIL THEN typ.strobj := obj END ; IF forward # NIL THEN (*fixup*) SetPtrBase(forward, typ) END ; CheckSym(semicolon) END END ; IF sym = var THEN OBS.Get(sym); WHILE sym = ident DO OBT.Insert(OBS.name, obj); first := obj; CheckMark(obj.marked); obj.mode := Var; obj.typ := OBT.undftyp; LOOP IF sym = comma THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(19) ELSE EXIT END ; IF sym = ident THEN OBT.Insert(OBS.name, obj); CheckMark(obj.marked); obj.mode := Var; obj.typ := OBT.undftyp ELSE OBS.Mark(10) END END ; CheckSym(colon); Type(typ); size := typ.size; IF size >= 4 THEN INC(dsize, (-dsize) MOD 4) ELSIF size = 2 THEN INC(dsize, dsize MOD 2) END ; WHILE first # NIL DO first.typ := typ; INC(dsize, size); first.a0 := -dsize; first := first.next END ; CheckSym(semicolon) END END ; IF (sym < const) OR (sym > var) THEN EXIT END ; END ; CheckUndefPointerTypes; INC(dsize, (-dsize) MOD 4); IF OBC.level = 0 THEN OBH.LFJ(L0); OBC.SetStrOffset(dsize) ELSE OBH.FJ(L0) END ; WHILE sym = procedure DO OBS.Get(sym); ProcedureDeclaration; CheckSym(semicolon) END ; IF OBC.level = 0 THEN OBC.fixupL(L0) ELSE OBC.fixupC(L0) END ; OBE.inxloc := 0; OBE.tchkloc := 0; IF sym = begin THEN OBS.Get(sym); StatSeq END ; CheckSym(end) END Block; PROCEDURE CompilationUnit(source: Texts.Text; pos: LONGINT); VAR L0: INTEGER; ch: CHAR; time, date, key: LONGINT; modid, impid, FName: ARRAY 32 OF CHAR; PROCEDURE MakeFileName(VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR); VAR i, j: INTEGER; ch: CHAR; BEGIN i := 0; LOOP ch := name[i]; IF ch = 0X THEN EXIT END ; FName[i] := ch; INC(i) END ; j := 0; REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j) UNTIL ch = 0X END MakeFileName; BEGIN dsize := 0; LoopLevel := 0; ExitNo := 0; OBC.Init; OBT.Init; OBS.Init(source, pos); OBS.Get(sym); Texts.WriteString(W, " compiling "); IF sym = module THEN OBS.Get(sym) ELSE OBS.Mark(16) END ; IF sym = ident THEN Texts.WriteString(W, OBS.name); Texts.Append(Oberon.Log, W.buf); L0 := 0; ch := OBS.name[0]; WHILE (ch # 0X) & (L0 < ModNameLen-1) DO modid[L0] := ch; INC(L0); ch := OBS.name[L0] END ; modid[L0] := 0X; IF ch # 0X THEN OBS.Mark(228) END ; OBT.OpenScope(0); OBS.Get(sym); CheckSym(semicolon); OBH.Enter(Mod, L0); IF sym = import THEN OBS.Get(sym); LOOP IF sym = ident THEN COPY(OBS.name, impid); OBS.Get(sym); MakeFileName(impid, FName, ".sym"); IF sym = becomes THEN OBS.Get(sym); IF sym = ident THEN MakeFileName(OBS.name, FName, ".sym"); OBS.Get(sym) ELSE OBS.Mark(10) END END ; OBT.Import(impid, modid, FName) ELSE OBS.Mark(10) END ; IF sym = comma THEN OBS.Get(sym) ELSIF sym = ident THEN OBS.Mark(19) ELSE EXIT END END ; CheckSym(semicolon) END ; IF ~OBS.scanerr THEN Block(dsize); OBH.Return(LProc, 8); IF OBE.inxloc > 0 THEN OBC.FixLink(OBE.inxloc); OBC.PutF1(0F2H); OBC.PutByte(15) END ; IF OBE.tchkloc > 0 THEN OBC.FixLink(OBE.tchkloc); OBC.PutF1(0F2H); OBC.PutByte(17) END ; IF sym = ident THEN IF OBS.name # modid THEN OBS.Mark(4) END ; OBS.Get(sym) ELSE OBS.Mark(10) END ; IF sym # period THEN OBS.Mark(18) END ; IF ~OBS.scanerr THEN Oberon.GetClock(time, date); key := (date MOD 4000H) * 20000H + time; MakeFileName(modid, FName, ".sym"); OBT.Export(modid, FName, newSF, key); IF newSF THEN Texts.WriteString(W, " new symbol file") END ; IF ~OBS.scanerr THEN MakeFileName(modid, FName, ".obj"); OBC.OutCode(FName, modid, key, dsize); Texts.WriteInt(W, OBC.pc, 6); Texts.WriteInt(W, dsize, 6) END END END ; OBT.CloseScope ELSE OBS.Mark(10) END; OBT.Close; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END CompilationUnit; PROCEDURE Compile*; VAR beg, end, time: LONGINT; T: Texts.Text; S: Texts.Scanner; v: Viewers.Viewer; PROCEDURE Options; VAR ch: CHAR; BEGIN IF S.nextCh = "/" THEN LOOP Texts.Read(S, ch); IF ch = "x" THEN OBE.inxchk := FALSE ELSIF ch = "t" THEN OBC.typchk := FALSE ELSIF ch = "c" THEN OBH.clrchk := TRUE ELSIF ch = "k" THEN OBH.stkchk := TRUE ELSIF ch = "s" THEN newSF := TRUE ELSE S.nextCh := ch; EXIT END END END END Options; BEGIN OBE.inxchk := TRUE; OBC.typchk := TRUE; OBH.clrchk := FALSE; OBH.stkchk := FALSE; newSF := FALSE; Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF S.class = Texts.Char THEN IF S.c = "*" THEN v := Oberon.MarkedViewer(); IF (v.dsc # NIL) & (v.dsc.next IS TextFrames.Frame) THEN Options; CompilationUnit(v.dsc.next(TextFrames.Frame).text, 0) END ELSIF S.c = "^" THEN Oberon.GetSelection(T, beg, end, time); IF time >= 0 THEN Texts.OpenScanner(S, T, beg); Texts.Scan(S); IF S.class = Texts.Name THEN Options; Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s); IF T.len # 0 THEN CompilationUnit(T, 0) ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END END ELSIF S.c = "@" THEN Oberon.GetSelection(T, beg, end, time); IF time >= 0 THEN Options; CompilationUnit(T, beg) END END ELSE NEW(T); WHILE S.class = Texts.Name DO Options; Texts.WriteString(W, S.s); Texts.Open(T, S.s); IF T.len # 0 THEN CompilationUnit(T, 0) ELSE Texts.WriteString(W, " not found"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ; Texts.Scan(S) END END ; Oberon.Collect(0) END Compile; BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Compiler NW 14.12.93"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END Compiler.