COMPILER M2 (* Step 1 — minimal integer pipeline (m2compiler-V3). Subset: program MODULE + CONST (literal) + VAR INTEGER + assignment + integer expressions (+ - * DIV MOD, leading sign, parens). Fresh QBE backend (QbeGen) to gen_ssa/.ssa; assemble with qbe, link with cc. Test convention: a global VAR ExitCode : INTEGER makes generated $main return its value as the process exit code, else return 0. Semantic errors reuse the V1/V2/Test2 family: 200 duplicate, 201 undeclared, 202 module name mismatch, 210 bad assignment, 211 bad arithmetic, 221 not a type, 230 not supported yet, 231 opaque type outside definition. Scalar-phase TYPEs (named, integer subrange, enum) check fully; composite forms wait for step 3. Procedure headings (formals, result, FORWARD) enter scopes now; bodies parse + check with one 230 at END (lowering = step 4). Statements: assignment, IF/ELSIF/ELSE, WHILE, REPEAT/UNTIL, LOOP/EXIT (230 outside LOOP), FOR/TO/static-sign-BY, full CASE (labels, ranges, ELSE; compare-chain), RETURN with 232 checks (outside proc / value mismatch / missing value). WITH waits for records (step 3). Boolean connectives are eager (or/and/xor); relations yield 0/1 via cXXw. Clarion-form classes (docs/OOP.txt): CLASS decl + single inheritance + CLASS IMPLEMENTATION blocks, methods with ";" (per the Table example, not the sketch's ","), VIRTUAL flagged. Scopes and member checks now; lowering later (one 230 per class/impl block). Classic identifiers: no underscores, so the Table example's _names stay lexically out of reach. Step 3.1 arrays: "ARRAY [lo..hi, ...] OF T" (folded literal bounds, int/char) and open "ARRAY OF T" formals; index suffixes with per-level checks (217/218, trap on breach via $abort); whole-array ":=" with runtime count check + blit; string literals lower as descriptors (1-char stays CHAR, empty works); array/string "=" is 213 (no built-in whole comparison). Step 3.3 sets: multi-word masks (no header, static words) over bases ≤ 256 values; literals are SET OF [0..255] (222 on out-of-span); + - * / as or/and/xor-not, IN with span trap, =/# word-wise (lenient cross-base); CASE labels reject sets. Step 3.4 records: flat blobs; array fields are pointers to static descriptors (locked amendment — one layout per type); nested records inline; static declaration-order offsets; field chains mix with indexes; WITH pushes fields + bases (215/216); whole-record deep copy; record/set/class "=" is 213. Step 3.6 pointers: vars (l), NIL as a real type (FNil — assignment and =/# work, everything else 210-214/222), ^ deref with sfx discipline (address flows, load at use; chains compose), pointer =/# via ceql/cnel (< > etc. are 213), NEW/DISPOSE as builtin statements via extern malloc/free (recursive skeleton init; DISPOSE shallow and nils, deviating from Wirth-undefined); nil-deref is raw (no check). *) IMPORT SymTab, QbeGen, AST, Lower; VAR (* Two-phase frontend (docs/plan-two-phase.md). When TRUE the productions ALSO build AST nodes alongside the legacy emit path. Slice 1: the nodes are inert scaffolding — nothing reads them, so the emitted output is unchanged. *) twoPhase: BOOLEAN; (* Result slot for the expression-AST builder (slice 2). Every Expr/SimExpr/Term/Fact leaves its node here; the combination productions save it into locals before parsing the next operand. `astIsLit` in Fact is per-invocation, so a nested Fact cannot make an outer non-literal Fact look literal. *) astCur: AST.Node; (* Actual-argument nodes collected by ActParam for the call being parsed by ArgList (slice 4). Fact resets the count before the optional ArgList and then folds the nodes into an NkCall. *) astNArgs: CARDINAL; astArgs: ARRAY [0 .. 31] OF AST.Node; (* Statement-AST result slot (slice 5): the most recently parsed statement. StatSeq folds these into an NkBlock. *) astStmt: AST.Node; (* Declaration-AST result slot (slice 6): the most recently built declaration; DeclSeq folds these into an NkDeclSeq. *) astDecl: AST.Node; (* The local declarations of the most recent Block (a procedure body); ProcDecl stores them as the proc node's child 2. *) astBlkDecls: AST.Node; (* Unit-AST root (slice 7): NkUnit(name, decls, body). *) astUnit: AST.Node; (* Test-only: when TRUE the program unit is re-emitted from the AST via Lower right after the legacy EndModule (before EndUnit closes the module scope, so Lower can still resolve names). *) lowerRequested: BOOLEAN; (* Import accumulator (slice 11): `{ Import }` appends NkImport nodes here; each unit stores them as NkUnit child[3]. *) astImp, astImpTail: AST.Node; (* Class-AST accumulators (slice 13): the class node currently being parsed and its parent/field/method lists. Classes are not nested inside one another, so module-level state is safe. *) astCls, astClsP, astClsPTail, astClsF, astClsFTail, astClsM, astClsMTail, astMethod: AST.Node; (* Class of the method named by the last `obj.Method` designator (InvalidType when the callee is an ordinary procedure). Set by Design, consumed by the following ArgList. *) methCls: SymTab.TypeIndex; (* Class of the type of the innermost `TypeName{...}` brace constructor (ClSet or ClArray); dispatches BraceElem. *) braceCls: INTEGER; (* Module-level VAR declarations whose type was still an unresolved forward alias at declaration time; emitted once the TYPE block completes (module scope only). *) nPendVar: CARDINAL; pendVarName: ARRAY [0 .. 255] OF SymTab.Name; pendVarT: ARRAY [0 .. 255] OF SymTab.TypeIndex; (* Forward module-level variables referenced from a procedure body. *) nFvarRefs: CARDINAL; fvarId: ARRAY [0 .. 255] OF INTEGER; fvarSlot: ARRAY [0 .. 255] OF INTEGER; PROCEDURE FlushPend; (* Emit module-level globals whose forward type is now resolved. *) VAR k: CARDINAL; BEGIN k := 0; WHILE k < nPendVar DO QbeGen.DeclVar(pendVarName[k], pendVarT[k]); INC(k) END; nPendVar := 0 END FlushPend; PROCEDURE FwdVarNote (id, slot: INTEGER); BEGIN IF nFvarRefs <= HIGH(fvarId) THEN fvarId[nFvarRefs] := id; fvarSlot[nFvarRefs] := slot; INC(nFvarRefs) END END FwdVarNote; PROCEDURE FwdVarFlush; (* At module end: resolve every forward reference against the declared names (an unresolved one is 201) and patch its placeholder symbol. *) VAR k: CARDINAL; nm, g: SymTab.Name; cls: INTEGER; oper: CHAR; t: SymTab.TypeIndex; ok: BOOLEAN; BEGIN k := 0; WHILE k < nFvarRefs DO SymTab.FwdVarName(fvarId[k], nm); IF nm[0] # CHR(0) THEN IF NOT SymTab.FwdVarResolve(fvarId[k]) THEN SemError(201) ELSE t := SymTab.FwdVarType(fvarId[k]); cls := SymTab.ClassOf(t); IF cls = SymTab.ClReal THEN oper := "d" ELSIF SymTab.IsLongFamily(t) THEN oper := "l" ELSE oper := "w" END; ok := SymTab.GlobalRef(nm, g); QbeGen.FwdPatch(fvarSlot[k], fvarSlot[k], nm, oper, ok) END END; INC(k) END; nFvarRefs := 0 END FwdVarFlush; PROCEDURE AstCallNode (callee: AST.Node) : AST.Node; (* Builds NkCall(callee, actuals...) from astArgs/astNArgs. *) VAR n: AST.Node; j: CARDINAL; BEGIN n := AST.MakeNode(AST.NkCall); AST.SetChild(n, 0, callee); j := 0; WHILE (j < astNArgs) AND (AST.NChild(n) < AST.MaxChild) DO AST.SetChild(n, AST.NChild(n), astArgs[j]); INC(j) END; RETURN n END AstCallNode; PROCEDURE AstAppend (kind: INTEGER; VAR head, tail: AST.Node; item: AST.Node); (* Appends `item` to a chunked sequence: each node holds up to AST.MaxChild-1 items; child[MaxChild-1] continues into the next chunk. Unbounded, so blocks/decl sequences are not capped at 8. *) VAR n: AST.Node; BEGIN IF item = AST.NoNode THEN RETURN END; IF head = AST.NoNode THEN head := AST.MakeNode(kind); tail := head END; IF AST.NChild(tail) >= AST.MaxChild - 1 THEN n := AST.MakeNode(kind); AST.SetChild(tail, AST.MaxChild - 1, n); tail := n END; AST.SetChild(tail, AST.NChild(tail), item) END AstAppend; PROCEDURE GetUnit (): AST.Node; (* The most recently parsed unit's AST root (for the Lower comparison). *) BEGIN RETURN astUnit END GetUnit; PROCEDURE SetLower (b: BOOLEAN); (* Enables the test-only Lower re-emit at program-unit end. *) BEGIN lowerRequested := b END SetLower; CHARACTERS eol = CHR(13) . lf = CHR(10) . letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" . digit = "0123456789" . hexDigit = digit + "ABCDEFabcdef" . noQuote1 = ANY - "'" - eol . noQuote2 = ANY - '"' - eol . IGNORE CHR(9) .. CHR(13) COMMENTS FROM "(*" TO "*)" NESTED COMMENTS FROM "//" TO lf TOKENS ident = letter { letter | digit | "_" } . integer = digit { digit } | digit { digit } CONTEXT("..") | "0x" hexDigit { hexDigit } | "0X" hexDigit { hexDigit } . real = digit { digit } "." { digit } [ ( "E" | "e" ) [ "+" | "-" ] digit { digit } ] . string = "'" { noQuote1 } "'" | '"' { noQuote2 } '"' . charConst = digit { digit } ( "C" | "c" ) . ustring = ( "U" | "u" ) ( "'" { noQuote1 } "'" | '"' { noQuote2 } '"' ) . PRODUCTIONS M2 = (. twoPhase := TRUE; astCur := AST.NoNode; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; .) 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 . (* Step 4.3: one session compiles DEFINITION, its IMPLEMENTATION and one program (last) into one image. Units share the symbol table; imports materialize exported names. *) DefUnit (. VAR m1, m2, pn: SymTab.Name; astSeq, astTail, astProc: AST.Node; .) = "DEFINITION" "MODULE" GetIdent (. IF NOT SymTab.BeginDef(m1) THEN SemError(200) END; QbeGen.SetModule(m1); .) ";" { Import (. AstAppend(AST.NkDeclSeq, astImp, astImpTail, astDecl); .) } [ "EXPORT" [ "QUALIFIED" ] (. (* definition-module export list: parsed, and the names are already exported by the module scope *) .) GetIdent { "," GetIdent } ";" ] (. astSeq := AST.NoNode; astTail := AST.NoNode; .) { ConstBlock (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) | TypeBlock (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) | VarBlock (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) | ProcHeading ";" (. (* a heading only: record it so Lower can replay it *) astProc := AST.MakeNode(AST.NkProcDecl); AST.SetOp(astProc, 0); AST.SetChild(astProc, 0, AST.MakeLeaf(AST.NkIdent, pn)); AstAppend(AST.NkDeclSeq, astSeq, astTail, astProc); SymTab.CloseProc; QbeGen.AbortFunc; .) } (. astUnit := AST.MakeNode(AST.NkUnit); AST.SetChild(astUnit, 0, AST.MakeLeaf(AST.NkIdent, m1)); AST.SetChild(astUnit, 1, astSeq); AST.SetChild(astUnit, 3, astImp); astDecl := AST.NoNode; astStmt := AST.NoNode; .) "END" GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) . ImplUnit (. VAR m1, m2: SymTab.Name; k: CARDINAL; fname: SymTab.Name; unres: BOOLEAN; astNode: AST.Node; .) = "IMPLEMENTATION" "MODULE" GetIdent (. IF NOT SymTab.BeginImpl(m1) THEN SemError(201) END; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; nPendVar := 0; QbeGen.SetModule(m1); .) ";" { Import (. AstAppend(AST.NkDeclSeq, astImp, astImpTail, astDecl); .) } DeclSeq [ "BEGIN" (. FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; FwdVarFlush; QbeGen.BeginInit(m1); .) [ StatSeq ] (. QbeGen.EndInit; .) ] "END" GetIdent (. FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; FwdVarFlush; astNode := AST.MakeNode(AST.NkUnit); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, m1)); AST.SetChild(astNode, 1, astDecl); AST.SetChild(astNode, 2, astStmt); AST.SetChild(astNode, 3, astImp); astUnit := astNode; IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) . ProgModule (. VAR m1, m2: SymTab.Name; k: CARDINAL; fname: SymTab.Name; unres: BOOLEAN; astNode: AST.Node; .) = "MODULE" GetIdent (. IF NOT SymTab.BeginProg(m1) THEN SemError(200) END; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; nPendVar := 0; QbeGen.SetModule(m1); .) [ Priority ] ";" { Import (. AstAppend(AST.NkDeclSeq, astImp, astImpTail, astDecl); .) } DeclSeq [ "BEGIN" (. FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; FwdVarFlush; QbeGen.BeginBody; .) [ StatSeq ] ] "END" GetIdent (. FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; FwdVarFlush; IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; astNode := AST.MakeNode(AST.NkUnit); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, m1)); AST.SetChild(astNode, 1, astDecl); AST.SetChild(astNode, 2, astStmt); AST.SetChild(astNode, 3, astImp); astUnit := astNode; QbeGen.EndModule(m1); SymTab.EndUnit; .) . DeclSeq (. VAR astSeq, astTail: AST.Node; .) = (. astSeq := AST.NoNode; astTail := AST.NoNode; .) { (. astDecl := AST.NoNode; .) ( ConstBlock | TypeBlock | VarBlock | ProcDecl ";" | NestedModule ";" | ClassItem ";" ) (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) } (. astDecl := astSeq; .) . (* Local module, Wirth form. Declarations lower like top-level ones (same QBE module prefix); a BEGIN body becomes an init function that main calls; the EXPORT list is hoisted into the enclosing scope at END. *) NestedModule (. VAR m1, m2: SymTab.Name; expNames: ARRAY [0 .. 63] OF SymTab.Name; expCount, k: CARDINAL; astNode, nImp, nImpTail: AST.Node; .) = "MODULE" GetIdent (. IF NOT SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; SymTab.PushScope; expCount := 0; astNode := AST.MakeNode(AST.NkUnit); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, m1)); astStmt := AST.NoNode; astDecl := AST.NoNode; nImp := AST.NoNode; nImpTail := AST.NoNode; .) [ Priority ] ";" { Import (. AstAppend(AST.NkDeclSeq, nImp, nImpTail, astDecl); .) } [ "EXPORT" [ "QUALIFIED" ] GetIdent (. INC(expCount); .) { "," GetIdent (. INC(expCount); .) } ";" ] DeclSeq [ "BEGIN" (. astStmt := AST.NoNode; QbeGen.BeginInit(m1); .) [ StatSeq ] (. QbeGen.EndInit; .) ] "END" GetIdent (. AST.SetChild(astNode, 1, astDecl); AST.SetChild(astNode, 2, astStmt); AST.SetChild(astNode, 3, nImp); astDecl := astNode; IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; k := 0; WHILE k < expCount DO SymTab.ExportUp(expNames[k]); INC(k) END; SymTab.PopScope; .) . Priority = "[" integer "]" (. SemError(230); .) . (* Imports (4.3): FROM materializes the names (unqualified use); plain IMPORT only demands the module exists — qualified `L.x` materializes on first use (Design). *) (* Unknown modules stay unchecked stubs (legacy, so hand-written import lines don't fail); a known module's missing export is 201. *) Import (. VAR n: SymTab.Name; astImport: AST.Node; .) = "FROM" GetIdent (. astImport := AST.MakeNode(AST.NkImport); AST.SetChild(astImport, 0, AST.MakeLeaf(AST.NkIdent, n)); .) "IMPORT" ImpList ";" (. astDecl := astImport; .) | "IMPORT" (. astImport := AST.MakeNode(AST.NkImport); .) ImpModList ";" (. astDecl := astImport; .) . ImpList (. VAR n: SymTab.Name; .) = ImpName { "," ImpName } . (* Pervasive built-ins imported from SYSTEM (e.g. TSIZE) are accepted and ignored: the built-in applies regardless. *) ImpName (. VAR n: SymTab.Name; .) = GetIdent (. AST.SetChild(node, AST.NChild(node), AST.MakeLeaf(AST.NkIdent, n)); IF SymTab.Equal(mod, "libc") THEN (* intrinsic C library: permissive external *) IF NOT SymTab.DeclareCProc(n) THEN SemError(201) END ELSIF SymTab.ModKnown(mod) AND NOT SymTab.ImportFrom(mod, n) THEN SemError(201) END; .) | ( "TSIZE" | "SIZE" | "ADR" | "HIGH" | "LEN" | "CHR" | "ORD" | "ORDL" | "VAL" | "ABS" | "CAP" | "UCHR" | "CHR8" | "UORD" | "INC" | "DEC" ) . ImpModList (. VAR n: SymTab.Name; .) = GetIdent (. AST.SetChild(node, AST.NChild(node), AST.MakeLeaf(AST.NkIdent, n)); .) { "," GetIdent (. AST.SetChild(node, AST.NChild(node), AST.MakeLeaf(AST.NkIdent, n)); .) } . (* Opaque TYPE declarations (definition modules). The targetless alias resolves to InvalidType until step 4 completes it. *) (* Scalar-phase TYPEs: named types, integer subranges, enumerations. Opaque "TYPE T;" needs isDef (definition units); elsewhere 231. Composite forms (ARRAY/RECORD/SET/POINTER) arrive with step 3. *) TypeBlock (. VAR astSeq, astTail: AST.Node; .) = "TYPE" (. SymTab.BeginTypeBlock; astSeq := AST.NoNode; astTail := AST.NoNode; .) { (. astDecl := AST.NoNode; .) ( TypeItem ";" | ClassItem ";" ) (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) } (. SymTab.EndTypeBlock; astDecl := astSeq; .) . TypeItem (. VAR n: SymTab.Name; t, op: SymTab.TypeIndex; astNode: AST.Node; .) = GetIdent (. op := SymTab.OpaqueBase(n); IF op = SymTab.InvalidType THEN IF NOT SymTab.Enter(n, SymTab.KindType) THEN SemError(200) END END; .) ( "=" Type (. astNode := AST.MakeNode(AST.NkTypeDecl); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, n)); AST.SetTy(astNode, t); astDecl := astNode; IF op # SymTab.InvalidType THEN SymTab.SetTarget(op, t) ELSE SymTab.SetSymType(n, t) END; .) | (. IF op # SymTab.InvalidType THEN (* stays opaque *) ELSIF NOT isDef THEN SemError(231) ELSE SymTab.SetSymType(n, SymTab.NewAlias()) END; .) ) . Type = TypeIdent [ Subrange ] (* anchored subrange: T[lo..hi] *) | Subrange | Enum | ArrayType | SetType | RecordType | PointerType | ProcType . PointerType (. VAR base: SymTab.TypeIndex; .) = "POINTER" "TO" Type(. t := SymTab.NewPtr(base); .) . (* Procedure types (step 8.5): PROCEDURE (params): result. Values are code pointers; params are collected into the descriptor. *) ProcType (. VAR res, pt: SymTab.TypeIndex; isV: BOOLEAN; .) = "PROCEDURE" (. res := SymTab.InvalidType; t := SymTab.NewProcType(res); .) [ "(" [ ProcTypeSection { ";" ProcTypeSection } ] ")" ] [ ":" TypeIdent (. SymTab.SetProcTypeRes(t, res); .) ] . ProcTypeSection (. VAR pt: SymTab.TypeIndex; isV: BOOLEAN; cnt, k: CARDINAL; names: ARRAY [0 .. 15] OF SymTab.Name; .) = (. isV := FALSE; cnt := 0; .) [ "VAR" (. isV := TRUE; .) ] ( GetIdent (. INC(cnt); .) { "," GetIdent (. INC(cnt); .) } ( ":" Type (. k := 0; WHILE k < cnt DO SymTab.ProcTypeAdd(t, isV, pt); INC(k) END; .) | (. (* type-only parameter list: each name is a type (GNU shorthand used by the Coco/R scanner frame) *) k := 0; WHILE k < cnt DO IF SymTab.Lookup(names[k]) AND ((SymTab.SymKind(names[k]) = SymTab.KindType) OR (SymTab.SymKind(names[k]) = SymTab.KindPredef)) THEN pt := SymTab.SymType(names[k]) ELSE SemError(201); pt := SymTab.InvalidType END; SymTab.ProcTypeAdd(t, isV, pt); INC(k) END; .) ) | Type (. (* unnamed parameter (PIM): e.g. PROCEDURE (VAR ARRAY OF REAL) *) SymTab.ProcTypeAdd(t, isV, pt); .) ) . (* Arrays: "OF" without bounds is an open formal (allowed only where allowOpen); "[lo..hi, ...]" nests bounded levels inside out. Bounds are folded literals (int/char); anything else 230. Bare-type indices ("ARRAY Color OF") wait for enum ordinals. *) ArrayType (. VAR elem: SymTab.TypeIndex; ok: BOOLEAN; bnds, bndh: ARRAY [0 .. 7] OF INTEGER; nb, k: CARDINAL; idx: SymTab.TypeIndex; ilo, ihi: INTEGER; .) = "ARRAY" ( "OF" Type (. IF NOT allowOpen THEN SemError(230) END; t := SymTab.NewOpenArray(elem); .) | TypeIdent [ Subrange ] "OF" Type (. (* index-type array: the index type's ordinal bounds give the [lo..hi] pair *) IF SymTab.TypeBounds(idx, ilo, ihi) THEN t := SymTab.NewArrayB(elem, ilo, ihi) ELSE SemError(230); t := SymTab.InvalidType END; .) | "[" (. SymTab.BoundBegin; ok := TRUE; .) BoundPair { "," BoundPair } "]" (. (* snapshot before the element type, which reuses the bound buffer for a nested ARRAY *) nb := SymTab.BoundCount(); k := 0; WHILE k < nb DO bnds[k] := SymTab.BoundLo(k); bndh[k] := SymTab.BoundHi(k); INC(k) END; .) "OF" Type (. IF ok THEN k := nb; WHILE k > 0 DO DEC(k); elem := SymTab.NewArrayB( elem, bnds[k], bndh[k]) END; t := elem ELSE t := SymTab.InvalidType END; .) ) . BoundPair (. VAR tlo, thi: SymTab.TypeIndex; qlo, qhi: QbeGen.QVal; lo, hi: INTEGER; cl, cl2: INTEGER; .) = Expr ".." Expr (. IF (tlo = SymTab.InvalidType) OR (thi = SymTab.InvalidType) THEN ok := FALSE ELSE cl := SymTab.ClassOf(tlo); cl2 := SymTab.ClassOf(thi); IF ((cl # SymTab.ClInt) AND (cl # SymTab.ClChar)) OR ((cl2 # SymTab.ClInt) AND (cl2 # SymTab.ClChar)) THEN SemError(230); ok := FALSE ELSIF NOT SymTab.ConstInt(qlo, lo) OR NOT SymTab.ConstInt(qhi, hi) OR (lo > hi) THEN SemError(230); ok := FALSE ELSIF NOT SymTab.BoundAdd(lo, hi) THEN SemError(230); ok := FALSE END; END; .) . (* Sets: multi-word masks over bases ≤ 256 values (bool, char, bounded subranges; enums wait for ordinals, INTEGER is unbounded). Literals are SET OF [0..255]; assignment and comparison across suitable bases are lenient (masks over min words + zero-check extras), out-of-span literals are 222. *) SetType (. VAR base: SymTab.TypeIndex; blo, bhi, bspan: INTEGER; bcls: INTEGER; .) = "SET" "OF" Type (. IF base = SymTab.InvalidType THEN t := SymTab.InvalidType ELSE bcls := SymTab.ClassOf(base); IF bcls = SymTab.ClBool THEN blo := 0; bspan := 2 ELSIF bcls = SymTab.ClChar THEN blo := 0; bspan := 256 ELSIF bcls = SymTab.ClEnum THEN blo := 0; bspan := VAL(INTEGER, SymTab.EnumCount(base)) ELSIF SymTab.SubBounds(base, blo, bhi) THEN bspan := bhi - blo + 1 ELSE bspan := 0 END; IF (bspan <= 0) OR (bspan > 65536) THEN SemError(230); t := SymTab.InvalidType ELSE t := SymTab.NewSet(base) END END; .) . (* Records: flat blobs; array fields are pointers to static descriptors (locked amendment), nested records inline. Field offsets static and declaration-ordered. *) (* Field list: plain fields and (optionally) one variant part. The variant part is a `CASE ... END` item; because it starts with the CASE keyword it is unambiguously distinguishable from a field (which starts with an identifier). *) RecordType (. VAR t2: SymTab.TypeIndex; tagOk: BOOLEAN; .) = "RECORD" (. t := SymTab.NewRecord(); .) [ RecItem { ";" [ RecItem ] } ] "END" . RecItem (. VAR tt: SymTab.TypeIndex; .) = RecField | CaseField (. SymTab.MarkVariant(rec); .) . (* A variant part: CASE tag : Type OF variants. The layout overlays every branch from the tag slot (see SymTab.ComputeOffsets). *) CaseField (. VAR tagT: SymTab.TypeIndex; tagN: SymTab.Name; .) = "CASE" (. SymTab.ResetFields(rec); .) GetIdent (. IF NOT SymTab.FieldPending(rec, tagN) THEN SemError(200) END; .) ":" Type (. IF (tagT # SymTab.InvalidType) AND NOT SymTab.IsOrdinal(tagT) THEN SemError(224) END; SymTab.FixPendingF(rec, tagT); SymTab.SetVariantTag(rec, tagN); .) "OF" RecFieldList { "|" (. SymTab.ResetFields(rec); .) RecFieldList } "END" . RecFieldList (. VAR lt, lq: SymTab.TypeIndex; lv1, lv2: QbeGen.QVal; .) = VarLabel [ ".." VarLabel ] ":" RecField { ";" [ RecField ] } . (* Variant case label: a constant (or a constant range). Values are not interpreted (the layout overlays regardless). *) VarLabel (. VAR lname: SymTab.Name; .) = ( ident (. LexName(lname); QbeGen.CopyOp("0", q); t := SymTab.IntType(); .) | integer (. LexString(lname); QbeGen.CopyOp("0", q); t := SymTab.IntType(); .) | charConst (. LexString(lname); QbeGen.CopyOp("0", q); t := SymTab.CharType(); .) ) . RecField (. VAR n: SymTab.Name; t2: SymTab.TypeIndex; .) = RecIdents ":" Type(. SymTab.FixPendingF(rec, t2); .) . RecIdents (. VAR n: SymTab.Name; .) = GetIdent (. IF NOT SymTab.FieldPending(rec, n) THEN SemError(200) END; .) { "," GetIdent (. IF NOT SymTab.FieldPending(rec, n) THEN SemError(200) END; .) } . TypeIdent (. VAR n, qid: SymTab.Name; k: INTEGER; dotted: BOOLEAN; .) = GetIdent (. dotted := FALSE; IF NOT SymTab.Lookup(n) THEN k := -1; t := SymTab.ForwardType(n); IF t = SymTab.InvalidType THEN SemError(201) END ELSE k := SymTab.SymKind(n); IF (k = SymTab.KindType) OR (k = SymTab.KindPredef) THEN t := SymTab.SymType(n) ELSE t := SymTab.InvalidType END END; .) [ "." GetIdent (. dotted := TRUE; IF k = SymTab.KindModule THEN t := SymTab.QualType(n, qid); IF t = SymTab.InvalidType THEN SemError(201) END ELSE SemError(221); t := SymTab.InvalidType END; .) ] (. IF NOT dotted THEN IF (k = SymTab.KindModule) OR ((k # SymTab.KindType) AND (k # SymTab.KindPredef) AND (k # SymTab.KindImport) AND (k # -1)) THEN SemError(221) END END; .) . Subrange (. 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 NOT SymTab.IsOrdinal(tlo) OR NOT SymTab.IsOrdinal(thi) THEN SemError(230); t := SymTab.InvalidType ELSIF NOT SymTab.ConstInt(qlo, lo) OR NOT 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; ord: INTEGER; qv: QbeGen.QVal; .) = "(" (. t := SymTab.NewEnum(); ord := 0; .) GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); QbeGen.IntStr(ord, qv); SymTab.SetSymVal(n, qv); INC(ord); .) { "," GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); QbeGen.IntStr(ord, qv); SymTab.SetSymVal(n, qv); INC(ord); .) } ")" (. SymTab.SetEnumCount(t, VAL(CARDINAL, ord)); .) . (* Clarion-form classes (docs/OOP.txt): declaration + single inheritance + 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 (not "," as in the sketch). No underscores in identifiers. *) (* 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. A misplaced CLASS IMPLEMENTATION inside TYPE still parses (harmless: the whole unit ends 230 until lowering). *) ClassItem = "CLASS" ( "IMPLEMENTATION" ClassImplRest | ClassRest ) . ClassRest (. VAR cn, m2, pn: SymTab.Name; ct: SymTab.TypeIndex; .) = GetIdent (. IF NOT SymTab.Enter(cn, SymTab.KindType) THEN SemError(200) END; ct := SymTab.NewClass(); SymTab.SetSymType(cn, ct); SymTab.PushClassScope(ct); astCls := AST.MakeNode(AST.NkClassDecl); AST.SetChild(astCls, 0, AST.MakeLeaf(AST.NkIdent, cn)); astClsP := AST.NoNode; astClsPTail := AST.NoNode; astClsF := AST.NoNode; astClsFTail := AST.NoNode; astClsM := AST.NoNode; astClsMTail := AST.NoNode; .) [ Parents ] ";" { ClassField ";" } { MethodHeading ";" (. SymTab.CloseProc; QbeGen.AbortFunc; .) } "END" GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.LayoutClass(ct); SymTab.PopScope; AST.SetChild(astCls, 1, astClsP); AST.SetChild(astCls, 2, astClsF); AST.SetChild(astCls, 3, astClsM); astDecl := astCls; .) . Parents (. VAR p: SymTab.Name; .) = "(" Parent1 { "," GetIdent

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

(. IF NOT 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; AstAppend(AST.NkFieldDecl, astClsP, astClsPTail, AST.MakeLeaf(AST.NkIdent, p)); .) . ClassField (. VAR n, rhs: SymTab.Name; t: SymTab.TypeIndex; astNode: AST.Node; .) = GetIdent ( "=" GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; astNode := AST.MakeNode(AST.NkConstDecl); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, n)); AST.SetChild(astNode, 1, AST.MakeLeaf(AST.NkIdent, rhs)); AstAppend(AST.NkFieldDecl, astClsF, astClsFTail, astNode); IF SymTab.Lookup(rhs) THEN SymTab.SetSymType(n, SymTab.SymType(rhs)) END; .) | (. IF NOT SymTab.FieldPending(ct, n) THEN SemError(200) END; astNode := AST.MakeNode(AST.NkVarDecl); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, n)); .) { "," GetIdent (. IF NOT SymTab.FieldPending(ct, n) THEN SemError(200) END; AST.SetChild(astNode, AST.NChild(astNode), AST.MakeLeaf(AST.NkIdent, n)); .) } ":" Type (. SymTab.FixPendingF(ct, t); AST.SetTy(astNode, t); AstAppend(AST.NkFieldDecl, astClsF, astClsFTail, astNode); .) ) . MethodHeading (. VAR wantVirt: BOOLEAN; .) = (. wantVirt := FALSE; .) [ "VIRTUAL" (. wantVirt := TRUE; .) ] ProcHeading (. IF wantVirt THEN SymTab.MarkVirtual END; astMethod := AST.MakeNode(AST.NkProcDecl); AST.SetChild(astMethod, 0, AST.MakeLeaf(AST.NkIdent, pn)); IF wantVirt THEN AST.SetOp(astMethod, 3) ELSE AST.SetOp(astMethod, 0) END; AstAppend(AST.NkFieldDecl, astClsM, astClsMTail, astMethod); .) . ClassImplRest (. VAR cn, m2: SymTab.Name; ct: SymTab.TypeIndex; .) = GetIdent (. IF NOT 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; astCls := AST.MakeNode(AST.NkClassDecl); AST.SetOp(astCls, 1); AST.SetChild(astCls, 0, AST.MakeLeaf(AST.NkIdent, cn)); astClsM := AST.NoNode; astClsMTail := AST.NoNode; astStmt := AST.NoNode; IF ct # SymTab.InvalidType THEN IF NOT SymTab.PushClassMembers( ct) THEN SemError(230) END; SymTab.PushImplClass(ct) END; .) ";" { MethodImpl ";" } (. astStmt := AST.NoNode; .) [ "BEGIN" (. astStmt := AST.MakeNode(AST.NkBlock); QbeGen.BeginInit(cn); .) [ StatSeq ] (. QbeGen.EndInit; .) ] "END" GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.PopImplClass; SymTab.PopScope; AST.SetChild(astCls, 1, AST.NoNode); AST.SetChild(astCls, 2, astStmt); AST.SetChild(astCls, 3, astClsM); astDecl := astCls; .) . MethodImpl (. VAR pn: SymTab.Name; thisQ: QbeGen.QVal; methRes: SymTab.TypeIndex; .) = MethodHeading ";" (. IF (ct # SymTab.InvalidType) AND NOT SymTab.MethodExists(ct, pn) THEN SemError(201) END; .) ( "FORWARD" (. AST.SetOp(astMethod, 1); SymTab.MarkFwd; QbeGen.AbortFunc; SymTab.CloseProc; .) | (. QbeGen.EndFuncHeader; (* bind the receiver: bare field names resolve against THIS *) QbeGen.ThisBase(thisQ); QbeGen.PushWith(thisQ); .) Block (. AST.SetChild(astMethod, 1, astStmt); QbeGen.PopWith; methRes := SymTab.CurRes(); SymTab.CloseProc; QbeGen.EndFunc(methRes); .) ) . ConstBlock (. VAR astSeq, astTail: AST.Node; .) = "CONST" (. astSeq := AST.NoNode; astTail := AST.NoNode; .) { ConstDecl ";" (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) } (. astDecl := astSeq; .) . ConstDecl (. VAR n: SymTab.Name; t: SymTab.TypeIndex; qv: QbeGen.QVal; cls: INTEGER; astNode: AST.Node; .) = GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; .) "=" Expr (. astNode := AST.MakeNode(AST.NkConstDecl); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, n)); AST.SetChild(astNode, 1, astCur); AST.SetTy(astNode, t); astDecl := astNode; Lower.NoteVar(n, SymTab.KindConst, t); SymTab.SetSymType(n, t); cls := SymTab.ClassOf(t); IF (cls = SymTab.ClArray) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) OR (cls = SymTab.ClStr) OR (cls = SymTab.ClUStr) THEN (* an aggregate/string constant: qv is its descriptor address; no scalar data *) SymTab.SetSymVal(n, qv) ELSIF NOT QbeGen.IsImm(qv) THEN SemError(230) ELSE SymTab.SetSymVal(n, qv); QbeGen.DeclConst(n, qv, t) END; .) . VarBlock (. VAR astSeq, astTail: AST.Node; .) = "VAR" (. astSeq := AST.NoNode; astTail := AST.NoNode; .) { VarDecl ";" (. AstAppend(AST.NkDeclSeq, astSeq, astTail, astDecl); .) } (. astDecl := astSeq; .) . VarDecl (. VAR nm: SymTab.Name; t: SymTab.TypeIndex; i: CARDINAL; cls: INTEGER; astNode: AST.Node; .) = VarIdents ":" Type (. astNode := AST.MakeNode(AST.NkVarDecl); i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); Lower.NoteVar(nm, SymTab.KindVar, t); AST.SetChild(astNode, AST.NChild(astNode), AST.MakeLeaf(AST.NkIdent, nm)); INC(i) END; AST.SetTy(astNode, t); astDecl := astNode; cls := SymTab.ClassOf(t); IF (t # SymTab.InvalidType) AND NOT SymTab.IsUnresolved(t) AND (cls # SymTab.ClInt) AND (cls # SymTab.ClBool) AND (cls # SymTab.ClChar) AND (cls # SymTab.ClReal) AND (cls # SymTab.ClArray) AND (cls # SymTab.ClSet) AND (cls # SymTab.ClRecord) AND (cls # SymTab.ClPtr) AND (cls # SymTab.ClLong) AND (cls # SymTab.ClProc) AND (cls # SymTab.ClUChar) AND (cls # SymTab.ClUStr) AND (cls # SymTab.ClEnum) AND (cls # SymTab.ClClass) THEN SemError(230) END; IF QbeGen.LocFull() THEN SemError(233) END; i := 0; IF SymTab.IsUnresolved(t) AND NOT SymTab.InProc() THEN (* a forward-typed global: defer emission until the TYPE block completes *) WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); IF nPendVar <= HIGH(pendVarName) THEN pendVarName[nPendVar] := nm; pendVarT[nPendVar] := t; INC(nPendVar) END; INC(i) END ELSE WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); QbeGen.DeclVar(nm, t); INC(i) END END; (* a plain VAR list, not a heading: the signature result is discarded *) IF NOT SymTab.FixPending(t) THEN END; .) . VarIdents (. VAR n: SymTab.Name; .) = GetIdent (. IF NOT SymTab.EnterPending(n, SymTab.KindVar) THEN SemError(200) END; .) { "," GetIdent (. IF NOT SymTab.EnterPending(n, SymTab.KindVar) THEN SemError(200) END; .) } . ParIdents (. VAR n: SymTab.Name; .) = GetIdent (. IF NOT SymTab.EnterParam(n, isV) THEN SemError(200) END; .) { "," GetIdent (. IF NOT SymTab.EnterParam(n, isV) THEN SemError(200) END; .) } . (* Procedure headings enter scopes/params/result and buffer the QBE header; bodies lower to functions (4.1, module level only). FORWARD marks; the body heading re-enters (signature compare deferred). Nested procedures parse + check, lowering = 4.2. *) ProcHeading (. VAR t: SymTab.TypeIndex; mg: QbeGen.QVal; .) = "PROCEDURE" GetIdent (. IF methCls # SymTab.InvalidType THEN (* a method: resume the declared symbol (reuse its uid) *) IF NOT SymTab.ResumeMethod( methCls, pn) THEN SemError(200) END ELSIF NOT SymTab.EnterProc(pn) THEN IF NOT SymTab.ReenterProc(pn) THEN IF NOT SymTab.ResumeProc(pn) THEN SemError(200) END END END; Lower.ScopeEnter; Lower.NoteProc(pn, SymTab.ProcUid(pn), SymTab.InvalidType, SymTab.ProcDepthOf(pn), FALSE); IF methCls # SymTab.InvalidType THEN QbeGen.Mangled(pn, SymTab.MethUid(), mg) ELSE QbeGen.Mangled(pn, SymTab.ProcUid(pn), mg) END; QbeGen.BeginFunc(mg); IF methCls # SymTab.InvalidType THEN (* hidden THIS receiver: a VAR param of the class type, pushed as the WITH base *) IF NOT SymTab.EnterThisParam( methCls) THEN SemError(200) END; IF NOT QbeGen.FuncParam( "THIS", TRUE, methCls) THEN SemError(233) END END; .) [ FormalParams ] [ ":" TypeIdent (. IF NOT SymTab.SetProcRes(t) THEN SemError(235) END; Lower.SetProcRes(t); QbeGen.SetFuncRes(t); IF (t # SymTab.InvalidType) AND ((SymTab.ClassOf(t) = SymTab.ClArray) OR (SymTab.ClassOf(t) = SymTab.ClRecord) OR (SymTab.ClassOf(t) = SymTab.ClSet) OR (SymTab.ClassOf(t) = SymTab.ClClass)) THEN SemError(230) END; .) ] . FormalParams = "(" [ ParamSection { ";" ParamSection } ] ")" . ParamSection (. VAR t: SymTab.TypeIndex; nm: SymTab.Name; i: CARDINAL; isV: BOOLEAN; .) = (. isV := FALSE; .) [ "VAR" (. isV := TRUE; .) ] ParIdents ":" Type (. i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); Lower.NoteParam(nm, t, isV); Lower.NoteVar(nm, SymTab.KindParam, t); (* value open arrays are passed as descriptor addresses (no copy): same representation as VAR formals *) IF NOT QbeGen.FuncParam(nm, isV OR SymTab.IsOpenArray(t), t) THEN SemError(233) END; INC(i) END; IF NOT SymTab.FixPending(t) THEN SemError(235) END; .) . (* Nested procedures lower like top-level ones (4.2): the static link gives them their parent's frame. Methods keep parse-now/230-later. *) ProcDecl (. VAR pn: SymTab.Name; astNode: AST.Node; .) = ProcHeading ";" (. astNode := AST.MakeNode(AST.NkProcDecl); AST.SetOp(astNode, 0); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, pn)); .) ( "FORWARD" (. AST.SetOp(astNode, 1); astDecl := astNode; Lower.ScopeLeave; SymTab.MarkFwd; SymTab.CloseProc; QbeGen.AbortFunc; .) | "EXTERNAL" (. AST.SetOp(astNode, 2); astDecl := astNode; Lower.ScopeLeave; SymTab.MarkExternal(""); SymTab.CloseProc; QbeGen.AbortFunc; .) | (. QbeGen.EndFuncHeader; .) Block (. AST.SetChild(astNode, 1, astStmt); AST.SetChild(astNode, 2, astBlkDecls); astDecl := astNode; Lower.ScopeLeave; SymTab.CloseProc; QbeGen.EndFunc( SymTab.ProcRes(pn)); .) ) . Block (. VAR m2: SymTab.Name; .) = DeclSeq (. astBlkDecls := astDecl; astStmt := AST.NoNode; .) [ "BEGIN" [ StatSeq ] ] "END" GetIdent (. IF NOT SymTab.Equal(pn, m2) THEN SemError(202) END; .) . StatSeq (. VAR astSeq, astTail: AST.Node; .) = (. astSeq := AST.NoNode; astTail := AST.NoNode; .) Statement (. AstAppend(AST.NkBlock, astSeq, astTail, astStmt); .) { ";" [ Statement (. AstAppend(AST.NkBlock, astSeq, astTail, astStmt); .) ] } (. astStmt := astSeq; .) . (* Trailing/empty statements (`a; ; b`, Coco/R's generated `;;`) are accepted: the statement after ';' is optional. *) Statement (. VAR lx: QbeGen.QVal; .) = (. astStmt := AST.NoNode; .) ( AssOrCall | IfStat | WhileStat | RepeatStat | LoopStat | ForStat | CaseStat | WithStat | ReturnStat | HaltStat | NewStat | DisposeStat | IncDecStat | InclExclStat | "EXIT" (. IF QbeGen.TopLoop(lx) THEN QbeGen.Jmp(lx) ELSE SemError(230) END; astStmt := AST.MakeNode(AST.NkExit); .) ) . (* INCL(set, elem) / EXCL(set, elem): PIM set-element builtins. *) InclExclStat (. VAR at, et2: SymTab.TypeIndex; dk: INTEGER; qd, qe: QbeGen.QVal; qn: SymTab.Name; sfx, isInc: BOOLEAN; astNode, astD: AST.Node; .) = ( "INCL" (. isInc := TRUE; .) | "EXCL" (. isInc := FALSE; .) ) "(" Design (. astD := astCur; .) "," Expr ")" (. astNode := AST.MakeNode(AST.NkCall); IF isInc THEN AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "INCL")) ELSE AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "EXCL")) END; IF astD # AST.NoNode THEN AST.SetChild(astNode, 1, astD) END; IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; astStmt := astNode; .) (. IF at = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(at) # SymTab.ClSet THEN SemError(222) ELSE IF isInc THEN QbeGen.SetBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at)) ELSE QbeGen.SetClearBit(qd, qe, SymTab.SetBaseLo(at), SymTab.SetCount(at)) END END; .) . (* INC(v [,step]) / DEC(v [,step]) as builtin statements over an integer designator. *) IncDecStat (. VAR dt, et2: SymTab.TypeIndex; dk: INTEGER; qd, qv, qn2, qstep: QbeGen.QVal; qn: SymTab.Name; sfx, isInc: BOOLEAN; astNode, astD, astStep: AST.Node; .) = (. isInc := TRUE; .) ( "INC" (. isInc := TRUE; .) | "DEC" (. isInc := FALSE; .) ) "(" (. QbeGen.CopyOp("1", qstep); astStep := AST.NoNode; .) Design (. astD := astCur; .) [ "," Expr (. astStep := astCur; .) ] ")" (. astNode := AST.MakeNode(AST.NkCall); IF isInc THEN AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "INC")) ELSE AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "DEC")) END; IF astD # AST.NoNode THEN AST.SetChild(astNode, 1, astD) END; IF astStep # AST.NoNode THEN AST.SetChild(astNode, 2, astStep) END; astStmt := astNode; .) (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF NOT SymTab.IsIntFamily(dt) THEN SemError(211) ELSE IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv) ELSE QbeGen.LoadVar(qn, FALSE, qv) END; QbeGen.NewTemp(qn2); IF isInc THEN QbeGen.Op3("add", qn2, qv, qstep, FALSE) ELSE QbeGen.Op3("sub", qn2, qv, qstep, FALSE) END; IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qn2, dt) ELSE QbeGen.StoreVar(qn, qn2, FALSE) END END; .) . (* NEW/DISPOSE as builtin statements (no call syntax until step 4). Targets are pointer designators; DISPOSE nils afterwards (safer than Wirth-undefined; documented). DISPOSE is shallow. *) NewStat (. VAR dt: SymTab.TypeIndex; dk: INTEGER; qd, qm: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN; bt: SymTab.TypeIndex; astNode, astD: AST.Node; .) = "NEW" "(" Design (. astD := astCur; .) ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "NEW")); IF astD # AST.NoNode THEN AST.SetChild(astNode, 1, astD) END; astStmt := astNode; .) (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN SemError(219) ELSE bt := SymTab.PtrBase(dt); IF bt # SymTab.InvalidType THEN QbeGen.NewHeap(bt, qm); QbeGen.InitHeap(qm, bt); IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qm, dt) ELSE QbeGen.StorePtr(qn, qm) END END END; .) . DisposeStat (. VAR dt: SymTab.TypeIndex; dk: INTEGER; qd, qv: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN; astNode, astD: AST.Node; .) = "DISPOSE" "(" Design (. astD := astCur; .) ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "DISPOSE")); IF astD # AST.NoNode THEN AST.SetChild(astNode, 1, astD) END; astStmt := astNode; .) (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN SemError(219) ELSE IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv) ELSE QbeGen.LoadPtr(qn, qv) END; QbeGen.FreeHeap(qv); IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, "0", dt) ELSE QbeGen.StorePtr(qn, "0") END END; .) . (* WITH pushes each record's fields (inner wins) plus its base address; field designators resolve through both stacks. *) WithStat (. VAR nW: CARDINAL; astNode: AST.Node; .) = "WITH" (. nW := 0; astNode := AST.MakeNode(AST.NkWith); .) WithItem { "," WithItem } "DO" (. astStmt := AST.NoNode; .) [ StatSeq ] "END" (. AST.SetChild(astNode, AST.NChild(astNode), astStmt); astStmt := astNode; WHILE nW > 0 DO SymTab.PopScope; QbeGen.PopWith; DEC(nW) END; .) . WithItem (. VAR dt: SymTab.TypeIndex; dk: INTEGER; qd, qe: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN; .) = Design (. IF astCur # AST.NoNode THEN AST.SetChild(wnode, AST.NChild(wnode), astCur) END; IF dt = SymTab.InvalidType THEN ELSIF (SymTab.ClassOf(dt) # SymTab.ClRecord) AND (SymTab.ClassOf(dt) # SymTab.ClClass) THEN SemError(215) ELSIF SymTab.PushRecord(dt) THEN QbeGen.PushWith(qd); INC(nW) END; .) . (* Assignment or procedure-statement call (4.1, module level). Bare `P;` is a syntax error; function-as-statement is 233. *) AssOrCall (. VAR dt, et: SymTab.TypeIndex; dk: INTEGER; qd, qe, qt, ql: QbeGen.QVal; qn: SymTab.Name; ct2, res0: SymTab.TypeIndex; q2, mg0: QbeGen.QVal; isR, conv, wconv: BOOLEAN; called, sfx: BOOLEAN; astLhs: AST.Node; .) = Design (. astLhs := astCur; astNArgs := 0; .) ( ":=" Expr (. astStmt := AST.MakeBin( AST.NkAssign, 0, astLhs, astCur); IF (dt # SymTab.InvalidType) AND (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF NOT SymTab.Assignable(et, dt) THEN SemError(210) ELSIF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClClass) THEN SemError(230) END; isR := (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClReal); conv := isR AND SymTab.IsIntFamily(et); wconv := (dt # SymTab.InvalidType) AND SymTab.IsLongFamily(dt) AND SymTab.IsIntFamily(et); IF ((dk = SymTab.KindVar) OR (dk = SymTab.KindParam) OR (dk = SymTab.KindField)) AND (dt # SymTab.InvalidType) AND (et # SymTab.InvalidType) AND (SymTab.ClassOf(dt) # SymTab.ClClass) THEN IF sfx OR (dk = SymTab.KindField) THEN IF SymTab.ClassOf(dt) = SymTab.ClArray THEN IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr) AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe) ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe) ELSE QbeGen.CopyArray(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et)) ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN QbeGen.CopyRecord(qd, qe, dt) ELSIF SymTab.IsLongFamily(dt) THEN IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.ElemStore(qd, ql, dt) ELSE QbeGen.ElemStore(qd, qe, dt) END ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.ElemStore(qd, qt, dt) ELSE QbeGen.ElemStore(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClArray THEN IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr) AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe) ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe) ELSE QbeGen.CopyArray(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et)) ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN QbeGen.CopyRecord(qd, qe, dt) ELSIF (SymTab.ClassOf(dt) = SymTab.ClPtr) OR (SymTab.ClassOf(dt) = SymTab.ClProc) THEN QbeGen.StorePtr(qn, qe) ELSIF SymTab.IsLongFamily(dt) THEN IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.StoreLong(qn, ql) ELSE QbeGen.StoreLong(qn, qe) END ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.StoreVar(qn, qt, TRUE) ELSE QbeGen.StoreVar(qn, qe, isR) END END; .) | ArgList (. astStmt := AstCallNode(astLhs); .) | (* bare `P;`: proper parameterless procedure call; anything else here is 233 (was a bare syntax error before 4.2) *) (. astStmt := AstCallNode(astLhs); IF (dk = SymTab.KindProc) AND NOT sfx THEN res0 := SymTab.ProcRes(qn); IF res0 # SymTab.InvalidType THEN SemError(233) ELSIF SymTab.ProcNPar(qn) # 0 THEN SemError(233) ELSE QbeGen.Mangled(qn, SymTab.ProcUid(qn), mg0); QbeGen.CallBegin(mg0, res0, SymTab.ProcDepthOf(qn), SymTab.IsExternal(qn)); QbeGen.CallEnd(FALSE, q2) END ELSE SemError(233) END; .) ) . (* Actual-parameter list shared by statement and expression calls. want selects CallEnd's result handling; t/q carry the call value (statement calls discard). Arity/type failures are 233; evaluation code still emits so the .ssa stays assembleable. *) ArgList (. VAR i, np: CARDINAL; vs: INTEGER; res: SymTab.TypeIndex; mg: QbeGen.QVal; ok, ind, isMeth, va: BOOLEAN; .) = "(" (. called := TRUE; ok := TRUE; ind := FALSE; isMeth := methCls # SymTab.InvalidType; IF isMeth THEN (* class method: the receiver is armed. Virtual -> dispatch through the vtable; otherwise a static call. *) res := SymTab.ClassMethodRes( methCls, pn); vs := SymTab.VirtSlot( methCls, pn); IF vs >= 0 THEN QbeGen.VirtCallBegin( callee, vs, res) ELSE QbeGen.Mangled(pn, SymTab.ClassMethodUid( methCls, pn), mg); QbeGen.CallBegin(mg, res, 0, FALSE) END ELSIF SymTab.SymKind(pn) = SymTab.KindProc THEN res := SymTab.ProcRes(pn); QbeGen.Mangled(pn, SymTab.ProcUid(pn), mg); QbeGen.CallBegin(mg, res, SymTab.ProcDepthOf(pn), SymTab.IsExternal(pn)) ELSIF (pt # SymTab.InvalidType) AND (SymTab.ClassOf(pt) = SymTab.ClProc) THEN ind := TRUE; res := SymTab.ProcTypeRes(pt); QbeGen.CallBeginInd(callee, res, FALSE) ELSE SemError(233); ok := FALSE; res := SymTab.InvalidType END; i := 0; .) [ ActParam (. INC(i); .) { "," ActParam (. INC(i); .) } ] ")" (. IF ok THEN IF isMeth THEN np := SymTab.ClassMethodNPar( methCls, pn) ELSIF ind THEN np := SymTab.ProcTypeNPar(pt) ELSE np := SymTab.ProcNPar(pn) END; va := (NOT isMeth) AND (NOT ind) AND (SymTab.SymKind(pn) = SymTab.KindProc) AND SymTab.Varargs(pn); IF (i # np) AND NOT va THEN SemError(233); ok := FALSE END END; IF NOT ok THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSIF want THEN IF res = SymTab.InvalidType THEN SemError(233); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE t := res; QbeGen.CallEnd(TRUE, q) END ELSE IF res # SymTab.InvalidType THEN SemError(233) END; t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q) END; .) . (* One actual: VAR formals take recorded designator addresses (233 otherwise); value formals take converted expressions. *) ActParam (. VAR at, ft: SymTab.TypeIndex; qe, qa, qt: QbeGen.QVal; isV, conv, va: BOOLEAN; cl: CHAR; .) = Expr (. IF astNArgs <= HIGH(astArgs) THEN astArgs[astNArgs] := astCur; INC(astNArgs) END; va := (NOT ind) AND (methCls = SymTab.InvalidType) AND (SymTab.SymKind(pn) = SymTab.KindProc) AND SymTab.Varargs(pn); IF ind THEN ft := SymTab.ProcTypeParamType(pt, i); isV := SymTab.ProcTypeParamIsVar(pt, i) ELSIF methCls # SymTab.InvalidType THEN ft := SymTab.ClassMethodParamType( methCls, pn, i); isV := SymTab.ClassMethodParamIsVar( methCls, pn, i) ELSE ft := SymTab.ParamType(pn, i); isV := SymTab.ParamIsVar(pn, i) END; IF (at = SymTab.InvalidType) THEN ELSIF ft = SymTab.InvalidType THEN IF va THEN QbeGen.CArgAdd(qe, at, qa, cl) END ELSIF isV THEN IF (SymTab.ClassOf(at) = SymTab.ClChar) AND (SymTab.ClassOf(ft) = SymTab.ClArray) AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar) AND QbeGen.IsImm(qe) THEN (* 1-char string literal passed to a VAR ARRAY OF CHAR *) QbeGen.DeclCharStr(qe, qa); IF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSIF NOT QbeGen.AddrOfVal(qe, qa) THEN SemError(233) ELSIF NOT SymTab.VarParamOk(at, ft) THEN SemError(233) ELSIF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSE IF (SymTab.ClassOf(at) = SymTab.ClChar) AND (SymTab.ClassOf(ft) = SymTab.ClArray) AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar) AND QbeGen.IsImm(qe) THEN (* 1-char string literal passed to ARRAY OF CHAR *) QbeGen.DeclCharStr(qe, qa); IF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSIF NOT SymTab.Assignable(at, ft) THEN SemError(233) ELSE conv := (SymTab.ClassOf( ft) = SymTab.ClReal) AND SymTab.IsIntFamily(at); IF conv THEN QbeGen.ConvIR(qe, qt); IF NOT QbeGen.CallArg(qt, "d") THEN SemError(233) END ELSIF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN SemError(233) END END END; .) . IfStat (. VAR t: SymTab.TypeIndex; q, lThen, lElse, lEnd: QbeGen.QVal; hasElse: BOOLEAN; astCond, astIf, astLast, astNode: AST.Node; .) = "IF" (. hasElse := FALSE; .) Expr (. astCond := astCur; astStmt := AST.NoNode; IF NOT 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 ] (. astNode := AST.MakeNode(AST.NkIf); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); astIf := astNode; astLast := astNode; QbeGen.Jmp(lEnd); .) { "ELSIF" (. QbeGen.EmitLabel(lElse); QbeGen.NewLabel(lElse); .) Expr (. astCond := astCur; astStmt := AST.NoNode; IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.NewLabel(lThen); QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen); .) "THEN" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkIf); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); AST.SetChild(astLast, 2, astNode); astLast := astNode; QbeGen.Jmp(lEnd); .) } [ "ELSE" (. QbeGen.EmitLabel(lElse); hasElse := TRUE; astStmt := AST.NoNode; .) [ StatSeq ] (. AST.SetChild(astLast, 2, astStmt); .) ] "END" (. astStmt := astIf; 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; astCond, astNode: AST.Node; .) = "WHILE" (. astStmt := AST.NoNode; QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) Expr (. astCond := astCur; IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lBody, lEnd); QbeGen.EmitLabel(lBody); .) "DO" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkWhile); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); astStmt := astNode; QbeGen.Jmp(lTop); .) "END" (. QbeGen.EmitLabel(lEnd); .) . RepeatStat (. VAR t: SymTab.TypeIndex; q, lTop, lEnd: QbeGen.QVal; astCond, astBody, astNode: AST.Node; .) = "REPEAT" (. astStmt := AST.NoNode; QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] (. astBody := astStmt; .) "UNTIL" Expr (. astCond := astCur; astNode := AST.MakeNode(AST.NkRepeat); AST.SetChild(astNode, 0, astBody); AST.SetChild(astNode, 1, astCond); astStmt := astNode; IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lEnd, lTop); QbeGen.EmitLabel(lEnd); .) . LoopStat (. VAR lTop, lEnd: QbeGen.QVal; astNode: AST.Node; .) = "LOOP" (. QbeGen.NewLabel(lTop); astStmt := AST.NoNode; QbeGen.NewLabel(lEnd); QbeGen.PushLoop(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] "END" (. astNode := AST.MakeNode(AST.NkLoop); AST.SetChild(astNode, 0, astStmt); astStmt := astNode; 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; astVar, astLo, astHi, astBy, astNode: AST.Node; .) = "FOR" (. by := 1; .) GetIdent (. astVar := AST.MakeLeaf(AST.NkIdent, lv); astStmt := AST.NoNode; astBy := AST.NoNode; ok := SymTab.Lookup(lv); IF NOT ok THEN SemError(201) ELSIF (SymTab.SymKind(lv) # SymTab.KindVar) AND (SymTab.SymKind(lv) # SymTab.KindParam) THEN SemError(220); ok := FALSE ELSIF NOT SymTab.IsIntFamily( SymTab.SymType(lv)) THEN SemError(220); ok := FALSE END; .) ":=" Expr (. astLo := astCur; IF NOT SymTab.IsIntFamily(tlo) THEN SemError(220); ok := FALSE END; .) "TO" Expr (. astHi := astCur; IF NOT SymTab.IsIntFamily(thi) THEN SemError(220); ok := FALSE END; .) [ "BY" Expr (. astBy := astCur; IF (tby # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(tby) THEN SemError(220); ok := FALSE END; IF NOT 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" (. astNode := AST.MakeNode(AST.NkFor); AST.SetChild(astNode, 0, astVar); AST.SetChild(astNode, 1, astLo); AST.SetChild(astNode, 2, astHi); AST.SetChild(astNode, 3, astBy); AST.SetChild(astNode, 4, astStmt); astStmt := astNode; 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; arm, astNode: AST.Node; .) = "CASE" Expr (. astNode := AST.MakeNode(AST.NkCase); AST.SetChild(astNode, 0, astCur); QbeGen.NewLabel(lEnd); .) "OF" CaseAlt { "|" CaseAlt } [ "ELSE" (. astStmt := AST.NoNode; .) [ StatSeq ] (. arm := AST.MakeNode(AST.NkCaseArm); AST.SetOp(arm, 1); AST.SetChild(arm, 0, astStmt); AST.SetChild(astNode, AST.NChild(astNode), arm); .) ] "END" (. astStmt := astNode; 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; arm: AST.Node; .) = (. arm := AST.MakeNode(AST.NkCaseArm); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lAfter); .) CaseLabel { "," CaseLabel } ":" (. astStmt := AST.NoNode; QbeGen.Jmp(lAfter); QbeGen.EmitLabel(lBody); .) [ StatSeq ] (. AST.SetChild(arm, AST.NChild(arm), astStmt); AST.SetChild(cnode, AST.NChild(cnode), arm); QbeGen.Jmp(lEnd); QbeGen.EmitLabel(lAfter); .) . CaseLabel (. VAR t2, t3: SymTab.TypeIndex; q2, q3, qc, qd, qe: QbeGen.QVal; astLab: AST.Node; lNext: QbeGen.QVal; .) = Expr (. astLab := astCur; IF (t2 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND ((SymTab.ClassOf(t2) = SymTab.ClSet) OR (SymTab.ClassOf(tsel) = SymTab.ClSet)) THEN SemError(230) ELSIF (t2 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND NOT SymTab.EqCheck(t2, tsel) THEN SemError(213) END; IF NOT 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 (. astLab := AST.MakeBin( AST.NkSubrange, 0, astLab, astCur); IF (t3 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND NOT SymTab.EqCheck(t3, tsel) THEN SemError(213) END; IF NOT 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); .) ] (. AST.SetChild(arm, AST.NChild(arm), astLab); .) . ReturnStat (. VAR t: SymTab.TypeIndex; q, qt: QbeGen.QVal; res: SymTab.TypeIndex; hadE, conv: BOOLEAN; astVal, astNode: AST.Node; .) = "RETURN" (. hadE := FALSE; astStmt := AST.NoNode; .) [ Expr (. hadE := TRUE; astVal := astCur; .) ] (. astNode := AST.MakeNode(AST.NkReturn); IF hadE THEN AST.SetChild(astNode, 0, astVal) END; astStmt := astNode; conv := FALSE; IF NOT SymTab.InProc() THEN SemError(232) ELSE res := SymTab.CurRes(); IF NOT hadE THEN IF res # SymTab.InvalidType THEN SemError(232) ELSE QbeGen.EmitRet(q, FALSE) END ELSIF (res = SymTab.InvalidType) OR (t # SymTab.InvalidType) AND NOT SymTab.Assignable(t, res) THEN SemError(232) ELSE conv := (SymTab.ClassOf( res) = SymTab.ClReal) AND SymTab.IsIntFamily(t); IF conv THEN QbeGen.ConvIR(q, qt); QbeGen.EmitRet(qt, TRUE) ELSE QbeGen.EmitRet(q, TRUE) END END END; .) . HaltStat (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; astVal, astNode: AST.Node; .) = "HALT" (. astVal := AST.NoNode; .) [ "(" Expr (. astVal := astCur; .) ")" ] (. astNode := AST.MakeNode(AST.NkHalt); IF astVal # AST.NoNode THEN AST.SetChild(astNode, 0, astVal) END; astStmt := astNode; QbeGen.HaltQ; .) . (* Designator: scalar loads, array addresses, and index suffixes. Each index descends one level (bounds-checked, trap on breach); nested levels reload the inner descriptor address. q ends as the value (scalars), the descriptor address (plain arrays), or the element address (indexed); sfx marks the indexed form. *) Design (. VAR n, fn, mal: SymTab.Name; cls: INTEGER; ic: SymTab.TypeIndex; curT, it, eT, bt: SymTab.TypeIndex; iq, ql, qlo, qhi, qe: QbeGen.QVal; lo, hi: INTEGER; fo: INTEGER; isOpen: BOOLEAN; qb, cv: QbeGen.QVal; fid, fref, slot: INTEGER; r: BOOLEAN; astDes, astSel: AST.Node; .) = GetIdent (. methCls := SymTab.InvalidType; QbeGen.CopyOp(n, qn); sfx := FALSE; fid := 0; fref := 0; slot := 0; IF NOT SymTab.Lookup(n) THEN (* a bare method name inside a CLASS IMPLEMENTATION is a sibling call on THIS *) ic := SymTab.CurImplClass(); IF (ic # SymTab.InvalidType) AND SymTab.MethodExists(ic, n) THEN sfx := FALSE; QbeGen.ThisBase(q); QbeGen.ArmRecv(q); methCls := ic; k := SymTab.KindProc; t := SymTab.InvalidType ELSIF SymTab.InProc() THEN (* not declared yet: a forward reference to a module-level variable declared further down. *) k := SymTab.KindVar; r := SymTab.FwdVarRef(n, k, fref, t); slot := QbeGen.FwdDesignator(); FwdVarNote(fref, slot); fid := slot; QbeGen.FwdAddrOper(fid, q); sfx := TRUE ELSE SemError(201); t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q) END 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) ELSIF SymTab.Equal(n, "NIL") THEN QbeGen.CopyOp("0", q) ELSE cls := SymTab.ClassOf(t); IF (t # SymTab.InvalidType) AND ((cls = SymTab.ClInt) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClReal) OR (cls = SymTab.ClLong) OR (cls = SymTab.ClNil)) THEN IF cls = SymTab.ClNil THEN QbeGen.CopyOp("0", q) ELSIF ((cls = SymTab.ClInt) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClLong)) AND SymTab.GetSymVal(n, cv) AND QbeGen.IsImm(cv) THEN QbeGen.CopyOp(cv, q) ELSE QbeGen.LoadVar(n, cls = SymTab.ClReal, q) END ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClClass) OR (cls = SymTab.ClStr) OR (cls = SymTab.ClUStr) THEN (* aggregate constant: its value IS the descriptor address *) IF SymTab.GetSymVal(n, cv) THEN QbeGen.CopyOp(cv, q) ELSE QbeGen.CopyOp("0", q) END 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.ClUChar) OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClReal) THEN QbeGen.LoadVar(n, cls = SymTab.ClReal, q) ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) THEN QbeGen.LoadPtr(n, q) ELSIF cls = SymTab.ClLong THEN QbeGen.LoadLong(n, q) ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClSet) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClUStr) OR (cls = SymTab.ClClass) THEN QbeGen.AddrOf(n, q) ELSE SemError(230); QbeGen.CopyOp("0", q) END ELSE QbeGen.CopyOp("0", q); IF k = SymTab.KindImport THEN SemError(230) ELSIF k = SymTab.KindProc THEN (* bare procedure name: a following ArgList makes it a call; otherwise Fact reports 230 *) ELSE IF k = SymTab.KindField THEN IF QbeGen.TopWith(qb) THEN fo := SymTab.FieldOffset( SymTab.FieldOwner(n), n); QbeGen.FieldAddr(qb, fo, q); sfx := TRUE ELSE SemError(230); QbeGen.CopyOp("0", q) END END END END END; .) (. astDes := AST.MakeNode(AST.NkDesignator); AST.SetChild(astDes, AST.NChild(astDes), AST.MakeLeaf(AST.NkIdent, n)); .) { "[" Expr (. AST.SetChild(astDes, AST.NChild(astDes), AST.MakeUn(AST.NkSelector, AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClArray THEN SemError(217); t := SymTab.InvalidType ELSIF NOT SymTab.IsIntFamily(it) AND (SymTab.ClassOf(it) # SymTab.ClChar) AND (SymTab.ClassOf(it) # SymTab.ClEnum) THEN SemError(218); t := SymTab.InvalidType ELSE QbeGen.WidenIndex(iq, ql); isOpen := SymTab.IsOpenArray(t); IF isOpen THEN QbeGen.CopyOp("0", qlo); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN QbeGen.OpenHiChar(q, qhi) ELSE QbeGen.OpenHi(q, qhi) END ELSE lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN hi := hi + 1 END; QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi) END; QbeGen.CheckRange(ql, qlo, qhi); eT := SymTab.ArrayElem(t); QbeGen.ElemAddr(q, ql, qlo, t, qe); IF SymTab.ClassOf(eT) = SymTab.ClArray THEN QbeGen.ElemLoad(qe, eT, q) ELSE QbeGen.CopyOp(qe, q) END; t := eT; sfx := TRUE END; .) { "," Expr (. AST.SetChild(astDes, AST.NChild(astDes), AST.MakeUn(AST.NkSelector, AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClArray THEN SemError(217); t := SymTab.InvalidType ELSIF NOT SymTab.IsIntFamily(it) AND (SymTab.ClassOf(it) # SymTab.ClChar) AND (SymTab.ClassOf(it) # SymTab.ClEnum) THEN SemError(218); t := SymTab.InvalidType ELSE QbeGen.WidenIndex(iq, ql); isOpen := SymTab.IsOpenArray(t); IF isOpen THEN QbeGen.CopyOp("0", qlo); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN QbeGen.OpenHiChar(q, qhi) ELSE QbeGen.OpenHi(q, qhi) END ELSE lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN hi := hi + 1 END; QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi) END; QbeGen.CheckRange(ql, qlo, qhi); eT := SymTab.ArrayElem(t); QbeGen.ElemAddr(q, ql, qlo, t, qe); IF SymTab.ClassOf(eT) = SymTab.ClArray THEN QbeGen.ElemLoad(qe, eT, q) ELSE QbeGen.CopyOp(qe, q) END; t := eT; sfx := TRUE END; .) } "]" | "." GetIdent (. astSel := AST.MakeNode(AST.NkSelector); AST.SetOp(astSel, AST.SelField); AST.SetChild(astSel, 0, AST.MakeLeaf(AST.NkIdent, fn)); AST.SetChild(astDes, AST.NChild(astDes), astSel); IF k = SymTab.KindModule THEN (* qualified L.x: materialize the export, then load it *) IF NOT SymTab.MaterializeAlias(n, fn, mal) THEN SemError(201); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE QbeGen.CopyOp(mal, qn); t := SymTab.SymType(mal); k := SymTab.SymKind(mal); sfx := FALSE; IF k = SymTab.KindProc THEN (* call: ArgList supplies the value *) QbeGen.CopyOp("0", q) ELSIF NOT QbeGen.LoadDesignator( mal, t, k, q) THEN SemError(230); QbeGen.CopyOp("0", q) END END ELSIF t = SymTab.InvalidType THEN ELSIF (SymTab.ClassOf(t) # SymTab.ClRecord) AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN SemError(215); t := SymTab.InvalidType ELSIF (SymTab.ClassOf(t) = SymTab.ClClass) AND SymTab.MethodExists(t, fn) THEN (* obj.Method: bind the method and pass obj as the hidden receiver; q already holds the object's address *) QbeGen.ArmRecv(q); QbeGen.CopyOp(fn, n); QbeGen.CopyOp(fn, qn); methCls := t; k := SymTab.KindProc; t := SymTab.InvalidType ELSIF NOT SymTab.FieldExists(t, fn) THEN SemError(216); t := SymTab.InvalidType ELSE fo := SymTab.FieldOffset(t, fn); t := SymTab.FieldType(t, fn); QbeGen.FieldAddr(q, fo, qe); (* array fields are inline: the field address is the descriptor, like records *) QbeGen.CopyOp(qe, q); sfx := TRUE END; .) | "^" (. astSel := AST.MakeNode(AST.NkSelector); AST.SetOp(astSel, AST.SelDeref); AST.SetChild(astDes, AST.NChild(astDes), astSel); IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClPtr THEN SemError(219); t := SymTab.InvalidType ELSE bt := SymTab.PtrBase(t); IF bt = SymTab.InvalidType THEN ELSE IF sfx THEN QbeGen.ElemLoad(q, t, qb); QbeGen.CopyOp(qb, q) END; t := bt; (* q holds the pointee address: Fact loads scalars/pointers and uses the address for aggregates; the VAR-actual note is q itself. *) sfx := TRUE END END; .) } (. astCur := astDes; .) . (* Result suffix (ISO component after a function call): `F()^`, `F()[i]`, `F().field`. The call result is in t/q with sfx FALSE (a value, or a descriptor address for aggregates); each component descends one level exactly like the Design components. *) ResultComp (. VAR it, eT, bt: SymTab.TypeIndex; iq, ql, qlo, qhi, qe, qb: QbeGen.QVal; lo, hi, fo: INTEGER; isOpen: BOOLEAN; fname: SymTab.Name; astWrap, astSel: AST.Node; .) = "[" Expr (. IF AST.Kind(node) # AST.NkDesignator THEN astWrap := AST.MakeNode( AST.NkDesignator); AST.SetChild(astWrap, 0, node); node := astWrap END; AST.SetChild(node, AST.NChild(node), AST.MakeUn(AST.NkSelector, AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClArray THEN SemError(217); t := SymTab.InvalidType ELSIF NOT SymTab.IsIntFamily(it) AND (SymTab.ClassOf(it) # SymTab.ClChar) AND (SymTab.ClassOf(it) # SymTab.ClEnum) THEN SemError(218); t := SymTab.InvalidType ELSE QbeGen.WidenIndex(iq, ql); isOpen := SymTab.IsOpenArray(t); IF isOpen THEN QbeGen.CopyOp("0", qlo); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN QbeGen.OpenHiChar(q, qhi) ELSE QbeGen.OpenHi(q, qhi) END ELSE lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN hi := hi + 1 END; QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi) END; QbeGen.CheckRange(ql, qlo, qhi); eT := SymTab.ArrayElem(t); QbeGen.ElemAddr(q, ql, qlo, t, qe); IF SymTab.ClassOf(eT) = SymTab.ClArray THEN QbeGen.ElemLoad(qe, eT, q) ELSE QbeGen.CopyOp(qe, q) END; t := eT; sfx := TRUE END; .) "]" | "." GetIdent (. IF AST.Kind(node) # AST.NkDesignator THEN astWrap := AST.MakeNode( AST.NkDesignator); AST.SetChild(astWrap, 0, node); node := astWrap END; AST.SetChild(node, AST.NChild(node), AST.MakeUn(AST.NkSelector, AST.SelField, AST.MakeLeaf(AST.NkIdent, fname))); IF t = SymTab.InvalidType THEN ELSIF (SymTab.ClassOf(t) # SymTab.ClRecord) AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN SemError(215); t := SymTab.InvalidType ELSIF NOT SymTab.FieldExists(t, fname) THEN SemError(216); t := SymTab.InvalidType ELSE fo := SymTab.FieldOffset(t, fname); t := SymTab.FieldType(t, fname); QbeGen.FieldAddr(q, fo, qe); QbeGen.CopyOp(qe, q); sfx := TRUE END; .) | "^" (. IF AST.Kind(node) # AST.NkDesignator THEN astWrap := AST.MakeNode( AST.NkDesignator); AST.SetChild(astWrap, 0, node); node := astWrap END; astSel := AST.MakeNode(AST.NkSelector); AST.SetOp(astSel, AST.SelDeref); AST.SetChild(node, AST.NChild(node), astSel); IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClPtr THEN SemError(219); t := SymTab.InvalidType ELSE bt := SymTab.PtrBase(t); IF bt # SymTab.InvalidType THEN IF sfx THEN QbeGen.ElemLoad(q, t, qb); QbeGen.CopyOp(qb, q) END; t := bt; sfx := TRUE END END; .) . Expr (. VAR t2: SymTab.TypeIndex; op: INTEGER; q2, qt, wl: QbeGen.QVal; astA, astB: AST.Node; astOp: INTEGER; astMade: BOOLEAN; isR: BOOLEAN; .) = SimExpr (. astA := astCur; astMade := FALSE; .) [ Rel SimExpr (. astB := astCur; astMade := TRUE; astOp := AST.OpEq; IF op = SymTab.OpNeq1 THEN astOp := AST.OpNe ELSIF op = SymTab.OpNeq2 THEN astOp := AST.OpNe ELSIF op = SymTab.OpLt THEN astOp := AST.OpLt ELSIF op = SymTab.OpLe THEN astOp := AST.OpLe ELSIF op = SymTab.OpGt THEN astOp := AST.OpGt ELSIF op = SymTab.OpGe THEN astOp := AST.OpGe ELSIF op = SymTab.OpIn THEN astOp := AST.OpIn END; IF op = SymTab.OpIn THEN IF SymTab.InCheck(t, t2) THEN IF (t = SymTab.InvalidType) OR (t2 = SymTab.InvalidType) THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) ELSE QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2), SymTab.SetCount(t2), qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) END ELSE SemError(222); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END ELSIF SymTab.RelCheck(t, t2, op) THEN IF (t = SymTab.InvalidType) OR (t2 = SymTab.InvalidType) THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr) OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN IF SymTab.IsFwdVar(t) OR SymTab.IsFwdVar(t2) THEN QbeGen.Cmp(op, q, q2, qt, FALSE); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSIF (op # SymTab.OpEq) AND (op # SymTab.OpNeq1) AND (op # SymTab.OpNeq2) THEN SemError(213); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE QbeGen.CmpL(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) END ELSIF (SymTab.ClassOf(t) = SymTab.ClSet) OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN QbeGen.CmpSet(op, q, q2, SymTab.SetWords(t), SymTab.SetWords(t2), qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSIF SymTab.StrCompat(t, t2) THEN QbeGen.StrEq(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSIF SymTab.IsLongFamily(t) OR SymTab.IsLongFamily(t2) THEN IF SymTab.IsIntFamily(t) THEN QbeGen.WidenLong(q, wl); QbeGen.CopyOp(wl, q) END; IF SymTab.IsIntFamily(t2) THEN QbeGen.WidenLong(q2, wl); QbeGen.CopyOp(wl, q2) END; QbeGen.CmpLong(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSE isR := SymTab.ClassOf(t) = SymTab.ClReal; t := SymTab.BoolType(); QbeGen.Cmp(op, q, q2, qt, isR); QbeGen.CopyOp(qt, q) END ELSE SemError(213); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END; astCur := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); .) ] (. IF NOT astMade THEN astCur := astA END; .) . Rel = "=" (. op := SymTab.OpEq; .) | "#" (. op := SymTab.OpNeq1; .) | "<" (. op := SymTab.OpLt; .) | "<=" (. op := SymTab.OpLe; .) | ">" (. op := SymTab.OpGt; .) | ">=" (. op := SymTab.OpGe; .) | "IN" (. op := SymTab.OpIn; .) . SimExpr (. VAR t2, res2, lt, rt: SymTab.TypeIndex; op: INTEGER; q2, qt, wq, qf, q2a, q2b: QbeGen.QVal; neg, isR, isL, folded: BOOLEAN; fok: BOOLEAN; lw, rw, mw: CARDINAL; lTrue, lNext, lDone, qr, qs: QbeGen.QVal; astA, astB: AST.Node; astSign, astOp: INTEGER; .) = (. neg := FALSE; astSign := 0; .) [ "+" (. neg := TRUE; astSign := 1; .) | "-" (. neg := TRUE; astSign := -1; .) ] Term (. astA := astCur; 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; IF astSign < 0 THEN astCur := AST.MakeUn( AST.NkUnary, AST.OpSub, astA); astA := astCur END; .) { AddOp (. IF op = SymTab.OpOr THEN QbeGen.DelayBegin END; .) Term (. astB := astCur; IF op = SymTab.OpOr THEN QbeGen.DelayEnd END; .) (. astOp := AST.OpAdd; IF op = SymTab.OpSub THEN astOp := AST.OpSub ELSIF op = SymTab.OpOr THEN astOp := AST.OpOr END; astA := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); astCur := astA; IF op = SymTab.OpOr THEN (* short-circuit: if q is true the RHS is skipped *) IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.Slot4(qs); QbeGen.NewLabel(lTrue); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lDone); QbeGen.Jnz(q, lTrue, lNext); QbeGen.EmitLabel(lTrue); QbeGen.StoreW(qs, "1"); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lNext); QbeGen.DelayFlush; QbeGen.StoreW(qs, q2); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lDone); QbeGen.LoadW(qs, qr); QbeGen.CopyOp(qr, q) ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) END ELSIF (op = SymTab.OpAdd) AND (SymTab.UStrCompat(t, t2) OR ((SymTab.ClassOf(t) = SymTab.ClUChar) AND (SymTab.ClassOf(t2) = SymTab.ClUStr)) OR ((SymTab.ClassOf(t) = SymTab.ClUStr) AND (SymTab.ClassOf(t2) = SymTab.ClUChar)) OR ((SymTab.ClassOf(t) = SymTab.ClUChar) AND (SymTab.ClassOf(t2) = SymTab.ClUChar))) THEN (* UString concatenation: a UCHAR operand becomes a 1-codepoint UString; the result is a descriptor in the shim's concat buffer. Work on copies so neither operand is clobbered. *) IF SymTab.ClassOf(t) = SymTab.ClUStr THEN QbeGen.CopyOp(q, q2a) ELSE QbeGen.UStrFrom(q, q2a) END; IF SymTab.ClassOf(t2) = SymTab.ClUStr THEN QbeGen.UStrCat(q2a, q2, qt) ELSE QbeGen.UStrFrom(q2, q2b); QbeGen.UStrCat(q2a, q2b, qt) END; t := SymTab.NewUStr(); QbeGen.CopyOp(qt, q) ELSIF (op = SymTab.OpAdd) AND (SymTab.StrCompat(t, t2) OR (SymTab.IsStrType(t) AND (SymTab.ClassOf(t2) = SymTab.ClChar)) OR ((SymTab.ClassOf(t) = SymTab.ClChar) AND SymTab.IsStrType(t2))) THEN (* string concatenation; a CHAR operand becomes a 1-character string literal. When both operands are constants, fold to a single string literal so a constructor element stays compile-time. *) QbeGen.StrFold(q, q2, SymTab.ClassOf(t), SymTab.ClassOf(t2), qt, fok); IF NOT fok THEN IF SymTab.StrCompat(t, t2) THEN QbeGen.StrCat(q, q2, qt) ELSIF SymTab.IsStrType(t) THEN QbeGen.DeclCharStr(q2, qs); QbeGen.StrCat(q, qs, qt) ELSE QbeGen.DeclCharStr(q, qs); QbeGen.StrCat(qs, q2, qt) END END; t := SymTab.NewStr(); QbeGen.CopyOp(qt, q) ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); mw := lw; IF rw > mw THEN mw := rw END; IF op = SymTab.OpAdd THEN QbeGen.SetBinOp(0, q, q2, lw, rw, qt) ELSE QbeGen.SetBinOp(2, q, q2, lw, rw, qt) END; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp(qt, q) ELSE IF SymTab.ArithCheck(t, t2, FALSE, res2) THEN lt := t; rt := t2; t := res2 ELSE SemError(211); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN isL := SymTab.IsLongFamily(t); isR := SymTab.ClassOf(t) = SymTab.ClReal; folded := FALSE; IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN IF op = SymTab.OpAdd THEN folded := QbeGen.Fold2(0, q, q2, qf) ELSE folded := QbeGen.Fold2(1, q, q2, qf) END END; IF folded THEN QbeGen.CopyOp(qf, q) ELSE IF isL THEN IF SymTab.IsIntFamily(lt) THEN QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) END; IF SymTab.IsIntFamily(rt) THEN QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) END; QbeGen.NewTemp(qt); IF op = SymTab.OpAdd THEN QbeGen.Op3L("add", qt, q, q2) ELSE QbeGen.Op3L("sub", qt, q, q2) END ELSE QbeGen.NewTemp(qt); IF op = SymTab.OpAdd THEN QbeGen.Op3("add", qt, q, q2, isR) ELSE QbeGen.Op3("sub", qt, q, q2, isR) END END; QbeGen.CopyOp(qt, q) END ELSE QbeGen.CopyOp("0", q) END END; .) } . AddOp = "+" (. op := SymTab.OpAdd; .) | "-" (. op := SymTab.OpSub; .) | "OR" (. op := SymTab.OpOr; .) . Term (. VAR t2, res2, lt, rt: SymTab.TypeIndex; op: INTEGER; q2, qt, wq, qf: QbeGen.QVal; isR, isL, folded: BOOLEAN; lw, rw, mw: CARDINAL; lNext, lFalse, lDone, qr, qs: QbeGen.QVal; astA, astB: AST.Node; astOp: INTEGER; .) = Fact (. astA := astCur; .) { MulOp (. IF op = SymTab.OpAnd THEN QbeGen.DelayBegin END; .) Fact (. astB := astCur; IF op = SymTab.OpAnd THEN QbeGen.DelayEnd END; .) (. astOp := AST.OpMul; IF op = SymTab.OpSlash THEN astOp := AST.OpDiv ELSIF op = SymTab.OpDiv THEN astOp := AST.OpDiv ELSIF op = SymTab.OpMod THEN astOp := AST.OpMod ELSIF op = SymTab.OpAnd THEN astOp := AST.OpAnd END; astA := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); astCur := astA; IF op = SymTab.OpAnd THEN (* short-circuit: if q is false the RHS is skipped *) IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.Slot4(qs); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lFalse); QbeGen.NewLabel(lDone); QbeGen.Jnz(q, lNext, lFalse); QbeGen.EmitLabel(lNext); QbeGen.DelayFlush; QbeGen.StoreW(qs, q2); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lFalse); QbeGen.StoreW(qs, "0"); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lDone); QbeGen.LoadW(qs, qr); QbeGen.CopyOp(qr, q) ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) END ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); mw := lw; IF rw > mw THEN mw := rw END; IF op = SymTab.OpTimes THEN QbeGen.SetBinOp(1, q, q2, lw, rw, qt) ELSE QbeGen.SetBinOp(3, q, q2, lw, rw, qt) END; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp(qt, q) ELSE IF SymTab.ArithCheck(t, t2, (op = SymTab.OpDiv) OR (op = SymTab.OpMod), res2) THEN lt := t; rt := t2; t := res2 ELSE SemError(211); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN isL := SymTab.IsLongFamily(t); isR := SymTab.ClassOf(t) = SymTab.ClReal; folded := FALSE; IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN IF op = SymTab.OpTimes THEN folded := QbeGen.Fold2(2, q, q2, qf) ELSIF op = SymTab.OpDiv THEN folded := QbeGen.Fold2(3, q, q2, qf) ELSIF op = SymTab.OpMod THEN folded := QbeGen.Fold2(4, q, q2, qf) END END; IF folded THEN QbeGen.CopyOp(qf, q) ELSE IF isL THEN IF SymTab.IsIntFamily(lt) THEN QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) END; IF SymTab.IsIntFamily(rt) THEN QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) END; QbeGen.NewTemp(qt); IF op = SymTab.OpTimes THEN QbeGen.Op3L("mul", qt, q, q2) ELSIF (op = SymTab.OpDiv) OR (op = SymTab.OpSlash) THEN QbeGen.Op3L("div", qt, q, q2) ELSE QbeGen.Op3L("rem", qt, q, q2) END ELSE 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 END; QbeGen.CopyOp(qt, q) END 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; .) . Fact (. VAR s: ARRAY [0 .. 255] OF CHAR; et, dt, t2, st, ct2, et2: SymTab.TypeIndex; dk: INTEGER; qd, q2, sq, qa, qm0, qr, qt: QbeGen.QVal; qn, vn: SymTab.Name; vt: SymTab.TypeIndex; c1, c2: INTEGER; lo, hi: INTEGER; isMax: BOOLEAN; called, isHigh, sfx, isCh, isU, uok, isStr: BOOLEAN; ucp: INTEGER; astIsLit: BOOLEAN; astD: AST.Node; astCall: BOOLEAN; astNode, astNot: AST.Node; j: CARDINAL; astArg2: AST.Node; astBrace: AST.Node; astRes: AST.Node; .) = (. astIsLit := FALSE; .) ( integer (. LexString(s); QbeGen.NormInt(s, q); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf(AST.NkIntLit, s) END; t := SymTab.IntType(); .) | charConst (. LexString(s); QbeGen.NormLit(s, q, isCh); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkCharLit, s) END; t := SymTab.CharType(); .) | real (. LexString(s); QbeGen.NormReal(s, q); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkRealLit, s) END; t := SymTab.RealType(); .) | string (. LexString(s); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkStrLit, s) END; IF SymTab.StrLen(s) = 3 THEN t := SymTab.CharType(); QbeGen.IntStr( QbeGen.CharVal(s), q) ELSE t := SymTab.NewStr(); QbeGen.DeclStr(s, q); (* a literal's value IS its static descriptor address *) QbeGen.NoteAddr(q, q) END; .) | ustring (. LexString(s); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkStrLit, s) END; QbeGen.DeclUStr(s, q, isU, ucp, uok); IF NOT uok THEN SemError(234); t := SymTab.InvalidType ELSIF isU THEN t := SymTab.UCharType(); QbeGen.IntStr(ucp, q) ELSE t := SymTab.NewUStr(); QbeGen.NoteAddr(q, q) END; .) | Design (. astD := astCur; astCall := FALSE; astBrace := AST.NoNode; astNArgs := 0; called := FALSE; t := dt; IF sfx THEN IF dt = SymTab.InvalidType THEN QbeGen.CopyOp("0", q) ELSIF (SymTab.ClassOf(dt) = SymTab.ClRecord) OR (SymTab.ClassOf(dt) = SymTab.ClSet) OR (SymTab.ClassOf(dt) = SymTab.ClArray) OR (SymTab.ClassOf(dt) = SymTab.ClClass) THEN QbeGen.CopyOp(qd, q) ELSE QbeGen.ElemLoad(qd, dt, q) END ELSE QbeGen.CopyOp(qd, q) END; IF (dk = SymTab.KindVar) OR (dk = SymTab.KindParam) OR (dk = SymTab.KindField) THEN IF sfx THEN QbeGen.NoteAddr(q, qd) ELSE QbeGen.AddrOf(qn, qa); QbeGen.NoteAddr(q, qa) END ELSIF sfx AND (dt # SymTab.InvalidType) AND ((SymTab.ClassOf(dt) = SymTab.ClArray) OR (SymTab.ClassOf(dt) = SymTab.ClSet) OR (SymTab.ClassOf(dt) = SymTab.ClRecord)) THEN QbeGen.NoteAddr(qd, qd) END; .) [ TypedBraceLit (. t := dt; astCall := TRUE; astBrace := astCur; .) ] [ ArgList (. astCall := TRUE; astNode := AstCallNode(astD); astRes := astNode; t := ct2; QbeGen.CopyOp(q2, q); sfx := FALSE; .) { ResultComp } (. IF sfx THEN IF t = SymTab.InvalidType THEN QbeGen.CopyOp("0", q) ELSIF (SymTab.ClassOf(t) # SymTab.ClRecord) AND (SymTab.ClassOf(t) # SymTab.ClSet) AND (SymTab.ClassOf(t) # SymTab.ClArray) AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN QbeGen.ElemLoad(q, t, q2); QbeGen.CopyOp(q2, q) END END; .) ] (. IF called THEN astCur := astRes ELSIF astCall THEN astCur := astBrace ELSE astCur := astD END; astIsLit := TRUE; IF NOT called AND (dk = SymTab.KindProc) THEN (* bare zero-arg function call (parentheses may be omitted); a proper or parameterised proc here is 230 *) IF (SymTab.ProcNPar(qn) = 0) AND (SymTab.ProcRes(qn) # SymTab.InvalidType) THEN QbeGen.Mangled(qn, SymTab.ProcUid(qn), qm0); QbeGen.CallBegin(qm0, SymTab.ProcRes(qn), SymTab.ProcDepthOf(qn), SymTab.IsExternal(qn)); QbeGen.CallEnd(TRUE, q); t := SymTab.ProcRes(qn) ELSE (* procedure used as a value (assign to a procedure variable): its code address *) t := SymTab.ProcTypeOf(qn); QbeGen.Mangled(qn, SymTab.ProcUid(qn), qm0); QbeGen.ProcAddr(qm0, q) END END; .) | ( "HIGH" (. isHigh := TRUE; .) | ( "LEN" | "LENGTH" ) (. isHigh := FALSE; .) ) "(" ( Design (. isStr := FALSE; isU := FALSE; .) | string (. LexString(s); astCur := AST.MakeLeaf(AST.NkStrLit, s); isStr := TRUE; isU := FALSE; IF SymTab.StrLen(s) = 3 THEN dt := SymTab.CharType(); QbeGen.IntStr(QbeGen.CharVal(s), qd) ELSE dt := SymTab.NewStr(); QbeGen.DeclStr(s, qd); QbeGen.NoteAddr(qd, qd) END; dk := -1; qn[0] := CHR(0); .) | ustring (. LexString(s); astCur := AST.MakeLeaf(AST.NkStrLit, s); QbeGen.DeclUStr(s, qd, isU, ucp, uok); isStr := FALSE; IF NOT uok THEN SemError(234); dt := SymTab.InvalidType ELSIF isU THEN (* one codepoint: a UCHAR; LEN is 1, HIGH is 0 *) dt := SymTab.UCharType(); QbeGen.IntStr(ucp, qd) ELSE dt := SymTab.NewUStr(); QbeGen.NoteAddr(qd, qd) END; dk := -1; qn[0] := CHR(0); .) ) ")" (. astNode := AST.MakeNode(AST.NkCall); IF isHigh THEN AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "HIGH")) ELSE AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "LEN")) END; IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; IF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClUStr) THEN (* UString: the count is the descriptor header *) IF isHigh THEN QbeGen.UStrLen(qd, qr); QbeGen.DecQ(qr) ELSE QbeGen.UStrLen(qd, qr) END; t := SymTab.IntType(); QbeGen.CopyOp(qr, q) ELSIF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClUChar) THEN (* single UCHAR codepoint *) IF isHigh THEN QbeGen.CopyOp("0", qr) ELSE QbeGen.CopyOp("1", qr) END; t := SymTab.IntType(); QbeGen.CopyOp(qr, q) ELSIF isStr THEN (* fold: content length at compile time *) IF SymTab.StrLen(s) = 3 THEN c1 := 1 ELSE c1 := SymTab.StrLen(s) - 2 END; IF isHigh THEN DEC(c1) END; QbeGen.IntStr(c1, qr); t := SymTab.IntType(); QbeGen.CopyOp(qr, q) ELSIF dt = SymTab.InvalidType THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSIF SymTab.ClassOf(dt) # SymTab.ClArray THEN SemError(217); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE IF isHigh THEN IF SymTab.IsOpenArray(dt) THEN QbeGen.OpenHi(qd, qr) ELSE QbeGen.IntStr( SymTab.ArrayHi(dt), qr) END ELSE IF SymTab.IsOpenArray(dt) THEN QbeGen.LoadCount(qd, qr) ELSE QbeGen.IntStr(VAL( INTEGER, SymTab.ArrayLen(dt)), qr) END END; t := SymTab.IntType(); QbeGen.CopyOp(qr, q) END; .) | ( "SIZE" | "TSIZE" ) "(" Design ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "SIZE")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF dt = SymTab.InvalidType THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE QbeGen.IntStr(VAL(INTEGER, SymTab.ObjectSize(dt)), q); t := SymTab.IntType() END; .) | ( "SHIFT" (. isMax := FALSE; .) | "ROTATE" (. isMax := TRUE; .) ) "(" Expr (. astArg2 := astCur; .) "," Expr ")" (. astNode := AST.MakeNode(AST.NkCall); IF isMax THEN AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ROTATE")) ELSE AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "SHIFT")) END; IF astArg2 # AST.NoNode THEN AST.SetChild(astNode, 1, astArg2) END; IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; astCur := astNode; astIsLit := TRUE; (* set shift/rotate: isMax doubles as "rotate" *) IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClSet) THEN QbeGen.SetShift(q, q2, SymTab.SetWords(et), SymTab.SetCount(et), isMax, qt); t := et; QbeGen.CopyOp(qt, q) ELSE SemError(230); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END; .) | ( "MIN" (. isMax := FALSE; .) | "MAX" (. isMax := TRUE; .) ) "(" Design ")" (. astNode := AST.MakeNode(AST.NkCall); IF isMax THEN AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "MAX")) ELSE AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "MIN")) END; IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; IF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClReal) THEN (* REAL/LONGREAL: the implementation bounds *) IF isMax THEN QbeGen.NormReal( "3.402823e38", q) ELSE QbeGen.NormReal( "-3.402823e38", q) END; t := SymTab.RealType() ELSIF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClLong) THEN IF isMax THEN QbeGen.CopyOp( "9223372036854775807", q) ELSE QbeGen.CopyOp( "-9223372036854775808", q) END; t := SymTab.LongType() ELSIF SymTab.TypeBounds(dt, lo, hi) THEN IF isMax THEN QbeGen.IntStr(hi, q) ELSE QbeGen.IntStr(lo, q) END; t := SymTab.IntType() ELSE SemError(230); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END; .) | "ADR" "(" Design ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ADR")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF dt = SymTab.InvalidType THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE IF sfx THEN QbeGen.CopyOp(qd, q) ELSIF (dk = SymTab.KindVar) OR (dk = SymTab.KindParam) THEN QbeGen.AddrOf(qn, q) ELSE SemError(230); QbeGen.CopyOp("0", q) END; t := SymTab.AddrType() END; .) | "CHR" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CHR")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF (et # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(et) THEN SemError(211) END; t := SymTab.CharType(); .) | ( "ORD" | "ORDL" ) "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ORD")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF et # SymTab.InvalidType THEN IF (SymTab.ClassOf(et) # SymTab.ClChar) AND (SymTab.ClassOf(et) # SymTab.ClBool) AND (SymTab.ClassOf(et) # SymTab.ClEnum) AND NOT SymTab.IsIntFamily(et) THEN SemError(211) END END; t := SymTab.IntType(); .) | "CAP" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CAP")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. QbeGen.CapQ(q, qa); QbeGen.CopyOp(qa, q); t := SymTab.CharType(); .) | "UCHR" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "UCHR")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. (* UCHR: the UCHAR constructor. CHAR -> UCHAR (identity); INTEGER familly -> UCHAR (codepoint value). *) IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) # SymTab.ClChar) AND NOT SymTab.IsIntFamily(et) THEN SemError(211) END; t := SymTab.UCharType(); .) | "CHR8" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CHR8")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN SemError(211) END; QbeGen.WidenLong(q, qa); QbeGen.CheckRange(qa, "0", "255"); t := SymTab.CharType(); .) | "UORD" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "UORD")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. (* UORD(u): the codepoint as a 32-bit ordinal (INTEGER), cf. ORD for CHAR. *) IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN SemError(211) END; t := SymTab.IntType(); .) | "ABS" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ABS")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF (et # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(et) AND (SymTab.ClassOf(et) # SymTab.ClReal) THEN SemError(211) ELSE QbeGen.AbsQ(q, qa, SymTab.ClassOf(et) = SymTab.ClReal); QbeGen.CopyOp(qa, q) END; t := et; .) | "VAL" "(" GetIdent (. astArg2 := AST.MakeLeaf(AST.NkIdent, vn); .) "," Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "VAL")); IF astArg2 # AST.NoNode THEN AST.SetChild(astNode, 1, astArg2) END; IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. IF NOT SymTab.Lookup(vn) THEN SemError(201); t := SymTab.InvalidType ELSE vt := SymTab.SymType(vn); IF vt = SymTab.InvalidType THEN t := SymTab.InvalidType ELSIF et = SymTab.InvalidType THEN t := vt ELSE c1 := SymTab.ClassOf(et); c2 := SymTab.ClassOf(vt); IF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClLong) THEN QbeGen.WidenLong(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF (c1 = SymTab.ClLong) AND (c2 = SymTab.ClInt) THEN QbeGen.NarrowLong(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF (c1 = SymTab.ClInt) AND (c2 = SymTab.ClReal) THEN QbeGen.ConvIR(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF (c1 = SymTab.ClLong) AND (c2 = SymTab.ClReal) THEN QbeGen.ConvLR(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF (c1 = SymTab.ClReal) AND (c2 = SymTab.ClInt) THEN QbeGen.ConvRI(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF (c1 = SymTab.ClReal) AND (c2 = SymTab.ClLong) THEN QbeGen.ConvRL(q, qa); QbeGen.CopyOp(qa, q); t := vt ELSIF ((c1 = SymTab.ClInt) OR (c1 = SymTab.ClChar) OR (c1 = SymTab.ClBool) OR (c1 = SymTab.ClEnum)) AND ((c2 = SymTab.ClInt) OR (c2 = SymTab.ClChar) OR (c2 = SymTab.ClBool) OR (c2 = SymTab.ClEnum)) THEN t := vt ELSIF (c1 = SymTab.ClPtr) AND (c2 = SymTab.ClPtr) THEN t := vt ELSIF (c1 = SymTab.ClReal) AND (c2 = SymTab.ClReal) THEN t := vt ELSE SemError(230); t := SymTab.InvalidType END END END; .) | "(" Expr ")" (. t := et; astIsLit := TRUE; .) | SetLit (. astIsLit := TRUE; t := st; QbeGen.CopyOp(sq, q); .) | ( "NOT" | "~" ) Fact (. astNot := astCur; 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; astIsLit := TRUE; astCur := AST.MakeUn( AST.NkUnary, AST.OpNot, astNot); .) ) (. IF NOT astIsLit THEN astCur := AST.NoNode END; .) . (* Set literals are SET OF [0..255] (8 words); elements validated 0..255 statically when foldable (222 otherwise), runtime trap for computed elements. Ranges always lower via SetRange. *) SetLit (. VAR astNode: AST.Node; .) = "{" (. t := SymTab.NewSet( SymTab.NewSubR(0, 255)); astNode := AST.MakeNode(AST.NkSetLit); QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8); .) [ SetElem { "," SetElem } ] "}" (. astCur := astNode; .) . (* Typed brace constructor: TypeName{ elems } — BITSET{0} (a set) or ArrayName{...} (an array constructor, GNU Modula-2). The declared type sets the width (set) or element type (array). *) TypedBraceLit (. VAR nw: CARDINAL; astNode: AST.Node; savedCls: INTEGER; .) = "{" (. savedCls := braceCls; astNode := AST.MakeNode(AST.NkBraceLit); IF vt = SymTab.InvalidType THEN braceCls := -1 ELSE braceCls := SymTab.ClassOf(vt) END; IF braceCls = SymTab.ClSet THEN IF vt = SymTab.InvalidType THEN nw := 8 ELSE nw := SymTab.SetWords(vt); IF nw = 0 THEN nw := 8 END END; QbeGen.NewSetTemp(nw, q); QbeGen.SetZero(q, nw) ELSIF (braceCls = SymTab.ClArray) OR (braceCls = SymTab.ClRecord) OR (braceCls = SymTab.ClClass) THEN QbeGen.CtorBegin(vt) ELSE IF vt # SymTab.InvalidType THEN SemError(230) END; braceCls := -1 END; .) [ BraceElem { "," BraceElem } ] "}" (. IF (braceCls = SymTab.ClArray) OR (braceCls = SymTab.ClRecord) OR (braceCls = SymTab.ClClass) THEN QbeGen.CtorEnd(q) ELSIF braceCls # SymTab.ClSet THEN QbeGen.CopyOp("0", q) END; braceCls := savedCls; .) (. astCur := astNode; .) . BraceElem (. VAR et, et2: SymTab.TypeIndex; qe, q2: QbeGen.QVal; v, v2, reps, k: INTEGER; elem: SymTab.TypeIndex; lo: INTEGER; span: CARDINAL; cl, cl2: INTEGER; hasR, hasB: BOOLEAN; astEl: AST.Node; .) = (. hasR := FALSE; hasB := FALSE; .) Expr (. astEl := astCur; .) [ ".." Expr (. astEl := AST.MakeBin( AST.NkSubrange, 0, astEl, astCur); hasR := TRUE; .) ] [ "BY" Expr (. hasB := TRUE; .) ] (. IF braceCls = SymTab.ClSet THEN IF hasB THEN SemError(230) END; lo := SymTab.SetBaseLo(vt); span := SymTab.SetCount(vt); IF (et = SymTab.InvalidType) OR (hasR AND (et2 = SymTab.InvalidType)) THEN ELSE cl := SymTab.ClassOf(et); IF hasR THEN cl2 := SymTab.ClassOf(et2) ELSE cl2 := SymTab.ClInt END; IF NOT SymTab.SetElemClassOk(cl) OR (hasR AND NOT SymTab.SetElemClassOk(cl2)) THEN SemError(222) ELSIF hasR AND SymTab.ConstInt(qe, v) AND SymTab.ConstInt(q2, v2) AND ((v < lo) OR (v2 < lo) OR (v >= lo + VAL(INTEGER, span)) OR (v2 >= lo + VAL(INTEGER, span)) OR (v > v2)) THEN SemError(222) ELSIF hasR THEN QbeGen.SetRange(sq, qe, q2, lo, span) ELSIF SymTab.ConstInt(qe, v) AND ((v < lo) OR (v >= lo + VAL(INTEGER, span))) THEN SemError(222) ELSE QbeGen.SetBit(sq, qe, lo, span) END END ELSIF (braceCls = SymTab.ClArray) OR (braceCls = SymTab.ClRecord) OR (braceCls = SymTab.ClClass) THEN IF hasR THEN SemError(230) END; reps := 1; IF hasB THEN IF SymTab.ConstInt(q2, v2) AND (v2 >= 1) THEN reps := v2 ELSE SemError(230) END END; k := 0; WHILE k < reps DO QbeGen.CtorElem(qe); INC(k) END END; .) (. AST.SetChild(node, AST.NChild(node), astEl); .) . SetElem (. VAR et, et2: SymTab.TypeIndex; qe, q2: QbeGen.QVal; v, v2: INTEGER; lo: INTEGER; span: CARDINAL; cl, cl2: INTEGER; hasR: BOOLEAN; astEl: AST.Node; .) = (. hasR := FALSE; .) Expr (. astEl := astCur; .) [ ".." Expr (. astEl := AST.MakeBin( AST.NkSubrange, 0, astEl, astCur); hasR := TRUE; .) ] (. lo := SymTab.SetBaseLo(st); span := SymTab.SetCount(st); IF (et = SymTab.InvalidType) OR (hasR AND (et2 = SymTab.InvalidType)) THEN ELSE cl := SymTab.ClassOf(et); IF hasR THEN cl2 := SymTab.ClassOf(et2) ELSE cl2 := SymTab.ClInt END; IF NOT SymTab.SetElemClassOk(cl) OR (hasR AND NOT SymTab.SetElemClassOk(cl2)) THEN SemError(222) ELSIF hasR AND SymTab.ConstInt(qe, v) AND SymTab.ConstInt(q2, v2) AND ((v < lo) OR (v2 < lo) OR (v >= lo + VAL(INTEGER, span)) OR (v2 >= lo + VAL(INTEGER, span)) OR (v > v2)) THEN SemError(222) ELSIF hasR THEN QbeGen.SetRange(sq, qe, q2, lo, span) ELSIF SymTab.ConstInt(qe, v) AND ((v < lo) OR (v >= lo + VAL(INTEGER, span))) THEN SemError(222) ELSE QbeGen.SetBit(sq, qe, lo, span) END END; .) (. AST.SetChild(node, AST.NChild(node), astEl); .) . GetIdent = ident (. LexName(n); .) . END M2.