COMPILER M2 (* ============================================================================= TopSpeed Modula-2 V3 - COMPLETE GRAMMAR (Coco/R .atg form) Historical JPI/Clarion V3 dialect, reconstructed from the real TS-V3 corpus (TABLE/GWINM2P/GWINC2M/BYTEFIDD/CLUB/RS/Modbase) + the shipped CR.MOD reserved words + PIM/ISO Modula-2 reference forms. This ATG is the deliverable of the "complete V3 grammar" work item. It intentionally DIVERGES from the modern m2compiler-V3 subset's locked rules where the corpus proves the original dialect differed: - identifiers carry '_' and '@' (Graph._VGA, ct__@Fssssi) - '&' = AND , '~' = NOT , '<>' = '#' (all accepted) - literal suffixes H (hex), C (char), B (base-8/octal), plus 0x/0X hex-prefix forms - `::=` constant alias form (GCoord::=INTEGER) - anchored type subranges (SHORTINT[-1..1]) - qualified type/designator idents (Client.ClientRec, t2.Root, p^.Left, S1[sp1], Graph.GetVideoConfig(vc)) - full composite types: ARRAY (fixed + open), RECORD + variants, SET OF (range/base/enum forms), POINTER TO, PROCEDURE types - statements: WITH, IN, IS, set constructors {}, shifts << >>, procedure/function call statements - Clarion-form classes with multi-parent CLAUSE (extra parent = 230) Constructs the current scalar backend cannot lower yet PARSE fully and end with the standard SemError(230) "not supported yet" marker, exactly like M2.atg's parse-now/lower-later discipline. Semantic error codes reused from the V1/V2/Test2 family: 200 duplicate, 201 undeclared, 202 module name mismatch, 210 bad assignment, 211 bad arithmetic, 212 boolean operand, 213 incompatible comparison, 214 boolean cond required, 220 FOR needs integer var/bounds, 221 not a type name, 222 set operand mismatch, 230 not supported yet, 231 opaque type outside definition, 232 bad RETURN. LL(1) notes (accepted as benign, verified correct codegen): - TypeBlock's CLASS/CLASS IMPLEMENTATION 2-token lookahead - variant-record CASE labels sharing first-sets with field identifier lists (classic Modula-2 ambiguity). ============================================================================= *) IMPORT SymTab, QbeGen; CHARACTERS eol = CHR(13) . lf = CHR(10) . letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" . digit = "0123456789" . octDigit = "01234567" . hexDigit = digit + "ABCDEFabcdef" . noQuote1 = ANY - "'" - eol . noQuote2 = ANY - '"' - eol . IGNORE CHR(9) .. CHR(13) COMMENTS FROM "(*" TO "*)" NESTED COMMENTS FROM "//" TO lf TOKENS (* V3 identifier: classic letters/digits PLUS '_' and '@' which the shipped code uses freely (Graph._VGA, _Find, ct__@Fssssi). *) ident = ( letter | "_" ) { letter | digit | "_" | "@" } . (* Numbers. V3 kept the PIM qualified forms: trailing H = hex, trailing C = character constant (hex value), trailing B = base-8 (the Modbase date code needs 60B = 48 = ORD('0'), i.e. octal 60); modern 0x/0X hex-prefix also accepted (TS Dev Guide). The CONTEXT("..") clause keeps `1..10` an integer + range operator rather than the start of a real `1. ...`. *) integer = digit { digit } | digit { digit } CONTEXT("..") | digit { digit } ( "B" | "b" ) | digit { hexDigit } ( "H" | "h" ) | digit { hexDigit } ( "C" | "c" ) | "0x" hexDigit { hexDigit } | "0X" hexDigit { hexDigit } . real = digit { digit } "." { digit } [ ( "E" | "e" ) [ "+" | "-" ] digit { digit } ] . string = "'" { noQuote1 } "'" | '"' { noQuote2 } '"' . PRODUCTIONS M2 = Unit "." . (* Units: program modules compile fully; DEFINITION and IMPLEMENTATION modules parse + check now but lower in step 4 (each ends with one 230); same for nested local modules. *) Unit = DefUnit | ImplUnit | ProgModule . DefUnit (. VAR m1, m2, pn: SymTab.Name; .) = "DEFINITION" "MODULE" GetIdent (. SymTab.Init; QbeGen.OpenModule(m1); IF ~SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; .) ";" { Import } { ConstBlock | TypeBlock | VarBlock | ConstDecl ";" (. (* manifest const, no CONST *) .) | ProcHeading ";" (. SymTab.CloseProc; .) | ClassItem ";" } "END" GetIdent (. IF ~SymTab.Equal(m1, m2) THEN SemError(202) END; .) (. QbeGen.CloseModule; SemError(230); SymTab.PrintTable; .) . ImplUnit (. VAR m1, m2: SymTab.Name; .) = "IMPLEMENTATION" "MODULE" GetIdent (. SymTab.Init; QbeGen.OpenModule(m1); IF ~SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; .) ";" { Import } DeclSeq [ "BEGIN" (. QbeGen.BeginBody; .) [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(m1, m2) THEN SemError(202) END; .) (. QbeGen.CloseModule; SemError(230); SymTab.PrintTable; .) . ProgModule (. VAR m1, m2: SymTab.Name; .) = "MODULE" GetIdent (. SymTab.Init; QbeGen.OpenModule(m1); IF ~SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; .) [ Priority ] ";" { Import } DeclSeq [ "BEGIN" (. QbeGen.BeginBody; .) [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(m1, m2) THEN SemError(202) END; .) (. QbeGen.EndModule(m1); SymTab.PrintTable; .) . DeclSeq = { ConstBlock | TypeBlock | VarBlock | ConstDecl ";" (. (* manifest const, no CONST *) .) | [ "INLINE" ] ProcDecl ";" | NestedModule ";" | ClassItem ";" | "LABEL" LabelList ";" } . LabelList (. VAR nm: SymTab.Name; .) = GetIdent (. SemError(230); .) { "," GetIdent (. SemError(230); .) } . (* Local module, Wirth form. Parses + checks fully (own scope); lowering waits for step 4, marked by one 230 at END. *) NestedModule (. VAR m1, m2: SymTab.Name; .) = "MODULE" GetIdent (. IF ~SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; SymTab.PushScope; .) [ Priority ] ";" { Import } [ Export ] DeclSeq [ "BEGIN" [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.PopScope; SemError(230); .) . Priority = "[" integer "]" (. SemError(230); .) . Export (. VAR nm: SymTab.Name; .) = "EXPORT" (* names wire up in step 4 *) [ "QUALIFIED" ] GetIdent { "," GetIdent } ";" . Import (. VAR n: SymTab.Name; .) = "FROM" GetIdent (. IF ~SymTab.Enter(n, SymTab.KindImport) THEN SemError(200) END; .) "IMPORT" ImpList ";" | "IMPORT" ImpList ";" . ImpList (. VAR n: SymTab.Name; .) = GetIdent (. IF ~SymTab.Enter(n, SymTab.KindImport) THEN SemError(200) END; .) { "," GetIdent (. IF ~SymTab.Enter(n, SymTab.KindImport) THEN SemError(200) END; .) } . (* Opaque "TYPE T;" needs isDef (definition units); elsewhere 231. *) TypeBlock = "TYPE" { TypeItem ";" | ClassItem ";" } . TypeItem (. VAR n: SymTab.Name; t: SymTab.TypeIndex; .) = GetIdent (. IF ~SymTab.Enter(n, SymTab.KindType) THEN SemError(200) END; .) ( "=" Type (. SymTab.SetSymType(n, t); .) | (. IF ~isDef THEN SemError(231) END; SymTab.SetSymType(n, SymTab.NewAlias()); .) ) . (* V3 TYPE surface. Start-symbols are all distinct: ident (named / anchored subrange), '[' (bare subrange), '(' (enum) , ARRAY , RECORD , SET , POINTER , PROCEDURE . *) Type = TypeIdent2 [ "[" SubrangeRest (. (* anchored subrange: SHORTINT[-1..1], SHORTCARD[0..7] *) .) "]" ] | "[" SubrangeRest "]" | Enum | ArrayType | RecordType | SetType | PointerType | "VIRTUAL" "POINTER" TypeIdent2 (. SemError(230); .) | ProcType . (* Qualified type ident: Client.ClientRec, SYSTEM.WORD. *) TypeIdent2 (. VAR n: SymTab.Name; k: INTEGER; .) = GetIdent (. IF ~SymTab.Lookup(n) THEN SemError(201); t := SymTab.InvalidType ELSE k := SymTab.SymKind(n); IF (k = SymTab.KindType) OR (k = SymTab.KindPredef) THEN t := SymTab.SymType(n) ELSIF k = SymTab.KindImport THEN t := SymTab.InvalidType ELSE SemError(221); t := SymTab.InvalidType END END; .) { "." GetIdent (. SemError(230); t := SymTab.InvalidType; .) } . (* '[' Expr '..' Expr ']' (bare or anchored). Folds literal bounds into a NewSubR subrange; anything else parses but lowers later. *) SubrangeRest (. VAR tlo, thi: SymTab.TypeIndex; qlo, qhi: QbeGen.QVal; lo, hi: INTEGER; .) = Expr ".." Expr (. IF (tlo = SymTab.InvalidType) OR (thi = SymTab.InvalidType) THEN t := SymTab.InvalidType ELSIF (SymTab.ClassOf(tlo) # SymTab.ClInt) OR (SymTab.ClassOf(thi) # SymTab.ClInt) THEN SemError(230); t := SymTab.InvalidType ELSIF ~SymTab.ConstInt(qlo, lo) OR ~SymTab.ConstInt(qhi, hi) OR (lo > hi) THEN SemError(230); t := SymTab.InvalidType ELSE t := SymTab.NewSubR(lo, hi) END; .) . Enum (. VAR n: SymTab.Name; .) = "(" (. t := SymTab.NewEnum(); .) GetIdent (. IF ~SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); .) { "," GetIdent (. IF ~SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); .) } ")" . (* ARRAY [lo..hi] OF T / ARRAY OF T (open formal) / multi bound *) ArrayType (. VAR e: SymTab.TypeIndex; i: CARDINAL; .) = "ARRAY" ( "[" Bound { "," Bound } "]" (. t := SymTab.InvalidType; .) | Bound (. t := SymTab.InvalidType; .) | (. t := SymTab.InvalidType; .) ) "OF" Type (. t := SymTab.NewOpenArray(e); SemError(230); .) . Bound (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; .) = Expr [ ".." Expr ] (. SemError(230); .) . (* RECORD with field lists and tagless/tagged variant CASE. FieldListSequence is the classic PIM form: fields separated by ';', alternatives by '|', optional ELSE. The label-vs-field first-set overlap is the known benign LL(1) advisory. *) RecordType (. VAR n: SymTab.Name; rt: SymTab.TypeIndex; .) = "RECORD" (. rt := SymTab.NewRecord(); t := rt; .) FieldListSequence "END" (. SemError(230); .) . FieldListSequence = [ FieldList { ";" [ FieldList ] } ] . FieldList (. VAR tag: SymTab.Name; ti: SymTab.TypeIndex; .) = "CASE" (. SemError(230); .) ( GetIdent ":" (. (* named selector *) .) | ":" (. (* anonymous selector *) .) | (. (* no selector *) .) ) Type "OF" VariantList "END" | FieldIdents . FieldIdents (. VAR n: SymTab.Name; t: SymTab.TypeIndex; .) = GetIdent (. IF ~SymTab.FieldPending(rec, n) THEN SemError(200) END; .) { "," GetIdent (. IF ~SymTab.FieldPending(rec, n) THEN SemError(200) END; .) } ":" Type (. SymTab.FixPendingF(rec, t); .) . VariantList = [ "|" ] Variant { "|" [ Variant ] } [ "ELSE" FieldListSequence ] . Variant = VariantLabels ":" (. SymTab.PushScope; .) FieldListSequence (. SymTab.PopScope; .) . VariantLabels = VariantLabel { "," VariantLabel } . VariantLabel (. VAR t1, t2: SymTab.TypeIndex; q1, q2: QbeGen.QVal; .) = Expr (. SemError(230); .) [ ".." Expr (. SemError(230); .) ] . (* SET OF base: SHORTCARD[0..7], [0..31], CHAR, Direction, (RShift, LShift, Ctrl, ...) *) SetType (. VAR b: SymTab.TypeIndex; .) = "SET" "OF" ( TypeIdent2 (. t := SymTab.NewSet(b); SemError(230); .) | "[" SubrangeRest "]" (. t := SymTab.NewSet(b); SemError(230); .) | Enum (. t := SymTab.NewSet(b); SemError(230); .) ) . PointerType (. VAR b: SymTab.TypeIndex; .) = "POINTER" "TO" Type (. t := SymTab.NewPtr(b); SemError(230); .) . (* PROCEDURE type: Action = PROCEDURE(ElementPtr); IPROC = PROCEDURE(); CompareProc = PROCEDURE(ADDRESS,ADDRESS,CARDINAL) : CompareType; *) ProcType (. VAR b: SymTab.TypeIndex; .) = "PROCEDURE" (. t := SymTab.InvalidType; SemError(230); .) [ "(" [ ProcTypeParam { "," ProcTypeParam } ] ")" ] [ ":" TypeIdent2 (. SemError(230); .) ] . ProcTypeParam (. VAR b: SymTab.TypeIndex; .) = [ "VAR" ] Type (. SemError(230); .) . (* Clarion-form classes (docs/OOP.txt): declaration + (single or multiple) parent clause + IMPLEMENTATION blocks. Scopes and member checks now; lowering (vtable, dispatch, THIS) later — one 230 per class/impl block. Methods end with ";" per the Table example. *) (* Single CLASS item in both loops: separating declaration from IMPLEMENTATION at the loop level needs 2-token lookahead (CLASS ident vs CLASS IMPLEMENTATION), which LL(1) cannot do. The second token decides after CLASS is consumed. *) ClassItem = "CLASS" ( "IMPLEMENTATION" ClassImplRest | ClassRest ) . ClassRest (. VAR cn, m2, pn, q: SymTab.Name; ct: SymTab.TypeIndex; .) = GetIdent (. IF ~SymTab.Enter(cn, SymTab.KindType) THEN SemError(200) END; ct := SymTab.NewClass(); SymTab.SetSymType(cn, ct); SymTab.PushClassScope(ct); .) [ Parents ] ";" { ClassField ";" } (* V3 class methods: pure declaration (';' only), FORWARD, or a fully bodied method whose body starts with BEGIN (the corpus form). Each bodied/FORWARD method owns its trailing ';'. *) { MethodHeading ";" ( "FORWARD" (. SymTab.MarkFwd; SymTab.CloseProc; .) ";" | "BEGIN" [ StatSeq ] "END" GetIdent (. IF ~SymTab.Equal(pn, q) THEN SemError(202) END; SymTab.CloseProc; SemError(230); .) ";" | (. SymTab.CloseProc; .) ) } [ "BEGIN" (. SemError(230); .) [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.PopScope; SemError(230); .) . (* V3 class header may list several parents (CLASS GenElem (Element, Base2);); this grammar accepts the list and rejects every parent after the first at 230 — the current backend lowers single inheritance only. *) Parents (. VAR p: SymTab.Name; .) = "(" Parent1 { "," GetIdent

(. SemError(230); .) } ")" . Parent1 (. VAR p: SymTab.Name; pt: SymTab.TypeIndex; .) = GetIdent

(. IF ~SymTab.Lookup(p) THEN SemError(201) ELSE pt := SymTab.SymType(p); IF SymTab.ClassOf(pt) # SymTab.ClClass THEN SemError(230) ELSE SymTab.SetParent(ct, pt) END END; .) . ClassField (. VAR n, rhs: SymTab.Name; t: SymTab.TypeIndex; .) = GetIdent ( "=" GetIdent (. IF ~SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; IF SymTab.Lookup(rhs) THEN SymTab.SetSymType(n, SymTab.SymType(rhs)) END; .) | (. IF ~SymTab.FieldPending(ct, n) THEN SemError(200) END; .) { "," GetIdent (. IF ~SymTab.FieldPending(ct, n) THEN SemError(200) END; .) } ":" TypeIdent2 (. SymTab.FixPendingF(ct, t); .) ) . MethodHeading (. VAR wantVirt: BOOLEAN; .) = (. wantVirt := FALSE; .) [ "VIRTUAL" (. wantVirt := TRUE; .) ] ProcHeading (. IF wantVirt THEN SymTab.MarkVirtual END; .) . ClassImplRest (. VAR cn, m2: SymTab.Name; ct: SymTab.TypeIndex; .) = GetIdent (. IF ~SymTab.Lookup(cn) THEN SemError(201); ct := SymTab.InvalidType ELSE ct := SymTab.SymType(cn); IF SymTab.ClassOf(ct) # SymTab.ClClass THEN SemError(230); ct := SymTab.InvalidType END END; IF ct # SymTab.InvalidType THEN IF ~SymTab.PushClassMembers( ct) THEN SemError(230) END END; .) ";" { MethodImpl ";" } [ "BEGIN" (. QbeGen.BeginBody; .) [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.PopScope; SemError(230); .) . MethodImpl (. VAR pn: SymTab.Name; .) = MethodHeading ";" (. IF (ct # SymTab.InvalidType) & ~SymTab.MethodExists(ct, pn) THEN SemError(201) END; .) ( "FORWARD" (. SymTab.MarkFwd; SymTab.CloseProc; .) | Block (. SymTab.CloseProc; SemError(230); .) ) . (* E1) double-colon constant alias: Name ::= Expr ; GCoord::=INTEGER; TXBuffer ::= IOBase; *) ConstBlock = "CONST" { ConstDecl ";" } . ConstDecl (. VAR n: SymTab.Name; t: SymTab.TypeIndex; qv: QbeGen.QVal; cls: INTEGER; .) = GetIdent (. IF ~SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; .) ( "::=" (. SemError(230); .) Expr (. SymTab.SetSymType(n, t); QbeGen.DeclConst(n, "0", SymTab.InvalidType); .) | "=" Expr (. SymTab.SetSymType(n, t); cls := SymTab.ClassOf(t); IF cls = SymTab.ClStr THEN SemError(230) ELSIF ~QbeGen.IsImm(qv) THEN SemError(230) END; QbeGen.DeclConst(n, qv, t); .) ) . VarBlock = "VAR" { VarDecl ";" } . VarDecl (. VAR nm: SymTab.Name; t: SymTab.TypeIndex; i: CARDINAL; cls: INTEGER; .) = VarIdents ":" (* V3 VAR types may be composites; the scalar phase lowers the integer/char/bool/real family and reports 230 for the rest. *) Type (. cls := SymTab.ClassOf(t); IF (t # SymTab.InvalidType) & (cls # SymTab.ClInt) & (cls # SymTab.ClBool) & (cls # SymTab.ClChar) & (cls # SymTab.ClReal) THEN SemError(230) END; i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); QbeGen.DeclVar(nm, t); INC(i) END; IF NOT SymTab.FixPending(t) THEN END; .) . VarIdents (. VAR n: SymTab.Name; t: SymTab.TypeIndex; q: QbeGen.QVal; .) = GetIdent (. IF ~SymTab.EnterPending(n, SymTab.KindVar) THEN SemError(200) END; .) [ "[" Expr (. SemError(230); .) [ ":" Expr (. SemError(230); .) ] "]" ] { "," GetIdent (. IF ~SymTab.EnterPending(n, SymTab.KindVar) THEN SemError(200) END; .) [ "[" Expr (. SemError(230); .) [ ":" Expr (. SemError(230); .) ] "]" ] } . ParIdents (. VAR n: SymTab.Name; .) = GetIdent (. IF ~SymTab.EnterParam(n, isV) THEN SemError(200) END; .) { "," GetIdent (. IF ~SymTab.EnterParam(n, isV) THEN SemError(200) END; .) } . (* Procedure headings enter now (scopes, params, result); bodies parse + check with one 230 at END (lowering = step 4). FORWARD marks; the body heading re-enters (signature compare tightens in step 4). *) ProcHeading (. VAR t: SymTab.TypeIndex; .) = "PROCEDURE" GetIdent (. IF ~SymTab.EnterProc(pn) THEN IF ~SymTab.ReenterProc(pn) THEN SemError(200) END END; .) [ FormalParams ] [ ":" TypeIdent2 (. IF NOT SymTab.SetProcRes(t) THEN END; .) ] . FormalParams = "(" [ ParamSection { ";" ParamSection } ] ")" . ParamSection (. VAR t: SymTab.TypeIndex; isV: BOOLEAN; .) = (. isV := FALSE; .) [ "VAR" (. isV := TRUE; .) ] ParIdents ":" Type (. IF NOT SymTab.FixPending(t) THEN END; .) . ProcDecl (. VAR pn, assem: SymTab.Name; at: SymTab.TypeIndex; ak: INTEGER; aq: QbeGen.QVal; .) = ProcHeading ( ";" ( "FORWARD" (. SymTab.MarkFwd; SymTab.CloseProc; .) | "IN" GetIdent (. SymTab.CloseProc; SemError(230); .) | Block (. SymTab.CloseProc; SemError(230); .) ) | "=" Design (. SymTab.CloseProc; SemError(230); .) "(" [ ActualParams ] ")" ) . Block (. VAR m2: SymTab.Name; .) = DeclSeq [ "BEGIN" [ StatSeq ] ] "END" GetIdent (. IF ~SymTab.Equal(pn, m2) THEN SemError(202) END; .) . StatSeq = Statement { ";" [ Statement ] } . (* Statements. Assignments and procedure/function calls both start with a designator, so they share one factored production: after the designator, ':=' selects assignment, '(' a call, anything else is a parameterless procedure-call statement. *) Statement (. VAR lx: QbeGen.QVal; lqn: SymTab.Name; .) = DesignStat | IfStat | WhileStat | RepeatStat | LoopStat | ForStat | CaseStat | WithStat | ReturnStat | "GOTO" GetIdent (. SemError(230); .) | "EXIT" (. IF QbeGen.TopLoop(lx) THEN QbeGen.Jmp(lx) ELSE SemError(230) END; .) . DesignStat (. VAR dt, et: SymTab.TypeIndex; dk: INTEGER; qd, qe, qt: QbeGen.QVal; qn: SymTab.Name; isR, conv: BOOLEAN; .) = Design2 ( ":=" Expr (. IF (dt # SymTab.InvalidType) & (dk # SymTab.KindVar) & (dk # SymTab.KindParam) THEN SemError(210) ELSIF ~SymTab.Assignable(et, dt) THEN SemError(210) END; isR := (dt # SymTab.InvalidType) & (SymTab.ClassOf(dt) = SymTab.ClReal); conv := isR & SymTab.IsIntFamily(et); IF ((dk = SymTab.KindVar) OR (dk = SymTab.KindParam)) & (dt # SymTab.InvalidType) & (et # SymTab.InvalidType) THEN IF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.StoreVar(qn, qt, TRUE) ELSE QbeGen.StoreVar(qn, qe, isR) END END; .) | "(" [ ActualParams ] ")" (. SemError(230); .) | (. SemError(230); .) ) . ActualParams (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; .) = Expr { "," Expr } . IfStat (. VAR t: SymTab.TypeIndex; q, lThen, lElse, lEnd: QbeGen.QVal; hasElse: BOOLEAN; .) = "IF" (. hasElse := FALSE; .) Expr (. IF ~SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.NewLabel(lThen); QbeGen.NewLabel(lElse); QbeGen.NewLabel(lEnd); QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen); .) "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .) { "ELSIF" (. QbeGen.EmitLabel(lElse); QbeGen.NewLabel(lElse); .) Expr (. IF ~SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.NewLabel(lThen); QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen); .) "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .) } [ "ELSE" (. QbeGen.EmitLabel(lElse); hasElse := TRUE; .) [ StatSeq ] ] "END" (. IF hasElse THEN QbeGen.EmitLabel(lEnd) ELSE QbeGen.EmitLabel(lElse); QbeGen.EmitLabel(lEnd) END; .) . WhileStat (. VAR t: SymTab.TypeIndex; q, lTop, lBody, lEnd: QbeGen.QVal; .) = "WHILE" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) Expr (. IF ~SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lBody, lEnd); QbeGen.EmitLabel(lBody); .) "DO" [ StatSeq ] (. QbeGen.Jmp(lTop); .) "END" (. QbeGen.EmitLabel(lEnd); .) . RepeatStat (. VAR t: SymTab.TypeIndex; q, lTop, lEnd: QbeGen.QVal; .) = "REPEAT" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] "UNTIL" Expr (. IF ~SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lEnd, lTop); QbeGen.EmitLabel(lEnd); .) . LoopStat (. VAR lTop, lEnd: QbeGen.QVal; .) = "LOOP" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.PushLoop(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] "END" (. QbeGen.Jmp(lTop); QbeGen.PopLoop; QbeGen.EmitLabel(lEnd); .) . (* FOR with static-sign BY (literal, non-zero; 220 otherwise). Runtime direction would need a compare-select; the literal sign picks cslew/csegew at "DO" time. *) ForStat (. VAR lv: SymTab.Name; tlo, thi, tby: SymTab.TypeIndex; qlo, qhi, qby, qt, qk, qb: QbeGen.QVal; lTop, lBody, lEnd: QbeGen.QVal; by: INTEGER; ok: BOOLEAN; .) = "FOR" (. by := 1; .) GetIdent (. ok := SymTab.Lookup(lv); IF ~ok THEN SemError(201) ELSIF (SymTab.SymKind(lv) # SymTab.KindVar) & (SymTab.SymKind(lv) # SymTab.KindParam) THEN SemError(220); ok := FALSE ELSIF ~SymTab.IsIntFamily( SymTab.SymType(lv)) THEN SemError(220); ok := FALSE END; .) ":=" Expr (. IF ~SymTab.IsIntFamily(tlo) THEN SemError(220); ok := FALSE END; .) "TO" Expr (. IF ~SymTab.IsIntFamily(thi) THEN SemError(220); ok := FALSE END; .) [ "BY" Expr (. IF (tby # SymTab.InvalidType) & ~SymTab.IsIntFamily(tby) THEN SemError(220); ok := FALSE END; IF ~SymTab.ConstInt(qby, by) THEN SemError(230); by := 1 ELSIF by = 0 THEN SemError(220); by := 1 END; .) ] "DO" (. IF ok THEN QbeGen.StoreVar(lv, qlo, FALSE) END; QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); QbeGen.LoadVar(lv, FALSE, qt); QbeGen.NewTemp(qk); IF by > 0 THEN QbeGen.Op3("cslew", qk, qt, qhi, FALSE) ELSE QbeGen.Op3("csgew", qk, qt, qhi, FALSE) END; QbeGen.Jnz(qk, lBody, lEnd); QbeGen.EmitLabel(lBody); .) [ StatSeq ] "END" (. IF ok THEN QbeGen.LoadVar(lv, FALSE, qt); QbeGen.IntStr(by, qb); QbeGen.NewTemp(qk); QbeGen.Op3("add", qk, qt, qb, FALSE); QbeGen.StoreVar(lv, qk, FALSE) END; QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd); .) . CaseStat (. VAR tsel: SymTab.TypeIndex; qsel, lEnd: QbeGen.QVal; .) = "CASE" Expr (. QbeGen.NewLabel(lEnd); .) "OF" [ "|" ] { CaseAlt [ ";" ] [ "|" ] } [ "ELSE" [ StatSeq ] ] "END" (. QbeGen.EmitLabel(lEnd); .) . (* Compare-chain lowering: each alternative ends its match-tests with "jmp lAfter", so the no-match fallthrough skips the body: "cmp; jnz(lBody,lF); lF: ... ; jmp lAfter; lBody: S; jmp lEnd; lAfter:". Falls into the next alternative, ELSE, or END. *) CaseAlt (. VAR lBody, lAfter: QbeGen.QVal; .) = (. QbeGen.NewLabel(lBody); QbeGen.NewLabel(lAfter); .) CaseLabel { "," CaseLabel } ":" (. QbeGen.Jmp(lAfter); QbeGen.EmitLabel(lBody); .) [ StatSeq (. QbeGen.Jmp(lEnd); .) ] (. QbeGen.EmitLabel(lAfter); .) . CaseLabel (. VAR t2, t3: SymTab.TypeIndex; q2, q3, qc, qd, qe: QbeGen.QVal; lNext: QbeGen.QVal; .) = Expr (. IF (t2 # SymTab.InvalidType) & (tsel # SymTab.InvalidType) & ~SymTab.EqCheck(t2, tsel) THEN SemError(213) END; IF ~QbeGen.IsImm(q2) THEN SemError(230); QbeGen.CopyOp("0", q2) END; QbeGen.NewLabel(lNext); QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE); QbeGen.Jnz(qc, lBody, lNext); QbeGen.EmitLabel(lNext); .) [ ".." Expr (. IF (t3 # SymTab.InvalidType) & (tsel # SymTab.InvalidType) & ~SymTab.EqCheck(t3, tsel) THEN SemError(213) END; IF ~QbeGen.IsImm(q3) THEN SemError(230); QbeGen.CopyOp("0", q3) END; QbeGen.Cmp(SymTab.OpGe, qsel, q2, qc, FALSE); QbeGen.Cmp(SymTab.OpLe, qsel, q3, qd, FALSE); QbeGen.NewTemp(qe); QbeGen.Op3("and", qe, qc, qd, FALSE); QbeGen.NewLabel(lNext); QbeGen.Jnz(qe, lBody, lNext); QbeGen.EmitLabel(lNext); .) ] . ReturnStat (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; res: SymTab.TypeIndex; hadE: BOOLEAN; .) = "RETURN" (. hadE := FALSE; .) [ Expr (. hadE := TRUE; .) ] (. IF ~SymTab.InProc() THEN SemError(232) ELSE res := SymTab.CurRes(); IF ~hadE THEN IF res # SymTab.InvalidType THEN SemError(232) END ELSIF (res = SymTab.InvalidType) OR (t # SymTab.InvalidType) & ~SymTab.Assignable(t, res) THEN SemError(232) END END; .) . (* WITH pushes the record's fields as an inner scope (classic short-hand member access); record lowering is still 230. *) WithStat (. VAR t: SymTab.TypeIndex; k: INTEGER; q: QbeGen.QVal; qn: SymTab.Name; .) = "WITH" Design2 (. IF ~SymTab.PushRecord(t) THEN SemError(230) END; .) "DO" [ StatSeq ] "END" (. SymTab.PopScope; SemError(230); .) . (* Designators (E3): simple names behave exactly like the scalar phase; '.' '^' '[' selector chains parse and report one 230 (member/pointer/array lowering arrives with step 3). *) Design (. VAR n: SymTab.Name; cls: INTEGER; .) = GetIdent (. QbeGen.CopyOp(n, qn); IF ~SymTab.Lookup(n) THEN SemError(201); t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q) ELSE t := SymTab.SymType(n); k := SymTab.SymKind(n); IF k = SymTab.KindConst THEN IF SymTab.Equal(n, "TRUE") THEN t := SymTab.BoolType(); QbeGen.CopyOp("1", q) ELSIF SymTab.Equal(n, "FALSE") THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) ELSE cls := SymTab.ClassOf(t); IF (t # SymTab.InvalidType) & ((cls = SymTab.ClInt) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClReal)) THEN QbeGen.LoadVar(n, cls = SymTab.ClReal, q) ELSE IF t # SymTab.InvalidType THEN SemError(230) END; QbeGen.CopyOp("0", q) END END ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN cls := SymTab.ClassOf(t); IF (cls = SymTab.ClInt) OR (cls = SymTab.ClBool) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClReal) THEN QbeGen.LoadVar(n, cls = SymTab.ClReal, q) ELSE SemError(230); QbeGen.CopyOp("0", q) END ELSE QbeGen.CopyOp("0", q); IF (k = SymTab.KindImport) OR (k = SymTab.KindProc) OR (k = SymTab.KindField) THEN SemError(230) END END END; .) . Design2 = Design { "." GetIdent (. SemError(230); t := SymTab.InvalidType; .) | "^" (. SemError(230); t := SymTab.InvalidType; .) | "[" ExprList "]" (. SemError(230); t := SymTab.InvalidType; .) | "(" [ ActualParams ] ")" (. SemError(230); t := SymTab.InvalidType; .) } . ExprList (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; .) = Expr { "," Expr } . (* Expressions. After SimExpr the optional suffix is decided by a distinct first token: relation (= # <> < <= > >=), IN, or IS. *) Expr (. VAR t2: SymTab.TypeIndex; op: INTEGER; q2, qt: QbeGen.QVal; isR: BOOLEAN; .) = SimExpr [ Rel SimExpr (. IF SymTab.RelCheck(t, t2, op) THEN isR := SymTab.ClassOf(t) = SymTab.ClReal; t := SymTab.BoolType() ELSE SemError(213); t := SymTab.InvalidType; isR := FALSE END; IF t # SymTab.InvalidType THEN QbeGen.Cmp(op, q, q2, qt, isR); QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END; .) | "IN" SimExpr (. IF ~SymTab.InCheck(t, t2) THEN SemError(222) END; SemError(230); QbeGen.CopyOp("0", q); t := SymTab.InvalidType; .) | "IS" TypeIdent2 (. SemError(213); SemError(230); QbeGen.CopyOp("0", q); t := SymTab.InvalidType; .) ] . (* V3 relations keep both PIM '#" and the '<>' alias. *) Rel = "=" (. op := SymTab.OpEq; .) | "#" (. op := SymTab.OpNeq1; .) | "<>" (. op := SymTab.OpNeq1; .) | "<" (. op := SymTab.OpLt; .) | "<=" (. op := SymTab.OpLe; .) | ">" (. op := SymTab.OpGt; .) | ">=" (. op := SymTab.OpGe; .) . SimExpr (. VAR t2, res2: SymTab.TypeIndex; op: INTEGER; q2, qt: QbeGen.QVal; neg, isR: BOOLEAN; .) = (. neg := FALSE; .) [ "+" | "-" (. neg := TRUE; .) ] Term (. IF neg THEN IF QbeGen.IsImm(q) THEN QbeGen.NegFold(q, q) ELSE QbeGen.NewTemp(qt); QbeGen.NegQ(q, qt, SymTab.ClassOf(t) = SymTab.ClReal); QbeGen.CopyOp(qt, q) END END; .) { AddOp Term (. IF op = SymTab.OpOr THEN IF SymTab.BoolCheck(t) & SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NewTemp(qt); QbeGen.Op3("or", qt, q, q2, FALSE); QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END ELSE IF SymTab.ArithCheck(t, t2, FALSE, res2) THEN t := res2 ELSE SemError(211); t := SymTab.InvalidType END; isR := SymTab.ClassOf(t) = SymTab.ClReal; IF t # SymTab.InvalidType THEN QbeGen.NewTemp(qt); IF op = SymTab.OpAdd THEN QbeGen.Op3("add", qt, q, q2, isR) ELSE QbeGen.Op3("sub", qt, q, q2, isR) END; QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END END; .) } . AddOp = "+" (. op := SymTab.OpAdd; .) | "-" (. op := SymTab.OpSub; .) | "OR" (. op := SymTab.OpOr; .) . (* Term holds multiplication, AND (word or '&'), and the V3 shift operators << >>. MulOp start symbols are all distinct. *) Term (. VAR t2, res2: SymTab.TypeIndex; op: INTEGER; q2, qt: QbeGen.QVal; isR: BOOLEAN; .) = Fact { MulOp Fact (. IF (op = SymTab.OpAnd) THEN IF SymTab.BoolCheck(t) & SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NewTemp(qt); QbeGen.Op3("and", qt, q, q2, FALSE); QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END ELSIF (op = 10) OR (op = 11) THEN (* << and >> : V3 word shifts; QBE shl/sar. *) IF ~SymTab.IsIntFamily(t) OR ~SymTab.IsIntFamily(t2) THEN SemError(211); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NewTemp(qt); IF op = 10 THEN QbeGen.Op3("shl", qt, q, q2, FALSE) ELSE QbeGen.Op3("sar", qt, q, q2, FALSE) END; QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END ELSE IF SymTab.ArithCheck(t, t2, (op = SymTab.OpDiv) OR (op = SymTab.OpMod), res2) THEN t := res2 ELSE SemError(211); t := SymTab.InvalidType END; isR := SymTab.ClassOf(t) = SymTab.ClReal; IF t # SymTab.InvalidType THEN QbeGen.NewTemp(qt); IF op = SymTab.OpTimes THEN QbeGen.Op3("mul", qt, q, q2, isR) ELSIF (op = SymTab.OpDiv) OR (op = SymTab.OpSlash) THEN QbeGen.Op3("div", qt, q, q2, isR) ELSE QbeGen.Op3("rem", qt, q, q2, isR) END; QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("0", q) END END; .) } . MulOp = "*" (. op := SymTab.OpTimes; .) | "/" (. op := SymTab.OpSlash; .) | "DIV" (. op := SymTab.OpDiv; .) | "MOD" (. op := SymTab.OpMod; .) | "AND" (. op := SymTab.OpAnd; .) | "&" (. op := SymTab.OpAnd; .) | "<<" (. op := 10; .) | ">>" (. op := 11; .) . Fact (. VAR s: ARRAY [0 .. 255] OF CHAR; et, dt, t2, b: SymTab.TypeIndex; dk: INTEGER; qd, q2: QbeGen.QVal; qn: SymTab.Name; isCh: BOOLEAN; .) = integer (. LexString(s); QbeGen.NormLit(s, q, isCh); IF isCh THEN t := SymTab.CharType() ELSE t := SymTab.IntType() END; .) | real (. LexString(s); QbeGen.NormReal(s, q); t := SymTab.RealType(); .) | string (. LexString(s); IF SymTab.StrLen(s) <= 3 THEN t := SymTab.CharType(); QbeGen.IntStr( QbeGen.CharVal(s), q) ELSE t := SymTab.NewStr(); SemError(230); QbeGen.CopyOp("0", q) END; .) | "{" [ SetItems ] "}" (. SemError(230); QbeGen.CopyOp("0", q); t := SymTab.InvalidType; .) | "[" Expr ":" Expr (. SemError(230); QbeGen.CopyOp("0", q); t := SymTab.InvalidType; .) [ TypeIdent2 ] "]" MapTail | Design2 (. t := dt; QbeGen.CopyOp(qd, q); .) | "(" Expr ")" (. t := et; .) | "NOT" Fact (. IF SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NotQ(q2, q) ELSE QbeGen.CopyOp("0", q) END; .) | "~" Fact (. IF SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NotQ(q2, q) ELSE QbeGen.CopyOp("0", q) END; .) . MapTail (* suffix chain after a mapped-array constructor: deref, field or subscript, like a designator. *) (. VAR mq: SymTab.Name; et: SymTab.TypeIndex; q2: QbeGen.QVal; .) = { "." GetIdent (. SemError(230); .) | "^" (. SemError(230); .) | "[" Expr "]" (. SemError(230); .) | "(" [ ActualParams ] ")" (. SemError(230); .) } . SetItems = SetItem { "," SetItem } . SetItem (. VAR t1, t2: SymTab.TypeIndex; q1, q2: QbeGen.QVal; .) = Expr (. SemError(230); .) [ ".." Expr (. SemError(230); .) ] . GetIdent = ident (. LexName(n); .) . END M2.