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; 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 = Unit "." . (* Units: program modules compile fully; DEFINITION and IMPLEMENTATION modules parse + check now but lower in step 4 (each ends with one 230); same for nested local modules. *) Unit = DefUnit | ImplUnit | ProgModule . (* Step 4.3: one session compiles DEFINITION, its IMPLEMENTATION and one program (last) into one image. Units share the symbol table; imports materialize exported names. *) DefUnit (. VAR m1, m2, pn: SymTab.Name; .) = "DEFINITION" "MODULE" GetIdent (. IF NOT SymTab.BeginDef(m1) THEN SemError(200) END; QbeGen.SetModule(m1); .) ";" { Import } { ConstBlock | TypeBlock | VarBlock | ProcHeading ";" (. SymTab.CloseProc; QbeGen.AbortFunc; .) } "END" GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) . ImplUnit (. VAR m1, m2: SymTab.Name; .) = "IMPLEMENTATION" "MODULE" GetIdent (. IF NOT SymTab.BeginImpl(m1) THEN SemError(201) END; QbeGen.SetModule(m1); .) ";" { Import } DeclSeq [ "BEGIN" (. QbeGen.BeginInit(m1); .) [ StatSeq ] (. QbeGen.EndInit; .) ] "END" GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; SymTab.EndUnit; .) . ProgModule (. VAR m1, m2: SymTab.Name; .) = "MODULE" GetIdent (. IF NOT SymTab.BeginProg(m1) THEN SemError(200) END; QbeGen.SetModule(m1); .) [ Priority ] ";" { Import } DeclSeq [ "BEGIN" (. QbeGen.BeginBody; .) [ StatSeq ] ] "END" GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN SemError(202) END; QbeGen.EndModule(m1); SymTab.EndUnit; .) . DeclSeq = { ConstBlock | TypeBlock | VarBlock | ProcDecl ";" | NestedModule ";" | ClassItem ";" } . (* 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; .) = "MODULE" GetIdent (. IF NOT SymTab.Enter(m1, SymTab.KindModule) THEN SemError(200) END; SymTab.PushScope; expCount := 0; .) [ Priority ] ";" { Import } [ "EXPORT" [ "QUALIFIED" ] GetIdent (. INC(expCount); .) { "," GetIdent (. INC(expCount); .) } ";" ] DeclSeq [ "BEGIN" (. QbeGen.BeginInit(m1); .) [ StatSeq ] (. QbeGen.EndInit; .) ] "END" GetIdent (. 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; .) = "FROM" GetIdent "IMPORT" ImpList ";" | "IMPORT" ImpModList ";" . 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 (. IF SymTab.ModKnown(mod) AND NOT SymTab.ImportFrom(mod, n) THEN SemError(201) END; .) | ( "TSIZE" | "SIZE" | "ADR" | "HIGH" | "LEN" | "CHR" | "ORD" | "ORDL" | "VAL" | "ABS" | "CAP" | "UCHR" | "CHR8" | "UORD" | "INC" | "DEC" ) . ImpModList (. VAR n: SymTab.Name; .) = GetIdent { "," GetIdent } . (* 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 = "TYPE" (. SymTab.BeginTypeBlock; .) { TypeItem ";" | ClassItem ";" } (. SymTab.EndTypeBlock; .) . TypeItem (. VAR n: SymTab.Name; t, op: SymTab.TypeIndex; .) = GetIdent (. op := SymTab.OpaqueBase(n); IF op = SymTab.InvalidType THEN IF NOT SymTab.Enter(n, SymTab.KindType) THEN SemError(200) END END; .) ( "=" Type (. 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 | 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; .) ) . (* 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; .) = "ARRAY" ( "OF" Type (. IF NOT allowOpen THEN SemError(230) END; t := SymTab.NewOpenArray(elem); .) | "[" (. SymTab.BoundBegin; ok := TRUE; .) BoundPair { "," BoundPair } "]" (. (* snapshot before the element type, which reuses the bound buffer for a nested ARRAY *) nb := SymTab.BoundCount(); k := 0; WHILE k < nb DO bnds[k] := SymTab.BoundLo(k); bndh[k] := SymTab.BoundHi(k); INC(k) END; .) "OF" Type (. IF ok THEN k := nb; WHILE k > 0 DO DEC(k); elem := SymTab.NewArrayB( elem, bnds[k], bndh[k]) END; t := elem ELSE t := SymTab.InvalidType END; .) ) . BoundPair (. VAR tlo, thi: SymTab.TypeIndex; qlo, qhi: QbeGen.QVal; lo, hi: INTEGER; cl, cl2: INTEGER; .) = Expr ".." Expr (. IF (tlo = SymTab.InvalidType) OR (thi = SymTab.InvalidType) THEN ok := FALSE ELSE cl := SymTab.ClassOf(tlo); cl2 := SymTab.ClassOf(thi); IF ((cl # SymTab.ClInt) AND (cl # SymTab.ClChar)) OR ((cl2 # SymTab.ClInt) AND (cl2 # SymTab.ClChar)) THEN SemError(230); ok := FALSE ELSIF NOT SymTab.ConstInt(qlo, lo) OR NOT SymTab.ConstInt(qhi, hi) OR (lo > hi) THEN SemError(230); ok := FALSE ELSIF NOT SymTab.BoundAdd(lo, hi) THEN SemError(230); ok := FALSE END; END; .) . (* Sets: multi-word masks over bases ≤ 256 values (bool, char, bounded subranges; enums wait for ordinals, INTEGER is unbounded). Literals are SET OF [0..255]; assignment and comparison across suitable bases are lenient (masks over min words + zero-check extras), out-of-span literals are 222. *) SetType (. VAR base: SymTab.TypeIndex; blo, bhi, bspan: INTEGER; bcls: INTEGER; .) = "SET" "OF" Type (. IF base = SymTab.InvalidType THEN t := SymTab.InvalidType ELSE bcls := SymTab.ClassOf(base); IF bcls = SymTab.ClBool THEN blo := 0; bspan := 2 ELSIF bcls = SymTab.ClChar THEN blo := 0; bspan := 256 ELSIF SymTab.SubBounds(base, blo, bhi) THEN bspan := bhi - blo + 1 ELSE bspan := 0 END; IF (bspan <= 0) OR (bspan > 256) THEN SemError(230); t := SymTab.InvalidType ELSE t := SymTab.NewSet(base) END END; .) . (* Records: flat blobs; array fields are pointers to static descriptors (locked amendment), nested records inline. Field offsets static and declaration-ordered. *) (* Field list: plain fields and (optionally) one variant part. The variant part is a `CASE ... END` item; because it starts with the CASE keyword it is unambiguously distinguishable from a field (which starts with an identifier). *) RecordType (. VAR t2: SymTab.TypeIndex; tagOk: BOOLEAN; .) = "RECORD" (. t := SymTab.NewRecord(); .) [ RecItem { ";" [ RecItem ] } ] "END" . RecItem (. VAR tt: SymTab.TypeIndex; .) = RecField | CaseField (. SymTab.MarkVariant(rec); .) . (* A variant part: CASE tag : Type OF variants. The layout overlays every branch from the tag slot (see SymTab.ComputeOffsets). *) CaseField (. VAR tagT: SymTab.TypeIndex; tagN: SymTab.Name; .) = "CASE" (. SymTab.ResetFields(rec); .) GetIdent (. IF NOT SymTab.FieldPending(rec, tagN) THEN SemError(200) END; .) ":" Type (. IF (tagT # SymTab.InvalidType) AND NOT SymTab.IsOrdinal(tagT) THEN SemError(224) END; SymTab.FixPendingF(rec, tagT); SymTab.SetVariantTag(rec, tagN); .) "OF" RecFieldList { "|" (. SymTab.ResetFields(rec); .) RecFieldList } "END" . RecFieldList (. VAR lt, lq: SymTab.TypeIndex; lv1, lv2: QbeGen.QVal; .) = VarLabel [ ".." VarLabel ] ":" RecField { ";" [ RecField ] } . (* Variant case label: a constant (or a constant range). Values are not interpreted (the layout overlays regardless). *) VarLabel (. VAR lname: SymTab.Name; .) = ( ident (. LexName(lname); QbeGen.CopyOp("0", q); t := SymTab.IntType(); .) | integer (. LexString(lname); QbeGen.CopyOp("0", q); t := SymTab.IntType(); .) | charConst (. LexString(lname); QbeGen.CopyOp("0", q); t := SymTab.CharType(); .) ) . RecField (. VAR n: SymTab.Name; t2: SymTab.TypeIndex; .) = RecIdents ":" Type(. SymTab.FixPendingF(rec, t2); .) . RecIdents (. VAR n: SymTab.Name; .) = GetIdent (. IF NOT SymTab.FieldPending(rec, n) THEN SemError(200) END; .) { "," GetIdent (. IF NOT SymTab.FieldPending(rec, n) THEN SemError(200) END; .) } . TypeIdent (. VAR n, qid: SymTab.Name; k: INTEGER; dotted: BOOLEAN; .) = GetIdent (. dotted := FALSE; IF NOT SymTab.Lookup(n) THEN k := -1; t := SymTab.ForwardType(n); IF t = SymTab.InvalidType THEN SemError(201) END ELSE k := SymTab.SymKind(n); IF (k = SymTab.KindType) OR (k = SymTab.KindPredef) THEN t := SymTab.SymType(n) ELSE t := SymTab.InvalidType END END; .) [ "." GetIdent (. dotted := TRUE; IF k = SymTab.KindModule THEN t := SymTab.QualType(n, qid); IF t = SymTab.InvalidType THEN SemError(201) END ELSE SemError(221); t := SymTab.InvalidType END; .) ] (. IF NOT dotted THEN IF (k = SymTab.KindModule) OR ((k # SymTab.KindType) AND (k # SymTab.KindPredef) AND (k # SymTab.KindImport) AND (k # -1)) THEN SemError(221) END END; .) . Subrange (. VAR tlo, thi: SymTab.TypeIndex; qlo, qhi: QbeGen.QVal; lo, hi: INTEGER; .) = "[" Expr ".." Expr (. IF (tlo = SymTab.InvalidType) OR (thi = SymTab.InvalidType) THEN t := SymTab.InvalidType ELSIF (SymTab.ClassOf(tlo) # SymTab.ClInt) OR (SymTab.ClassOf(thi) # SymTab.ClInt) THEN SemError(230); t := SymTab.InvalidType ELSIF NOT SymTab.ConstInt(qlo, lo) OR NOT SymTab.ConstInt(qhi, hi) OR (lo > hi) THEN SemError(230); t := SymTab.InvalidType ELSE t := SymTab.NewSubR(lo, hi) END; .) "]" . Enum (. VAR n: SymTab.Name; ord: INTEGER; qv: QbeGen.QVal; .) = "(" (. t := SymTab.NewEnum(); ord := 0; .) GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); QbeGen.IntStr(ord, qv); SymTab.SetSymVal(n, qv); INC(ord); .) { "," GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; SymTab.SetSymType(n, t); QbeGen.IntStr(ord, qv); SymTab.SetSymVal(n, qv); INC(ord); .) } ")" . (* 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); .) [ Parents ] ";" { ClassField ";" } { MethodHeading ";" (. SymTab.CloseProc; QbeGen.AbortFunc; .) } "END" GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.PopScope; SemError(230); .) . 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; .) . ClassField (. VAR n, rhs: SymTab.Name; t: SymTab.TypeIndex; .) = GetIdent ( "=" GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; IF SymTab.Lookup(rhs) THEN SymTab.SetSymType(n, SymTab.SymType(rhs)) END; .) | (. IF NOT SymTab.FieldPending(ct, n) THEN SemError(200) END; .) { "," GetIdent (. IF NOT SymTab.FieldPending(ct, n) THEN SemError(200) END; .) } ":" Type (. SymTab.FixPendingF(ct, t); .) ) . MethodHeading (. VAR wantVirt: BOOLEAN; .) = (. wantVirt := FALSE; .) [ "VIRTUAL" (. wantVirt := TRUE; .) ] ProcHeading (. IF wantVirt THEN SymTab.MarkVirtual END; .) . ClassImplRest (. VAR cn, m2: SymTab.Name; ct: SymTab.TypeIndex; .) = GetIdent (. IF 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; IF ct # SymTab.InvalidType THEN IF NOT SymTab.PushClassMembers( ct) THEN SemError(230) END END; .) ";" { MethodImpl ";" } [ "BEGIN" [ StatSeq ] ] "END" GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN SemError(202) END; SymTab.PopScope; SemError(230); .) . MethodImpl (. VAR pn: SymTab.Name; .) = (. QbeGen.SetNoEmit(TRUE); .) MethodHeading ";" (. IF (ct # SymTab.InvalidType) AND NOT SymTab.MethodExists(ct, pn) THEN SemError(201) END; .) ( "FORWARD" (. SymTab.MarkFwd; SymTab.CloseProc; .) | Block (. SymTab.CloseProc; .) ) (. QbeGen.AbortFunc; QbeGen.SetNoEmit(FALSE); SemError(230); .) . ConstBlock = "CONST" { ConstDecl ";" } . ConstDecl (. VAR n: SymTab.Name; t: SymTab.TypeIndex; qv: QbeGen.QVal; cls: INTEGER; .) = GetIdent (. IF NOT SymTab.Enter(n, SymTab.KindConst) THEN SemError(200) END; .) "=" Expr (. SymTab.SetSymType(n, t); cls := SymTab.ClassOf(t); IF cls = SymTab.ClStr THEN SemError(230) ELSIF NOT QbeGen.IsImm(qv) THEN SemError(230) END; SymTab.SetSymVal(n, qv); QbeGen.DeclConst(n, qv, t); .) . VarBlock = "VAR" { VarDecl ";" } . VarDecl (. VAR nm: SymTab.Name; t: SymTab.TypeIndex; i: CARDINAL; cls: INTEGER; .) = VarIdents ":" Type (. cls := SymTab.ClassOf(t); IF (t # SymTab.InvalidType) 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) THEN SemError(230) END; IF QbeGen.LocFull() THEN SemError(233) END; i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); QbeGen.DeclVar(nm, t); INC(i) 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 NOT SymTab.EnterProc(pn) THEN IF NOT SymTab.ReenterProc(pn) THEN IF NOT SymTab.ResumeProc(pn) THEN SemError(200) END END END; QbeGen.Mangled(pn, SymTab.ProcUid(pn), mg); QbeGen.BeginFunc(mg); .) [ FormalParams ] [ ":" TypeIdent (. IF NOT SymTab.SetProcRes(t) THEN SemError(235) END; QbeGen.SetFuncRes(t); IF (t # SymTab.InvalidType) AND ((SymTab.ClassOf(t) = SymTab.ClArray) OR (SymTab.ClassOf(t) = SymTab.ClRecord) OR (SymTab.ClassOf(t) = SymTab.ClSet) OR (SymTab.ClassOf(t) = SymTab.ClClass)) THEN SemError(230) END; .) ] . FormalParams = "(" [ ParamSection { ";" ParamSection } ] ")" . ParamSection (. VAR t: SymTab.TypeIndex; nm: SymTab.Name; i: CARDINAL; isV: BOOLEAN; .) = (. isV := FALSE; .) [ "VAR" (. isV := TRUE; .) ] ParIdents ":" Type (. i := 0; WHILE i < SymTab.PendCount() DO SymTab.PendName(i, nm); (* 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; .) = ProcHeading ";" ( "FORWARD" (. SymTab.MarkFwd; SymTab.CloseProc; QbeGen.AbortFunc; .) | "EXTERNAL" (. SymTab.MarkExternal(""); SymTab.CloseProc; QbeGen.AbortFunc; .) | (. QbeGen.EndFuncHeader; .) Block (. SymTab.CloseProc; QbeGen.EndFunc( SymTab.ProcRes(pn)); .) ) . Block (. VAR m2: SymTab.Name; .) = DeclSeq [ "BEGIN" [ StatSeq ] ] "END" GetIdent (. IF NOT SymTab.Equal(pn, m2) THEN SemError(202) END; .) . StatSeq = Statement { ";" [ Statement ] } . (* Trailing/empty statements (`a; ; b`, Coco/R's generated `;;`) are accepted: the statement after ';' is optional. *) Statement (. VAR lx: QbeGen.QVal; .) = AssOrCall | IfStat | WhileStat | RepeatStat | LoopStat | ForStat | CaseStat | WithStat | ReturnStat | HaltStat | NewStat | DisposeStat | IncDecStat | "EXIT" (. IF QbeGen.TopLoop(lx) THEN QbeGen.Jmp(lx) ELSE SemError(230) 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; .) = (. isInc := TRUE; .) ( "INC" (. isInc := TRUE; .) | "DEC" (. isInc := FALSE; .) ) "(" (. QbeGen.CopyOp("1", qstep); .) Design [ "," Expr ] ")" (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF NOT SymTab.IsIntFamily(dt) THEN SemError(211) ELSE IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv) ELSE QbeGen.LoadVar(qn, FALSE, qv) END; QbeGen.NewTemp(qn2); IF isInc THEN QbeGen.Op3("add", qn2, qv, qstep, FALSE) ELSE QbeGen.Op3("sub", qn2, qv, qstep, FALSE) END; IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qn2, dt) ELSE QbeGen.StoreVar(qn, qn2, FALSE) END END; .) . (* NEW/DISPOSE as builtin statements (no call syntax until step 4). Targets are pointer designators; DISPOSE nils afterwards (safer than Wirth-undefined; documented). DISPOSE is shallow. *) NewStat (. VAR dt: SymTab.TypeIndex; dk: INTEGER; qd, qm: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN; bt: SymTab.TypeIndex; .) = "NEW" "(" Design ")" (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN SemError(219) ELSE bt := SymTab.PtrBase(dt); IF bt # SymTab.InvalidType THEN QbeGen.NewHeap(bt, qm); QbeGen.InitHeap(qm, bt); IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, qm, dt) ELSE QbeGen.StorePtr(qn, qm) END END END; .) . DisposeStat (. VAR dt: SymTab.TypeIndex; dk: INTEGER; qd, qv: QbeGen.QVal; qn: SymTab.Name; sfx: BOOLEAN; .) = "DISPOSE" "(" Design ")" (. IF dt = SymTab.InvalidType THEN ELSIF (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF SymTab.ClassOf(dt) # SymTab.ClPtr THEN SemError(219) ELSE IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemLoad(qd, dt, qv) ELSE QbeGen.LoadPtr(qn, qv) END; QbeGen.FreeHeap(qv); IF sfx OR (dk = SymTab.KindField) THEN QbeGen.ElemStore(qd, "0", dt) ELSE QbeGen.StorePtr(qn, "0") END END; .) . (* WITH pushes each record's fields (inner wins) plus its base address; field designators resolve through both stacks. *) WithStat (. VAR nW: CARDINAL; .) = "WITH" (. nW := 0; .) WithItem { "," WithItem } "DO" [ StatSeq ] "END" (. 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 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; .) = Design ( ":=" Expr (. IF (dt # SymTab.InvalidType) AND (dk # SymTab.KindVar) AND (dk # SymTab.KindParam) AND (dk # SymTab.KindField) THEN SemError(210) ELSIF NOT SymTab.Assignable(et, dt) THEN SemError(210) ELSIF (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClClass) THEN SemError(230) END; isR := (dt # SymTab.InvalidType) AND (SymTab.ClassOf(dt) = SymTab.ClReal); conv := isR AND SymTab.IsIntFamily(et); wconv := (dt # SymTab.InvalidType) AND SymTab.IsLongFamily(dt) AND SymTab.IsIntFamily(et); IF ((dk = SymTab.KindVar) OR (dk = SymTab.KindParam) OR (dk = SymTab.KindField)) AND (dt # SymTab.InvalidType) AND (et # SymTab.InvalidType) AND (SymTab.ClassOf(dt) # SymTab.ClClass) THEN IF sfx OR (dk = SymTab.KindField) THEN IF SymTab.ClassOf(dt) = SymTab.ClArray THEN IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr) AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe) ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe) ELSE QbeGen.CopyArray(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et)) ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN QbeGen.CopyRecord(qd, qe, dt) ELSIF SymTab.IsLongFamily(dt) THEN IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.ElemStore(qd, ql, dt) ELSE QbeGen.ElemStore(qd, qe, dt) END ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.ElemStore(qd, qt, dt) ELSE QbeGen.ElemStore(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClArray THEN IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) = SymTab.ClUStr) AND SymTab.IsUCharArray(dt) THEN QbeGen.UAssign(qd, qe) ELSIF SymTab.StrCompat(dt, et) THEN QbeGen.StrAssign(qd, qe) ELSE QbeGen.CopyArray(qd, qe, dt) END ELSIF SymTab.ClassOf(dt) = SymTab.ClSet THEN QbeGen.CopySet(qd, qe, SymTab.SetWords(dt), SymTab.SetWords(et)) ELSIF SymTab.ClassOf(dt) = SymTab.ClRecord THEN QbeGen.CopyRecord(qd, qe, dt) ELSIF (SymTab.ClassOf(dt) = SymTab.ClPtr) OR (SymTab.ClassOf(dt) = SymTab.ClProc) THEN QbeGen.StorePtr(qn, qe) ELSIF SymTab.IsLongFamily(dt) THEN IF wconv THEN QbeGen.WidenLong(qe, ql); QbeGen.StoreLong(qn, ql) ELSE QbeGen.StoreLong(qn, qe) END ELSIF conv THEN QbeGen.ConvIR(qe, qt); QbeGen.StoreVar(qn, qt, TRUE) ELSE QbeGen.StoreVar(qn, qe, isR) END END; .) | ArgList | (* bare `P;`: proper parameterless procedure call; anything else here is 233 (was a bare syntax error before 4.2) *) (. IF (dk = SymTab.KindProc) AND NOT sfx THEN res0 := SymTab.ProcRes(qn); IF res0 # SymTab.InvalidType THEN SemError(233) ELSIF SymTab.ProcNPar(qn) # 0 THEN SemError(233) ELSE QbeGen.Mangled(qn, SymTab.ProcUid(qn), mg0); QbeGen.CallBegin(mg0, res0, SymTab.ProcDepthOf(qn), SymTab.IsExternal(qn)); QbeGen.CallEnd(FALSE, q2) END ELSE SemError(233) END; .) ) . (* Actual-parameter list shared by statement and expression calls. want selects CallEnd's result handling; t/q carry the call value (statement calls discard). Arity/type failures are 233; evaluation code still emits so the .ssa stays assembleable. *) ArgList (. VAR i: CARDINAL; res: SymTab.TypeIndex; mg: QbeGen.QVal; ok, ind: BOOLEAN; .) = "(" (. called := TRUE; ok := TRUE; ind := FALSE; IF SymTab.SymKind(pn) = SymTab.KindProc THEN res := SymTab.ProcRes(pn); QbeGen.Mangled(pn, SymTab.ProcUid(pn), mg); QbeGen.CallBegin(mg, res, SymTab.ProcDepthOf(pn), SymTab.IsExternal(pn)) ELSIF (pt # SymTab.InvalidType) AND (SymTab.ClassOf(pt) = SymTab.ClProc) THEN ind := TRUE; res := SymTab.ProcTypeRes(pt); QbeGen.CallBeginInd(callee, res, FALSE) ELSE SemError(233); ok := FALSE; res := SymTab.InvalidType END; i := 0; .) [ ActParam (. INC(i); .) { "," ActParam (. INC(i); .) } ] ")" (. IF ok THEN IF ind THEN IF i # SymTab.ProcTypeNPar(pt) THEN SemError(233); ok := FALSE END ELSIF i # SymTab.ProcNPar(pn) THEN SemError(233); ok := FALSE END END; IF NOT ok THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSIF want THEN IF res = SymTab.InvalidType THEN SemError(233); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE t := res; QbeGen.CallEnd(TRUE, q) END ELSE IF res # SymTab.InvalidType THEN SemError(233) END; t := SymTab.InvalidType; QbeGen.CopyOp("0", q); QbeGen.CallEnd(FALSE, q) END; .) . (* One actual: VAR formals take recorded designator addresses (233 otherwise); value formals take converted expressions. *) ActParam (. VAR at, ft: SymTab.TypeIndex; qe, qa, qt: QbeGen.QVal; isV, conv: BOOLEAN; .) = Expr (. IF ind THEN ft := SymTab.ProcTypeParamType(pt, i); isV := SymTab.ProcTypeParamIsVar(pt, i) ELSE ft := SymTab.ParamType(pn, i); isV := SymTab.ParamIsVar(pn, i) END; IF (at = SymTab.InvalidType) OR (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 (* 1-char string literal passed to a VAR ARRAY OF CHAR *) QbeGen.DeclCharStr(qe, qa); IF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSIF NOT QbeGen.AddrOfVal(qe, qa) THEN SemError(233) ELSIF NOT SymTab.VarParamOk(at, ft) THEN SemError(233) ELSIF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSE IF (SymTab.ClassOf(at) = SymTab.ClChar) AND (SymTab.ClassOf(ft) = SymTab.ClArray) AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) = SymTab.ClChar) AND QbeGen.IsImm(qe) THEN (* 1-char string literal passed to ARRAY OF CHAR *) QbeGen.DeclCharStr(qe, qa); IF NOT QbeGen.CallArg(qa, "l") THEN SemError(233) END ELSIF NOT SymTab.Assignable(at, ft) THEN SemError(233) ELSE conv := (SymTab.ClassOf( ft) = SymTab.ClReal) AND SymTab.IsIntFamily(at); IF conv THEN QbeGen.ConvIR(qe, qt); IF NOT QbeGen.CallArg(qt, "d") THEN SemError(233) END ELSIF NOT QbeGen.CallArg(qe, QbeGen.ArgClass(ft)) THEN SemError(233) END END END; .) . IfStat (. VAR t: SymTab.TypeIndex; q, lThen, lElse, lEnd: QbeGen.QVal; hasElse: BOOLEAN; .) = "IF" (. hasElse := FALSE; .) Expr (. IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.NewLabel(lThen); QbeGen.NewLabel(lElse); QbeGen.NewLabel(lEnd); QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen); .) "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .) { "ELSIF" (. QbeGen.EmitLabel(lElse); QbeGen.NewLabel(lElse); .) Expr (. IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.NewLabel(lThen); QbeGen.Jnz(q, lThen, lElse); QbeGen.EmitLabel(lThen); .) "THEN" [ StatSeq ] (. QbeGen.Jmp(lEnd); .) } [ "ELSE" (. QbeGen.EmitLabel(lElse); hasElse := TRUE; .) [ StatSeq ] ] "END" (. IF hasElse THEN QbeGen.EmitLabel(lEnd) ELSE QbeGen.EmitLabel(lElse); QbeGen.EmitLabel(lEnd) END; .) . WhileStat (. VAR t: SymTab.TypeIndex; q, lTop, lBody, lEnd: QbeGen.QVal; .) = "WHILE" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) Expr (. IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lBody, lEnd); QbeGen.EmitLabel(lBody); .) "DO" [ StatSeq ] (. QbeGen.Jmp(lTop); .) "END" (. QbeGen.EmitLabel(lEnd); .) . RepeatStat (. VAR t: SymTab.TypeIndex; q, lTop, lEnd: QbeGen.QVal; .) = "REPEAT" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] "UNTIL" Expr (. IF NOT SymTab.BoolCheck(t) THEN SemError(214) END; QbeGen.Jnz(q, lEnd, lTop); QbeGen.EmitLabel(lEnd); .) . LoopStat (. VAR lTop, lEnd: QbeGen.QVal; .) = "LOOP" (. QbeGen.NewLabel(lTop); QbeGen.NewLabel(lEnd); QbeGen.PushLoop(lEnd); QbeGen.EmitLabel(lTop); .) [ StatSeq ] "END" (. QbeGen.Jmp(lTop); QbeGen.PopLoop; QbeGen.EmitLabel(lEnd); .) . (* FOR with static-sign BY (literal, non-zero; 220 otherwise). Runtime direction would need a compare-select; the literal sign picks cslew/csegew at "DO" time. *) ForStat (. VAR lv: SymTab.Name; tlo, thi, tby: SymTab.TypeIndex; qlo, qhi, qby, qt, qk, qb: QbeGen.QVal; lTop, lBody, lEnd: QbeGen.QVal; by: INTEGER; ok: BOOLEAN; .) = "FOR" (. by := 1; .) GetIdent (. ok := SymTab.Lookup(lv); IF 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 (. IF NOT SymTab.IsIntFamily(tlo) THEN SemError(220); ok := FALSE END; .) "TO" Expr (. IF NOT SymTab.IsIntFamily(thi) THEN SemError(220); ok := FALSE END; .) [ "BY" Expr (. IF (tby # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(tby) THEN SemError(220); ok := FALSE END; IF NOT SymTab.ConstInt(qby, by) THEN SemError(230); by := 1 ELSIF by = 0 THEN SemError(220); by := 1 END; .) ] "DO" (. IF ok THEN QbeGen.StoreVar(lv, qlo, FALSE) END; QbeGen.NewLabel(lTop); QbeGen.NewLabel(lBody); QbeGen.NewLabel(lEnd); QbeGen.EmitLabel(lTop); QbeGen.LoadVar(lv, FALSE, qt); QbeGen.NewTemp(qk); IF by > 0 THEN QbeGen.Op3("cslew", qk, qt, qhi, FALSE) ELSE QbeGen.Op3("csgew", qk, qt, qhi, FALSE) END; QbeGen.Jnz(qk, lBody, lEnd); QbeGen.EmitLabel(lBody); .) [ StatSeq ] "END" (. IF ok THEN QbeGen.LoadVar(lv, FALSE, qt); QbeGen.IntStr(by, qb); QbeGen.NewTemp(qk); QbeGen.Op3("add", qk, qt, qb, FALSE); QbeGen.StoreVar(lv, qk, FALSE) END; QbeGen.Jmp(lTop); QbeGen.EmitLabel(lEnd); .) . CaseStat (. VAR tsel: SymTab.TypeIndex; qsel, lEnd: QbeGen.QVal; .) = "CASE" Expr (. QbeGen.NewLabel(lEnd); .) "OF" CaseAlt { "|" CaseAlt } [ "ELSE" [ StatSeq ] ] "END" (. QbeGen.EmitLabel(lEnd); .) . (* Compare-chain lowering: each alternative ends its match-tests with "jmp lAfter", so the no-match fallthrough skips the body: "cmp; jnz(lBody,lF); lF: ... ; jmp lAfter; lBody: S; jmp lEnd; lAfter:". Falls into the next alternative, ELSE, or END. *) CaseAlt (. VAR lBody, lAfter: QbeGen.QVal; .) = (. QbeGen.NewLabel(lBody); QbeGen.NewLabel(lAfter); .) CaseLabel { "," CaseLabel } ":" (. QbeGen.Jmp(lAfter); QbeGen.EmitLabel(lBody); .) [ StatSeq ] (. QbeGen.Jmp(lEnd); QbeGen.EmitLabel(lAfter); .) . CaseLabel (. VAR t2, t3: SymTab.TypeIndex; q2, q3, qc, qd, qe: QbeGen.QVal; lNext: QbeGen.QVal; .) = Expr (. IF (t2 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND ((SymTab.ClassOf(t2) = SymTab.ClSet) OR (SymTab.ClassOf(tsel) = SymTab.ClSet)) THEN SemError(230) ELSIF (t2 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND NOT SymTab.EqCheck(t2, tsel) THEN SemError(213) END; IF NOT QbeGen.IsImm(q2) THEN SemError(230); QbeGen.CopyOp("0", q2) END; QbeGen.NewLabel(lNext); QbeGen.Cmp(SymTab.OpEq, qsel, q2, qc, FALSE); QbeGen.Jnz(qc, lBody, lNext); QbeGen.EmitLabel(lNext); .) [ ".." Expr (. IF (t3 # SymTab.InvalidType) AND (tsel # SymTab.InvalidType) AND NOT SymTab.EqCheck(t3, tsel) THEN SemError(213) END; IF NOT QbeGen.IsImm(q3) THEN SemError(230); QbeGen.CopyOp("0", q3) END; QbeGen.Cmp(SymTab.OpGe, qsel, q2, qc, FALSE); QbeGen.Cmp(SymTab.OpLe, qsel, q3, qd, FALSE); QbeGen.NewTemp(qe); QbeGen.Op3("and", qe, qc, qd, FALSE); QbeGen.NewLabel(lNext); QbeGen.Jnz(qe, lBody, lNext); QbeGen.EmitLabel(lNext); .) ] . ReturnStat (. VAR t: SymTab.TypeIndex; q, qt: QbeGen.QVal; res: SymTab.TypeIndex; hadE, conv: BOOLEAN; .) = "RETURN" (. hadE := FALSE; .) [ Expr (. hadE := TRUE; .) ] (. conv := FALSE; IF NOT SymTab.InProc() THEN SemError(232) ELSE res := SymTab.CurRes(); IF NOT hadE THEN IF res # SymTab.InvalidType THEN SemError(232) ELSE QbeGen.EmitRet(q, FALSE) END ELSIF (res = SymTab.InvalidType) OR (t # SymTab.InvalidType) AND NOT SymTab.Assignable(t, res) THEN SemError(232) ELSE conv := (SymTab.ClassOf( res) = SymTab.ClReal) AND SymTab.IsIntFamily(t); IF conv THEN QbeGen.ConvIR(q, qt); QbeGen.EmitRet(qt, TRUE) ELSE QbeGen.EmitRet(q, TRUE) END END END; .) . HaltStat (. VAR t: SymTab.TypeIndex; q: QbeGen.QVal; .) = "HALT" [ "(" Expr ")" ] (. QbeGen.HaltQ; .) . (* Designator: scalar loads, array addresses, and index suffixes. Each index descends one level (bounds-checked, trap on breach); nested levels reload the inner descriptor address. q ends as the value (scalars), the descriptor address (plain arrays), or the element address (indexed); sfx marks the indexed form. *) Design (. VAR n, fn, mal: SymTab.Name; cls: INTEGER; curT, it, eT, bt: SymTab.TypeIndex; iq, ql, qlo, qhi, qe: QbeGen.QVal; lo, hi: INTEGER; fo: INTEGER; isOpen: BOOLEAN; qb, cv: QbeGen.QVal; .) = GetIdent (. QbeGen.CopyOp(n, qn); sfx := FALSE; IF NOT SymTab.Lookup(n) THEN SemError(201); t := SymTab.InvalidType; k := -1; QbeGen.CopyOp("0", q) ELSE t := SymTab.SymType(n); k := SymTab.SymKind(n); IF k = SymTab.KindConst THEN IF SymTab.Equal(n, "TRUE") THEN t := SymTab.BoolType(); QbeGen.CopyOp("1", q) ELSIF SymTab.Equal(n, "FALSE") THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) 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.ClNil)) THEN IF cls = SymTab.ClNil THEN QbeGen.CopyOp("0", q) ELSIF ((cls = SymTab.ClInt) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClEnum)) AND SymTab.GetSymVal(n, cv) AND QbeGen.IsImm(cv) THEN QbeGen.CopyOp(cv, q) ELSE QbeGen.LoadVar(n, cls = SymTab.ClReal, q) END ELSE IF t # SymTab.InvalidType THEN SemError(230) END; QbeGen.CopyOp("0", q) END END ELSIF (k = SymTab.KindVar) OR (k = SymTab.KindParam) THEN cls := SymTab.ClassOf(t); IF (cls = SymTab.ClInt) OR (cls = SymTab.ClBool) OR (cls = SymTab.ClChar) OR (cls = SymTab.ClUChar) OR (cls = SymTab.ClEnum) OR (cls = SymTab.ClReal) THEN QbeGen.LoadVar(n, cls = SymTab.ClReal, q) ELSIF (cls = SymTab.ClPtr) OR (cls = SymTab.ClProc) THEN QbeGen.LoadPtr(n, q) ELSIF cls = SymTab.ClLong THEN QbeGen.LoadLong(n, q) ELSIF (cls = SymTab.ClArray) OR (cls = SymTab.ClSet) OR (cls = SymTab.ClRecord) OR (cls = SymTab.ClUStr) OR (cls = SymTab.ClClass) THEN QbeGen.AddrOf(n, q) ELSE SemError(230); QbeGen.CopyOp("0", q) END ELSE QbeGen.CopyOp("0", q); IF k = SymTab.KindImport THEN SemError(230) ELSIF k = SymTab.KindProc THEN (* bare procedure name: a following ArgList makes it a call; otherwise Fact reports 230 *) ELSE IF k = SymTab.KindField THEN IF QbeGen.TopWith(qb) THEN fo := SymTab.FieldOffset( SymTab.FieldOwner(n), n); QbeGen.FieldAddr(qb, fo, q); sfx := TRUE ELSE SemError(230); QbeGen.CopyOp("0", q) END END END END END; .) { "[" Expr (. 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) THEN SemError(218); t := SymTab.InvalidType ELSE QbeGen.WidenIndex(iq, ql); isOpen := SymTab.IsOpenArray(t); IF isOpen THEN QbeGen.CopyOp("0", qlo); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN QbeGen.OpenHiChar(q, qhi) ELSE QbeGen.OpenHi(q, qhi) END ELSE lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN hi := hi + 1 END; QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi) END; QbeGen.CheckRange(ql, qlo, qhi); eT := SymTab.ArrayElem(t); QbeGen.ElemAddr(q, ql, qlo, t, qe); IF SymTab.ClassOf(eT) = SymTab.ClArray THEN QbeGen.ElemLoad(qe, eT, q) ELSE QbeGen.CopyOp(qe, q) END; t := eT; sfx := TRUE END; .) { "," Expr (. 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) THEN SemError(218); t := SymTab.InvalidType ELSE QbeGen.WidenIndex(iq, ql); isOpen := SymTab.IsOpenArray(t); IF isOpen THEN QbeGen.CopyOp("0", qlo); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN QbeGen.OpenHiChar(q, qhi) ELSE QbeGen.OpenHi(q, qhi) END ELSE lo := SymTab.ArrayLo(t); hi := SymTab.ArrayHi(t); IF SymTab.IsCharArray(t) OR SymTab.IsUCharArray(t) THEN hi := hi + 1 END; QbeGen.IntStr(lo, qlo); QbeGen.IntStr(hi, qhi) END; QbeGen.CheckRange(ql, qlo, qhi); eT := SymTab.ArrayElem(t); QbeGen.ElemAddr(q, ql, qlo, t, qe); IF SymTab.ClassOf(eT) = SymTab.ClArray THEN QbeGen.ElemLoad(qe, eT, q) ELSE QbeGen.CopyOp(qe, q) END; t := eT; sfx := TRUE END; .) } "]" | "." GetIdent (. IF k = SymTab.KindModule THEN (* qualified L.x: materialize the export, then load it *) IF NOT SymTab.MaterializeAlias(n, fn, mal) THEN SemError(201); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE QbeGen.CopyOp(mal, qn); t := SymTab.SymType(mal); k := SymTab.SymKind(mal); sfx := FALSE; IF k = SymTab.KindProc THEN (* call: ArgList supplies the value *) QbeGen.CopyOp("0", q) ELSIF NOT QbeGen.LoadDesignator( mal, t, k, q) THEN SemError(230); QbeGen.CopyOp("0", q) END END ELSIF t = SymTab.InvalidType THEN ELSIF (SymTab.ClassOf(t) # SymTab.ClRecord) AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN SemError(215); t := SymTab.InvalidType ELSIF NOT SymTab.FieldExists(t, fn) THEN SemError(216); t := SymTab.InvalidType ELSE fo := SymTab.FieldOffset(t, fn); t := SymTab.FieldType(t, fn); QbeGen.FieldAddr(q, fo, qe); (* array fields are inline: the field address is the descriptor, like records *) QbeGen.CopyOp(qe, q); sfx := TRUE END; .) | "^" (. IF t = SymTab.InvalidType THEN ELSIF SymTab.ClassOf(t) # SymTab.ClPtr THEN SemError(219); t := SymTab.InvalidType ELSE bt := SymTab.PtrBase(t); IF bt = SymTab.InvalidType THEN ELSE IF sfx THEN QbeGen.ElemLoad(q, t, qb); QbeGen.CopyOp(qb, q) END; t := bt; (* q holds the pointee address: Fact loads scalars/pointers and uses the address for aggregates; the VAR-actual note is q itself. *) sfx := TRUE END END; .) } . Expr (. VAR t2: SymTab.TypeIndex; op: INTEGER; q2, qt, wl: QbeGen.QVal; isR: BOOLEAN; .) = SimExpr [ Rel SimExpr (. IF op = SymTab.OpIn THEN IF SymTab.InCheck(t, t2) THEN IF (t = SymTab.InvalidType) OR (t2 = SymTab.InvalidType) THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) ELSE QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2), SymTab.SetCount(t2), qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) END ELSE SemError(222); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END ELSIF SymTab.RelCheck(t, t2, op) THEN IF (t = SymTab.InvalidType) OR (t2 = SymTab.InvalidType) THEN t := SymTab.BoolType(); QbeGen.CopyOp("0", q) ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr) OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN IF (op # SymTab.OpEq) AND (op # SymTab.OpNeq1) AND (op # SymTab.OpNeq2) THEN SemError(213); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE QbeGen.CmpL(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) END ELSIF (SymTab.ClassOf(t) = SymTab.ClSet) OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN QbeGen.CmpSet(op, q, q2, SymTab.SetWords(t), SymTab.SetWords(t2), qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSIF SymTab.StrCompat(t, t2) THEN QbeGen.StrEq(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSIF SymTab.IsLongFamily(t) OR SymTab.IsLongFamily(t2) THEN IF SymTab.IsIntFamily(t) THEN QbeGen.WidenLong(q, wl); QbeGen.CopyOp(wl, q) END; IF SymTab.IsIntFamily(t2) THEN QbeGen.WidenLong(q2, wl); QbeGen.CopyOp(wl, q2) END; QbeGen.CmpLong(op, q, q2, qt); t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) ELSE isR := SymTab.ClassOf(t) = SymTab.ClReal; t := SymTab.BoolType(); QbeGen.Cmp(op, q, q2, qt, isR); QbeGen.CopyOp(qt, q) END ELSE SemError(213); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) END; .) ] . 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: QbeGen.QVal; neg, isR, isL, folded: BOOLEAN; lw, rw, mw: CARDINAL; lTrue, lNext, lDone, qr, qs: QbeGen.QVal; .) = (. neg := FALSE; .) [ "+" | "-" (. neg := TRUE; .) ] Term (. IF neg THEN IF QbeGen.IsImm(q) THEN QbeGen.NegFold(q, q) ELSE QbeGen.NewTemp(qt); QbeGen.NegQ(q, qt, SymTab.ClassOf(t) = SymTab.ClReal); QbeGen.CopyOp(qt, q) END END; .) { AddOp (. IF op = SymTab.OpOr THEN QbeGen.DelayBegin END; .) Term (. IF op = SymTab.OpOr THEN QbeGen.DelayEnd END; .) (. IF op = SymTab.OpOr THEN (* short-circuit: if q is true the RHS is skipped *) IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.Slot4(qs); QbeGen.NewLabel(lTrue); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lDone); QbeGen.Jnz(q, lTrue, lNext); QbeGen.EmitLabel(lTrue); QbeGen.StoreW(qs, "1"); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lNext); QbeGen.DelayFlush; QbeGen.StoreW(qs, q2); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lDone); QbeGen.LoadW(qs, qr); QbeGen.CopyOp(qr, q) ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) END ELSIF (op = SymTab.OpAdd) AND (SymTab.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 *) IF SymTab.StrCompat(t, t2) THEN QbeGen.StrCat(q, q2, qt) ELSIF SymTab.IsStrType(t) THEN QbeGen.DeclCharStr(q2, qs); QbeGen.StrCat(q, qs, qt) ELSE QbeGen.DeclCharStr(q, qs); QbeGen.StrCat(qs, q2, qt) END; t := SymTab.NewStr(); QbeGen.CopyOp(qt, q) ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); mw := lw; IF rw > mw THEN mw := rw END; IF op = SymTab.OpAdd THEN QbeGen.SetBinOp(0, q, q2, lw, rw, qt) ELSE QbeGen.SetBinOp(2, q, q2, lw, rw, qt) END; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp(qt, q) ELSE IF SymTab.ArithCheck(t, t2, FALSE, res2) THEN lt := t; rt := t2; t := res2 ELSE SemError(211); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN isL := SymTab.IsLongFamily(t); isR := SymTab.ClassOf(t) = SymTab.ClReal; folded := FALSE; IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN IF op = SymTab.OpAdd THEN folded := QbeGen.Fold2(0, q, q2, qf) ELSE folded := QbeGen.Fold2(1, q, q2, qf) END END; IF folded THEN QbeGen.CopyOp(qf, q) ELSE IF isL THEN IF SymTab.IsIntFamily(lt) THEN QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) END; IF SymTab.IsIntFamily(rt) THEN QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) END; QbeGen.NewTemp(qt); IF op = SymTab.OpAdd THEN QbeGen.Op3L("add", qt, q, q2) ELSE QbeGen.Op3L("sub", qt, q, q2) END ELSE QbeGen.NewTemp(qt); IF op = SymTab.OpAdd THEN QbeGen.Op3("add", qt, q, q2, isR) ELSE QbeGen.Op3("sub", qt, q, q2, isR) END END; QbeGen.CopyOp(qt, q) END ELSE QbeGen.CopyOp("0", q) END END; .) } . AddOp = "+" (. op := SymTab.OpAdd; .) | "-" (. op := SymTab.OpSub; .) | "OR" (. op := SymTab.OpOr; .) . Term (. VAR t2, res2, lt, rt: SymTab.TypeIndex; op: INTEGER; q2, qt, wq, qf: QbeGen.QVal; isR, isL, folded: BOOLEAN; lw, rw, mw: CARDINAL; lNext, lFalse, lDone, qr, qs: QbeGen.QVal; .) = Fact { MulOp (. IF op = SymTab.OpAnd THEN QbeGen.DelayBegin END; .) Fact (. IF op = SymTab.OpAnd THEN QbeGen.DelayEnd END; .) (. IF op = SymTab.OpAnd THEN (* short-circuit: if q is false the RHS is skipped *) IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.Slot4(qs); QbeGen.NewLabel(lNext); QbeGen.NewLabel(lFalse); QbeGen.NewLabel(lDone); QbeGen.Jnz(q, lNext, lFalse); QbeGen.EmitLabel(lNext); QbeGen.DelayFlush; QbeGen.StoreW(qs, q2); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lFalse); QbeGen.StoreW(qs, "0"); QbeGen.Jmp(lDone); QbeGen.EmitLabel(lDone); QbeGen.LoadW(qs, qr); QbeGen.CopyOp(qr, q) ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) END ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) AND (SymTab.ClassOf(t) = SymTab.ClSet) AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); mw := lw; IF rw > mw THEN mw := rw END; IF op = SymTab.OpTimes THEN QbeGen.SetBinOp(1, q, q2, lw, rw, qt) ELSE QbeGen.SetBinOp(3, q, q2, lw, rw, qt) END; t := SymTab.NewSet( SymTab.NewSubR(0, VAL(INTEGER, mw) * 32 - 1)); QbeGen.CopyOp(qt, q) ELSE IF SymTab.ArithCheck(t, t2, (op = SymTab.OpDiv) OR (op = SymTab.OpMod), res2) THEN lt := t; rt := t2; t := res2 ELSE SemError(211); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN isL := SymTab.IsLongFamily(t); isR := SymTab.ClassOf(t) = SymTab.ClReal; folded := FALSE; IF (NOT isL) AND (NOT isR) AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN IF op = SymTab.OpTimes THEN folded := QbeGen.Fold2(2, q, q2, qf) ELSIF op = SymTab.OpDiv THEN folded := QbeGen.Fold2(3, q, q2, qf) ELSIF op = SymTab.OpMod THEN folded := QbeGen.Fold2(4, q, q2, qf) END END; IF folded THEN QbeGen.CopyOp(qf, q) ELSE IF isL THEN IF SymTab.IsIntFamily(lt) THEN QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) END; IF SymTab.IsIntFamily(rt) THEN QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) END; QbeGen.NewTemp(qt); IF op = SymTab.OpTimes THEN QbeGen.Op3L("mul", qt, q, q2) ELSIF (op = SymTab.OpDiv) OR (op = SymTab.OpSlash) THEN QbeGen.Op3L("div", qt, q, q2) ELSE QbeGen.Op3L("rem", qt, q, q2) END ELSE QbeGen.NewTemp(qt); IF op = SymTab.OpTimes THEN QbeGen.Op3("mul", qt, q, q2, isR) ELSIF (op = SymTab.OpDiv) OR (op = SymTab.OpSlash) THEN QbeGen.Op3("div", qt, q, q2, isR) ELSE QbeGen.Op3("rem", qt, q, q2, isR) END END; QbeGen.CopyOp(qt, q) END ELSE QbeGen.CopyOp("0", q) END END; .) } . MulOp = "*" (. op := SymTab.OpTimes; .) | "/" (. op := SymTab.OpSlash; .) | "DIV" (. op := SymTab.OpDiv; .) | "MOD" (. op := SymTab.OpMod; .) | ( "AND" | "&" ) (. op := SymTab.OpAnd; .) . Fact (. VAR s: ARRAY [0 .. 255] OF CHAR; et, dt, t2, st, ct2: SymTab.TypeIndex; dk: INTEGER; qd, q2, sq, qa, qm0, qr: QbeGen.QVal; qn, vn: SymTab.Name; vt: SymTab.TypeIndex; c1, c2: INTEGER; called, isHigh, sfx, isCh, isU, uok, isStr: BOOLEAN; ucp: INTEGER; .) = integer (. LexString(s); QbeGen.NormInt(s, q); t := SymTab.IntType(); .) | charConst (. LexString(s); QbeGen.NormLit(s, q, isCh); t := SymTab.CharType(); .) | real (. LexString(s); QbeGen.NormReal(s, q); t := SymTab.RealType(); .) | string (. LexString(s); IF SymTab.StrLen(s) = 3 THEN t := SymTab.CharType(); QbeGen.IntStr( QbeGen.CharVal(s), q) ELSE t := SymTab.NewStr(); QbeGen.DeclStr(s, q); (* a literal's value IS its static descriptor address *) QbeGen.NoteAddr(q, q) END; .) | ustring (. LexString(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(); QbeGen.NoteAddr(q, q) END; .) | Design (. called := FALSE; t := dt; IF sfx THEN IF dt = SymTab.InvalidType THEN QbeGen.CopyOp("0", q) ELSIF (SymTab.ClassOf(dt) = SymTab.ClRecord) OR (SymTab.ClassOf(dt) = SymTab.ClSet) OR (SymTab.ClassOf(dt) = SymTab.ClArray) OR (SymTab.ClassOf(dt) = SymTab.ClClass) THEN QbeGen.CopyOp(qd, q) ELSE QbeGen.ElemLoad(qd, dt, q) END ELSE QbeGen.CopyOp(qd, q) END; IF (dk = SymTab.KindVar) OR (dk = SymTab.KindParam) OR (dk = SymTab.KindField) THEN IF sfx THEN QbeGen.NoteAddr(q, qd) ELSE QbeGen.AddrOf(qn, qa); QbeGen.NoteAddr(q, qa) END ELSIF sfx AND (dt # SymTab.InvalidType) AND ((SymTab.ClassOf(dt) = SymTab.ClArray) OR (SymTab.ClassOf(dt) = SymTab.ClSet) OR (SymTab.ClassOf(dt) = SymTab.ClRecord)) THEN QbeGen.NoteAddr(qd, qd) END; .) [ TypedSetLit (. t := dt; .) ] [ ArgList (. t := ct2; QbeGen.CopyOp(q2, q); .) ] (. IF NOT called AND (dk = SymTab.KindProc) THEN (* bare zero-arg function call (parentheses may be omitted); a proper or parameterised proc here is 230 *) IF (SymTab.ProcNPar(qn) = 0) AND (SymTab.ProcRes(qn) # SymTab.InvalidType) THEN QbeGen.Mangled(qn, SymTab.ProcUid(qn), qm0); QbeGen.CallBegin(qm0, SymTab.ProcRes(qn), SymTab.ProcDepthOf(qn), SymTab.IsExternal(qn)); QbeGen.CallEnd(TRUE, q); t := SymTab.ProcRes(qn) ELSE (* procedure used as a value (assign to a procedure variable): its code address *) t := SymTab.ProcTypeOf(qn); QbeGen.Mangled(qn, SymTab.ProcUid(qn), qm0); QbeGen.ProcAddr(qm0, q) END END; .) | ( "HIGH" (. isHigh := TRUE; .) | ( "LEN" | "LENGTH" ) (. isHigh := FALSE; .) ) "(" ( Design (. isStr := FALSE; .) | string (. LexString(s); isStr := TRUE; IF SymTab.StrLen(s) = 3 THEN dt := SymTab.CharType(); QbeGen.IntStr(QbeGen.CharVal(s), qd) ELSE dt := SymTab.NewStr(); QbeGen.DeclStr(s, qd); QbeGen.NoteAddr(qd, qd) END; dk := -1; qn[0] := CHR(0); .) ) ")" (. IF isStr THEN (* fold: content length at compile time *) IF SymTab.StrLen(s) = 3 THEN c1 := 1 ELSE c1 := SymTab.StrLen(s) - 2 END; IF isHigh THEN DEC(c1) END; QbeGen.IntStr(c1, qr); t := SymTab.IntType(); QbeGen.CopyOp(qr, q) ELSIF dt = SymTab.InvalidType THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSIF SymTab.ClassOf(dt) # SymTab.ClArray THEN SemError(217); t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE IF isHigh THEN IF SymTab.IsOpenArray(dt) THEN QbeGen.OpenHi(qd, qr) ELSE QbeGen.IntStr( SymTab.ArrayHi(dt), qr) END ELSE IF SymTab.IsOpenArray(dt) THEN QbeGen.LoadCount(qd, qr) ELSE QbeGen.IntStr(VAL( INTEGER, SymTab.ArrayLen(dt)), qr) END END; t := SymTab.IntType(); QbeGen.CopyOp(qr, q) END; .) | ( "SIZE" | "TSIZE" ) "(" Design ")" (. 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; .) | "ADR" "(" Design ")" (. IF dt = SymTab.InvalidType THEN t := SymTab.InvalidType; QbeGen.CopyOp("0", q) ELSE IF sfx THEN QbeGen.CopyOp(qd, q) ELSIF (dk = SymTab.KindVar) OR (dk = SymTab.KindParam) THEN QbeGen.AddrOf(qn, q) ELSE SemError(230); QbeGen.CopyOp("0", q) END; t := SymTab.AddrType() END; .) | "CHR" "(" Expr ")" (. IF (et # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(et) THEN SemError(211) END; t := SymTab.CharType(); .) | ( "ORD" | "ORDL" ) "(" Expr ")" (. 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 ")" (. QbeGen.CapQ(q, qa); QbeGen.CopyOp(qa, q); t := SymTab.CharType(); .) | "UCHR" "(" Expr ")" (. (* 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 ")" (. IF (et # SymTab.InvalidType) AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN SemError(211) END; QbeGen.WidenLong(q, qa); QbeGen.CheckRange(qa, "0", "255"); t := SymTab.CharType(); .) | "UORD" "(" Expr ")" (. (* 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 ")" (. IF (et # SymTab.InvalidType) AND NOT SymTab.IsIntFamily(et) AND (SymTab.ClassOf(et) # SymTab.ClReal) THEN SemError(211) ELSE QbeGen.AbsQ(q, qa, SymTab.ClassOf(et) = SymTab.ClReal); QbeGen.CopyOp(qa, q) END; t := et; .) | "VAL" "(" GetIdent "," Expr ")" (. 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) 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; .) | SetLit (. t := st; QbeGen.CopyOp(sq, q); .) | ( "NOT" | "~" ) Fact (. IF SymTab.BoolCheck(t2) THEN t := SymTab.BoolType() ELSE SemError(212); t := SymTab.InvalidType END; IF t # SymTab.InvalidType THEN QbeGen.NotQ(q2, q) ELSE QbeGen.CopyOp("0", q) END; .) . (* 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 = "{" (. t := SymTab.NewSet( SymTab.NewSubR(0, 255)); QbeGen.NewSetTemp(8, q); QbeGen.SetZero(q, 8); .) [ SetElem { "," SetElem } ] "}" . (* Typed set constructor: TypeName{ elems } — e.g. BITSET{0}, BITSET{}. The declared type (not SET OF [0..255]) sets the width and element span. *) TypedSetLit (. VAR nw: CARDINAL; .) = "{" (. IF SymTab.ClassOf(vt) # SymTab.ClSet THEN SemError(230); nw := 8 ELSE nw := SymTab.SetWords(vt); IF nw = 0 THEN nw := 8 END END; QbeGen.NewSetTemp(nw, q); QbeGen.SetZero(q, nw); .) [ SetElem { "," SetElem } ] "}" . SetElem (. VAR et, et2: SymTab.TypeIndex; qe, q2: QbeGen.QVal; v, v2: INTEGER; lo: INTEGER; span: CARDINAL; cl, cl2: INTEGER; hasR: BOOLEAN; .) = (. hasR := FALSE; .) Expr [ ".." Expr (. 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 ((cl # SymTab.ClInt) AND (cl # SymTab.ClChar) AND (cl # SymTab.ClBool)) OR (hasR AND ((cl2 # SymTab.ClInt) AND (cl2 # SymTab.ClChar) AND (cl2 # SymTab.ClBool))) 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; .) . GetIdent = ident (. LexName(n); .) . END M2.