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 parse (docs/plan-two-phase-parse.md), milestone 1. When TRUE each outermost procedure/method body is shadow-skipped at the token level and the skip verified before the body parses normally. Set by the driver (-notwophase turns it off); default on. Blocks being parsed so only outermost bodies probe. *) twoPhaseParse: BOOLEAN; (* Two-phase parse spans (milestone 2a): one entry per outermost body shadow-skipped while twoPhaseParse is on — procedure name and the buffer offset its body starts at (the lookahead token's nextPos). Per-parse; nothing consumes the table yet. *) nSpans: CARDINAL; spanName: ARRAY [0 .. 1023] OF SymTab.Name; spanStart: ARRAY [0 .. 1023] OF M2S.INT32; spanIdx: ARRAY [0 .. 1023] OF CARDINAL; spanTy: ARRAY [0 .. 1023] OF INTEGER; spanNode: ARRAY [0 .. 1023] OF AST.Node; (* Two-phase parse (milestone 2c): phase-1 skips a module-level proc body (DeferSkip) and phase 2 re-parses it at unit end (RepassAll). `deferredBody` reports the skip to ProcDecl's close choice; `repassing` disables deferral during phase 2; `allowDefer` limits deferral to plain ProcDecls (methods stay inline); `curProcNode` is the NkProcDecl whose body is about to be parsed. *) deferredBody: BOOLEAN; repassing: BOOLEAN; allowDefer: BOOLEAN; curProcNode: AST.Node; (* The last actual argument parsed by ActParam: folded value and type. A conversion T(x) has exactly one actual, so these let Fact constant-fold it (needed for `CONST c = T(x)`). *) convQ: QbeGen.QVal; convT: SymTab.TypeIndex; (* 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; (* 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. *) (* GOTO/labels: the label and goto names of the procedure being parsed, reset per procedure and checked at its END. *) nLab, nGot: CARDINAL; labNm, gotNm: ARRAY [0 .. 255] OF SymTab.Name; (* Generics (Increment 1): the last refining module seen — instance name, generic name, and the actual type parameters. *) refInst, refGen: SymTab.Name; refN: CARDINAL; refActual: ARRAY [0 .. 15] OF SymTab.TypeIndex; refKind: ARRAY [0 .. 15] OF INTEGER; (* 0 = type, 1 = value, 2 = proc *) refVal: ARRAY [0 .. 15] OF SymTab.Name; refMod: ARRAY [0 .. 15] OF SymTab.Name; isGen: BOOLEAN; (* Generics (Increment 2): instantiation re-parse context. When the driver re-parses a generic's source to instantiate it as `instName`, instActive is TRUE, the module is renamed, and each type formal is bound to the corresponding instActual entry. *) instActive: BOOLEAN; instName: SymTab.Name; instActual: ARRAY [0 .. 15] OF SymTab.TypeIndex; instKind: ARRAY [0 .. 15] OF INTEGER; instVal: ARRAY [0 .. 15] OF SymTab.Name; instMod: ARRAY [0 .. 15] OF SymTab.Name; instN: CARDINAL; instFk: CARDINAL; (* formal cursor while binding during re-parse *) (* Identity of the last-parsed unit and refinement, for the driver's generic registry and its re-parse decision. *) unitName: SymTab.Name; unitWasGen: BOOLEAN; unitWasDef: BOOLEAN; refSeen: BOOLEAN; refIsDef: BOOLEAN; PROCEDURE CopyNm (src: ARRAY OF CHAR; VAR dst: SymTab.Name); VAR i: CARDINAL; BEGIN i := 0; WHILE (i <= HIGH(dst)) AND (i <= HIGH(src)) AND (src[i] # CHR(0)) DO dst[i] := src[i]; INC(i) END; IF i <= HIGH(dst) THEN dst[i] := CHR(0) END END CopyNm; PROCEDURE InInst () : BOOLEAN; BEGIN RETURN instActive END InInst; PROCEDURE InstNameGet (VAR nm: SymTab.Name); BEGIN CopyNm(instName, nm) END InstNameGet; PROCEDURE InstActualGet (i: CARDINAL) : SymTab.TypeIndex; BEGIN IF i >= instN THEN RETURN SymTab.InvalidType END; RETURN instActual[i] END InstActualGet; PROCEDURE InstBegin (name: ARRAY OF CHAR); BEGIN instActive := TRUE; CopyNm(name, instName); instN := 0; instFk := 0 END InstBegin; PROCEDURE InstActualKind (i: CARDINAL) : INTEGER; BEGIN IF i >= instN THEN RETURN 0 END; RETURN instKind[i] END InstActualKind; PROCEDURE InstActualVal (i: CARDINAL; VAR v: SymTab.Name); VAR k: CARDINAL; BEGIN v[0] := CHR(0); IF i >= instN THEN RETURN END; k := 0; WHILE (k <= HIGH(v)) AND (instVal[i][k] # CHR(0)) DO v[k] := instVal[i][k]; INC(k) END; v[k] := CHR(0) END InstActualVal; PROCEDURE InstActualMod (i: CARDINAL; VAR m: SymTab.Name); VAR k: CARDINAL; BEGIN m[0] := CHR(0); IF i >= instN THEN RETURN END; k := 0; WHILE (k <= HIGH(m)) AND (instMod[i][k] # CHR(0)) DO m[k] := instMod[i][k]; INC(k) END; m[k] := CHR(0) END InstActualMod; PROCEDURE InstAddActual (kind: INTEGER; t: SymTab.TypeIndex; val, m: ARRAY OF CHAR); VAR k: CARDINAL; BEGIN IF instN > HIGH(instActual) THEN RETURN END; instKind[instN] := kind; instActual[instN] := t; k := 0; WHILE (k <= HIGH(instVal[instN])) AND (val[k] # CHR(0)) DO instVal[instN][k] := val[k]; INC(k) END; instVal[instN][k] := CHR(0); k := 0; WHILE (k <= HIGH(instMod[instN])) AND (m[k] # CHR(0)) DO instMod[instN][k] := m[k]; INC(k) END; instMod[instN][k] := CHR(0); INC(instN) END InstAddActual; PROCEDURE InstEnd; BEGIN instActive := FALSE; instN := 0 END InstEnd; PROCEDURE UnitNameGet (VAR nm: SymTab.Name); BEGIN CopyNm(unitName, nm) END UnitNameGet; PROCEDURE UnitIsGeneric () : BOOLEAN; BEGIN RETURN unitWasGen END UnitIsGeneric; PROCEDURE UnitIsDefModule () : BOOLEAN; BEGIN RETURN unitWasDef END UnitIsDefModule; PROCEDURE RefineSeen () : BOOLEAN; BEGIN RETURN refSeen END RefineSeen; PROCEDURE RefineIsDef () : BOOLEAN; BEGIN RETURN refIsDef END RefineIsDef; PROCEDURE RefineInst (VAR nm: SymTab.Name); BEGIN CopyNm(refInst, nm) END RefineInst; PROCEDURE RefineGen (VAR nm: SymTab.Name); BEGIN CopyNm(refGen, nm) END RefineGen; PROCEDURE RefineActualCount () : CARDINAL; BEGIN RETURN refN END RefineActualCount; PROCEDURE RefineActualGet (i: CARDINAL) : SymTab.TypeIndex; BEGIN IF i >= refN THEN RETURN SymTab.InvalidType END; RETURN refActual[i] END RefineActualGet; PROCEDURE RefineActualKind (i: CARDINAL) : INTEGER; BEGIN IF i >= refN THEN RETURN 0 END; RETURN refKind[i] END RefineActualKind; PROCEDURE RefineActualMod (i: CARDINAL; VAR m: SymTab.Name); VAR k: CARDINAL; BEGIN m[0] := CHR(0); IF i >= refN THEN RETURN END; k := 0; WHILE (k <= HIGH(m)) AND (refMod[i][k] # CHR(0)) DO m[k] := refMod[i][k]; INC(k) END; m[k] := CHR(0) END RefineActualMod; PROCEDURE RefineActualVal (i: CARDINAL; VAR v: SymTab.Name); VAR k: CARDINAL; BEGIN v[0] := CHR(0); IF i >= refN THEN RETURN END; k := 0; WHILE (k <= HIGH(v)) AND (refVal[i][k] # CHR(0)) DO v[k] := refVal[i][k]; INC(k) END; v[k] := CHR(0) END RefineActualVal; PROCEDURE NoteLabel (nm: ARRAY OF CHAR); (* Record a statement label; duplicate is 200. *) VAR i: CARDINAL; BEGIN i := 0; WHILE i < nLab DO IF SymTab.Equal(labNm[i], nm) THEN SemError(200); RETURN END; INC(i) END; IF nLab <= HIGH(labNm) THEN CopyNm(nm, labNm[nLab]); INC(nLab) END END NoteLabel; PROCEDURE NoteGoto (nm: ARRAY OF CHAR); VAR i: CARDINAL; BEGIN i := 0; WHILE i < nGot DO IF SymTab.Equal(gotNm[i], nm) THEN RETURN END; INC(i) END; IF nGot <= HIGH(gotNm) THEN CopyNm(nm, gotNm[nGot]); INC(nGot) END END NoteGoto; PROCEDURE CheckGotos; (* At a procedure's END: every GOTO must name a label in that procedure. *) VAR i, j: CARDINAL; found: BOOLEAN; BEGIN i := 0; WHILE i < nGot DO found := FALSE; j := 0; WHILE (j < nLab) AND NOT found DO IF SymTab.Equal(labNm[j], gotNm[i]) THEN found := TRUE END; INC(j) END; IF NOT found THEN SemError(201) END; INC(i) END END CheckGotos; PROCEDURE FlushPend; (* Emit module-level globals whose forward type is now resolved. *) VAR k: CARDINAL; BEGIN k := 0; WHILE k < nPendVar DO INC(k) END; nPendVar := 0 END FlushPend; 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 AstCallNode (callee: AST.Node) : AST.Node; (* Builds NkCall(callee, actuals...) from astArgs/astNArgs. The actuals are a chunked sequence (AstAppend): a call can have more than MaxChild-1 arguments (the generic ArgList has 9), and SetChild would silently drop the tail. NkBlock marks the continuation chunks. *) VAR n, tail: AST.Node; j: CARDINAL; BEGIN n := AST.MakeNode(AST.NkCall); AST.SetChild(n, 0, callee); tail := n; j := 0; WHILE j < astNArgs DO AstAppend(AST.NkBlock, n, tail, astArgs[j]); INC(j) END; RETURN n END AstCallNode; PROCEDURE GetUnit (): AST.Node; (* The most recently parsed unit's AST root (for the Lower comparison). *) BEGIN RETURN astUnit END GetUnit; PROCEDURE SetTwoPhase (b: BOOLEAN); (* Driver switch for the two-phase parse probe (milestone 1). *) BEGIN twoPhaseParse := b END SetTwoPhase; PROCEDURE TokIs (kw: ARRAY OF CHAR): BOOLEAN; (* The current lookahead token's source text equals kw. Compares text, not token codes, so grammar renumbering cannot desync the skipper. *) VAR tok: ARRAY [0 .. 63] OF CHAR; BEGIN M2S.GetName(M2S.nextPos, M2S.nextLen, tok); RETURN SymTab.Equal(tok, kw) END TokIs; PROCEDURE Adv; (* Advance one token: exactly the parser frame's Get for a grammar without pragmas (its pragma branch is empty and the scanner never returns a token above maxT, so the repeat loop runs once). A separate name because the frame's Get is declared later in this module: a bare Get here would bind the imported M2S.Get (which takes a parameter) under single-pass compilers. *) BEGIN M2S.Get(sym); INC(errDist) END Adv; PROCEDURE ConsCode (nm: ARRAY OF CHAR): INTEGER; (* Constraint name -> code: 0 none, 1 ORDINAL, 2 INTEGER, 3 REAL. *) BEGIN IF SymTab.Equal(nm, "ORDINAL") THEN RETURN 1 ELSIF SymTab.Equal(nm, "INTEGER") THEN RETURN 2 ELSIF SymTab.Equal(nm, "REAL") THEN RETURN 3 ELSIF SymTab.Equal(nm, "POINTER") THEN RETURN 4 ELSIF SymTab.Equal(nm, "SCALAR") THEN RETURN 5 END; RETURN 0 END ConsCode; PROCEDURE ConsOk (cons: INTEGER; t: SymTab.TypeIndex): BOOLEAN; (* TRUE when t satisfies the constraint code. *) BEGIN IF cons = 0 THEN RETURN TRUE ELSIF cons = 1 THEN RETURN SymTab.IsOrdinal(t) ELSIF cons = 2 THEN RETURN SymTab.ClassOf(t) = SymTab.ClInt ELSIF cons = 3 THEN RETURN SymTab.ClassOf(t) = SymTab.ClReal ELSIF cons = 4 THEN RETURN SymTab.ClassOf(t) = SymTab.ClPtr ELSIF cons = 5 THEN RETURN (SymTab.ClassOf(t) = SymTab.ClInt) OR (SymTab.ClassOf(t) = SymTab.ClChar) OR (SymTab.ClassOf(t) = SymTab.ClBool) OR (SymTab.ClassOf(t) = SymTab.ClEnum) OR (SymTab.ClassOf(t) = SymTab.ClUChar) OR (SymTab.ClassOf(t) = SymTab.ClReal) END; RETURN TRUE END ConsOk; PROCEDURE OrdClass (t: SymTab.TypeIndex): BOOLEAN; (* TRUE for scalar ordinal classes (int/char/bool/enum/uchar); a conversion between two of these is representation-preserving, so its folded value equals the operand's. *) VAR c: INTEGER; BEGIN c := SymTab.ClassOf(t); RETURN (c = SymTab.ClInt) OR (c = SymTab.ClChar) OR (c = SymTab.ClBool) OR (c = SymTab.ClEnum) OR (c = SymTab.ClUChar) END OrdClass; PROCEDURE NoteSpan (pn: SymTab.Name; start: M2S.INT32); (* Records an outermost body span for the re-parse pass (milestone 2). Diagnostic only for now: nothing consumes the table yet. Declared before its caller: V3 resolves single-pass (declaration before use), with no forward tolerance for procedure calls. *) BEGIN IF nSpans > HIGH(spanName) THEN RETURN END; CopyNm(pn, spanName[nSpans]); spanStart[nSpans] := start; spanIdx[nSpans] := SymTab.DeferBody(); INC(nSpans) END NoteSpan; PROCEDURE Openers (): BOOLEAN; (* TRUE when the current token opens a block that must be closed by an END (BEGIN is excluded: a block's BEGIN shares the declaration END; REPEAT..UNTIL and EXIT/RETURN need no END). *) BEGIN RETURN TokIs("MODULE") OR TokIs("PROCEDURE") OR TokIs("CLASS") OR TokIs("RECORD") OR TokIs("IF") OR TokIs("CASE") OR TokIs("WHILE") OR TokIs("FOR") OR TokIs("LOOP") OR TokIs("WITH") END Openers; PROCEDURE DeferSkip (pn: SymTab.Name): BOOLEAN; (* Phase 1 of the deferral: skip the body starting at the current token (the first token after the heading's ';') up to the matching END, verify the END's name, and LEAVE the scanner positioned exactly at that END (so Block's trailing "END" ident consumes it for real), with the span recorded for the re-parse pass. On any inconsistency, restore the scanner and return FALSE so the caller parses normally. *) VAR depth, guard: CARDINAL; nm: SymTab.Name; ok: BOOLEAN; start, endPos: M2S.INT32; BEGIN deferredBody := FALSE; start := M2S.nextPos; M2S.PushPos; depth := 0; guard := 0; ok := TRUE; LOOP IF sym = 0 THEN ok := FALSE; EXIT END; IF TokIs("END") THEN IF depth = 0 THEN EXIT END; DEC(depth) ELSIF Openers() THEN INC(depth) END; Adv; INC(guard); IF guard > 1000000 THEN ok := FALSE; EXIT END END; IF ok THEN (* sym is the matching END; check the name after it, then seek back so Block sees END (its "END" ident then consumes it for real). *) endPos := M2S.nextPos; Adv; M2S.GetName(M2S.nextPos, M2S.nextLen, nm); IF (sym = 0) OR NOT SymTab.Equal(nm, pn) THEN ok := FALSE END; IF ok THEN M2S.SeekTo(endPos); Adv END END; IF ok THEN NoteSpan(pn, start); spanTy[nSpans - 1] := Lower.CurScopeProc(); spanNode[nSpans - 1] := curProcNode; M2S.DropPos; (* keep the scanner at END; discard the snapshot *) deferredBody := TRUE; RETURN TRUE ELSE M2S.PopPos; FileIO.WriteString(FileIO.StdOut, "twophase defer mismatch in "); FileIO.WriteString(FileIO.StdOut, pn); FileIO.WriteLn(FileIO.StdOut); RETURN FALSE END END DeferSkip; 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 = (. astCur := AST.NoNode; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; nSpans := 0; SymTab.DeferReset; .) 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. *) (* Generics (Increment 1): formal and actual parameters. Formals are TYPE parameters only; actuals are type identifiers. *) GenericFormals = "(" GenericFormal { ";" GenericFormal } ")" . GenericFormal (. VAR nm: SymTab.Name; vt: SymTab.TypeIndex; names: ARRAY [0 .. 15] OF SymTab.Name; nn, k: CARDINAL; mmod: SymTab.Name; quid, qdep: CARDINAL; qres: SymTab.TypeIndex; qext: BOOLEAN; cons: INTEGER; cn: SymTab.Name; isTypeFormal: BOOLEAN; .) = (. nn := 0; .) GetIdent (. k := 0; WHILE (k <= HIGH(names[nn])) AND (nm[k] # CHR(0)) DO names[nn][k] := nm[k]; INC(k) END; names[nn][k] := CHR(0); INC(nn); .) { "," GetIdent (. k := 0; WHILE (k <= HIGH(names[nn])) AND (nm[k] # CHR(0)) DO names[nn][k] := nm[k]; INC(k) END; names[nn][k] := CHR(0); INC(nn); .) } ":" (. vt := SymTab.InvalidType; isTypeFormal := FALSE; .) ( "TYPE" (. isTypeFormal := TRUE; .) [ "(" GetIdent ")" (. cons := ConsCode(cn); .) ] | ProcType (. isTypeFormal := FALSE; .) | TypeIdent ) (. k := 0; WHILE k < nn DO IF isTypeFormal THEN IF instActive THEN (* constraint: a type formal needs a type actual that satisfies the declared constraint *) IF InstActualKind(instFk) # 0 THEN SemError(233) ELSIF NOT ConsOk(cons, InstActualGet(instFk)) THEN SemError(233) ELSIF NOT SymTab.EnterTypeParamBound(names[k], InstActualGet(instFk)) THEN SemError(200) END ELSIF NOT SymTab.EnterTypeParam(names[k]) THEN SemError(200) END ELSIF SymTab.ClassOf(vt) = SymTab.ClProc THEN (* procedure formal *) IF instActive THEN IF InstActualKind(instFk) # 2 THEN SemError(233) END; InstActualMod(instFk, mmod); InstActualVal(instFk, nm); IF NOT SymTab.AliasProc(names[k], mmod, nm) THEN SemError(201) ELSIF SymTab.QualProcInfo(mmod, nm, quid, qdep, qres, qext) THEN Lower.AliasProc(names[k], quid, qres, qdep, qext) END ELSE (* template: a callable placeholder of the formal's proc type *) IF NOT SymTab.Enter(names[k], SymTab.KindVar) THEN SemError(200) END; SymTab.SetSymType(names[k], vt) END ELSE (* constraint: a value formal needs a value actual *) IF instActive AND (InstActualKind(instFk) # 1) THEN SemError(233) END; IF NOT SymTab.Enter(names[k], SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(names[k], vt); IF instActive THEN InstActualVal(instFk, nm); SymTab.SetSymVal(names[k], nm) ELSE SymTab.SetSymVal(names[k], "0") END END; INC(instFk); INC(k) END; .) . Actuals = Actual { "," Actual } . Actual (. VAR at: SymTab.TypeIndex; nm: SymTab.Name; s: ARRAY [0 .. 255] OF CHAR; qv: QbeGen.QVal; isCh, isV: BOOLEAN; aKind: INTEGER; amod: SymTab.Name; nm2: SymTab.Name; qu, qd: CARDINAL; qr: SymTab.TypeIndex; qe: BOOLEAN; k: CARDINAL; .) = (. isV := FALSE; at := SymTab.InvalidType; nm[0] := CHR(0); nm2[0] := CHR(0); aKind := 0; amod[0] := CHR(0); .) ( integer (. LexString(s); QbeGen.NormInt(s, qv); isV := TRUE; aKind := 1; at := SymTab.IntType(); CopyNm(qv, nm); .) | charConst (. LexString(s); QbeGen.NormLit(s, qv, isCh); isV := TRUE; aKind := 1; at := SymTab.CharType(); CopyNm(qv, nm); .) | GetIdent [ "." GetIdent ] (. isV := FALSE; at := SymTab.InvalidType; aKind := 0; amod[0] := CHR(0); IF nm2[0] # CHR(0) THEN (* qualified actual Mod.Name: a nested instance's type (Mod.Type) or a procedure (Mod.Proc); no import needed *) IF SymTab.QualProcInfo(nm, nm2, qu, qd, qr, qe) THEN aKind := 2 ELSE at := SymTab.QualType(nm, nm2); IF at # SymTab.InvalidType THEN aKind := 0 ELSE SemError(201); aKind := 0; at := SymTab.InvalidType END END; CopyNm(nm, amod); CopyNm(nm2, nm) ELSIF SymTab.Lookup(nm) AND ((SymTab.SymKind(nm) = SymTab.KindType) OR (SymTab.SymKind(nm) = SymTab.KindPredef)) THEN at := SymTab.SymType(nm) ELSIF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindProc) THEN aKind := 2; at := SymTab.SymType(nm); IF NOT SymTab.SymMod(nm, amod) THEN amod[0] := CHR(0) END ELSIF SymTab.Lookup(nm) AND (SymTab.SymKind(nm) = SymTab.KindConst) THEN isV := TRUE; aKind := 1; at := SymTab.SymType(nm); IF NOT SymTab.GetSymVal(nm, s) THEN s[0] := CHR(0) END; CopyNm(s, nm) ELSE SemError(201) END; .) ) (. IF refN <= HIGH(refActual) THEN IF aKind = 0 THEN IF isV THEN refKind[refN] := 1 ELSE refKind[refN] := 0 END ELSE refKind[refN] := aKind END; refActual[refN] := at; k := 0; WHILE (k <= HIGH(refVal[refN])) AND (nm[k] # CHR(0)) DO refVal[refN][k] := nm[k]; INC(k) END; refVal[refN][k] := CHR(0); k := 0; WHILE (k <= HIGH(refMod[refN])) AND (amod[k] # CHR(0)) DO refMod[refN][k] := amod[k]; INC(k) END; refMod[refN][k] := CHR(0); INC(refN) END; .) . Unit = (. isGen := FALSE; allowDefer := FALSE; repassing := FALSE; .) [ "GENERIC" (. isGen := TRUE; .) ] ( 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; g: SymTab.Name; astSeq, astTail, astProc: AST.Node; .) = (. refN := 0; refSeen := FALSE; .) "DEFINITION" "MODULE" GetIdent (. IF instActive THEN InstNameGet(m1) END; IF instActive THEN IF NOT SymTab.Reenter(m1, SymTab.UnitDef) THEN SemError(200) END ELSIF NOT SymTab.BeginDef(m1) THEN SemError(200) END; QbeGen.SetModule(m1); CopyNm(m1, unitName); unitWasGen := isGen AND NOT instActive; unitWasDef := TRUE; .) [ GenericFormals ] ( ";" { 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); Lower.NoteProcNode(astProc); Lower.ScopeLeave; 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 instActive THEN InstNameGet(m2) END; IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) | "=" GetIdent [ "(" Actuals ")" ] ";" (. CopyNm(m1, refInst); CopyNm(g, refGen); refSeen := TRUE; refIsDef := TRUE; astUnit := AST.MakeNode(AST.NkUnit); AST.SetChild(astUnit, 0, AST.MakeLeaf(AST.NkIdent, m1)); 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; g: SymTab.Name; k: CARDINAL; rp: CARDINAL; rpOk: BOOLEAN; rErrs: INTEGER; rDecl, rStmt: AST.Node; rnm: SymTab.Name; rSym, rErr: CARDINAL; fname: SymTab.Name; unres: BOOLEAN; astNode: AST.Node; .) = (. refN := 0; refSeen := FALSE; .) "IMPLEMENTATION" "MODULE" GetIdent (. IF instActive THEN InstNameGet(m1) END; IF instActive THEN IF NOT SymTab.Reenter(m1, SymTab.UnitImpl) THEN SemError(201) END ELSIF NOT SymTab.BeginImpl(m1) THEN SemError(201) END; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; nPendVar := 0; CopyNm(m1, unitName); unitWasGen := isGen AND NOT instActive; unitWasDef := FALSE; QbeGen.SetModule(m1); .) [ GenericFormals ] ( ";" { Import (. AstAppend(AST.NkDeclSeq, astImp, astImpTail, astDecl); .) } DeclSeq (. astStmt := AST.NoNode; .) [ "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; nLab := 0; nGot := 0; .) [ StatSeq ] ] (. IF twoPhaseParse THEN rSym := sym; rErr := errDist; rDecl := astDecl; rStmt := astStmt; M2S.PushPos; repassing := TRUE; rp := 0; WHILE rp < nSpans DO k := 0; WHILE (k <= HIGH(rnm)) AND (spanName[rp][k] # CHR(0)) DO rnm[k] := spanName[rp][k]; INC(k) END; rnm[k] := CHR(0); M2S.SeekTo(spanStart[rp]); Adv; rpOk := SymTab.ReenterDeferred(spanIdx[rp]); IF NOT rpOk THEN FileIO.WriteString(FileIO.StdOut, "twophase reenter failed"); FileIO.WriteLn(FileIO.StdOut) END; Lower.ReenterScopeProc(spanTy[rp]); QbeGen.BeginFunc(""); Block(rnm); AST.SetChild(spanNode[rp], 1, astStmt); AST.SetChild(spanNode[rp], 2, astBlkDecls); Lower.ScopeLeave; SymTab.CloseProc; QbeGen.EndFunc(SymTab.ProcRes(rnm)); INC(rp) END; rErrs := M2S.errors; repassing := FALSE; M2S.PopPos; sym := rSym; errDist := rErr; M2S.errors := rErrs; astDecl := rDecl; astStmt := rStmt END; .) "END" GetIdent (. IF instActive THEN InstNameGet(m2) END; FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; 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; CheckGotos; SymTab.EndUnit; .) | "=" GetIdent [ "(" Actuals ")" ] ";" (. CopyNm(m1, refInst); CopyNm(g, refGen); refSeen := TRUE; refIsDef := FALSE; astNode := AST.MakeNode(AST.NkUnit); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, m1)); astDecl := AST.NoNode; astStmt := AST.NoNode; .) { Import (. (* refinement unit import *) .) } "END" GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) ) . ProgModule (. VAR m1, m2: SymTab.Name; k: CARDINAL; rp: CARDINAL; rpOk: BOOLEAN; rErrs: INTEGER; rDecl, rStmt: AST.Node; rnm: SymTab.Name; rSym, rErr: 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 (. astStmt := AST.NoNode; .) [ "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; nLab := 0; nGot := 0; .) [ StatSeq ] ] (. IF twoPhaseParse THEN rSym := sym; rErr := errDist; rDecl := astDecl; rStmt := astStmt; M2S.PushPos; repassing := TRUE; rp := 0; WHILE rp < nSpans DO k := 0; WHILE (k <= HIGH(rnm)) AND (spanName[rp][k] # CHR(0)) DO rnm[k] := spanName[rp][k]; INC(k) END; rnm[k] := CHR(0); M2S.SeekTo(spanStart[rp]); Adv; rpOk := SymTab.ReenterDeferred(spanIdx[rp]); IF NOT rpOk THEN FileIO.WriteString(FileIO.StdOut, "twophase reenter failed"); FileIO.WriteLn(FileIO.StdOut) END; Lower.ReenterScopeProc(spanTy[rp]); QbeGen.BeginFunc(""); Block(rnm); AST.SetChild(spanNode[rp], 1, astStmt); AST.SetChild(spanNode[rp], 2, astBlkDecls); Lower.ScopeLeave; SymTab.CloseProc; QbeGen.EndFunc(SymTab.ProcRes(rnm)); INC(rp) END; rErrs := M2S.errors; repassing := FALSE; M2S.PopPos; sym := rSym; errDist := rErr; M2S.errors := rErrs; astDecl := rDecl; astStmt := rStmt END; .) "END" GetIdent (. IF instActive THEN InstNameGet(m2) END; FlushPend; k := 0; WHILE k < SymTab.FwdPending() DO SymTab.FwdInfo(k, fname, unres); IF unres THEN SemError(201) END; INC(k) END; SymTab.FwdClear; 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; CheckGotos; 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 (. astStmt := AST.NoNode; .) [ "BEGIN" (. astStmt := AST.NoNode; .) [ StatSeq ] ] "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; Lower.NoteCProc(n) ELSIF SymTab.ModKnown(mod) THEN IF NOT SymTab.ImportFrom(mod, n) THEN SemError(201) ELSE Lower.NoteImportedProc(n) END END; .) | ( "TSIZE" | "SIZE" | "ADR" | "HIGH" | "LEN" | "CHR" | "ORD" | "ORDL" | "VAL" | "ABS" | "CAP" | "ODD" | "TRUNC" | "FLOAT" | "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) AND (cl # SymTab.ClBool) AND (cl # SymTab.ClEnum)) OR ((cl2 # SymTab.ClInt) AND (cl2 # SymTab.ClChar) AND (cl2 # SymTab.ClBool) AND (cl2 # SymTab.ClEnum)) 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 ELSIF SymTab.Unresolved(base) THEN (* a forward type: defer the span check; the base resolves once the TYPE block completes *) t := SymTab.NewSet(base) 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" (. SymTab.LayoutRecord(t); .) . 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); Lower.NoteVar(n, SymTab.KindConst, t); Lower.NoteConstVal(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); Lower.NoteVar(n, SymTab.KindConst, t); Lower.NoteConstVal(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 ";" (. Lower.ScopeLeave; 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); .) [ StatSeq ] ] "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; Lower.ScopeLeave; SymTab.CloseProc; .) | (. (* bind the receiver: bare field names resolve against THIS *) QbeGen.CopyOp("@", thisQ); QbeGen.PushWith(thisQ); .) Block (. AST.SetChild(astMethod, 1, astStmt); AST.SetChild(astMethod, 2, astBlkDecls); QbeGen.PopWith; methRes := SymTab.CurRes(); Lower.ScopeLeave; 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; mk: ARRAY [0 .. 15] OF CARDINAL; mw: CARDINAL; mlo: 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); Lower.NoteConstVal(qv); SymTab.SetSymType(n, t); cls := SymTab.ClassOf(t); IF cls = SymTab.ClSet THEN (* a SET CONST needs static data: fold its mask now (the grammar sees the element values) and let Lower re-emit it *) IF Lower.SetConstMaskOf( AST.Child(astNode, 1), mk, mw, mlo) THEN Lower.NoteSetMask(n, mk, mw, mlo); SymTab.SetSymVal(n, qv) ELSE SemError(230) END ELSIF (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); 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, astTail: AST.Node; .) = VarIdents ":" Type (. astNode := AST.MakeNode(AST.NkVarDecl); astTail := astNode; i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); Lower.NoteVar(nm, SymTab.KindVar, t); (* chunked: a VAR list can exceed AST.MaxChild *) AstAppend(AST.NkBlock, astNode, astTail, 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 *) AST.SetOp(astNode, 1); 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); 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); QbeGen.BeginFunc(""); 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); .) ] . 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)); Lower.NoteProcNode(astNode); .) ( "FORWARD" (. AST.SetOp(astNode, 1); astDecl := astNode; Lower.ScopeLeave; SymTab.MarkFwd; SymTab.CloseProc; QbeGen.AbortFunc; .) | "EXTERNAL" (. AST.SetOp(astNode, 2); astDecl := astNode; Lower.MarkProcExternal; Lower.ScopeLeave; SymTab.MarkExternal(""); SymTab.CloseProc; QbeGen.AbortFunc; .) | (. allowDefer := TRUE; deferredBody := FALSE; curProcNode := astNode; .) Block (. IF deferredBody THEN (* body skipped: close like FORWARD (no body node) *) astDecl := astNode; Lower.ScopeLeave; SymTab.CloseProc; QbeGen.AbortFunc ELSE AST.SetChild(astNode, 1, astStmt); AST.SetChild(astNode, 2, astBlkDecls); astDecl := astNode; Lower.ScopeLeave; SymTab.CloseProc; QbeGen.EndFunc( SymTab.ProcRes(pn)) END; .) ) . Block (. VAR m2: SymTab.Name; dfr: BOOLEAN; .) = (. dfr := FALSE; IF allowDefer AND twoPhaseParse AND NOT repassing THEN dfr := DeferSkip(pn) END; allowDefer := FALSE; .) DeclSeq (. astBlkDecls := astDecl; astStmt := AST.NoNode; nLab := 0; nGot := 0; .) [ "BEGIN" (. (* an empty body is still a body: mark it so Lower does not read it as a definition heading *) IF NOT dfr THEN IF astStmt = AST.NoNode THEN astStmt := AST.MakeNode(AST.NkBlock) END END; .) [ StatSeq ] ] "END" GetIdent (. IF NOT SymTab.Equal(pn, m2) THEN SemError(202) END; CheckGotos; .) . (* Two-phase, phase 2 (milestone 2c): re-parse every deferred module- level body once the unit's declarations are complete. Inlined at both call sites because a stand-alone epsilon production is "unreachable" to Coco/R (referenced only from actions). *) 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; lxnm: SymTab.Name; .) = (. astStmt := AST.NoNode; .) ( AssOrCall | IfStat | WhileStat | RepeatStat | LoopStat | ForStat | CaseStat | WithStat | ReturnStat | HaltStat | NewStat | DisposeStat | IncDecStat | InclExclStat | "EXIT" (. IF NOT QbeGen.TopLoop(lx) THEN SemError(230) END; astStmt := AST.MakeNode(AST.NkExit); .) | "GOTO" GetIdent (. NoteGoto(lxnm); astStmt := AST.MakeNode(AST.NkGoto); AST.SetChild(astStmt, 0, AST.MakeLeaf(AST.NkIdent, lxnm)); .) ) . (* 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) AND (SymTab.ClassOf(at) # SymTab.ClSet) THEN SemError(222) 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; .) ) "(" (. 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) 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) 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) 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, astRes: AST.Node; mname: SymTab.Name; isM: BOOLEAN; n: SymTab.Name; astLab, astNode: AST.Node; .) = GetIdent ( ":" (. NoteLabel(n); astNode := AST.MakeNode(AST.NkLabel); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, n)); astLab := AST.MakeNode(AST.NkBlock); AST.SetChild(astLab, 0, astNode); .) Statement (. IF astStmt # AST.NoNode THEN AST.SetChild(astLab, 1, astStmt) END; astStmt := astLab; .) | DesignTail (. 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 END; .) | ArgList (. astRes := AstCallNode(astLhs); sfx := FALSE; .) ( { ResultComp } ":=" Expr (. astStmt := AST.MakeBin( AST.NkAssign, 0, astRes, astCur); IF NOT sfx THEN SemError(233) ELSIF (ct2 # SymTab.InvalidType) AND NOT SymTab.Assignable(et, ct2) THEN SemError(210) END; .) | (. IF ct2 # SymTab.InvalidType THEN SemError(233) END; astStmt := astRes; .) ) | (* 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) 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, isConv: BOOLEAN; .) = "(" (. called := TRUE; ok := TRUE; ind := FALSE; isConv := FALSE; isMeth := methCls # SymTab.InvalidType; IF isMeth THEN res := SymTab.ClassMethodRes(methCls, pn) ELSIF SymTab.SymKind(pn) = SymTab.KindProc THEN res := SymTab.ProcRes(pn) ELSIF (SymTab.SymKind(pn) = SymTab.KindType) OR (SymTab.SymKind(pn) = SymTab.KindPredef) THEN (* ISO type conversion T(x): one value, result is T *) isConv := TRUE; res := SymTab.SymType(pn) ELSIF (pt # SymTab.InvalidType) AND (SymTab.ClassOf(pt) = SymTab.ClProc) THEN ind := TRUE; res := SymTab.ProcTypeRes(pt) ELSE SemError(233); ok := FALSE; res := SymTab.InvalidType END; i := 0; .) [ ActParam (. INC(i); .) { "," ActParam (. INC(i); .) } ] ")" (. IF ok THEN IF isConv THEN (* a conversion takes exactly one value *) IF i # 1 THEN SemError(233); ok := FALSE END ELSE 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 END; IF NOT ok THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSIF want THEN IF res = SymTab.InvalidType THEN IF NOT soft THEN SemError(233) END; t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE t := res; QbeGen.CopyOp("@", q) END ELSE IF res # SymTab.InvalidType THEN SemError(233) END; t := SymTab.InvalidType; QbeGen.CopyOp("0", 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; savedN, aj: CARDINAL; savedArgs: ARRAY [0 .. 31] OF AST.Node; astActual: AST.Node; .) = (. (* Parsing the actual can clobber the enclosing call's argument list (Factor resets astNArgs), so save/restore it. *) savedN := astNArgs; aj := 0; WHILE aj <= HIGH(astArgs) DO savedArgs[aj] := astArgs[aj]; INC(aj) END; .) Expr (. QbeGen.CopyOp(qe, convQ); convT := at; astActual := astCur; astNArgs := savedN; aj := 0; WHILE aj <= HIGH(astArgs) DO astArgs[aj] := savedArgs[aj]; INC(aj) END; 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 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 ELSIF (AST.Kind(astActual) # AST.NkDesignator) AND (AST.Kind(astActual) # AST.NkStrLit) THEN SemError(233) ELSIF NOT SymTab.VarParamOk(at, ft) 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 ELSIF NOT SymTab.Assignable(at, ft) THEN SemError(233) END END; .) . IfStat (. VAR t: SymTab.TypeIndex; q: 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; .) "THEN" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkIf); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); astIf := astNode; astLast := astNode; .) { "ELSIF" Expr (. astCond := astCur; astStmt := AST.NoNode; IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; .) "THEN" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkIf); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); AST.SetChild(astLast, 2, astNode); astLast := astNode; .) } [ "ELSE" (. hasElse := TRUE; astStmt := AST.NoNode; .) [ StatSeq ] (. AST.SetChild(astLast, 2, astStmt); .) ] "END" (. astStmt := astIf; .) . WhileStat (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; astCond, astNode: AST.Node; .) = "WHILE" (. astStmt := AST.NoNode; .) Expr (. astCond := astCur; IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; .) "DO" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkWhile); AST.SetChild(astNode, 0, astCond); AST.SetChild(astNode, 1, astStmt); astStmt := astNode; .) "END" . RepeatStat (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; astCond, astBody, astNode: AST.Node; .) = "REPEAT" (. astStmt := AST.NoNode; .) [ 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; .) . LoopStat (. VAR lEnd: QbeGen.QVal; astNode: AST.Node; .) = "LOOP" (. astStmt := AST.NoNode; QbeGen.NewLabel(lEnd); QbeGen.PushLoop(lEnd); .) [ StatSeq ] "END" (. astNode := AST.MakeNode(AST.NkLoop); AST.SetChild(astNode, 0, astStmt); astStmt := astNode; QbeGen.PopLoop; .) . (* 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" [ 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; .) . CaseStat (. VAR tsel: SymTab.TypeIndex; qsel, lEnd: QbeGen.QVal; arm, astNode, astArms, astArmsTail: AST.Node; .) = "CASE" Expr (. astNode := AST.MakeNode(AST.NkCase); AST.SetChild(astNode, 0, astCur); astArms := AST.NoNode; astArmsTail := AST.NoNode; .) "OF" CaseAlt { "|" CaseAlt } [ "ELSE" (. astStmt := AST.NoNode; .) [ StatSeq ] (. arm := AST.MakeNode(AST.NkCaseArm); AST.SetOp(arm, 1); AST.SetChild(arm, 0, astStmt); AstAppend(AST.NkBlock, astArms, astArmsTail, arm); .) ] "END" (. AST.SetChild(astNode, 1, astArms); astStmt := astNode; .) . (* 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 arm: AST.Node; .) = (. arm := AST.MakeNode(AST.NkCaseArm); .) CaseLabel { "," CaseLabel } ":" (. astStmt := AST.NoNode; .) [ StatSeq ] (. AST.SetChild(arm, AST.NChild(arm), astStmt); AstAppend(AST.NkBlock, arms, armsTail, arm); .) . 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) END; .) [ ".." 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) END; .) ] (. 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) END ELSIF (res = SymTab.InvalidType) OR (t # SymTab.InvalidType) AND NOT SymTab.Assignable(t, res) THEN SemError(232) 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; .) . (* 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: SymTab.Name; .) = GetIdent DesignTail . (* The part of Design after the identifier: resolve it and walk the selectors. Split out so a statement can decide between a label (`ident :`) and a designator (`ident := ...`) with one token. *) DesignTail (. VAR 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; r: BOOLEAN; astDes, astSel: AST.Node; .) = (. methCls := SymTab.InvalidType; QbeGen.CopyOp(n, qn); sfx := FALSE; 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.CopyOp("@", q); methCls := ic; k := SymTab.KindProc; t := SymTab.InvalidType ELSIF SymTab.InProc() THEN (* not declared anywhere in scope: with bodies parsed at unit end this is a genuine 201 (a nested-local forward is no longer tolerated). *) SemError(201); t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q) 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) OR (cls = SymTab.ClSet) 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) AND (cls # SymTab.ClBool) AND (cls # SymTab.ClChar) AND (cls # SymTab.ClUChar) AND (cls # SymTab.ClEnum) AND (cls # SymTab.ClReal) AND (cls # SymTab.ClPtr) AND (cls # SymTab.ClProc) AND (cls # SymTab.ClLong) AND (cls # SymTab.ClArray) AND (cls # SymTab.ClSet) AND (cls # SymTab.ClRecord) AND (cls # SymTab.ClUStr) AND (cls # SymTab.ClClass) THEN SemError(230); QbeGen.CopyOp("0", q) ELSE QbeGen.CopyOp("@", 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 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) AND (SymTab.ClassOf(it) # SymTab.ClBool) THEN SemError(218); t := SymTab.InvalidType ELSE eT := SymTab.ArrayElem(t); 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) AND (SymTab.ClassOf(it) # SymTab.ClBool) THEN SemError(218); t := SymTab.InvalidType ELSE eT := SymTab.ArrayElem(t); 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) 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.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 t := SymTab.FieldType(t, fn); 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 t := bt; 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 (. isM := FALSE; 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) AND (SymTab.ClassOf(it) # SymTab.ClBool) THEN SemError(218); t := SymTab.InvalidType ELSE eT := SymTab.ArrayElem(t); t := eT; sfx := TRUE END; .) "]" | "." GetIdent (. isM := FALSE; 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 (SymTab.ClassOf(t) = SymTab.ClClass) AND SymTab.MethodExists(t, fname) THEN (* a method on the call result: a following ArgList makes the call *) mname := fname; methCls := t; isM := TRUE; t := SymTab.InvalidType ELSIF NOT SymTab.FieldExists(t, fname) THEN SemError(216); t := SymTab.InvalidType ELSE t := SymTab.FieldType(t, fname); sfx := TRUE END; .) | "^" (. isM := FALSE; 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 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 t := SymTab.BoolType(); QbeGen.CopyOp("@", 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 (op # SymTab.OpEq) AND (op # SymTab.OpNeq1) AND (op # SymTab.OpNeq2) THEN SemError(213); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE t := SymTab.BoolType(); QbeGen.CopyOp("@", q) END ELSIF (SymTab.ClassOf(t) = SymTab.ClSet) OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN t := SymTab.BoolType(); QbeGen.CopyOp("@", 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 t := SymTab.BoolType(); QbeGen.CopyOp("@", q) ELSE t := SymTab.BoolType(); QbeGen.CopyOp("@", 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; .) (. IF astCur # AST.NoNode THEN AST.SetTy(astCur, t) 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 AND QbeGen.IsImm(q) THEN QbeGen.NegFold(q, q) END; IF astSign < 0 THEN astCur := AST.MakeUn( AST.NkUnary, AST.OpSub, astA); astA := astCur END; .) { AddOp Term (. astB := astCur; .) (. 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.CopyOp("@", q) ELSE 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. *) t := SymTab.NewUStr(); QbeGen.CopyOp("@", 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 fok THEN QbeGen.CopyOp(qt, q) ELSE QbeGen.CopyOp("@", q) END; t := SymTab.NewStr() 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; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp("@", 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 QbeGen.CopyOp("@", q) END ELSE QbeGen.CopyOp("0", q) END END; .) } (. IF astCur # AST.NoNode THEN AST.SetTy(astCur, t) 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 Fact (. astB := astCur; .) (. 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.CopyOp("@", q) ELSE 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; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp("@", 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 QbeGen.CopyOp("@", q) END ELSE QbeGen.CopyOp("0", q) END END; .) } (. IF astCur # AST.NoNode THEN AST.SetTy(astCur, t) 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; mname: SymTab.Name; isM: BOOLEAN; isConvF: BOOLEAN; .) = (. astIsLit := FALSE; .) ( integer (. LexString(s); QbeGen.NormInt(s, q); astIsLit := TRUE; astCur := AST.MakeLeaf(AST.NkIntLit, s); t := SymTab.IntType(); .) | charConst (. LexString(s); QbeGen.NormLit(s, q, isCh); astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkCharLit, s); t := SymTab.CharType(); .) | real (. LexString(s); QbeGen.NormReal(s, q); astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkRealLit, s); t := SymTab.RealType(); .) | string (. LexString(s); astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkStrLit, s); 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 *) END; .) | ustring (. LexString(s); astIsLit := TRUE; astCur := AST.MakeLeaf( AST.NkStrLit, s); 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(); END; .) | Design (. astD := astCur; astCall := FALSE; astBrace := AST.NoNode; astNArgs := 0; called := FALSE; t := dt; IF dk = SymTab.KindConst THEN QbeGen.CopyOp(qd, q) ELSE QbeGen.CopyOp("@", q) END; .) [ TypedBraceLit (. t := dt; astCall := TRUE; astBrace := astCur; .) ] [ ArgList (. astCall := TRUE; IF (SymTab.SymKind(qn) = SymTab.KindType) OR (SymTab.SymKind(qn) = SymTab.KindPredef) THEN (* T(x): emit as the VAL builtin so Lower's conversion rules apply unchanged *) astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "VAL")); AST.SetChild(astNode, 1, AST.MakeLeaf(AST.NkIdent, qn)); IF astNArgs = 1 THEN AST.SetChild(astNode, 2, astArgs[0]) END; isConvF := TRUE ELSE astNode := AstCallNode(astD) END; astRes := astNode; t := ct2; QbeGen.CopyOp(q2, q); IF isConvF AND QbeGen.IsImm(convQ) AND OrdClass(convT) AND OrdClass(ct2) THEN QbeGen.CopyOp(convQ, q) END; sfx := FALSE; .) { ResultComp [ (. astNArgs := 0; .) ArgList (. astNode := AstCallNode(astRes); astRes := astNode; t := ct2; QbeGen.CopyOp(q2, q); sfx := FALSE; .) ] } (. 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.CopyOp("@", 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 t := SymTab.ProcRes(qn); QbeGen.CopyOp("@", q); astCur := AST.MakeNode(AST.NkCall); AST.SetChild(astCur, 0, astD) ELSE t := SymTab.ProcTypeOf(qn); QbeGen.CopyOp("@", 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); 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(); 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 *) t := SymTab.IntType(); QbeGen.CopyOp("@", 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 SymTab.IsOpenArray(dt) THEN t := SymTab.IntType(); QbeGen.CopyOp("@", q) ELSE IF isHigh THEN QbeGen.IntStr( SymTab.ArrayHi(dt), qr) ELSE QbeGen.IntStr(VAL( INTEGER, SymTab.ArrayLen(dt)), qr) END; t := SymTab.IntType(); QbeGen.CopyOp(qr, q) END 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 t := et; QbeGen.CopyOp("@", 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 OR (dk = SymTab.KindVar) OR (dk = SymTab.KindParam) THEN QbeGen.CopyOp("@", 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.CopyOp("@", 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; 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.CopyOp("@", q) END; t := et; .) | "ODD" "(" Expr ")" (. astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ODD")); 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.BoolType(); QbeGen.CopyOp("@", q); .) | "TRUNC" "(" Expr ")" (. (* TRUNC(x): real -> INTEGER, as the VAL builtin *) astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "VAL")); AST.SetChild(astNode, 1, AST.MakeLeaf(AST.NkIdent, "INTEGER")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. t := SymTab.IntType(); QbeGen.CopyOp("@", q); .) | "FLOAT" "(" Expr ")" (. (* FLOAT(i): integer -> REAL, as the VAL builtin *) astNode := AST.MakeNode(AST.NkCall); AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "VAL")); AST.SetChild(astNode, 1, AST.MakeLeaf(AST.NkIdent, "REAL")); IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; astCur := astNode; astIsLit := TRUE; .) (. t := SymTab.RealType(); QbeGen.CopyOp("@", q); .) | "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.CopyOp("@", 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; .) (. IF astCur # AST.NoNode THEN AST.SetTy(astCur, t) 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, astTail: AST.Node; savedCls: INTEGER; .) = "{" (. savedCls := braceCls; astNode := AST.MakeNode(AST.NkBraceLit); AST.SetTy(astNode, vt); astTail := astNode; 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; reps := 1; .) 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; .) (. (* the BY form repeats the element; keep the AST in step with CtorElem *) k := 0; WHILE k < reps DO AstAppend(AST.NkBlock, node, tail, astEl); INC(k) END; .) . 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.