Coco/R - Compiler-Compiler V1.53 Released by Pat Terry 17 September 2002 Source file: M2.atg Grammar Tests: Deletable symbols: DeclSeq Undefined nonterminals: -- none -- Unreachable nonterminals: -- none -- Circular derivations: -- none -- Underivable nonterminals: -- none -- LL(1) conditions: LL(1) error in ProcTypeSection: ident is the start of several alternatives. LL(1) error in TypeBlock: "CLASS" is the start & successor of a deletable structure Listing: 1 COMPILER M2 2 (* Step 1 — minimal integer pipeline (m2compiler-V3). 3 Subset: program MODULE + CONST (literal) + VAR INTEGER + 4 assignment + integer expressions (+ - * DIV MOD, leading sign, 5 parens). Fresh QBE backend (QbeGen) to gen_ssa/.ssa; 6 assemble with qbe, link with cc. 7 8 Test convention: a global VAR ExitCode : INTEGER makes generated 9 $main return its value as the process exit code, else return 0. 10 11 Semantic errors reuse the V1/V2/Test2 family: 200 duplicate, 12 201 undeclared, 202 module name mismatch, 210 bad assignment, 13 211 bad arithmetic, 221 not a type, 230 not supported yet, 14 231 opaque type outside definition. 15 Scalar-phase TYPEs (named, integer subrange, enum) check fully; 16 composite forms wait for step 3. Procedure headings (formals, 17 result, FORWARD) enter scopes now; bodies parse + check with one 18 230 at END (lowering = step 4). 19 Statements: assignment, IF/ELSIF/ELSE, WHILE, REPEAT/UNTIL, 20 LOOP/EXIT (230 outside LOOP), FOR/TO/static-sign-BY, full CASE 21 (labels, ranges, ELSE; compare-chain), RETURN with 232 checks 22 (outside proc / value mismatch / missing value). WITH waits for 23 records (step 3). Boolean connectives are eager (or/and/xor); 24 relations yield 0/1 via cXXw. 25 Clarion-form classes (docs/OOP.txt): CLASS decl + single 26 inheritance + CLASS IMPLEMENTATION blocks, methods with ";" 27 (per the Table example, not the sketch's ","), VIRTUAL flagged. 28 Scopes and member checks now; lowering later (one 230 per 29 class/impl block). Classic identifiers: no underscores, so the 30 Table example's _names stay lexically out of reach. 31 Step 3.1 arrays: "ARRAY [lo..hi, ...] OF T" (folded literal 32 bounds, int/char) and open "ARRAY OF T" formals; index suffixes 33 with per-level checks (217/218, trap on breach via $abort); 34 whole-array ":=" with runtime count check + blit; string 35 literals lower as descriptors (1-char stays CHAR, empty works); 36 array/string "=" is 213 (no built-in whole comparison). 37 Step 3.3 sets: multi-word masks (no header, static words) over 38 bases ≤ 256 values; literals are SET OF [0..255] (222 on 39 out-of-span); + - * / as or/and/xor-not, IN with span trap, 40 =/# word-wise (lenient cross-base); CASE labels reject sets. 41 Step 3.4 records: flat blobs; array fields are pointers to static 42 descriptors (locked amendment — one layout per type); nested 43 records inline; static declaration-order offsets; field chains 44 mix with indexes; WITH pushes fields + bases (215/216); 45 whole-record deep copy; record/set/class "=" is 213. 46 Step 3.6 pointers: vars (l), NIL as a real type (FNil — assignment 47 and =/# work, everything else 210-214/222), ^ deref with sfx 48 discipline (address flows, load at use; chains compose), 49 pointer =/# via ceql/cnel (< > etc. are 213), NEW/DISPOSE as 50 builtin statements via extern malloc/free (recursive skeleton 51 init; DISPOSE shallow and nils, deviating from Wirth-undefined); 52 nil-deref is raw (no check). *) 53 54 IMPORT SymTab, QbeGen, AST, Lower; 55 56 VAR 57 (* Two-phase frontend (docs/plan-two-phase.md). When TRUE the 58 productions ALSO build AST nodes alongside the legacy emit path. 59 Slice 1: the nodes are inert scaffolding — nothing reads them, so 60 the emitted output is unchanged. *) 61 twoPhase: BOOLEAN; 62 63 (* Result slot for the expression-AST builder (slice 2). Every 64 Expr/SimExpr/Term/Fact leaves its node here; the combination 65 productions save it into locals before parsing the next operand. 66 `astIsLit` in Fact is per-invocation, so a nested Fact cannot make 67 an outer non-literal Fact look literal. *) 68 astCur: AST.Node; 69 70 (* Actual-argument nodes collected by ActParam for the call being 71 parsed by ArgList (slice 4). Fact resets the count before the 72 optional ArgList and then folds the nodes into an NkCall. *) 73 astNArgs: CARDINAL; 74 astArgs: ARRAY [0 .. 31] OF AST.Node; 75 76 (* Statement-AST result slot (slice 5): the most recently parsed 77 statement. StatSeq folds these into an NkBlock. *) 78 astStmt: AST.Node; 79 80 (* Declaration-AST result slot (slice 6): the most recently built 81 declaration; DeclSeq folds these into an NkDeclSeq. *) 82 astDecl: AST.Node; 83 84 (* The local declarations of the most recent Block (a procedure body); 85 ProcDecl stores them as the proc node's child 2. *) 86 astBlkDecls: AST.Node; 87 88 (* Unit-AST root (slice 7): NkUnit(name, decls, body). *) 89 astUnit: AST.Node; 90 91 (* Test-only: when TRUE the program unit is re-emitted from the AST via 92 Lower right after the legacy EndModule (before EndUnit closes the 93 module scope, so Lower can still resolve names). *) 94 lowerRequested: BOOLEAN; 95 96 (* Import accumulator (slice 11): `{ Import }` appends NkImport 97 nodes here; each unit stores them as NkUnit child[3]. *) 98 astImp, astImpTail: AST.Node; 99 100 (* Class-AST accumulators (slice 13): the class node currently being 101 parsed and its parent/field/method lists. Classes are not nested 102 inside one another, so module-level state is safe. *) 103 astCls, astClsP, astClsPTail, astClsF, astClsFTail, 104 astClsM, astClsMTail, astMethod: AST.Node; 105 106 (* Class of the method named by the last `obj.Method` designator 107 (InvalidType when the callee is an ordinary procedure). Set by 108 Design, consumed by the following ArgList. *) 109 methCls: SymTab.TypeIndex; 110 (* Class of the type of the innermost `TypeName{...}` brace 111 constructor (ClSet or ClArray); dispatches BraceElem. *) 112 braceCls: INTEGER; 113 (* Module-level VAR declarations whose type was still an unresolved 114 forward alias at declaration time; emitted once the TYPE block 115 completes (module scope only). *) 116 nPendVar: CARDINAL; 117 pendVarName: ARRAY [0 .. 255] OF SymTab.Name; 118 pendVarT: ARRAY [0 .. 255] OF SymTab.TypeIndex; 119 (* Forward module-level variables referenced from a procedure body. *) 120 nFvarRefs: CARDINAL; 121 fvarId: ARRAY [0 .. 255] OF INTEGER; 122 fvarSlot: ARRAY [0 .. 255] OF INTEGER; 123 124 PROCEDURE FlushPend; 125 (* Emit module-level globals whose forward type is now resolved. *) 126 VAR k: CARDINAL; 127 BEGIN 128 k := 0; 129 WHILE k < nPendVar DO 130 QbeGen.DeclVar(pendVarName[k], pendVarT[k]); 131 INC(k) 132 END; 133 nPendVar := 0 134 END FlushPend; 135 136 PROCEDURE FwdVarNote (id, slot: INTEGER); 137 BEGIN 138 IF nFvarRefs <= HIGH(fvarId) THEN 139 fvarId[nFvarRefs] := id; 140 fvarSlot[nFvarRefs] := slot; 141 INC(nFvarRefs) 142 END 143 END FwdVarNote; 144 145 PROCEDURE FwdVarFlush; 146 (* At module end: resolve every forward reference against the declared 147 names (an unresolved one is 201) and patch its placeholder symbol. *) 148 VAR k: CARDINAL; nm, g: SymTab.Name; cls: INTEGER; oper: CHAR; 149 t: SymTab.TypeIndex; ok: BOOLEAN; 150 BEGIN 151 k := 0; 152 WHILE k < nFvarRefs DO 153 SymTab.FwdVarName(fvarId[k], nm); 154 IF nm[0] # CHR(0) THEN 155 IF NOT SymTab.FwdVarResolve(fvarId[k]) THEN 156 SemError(201) 157 ELSE 158 t := SymTab.FwdVarType(fvarId[k]); 159 cls := SymTab.ClassOf(t); 160 IF cls = SymTab.ClReal THEN oper := "d" 161 ELSIF SymTab.IsLongFamily(t) THEN oper := "l" 162 ELSE oper := "w" 163 END; 164 ok := SymTab.GlobalRef(nm, g); 165 QbeGen.FwdPatch(fvarSlot[k], fvarSlot[k], nm, oper, ok) 166 END 167 END; 168 INC(k) 169 END; 170 nFvarRefs := 0 171 END FwdVarFlush; 172 173 PROCEDURE AstCallNode (callee: AST.Node) : AST.Node; 174 (* Builds NkCall(callee, actuals...) from astArgs/astNArgs. *) 175 VAR n: AST.Node; j: CARDINAL; 176 BEGIN 177 n := AST.MakeNode(AST.NkCall); 178 AST.SetChild(n, 0, callee); 179 j := 0; 180 WHILE (j < astNArgs) AND (AST.NChild(n) < AST.MaxChild) DO 181 AST.SetChild(n, AST.NChild(n), astArgs[j]); INC(j) 182 END; 183 RETURN n 184 END AstCallNode; 185 186 PROCEDURE AstAppend (kind: INTEGER; VAR head, tail: AST.Node; 187 item: AST.Node); 188 (* Appends `item` to a chunked sequence: each node holds up to 189 AST.MaxChild-1 items; child[MaxChild-1] continues into the next 190 chunk. Unbounded, so blocks/decl sequences are not capped at 8. *) 191 VAR n: AST.Node; 192 BEGIN 193 IF item = AST.NoNode THEN RETURN END; 194 IF head = AST.NoNode THEN 195 head := AST.MakeNode(kind); tail := head 196 END; 197 IF AST.NChild(tail) >= AST.MaxChild - 1 THEN 198 n := AST.MakeNode(kind); 199 AST.SetChild(tail, AST.MaxChild - 1, n); 200 tail := n 201 END; 202 AST.SetChild(tail, AST.NChild(tail), item) 203 END AstAppend; 204 205 PROCEDURE GetUnit (): AST.Node; 206 (* The most recently parsed unit's AST root (for the Lower comparison). *) 207 BEGIN 208 RETURN astUnit 209 END GetUnit; 210 211 PROCEDURE SetLower (b: BOOLEAN); 212 (* Enables the test-only Lower re-emit at program-unit end. *) 213 BEGIN 214 lowerRequested := b 215 END SetLower; 216 217 CHARACTERS 218 eol = CHR(13) . 219 lf = CHR(10) . 220 letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" . 221 digit = "0123456789" . 222 hexDigit = digit + "ABCDEFabcdef" . 223 noQuote1 = ANY - "'" - eol . 224 noQuote2 = ANY - '"' - eol . 225 226 IGNORE CHR(9) .. CHR(13) 227 228 COMMENTS FROM "(*" TO "*)" NESTED 229 COMMENTS FROM "//" TO lf 230 231 TOKENS 232 ident = letter { letter | digit | "_" } . 233 integer = digit { digit } 234 | digit { digit } CONTEXT("..") 235 | "0x" hexDigit { hexDigit } 236 | "0X" hexDigit { hexDigit } . 237 real = digit { digit } "." { digit } 238 [ ( "E" | "e" ) [ "+" | "-" ] digit { digit } ] . 239 string = "'" { noQuote1 } "'" 240 | '"' { noQuote2 } '"' . 241 charConst = digit { digit } ( "C" | "c" ) . 242 ustring = ( "U" | "u" ) ( "'" { noQuote1 } "'" | '"' { noQuote2 } '"' ) . 243 244 PRODUCTIONS 245 M2 246 = (. AST.Init; twoPhase := TRUE; astCur := AST.NoNode; astStmt := AST.NoNode; astDecl := AST.NoNode; astImp := AST.NoNode; astImpTail := AST.NoNode; Lower.Reset; 247 astImp := AST.NoNode; 248 astImpTail := AST.NoNode; .) 249 Unit "." (. FileIO.WriteString(FileIO.StdOut, "ASTDUMP:"); FileIO.WriteLn(FileIO.StdOut); AST.Dump(astUnit, 0); .) . 250 (* Units: program modules compile fully; DEFINITION and 251 IMPLEMENTATION modules parse + check now but lower in step 4 252 (each ends with one 230); same for nested local modules. *) 253 Unit 254 = DefUnit 255 | ImplUnit 256 | ProgModule . 257 (* Step 4.3: one session compiles DEFINITION, its IMPLEMENTATION 258 and one program (last) into one image. Units share the symbol 259 table; imports materialize exported names. *) 260 DefUnit (. VAR m1, m2, pn: SymTab.Name; .) 261 = "DEFINITION" "MODULE" 262 GetIdent (. IF NOT SymTab.BeginDef(m1) THEN 263 SemError(200) END; 264 QbeGen.SetModule(m1); .) 265 ";" 266 { Import (. AstAppend(AST.NkDeclSeq, 267 astImp, astImpTail, astDecl); .) } 268 [ "EXPORT" [ "QUALIFIED" ] (. (* definition-module export 269 list: parsed, and the 270 names are already exported 271 by the module scope *) .) 272 GetIdent { "," GetIdent } ";" ] 273 { ConstBlock | TypeBlock | VarBlock 274 | ProcHeading ";" 275 (. SymTab.CloseProc; 276 QbeGen.AbortFunc; .) } 277 (. astUnit := AST.MakeNode(AST.NkUnit); 278 AST.SetChild(astUnit, 0, 279 AST.MakeLeaf(AST.NkIdent, m1)); 280 AST.SetChild(astUnit, 1, astDecl); 281 AST.SetChild(astUnit, 3, astImp); 282 astDecl := AST.NoNode; 283 astStmt := AST.NoNode; .) 284 "END" 285 GetIdent (. IF NOT SymTab.Equal(m1, m2) THEN 286 SemError(202) END; 287 SymTab.EndUnit; .) . 288 ImplUnit (. VAR m1, m2: SymTab.Name; 289 k: CARDINAL; 290 fname: SymTab.Name; 291 unres: BOOLEAN; 292 astNode: AST.Node; .) 293 = "IMPLEMENTATION" "MODULE" 294 GetIdent (. IF NOT SymTab.BeginImpl(m1) THEN 295 SemError(201) END; 296 astStmt := AST.NoNode; 297 astDecl := AST.NoNode; 298 astImp := AST.NoNode; 299 astImpTail := AST.NoNode; 300 nPendVar := 0; 301 QbeGen.SetModule(m1); .) 302 ";" 303 { Import (. AstAppend(AST.NkDeclSeq, 304 astImp, astImpTail, astDecl); .) } 305 DeclSeq 306 [ "BEGIN" (. FlushPend; 307 k := 0; 308 WHILE k < SymTab.FwdPending() DO 309 SymTab.FwdInfo(k, fname, unres); 310 IF unres THEN SemError(201) END; 311 INC(k) 312 END; 313 SymTab.FwdClear; 314 FwdVarFlush; 315 QbeGen.BeginInit(m1); .) 316 [ StatSeq ] (. QbeGen.EndInit; .) ] 317 "END" 318 GetIdent (. FlushPend; 319 k := 0; 320 WHILE k < SymTab.FwdPending() DO 321 SymTab.FwdInfo(k, fname, unres); 322 IF unres THEN SemError(201) END; 323 INC(k) 324 END; 325 SymTab.FwdClear; 326 FwdVarFlush; 327 astNode := AST.MakeNode(AST.NkUnit); 328 AST.SetChild(astNode, 0, 329 AST.MakeLeaf(AST.NkIdent, m1)); 330 AST.SetChild(astNode, 1, astDecl); 331 AST.SetChild(astNode, 2, astStmt); 332 AST.SetChild(astNode, 3, astImp); 333 astUnit := astNode; 334 IF NOT SymTab.Equal(m1, m2) THEN 335 SemError(202) END; 336 SymTab.EndUnit; .) . 337 ProgModule (. VAR m1, m2: SymTab.Name; 338 k: CARDINAL; 339 fname: SymTab.Name; 340 unres: BOOLEAN; 341 astNode: AST.Node; .) 342 = "MODULE" 343 GetIdent (. IF NOT SymTab.BeginProg(m1) THEN 344 SemError(200) END; 345 astStmt := AST.NoNode; 346 astDecl := AST.NoNode; 347 astImp := AST.NoNode; 348 astImpTail := AST.NoNode; 349 nPendVar := 0; 350 QbeGen.SetModule(m1); .) 351 [ Priority ] 352 ";" 353 { Import (. AstAppend(AST.NkDeclSeq, 354 astImp, astImpTail, astDecl); .) } 355 DeclSeq 356 [ "BEGIN" (. FlushPend; 357 k := 0; 358 WHILE k < SymTab.FwdPending() DO 359 SymTab.FwdInfo(k, fname, unres); 360 IF unres THEN SemError(201) END; 361 INC(k) 362 END; 363 SymTab.FwdClear; 364 FwdVarFlush; 365 QbeGen.BeginBody; .) 366 [ StatSeq ] ] 367 "END" 368 GetIdent (. FlushPend; 369 k := 0; 370 WHILE k < SymTab.FwdPending() DO 371 SymTab.FwdInfo(k, fname, unres); 372 IF unres THEN SemError(201) END; 373 INC(k) 374 END; 375 SymTab.FwdClear; 376 FwdVarFlush; 377 IF NOT SymTab.Equal(m1, m2) THEN 378 SemError(202) END; 379 astNode := AST.MakeNode(AST.NkUnit); 380 AST.SetChild(astNode, 0, 381 AST.MakeLeaf(AST.NkIdent, m1)); 382 AST.SetChild(astNode, 1, astDecl); 383 AST.SetChild(astNode, 2, astStmt); 384 AST.SetChild(astNode, 3, astImp); 385 astUnit := astNode; 386 QbeGen.EndModule(m1); 387 IF lowerRequested 388 AND Lower.CanLower(astNode) THEN 389 Lower.LowerUnit(astNode) 390 END; 391 SymTab.EndUnit; .) . 392 DeclSeq (. VAR astSeq, astTail: AST.Node; .) 393 = (. astSeq := AST.NoNode; 394 astTail := AST.NoNode; .) 395 { (. astDecl := AST.NoNode; .) 396 ( ConstBlock | TypeBlock | VarBlock | ProcDecl ";" 397 | NestedModule ";" | ClassItem ";" ) 398 (. AstAppend(AST.NkDeclSeq, 399 astSeq, astTail, astDecl); .) } 400 (. astDecl := astSeq; .) . 401 (* Local module, Wirth form. Declarations lower like top-level ones 402 (same QBE module prefix); a BEGIN body becomes an init function 403 that main calls; the EXPORT list is hoisted into the enclosing 404 scope at END. *) 405 NestedModule (. VAR m1, m2: SymTab.Name; 406 expNames: ARRAY [0 .. 63] OF SymTab.Name; 407 expCount, k: CARDINAL; 408 astNode, nImp, nImpTail: 409 AST.Node; .) 410 = "MODULE" 411 GetIdent (. IF NOT SymTab.Enter(m1, 412 SymTab.KindModule) THEN 413 SemError(200) END; 414 SymTab.PushScope; 415 expCount := 0; 416 astNode := AST.MakeNode(AST.NkUnit); 417 AST.SetChild(astNode, 0, 418 AST.MakeLeaf(AST.NkIdent, m1)); 419 astStmt := AST.NoNode; 420 astDecl := AST.NoNode; 421 nImp := AST.NoNode; 422 nImpTail := AST.NoNode; .) 423 [ Priority ] 424 ";" 425 { Import (. AstAppend(AST.NkDeclSeq, 426 nImp, nImpTail, astDecl); .) } 427 [ "EXPORT" [ "QUALIFIED" ] 428 GetIdent (. INC(expCount); .) 429 { "," GetIdent 430 (. INC(expCount); .) } 431 ";" ] 432 DeclSeq 433 [ "BEGIN" (. astStmt := AST.NoNode; 434 QbeGen.BeginInit(m1); .) 435 [ StatSeq ] (. QbeGen.EndInit; .) ] 436 "END" 437 GetIdent (. AST.SetChild(astNode, 1, astDecl); 438 AST.SetChild(astNode, 2, astStmt); 439 AST.SetChild(astNode, 3, nImp); 440 astDecl := astNode; 441 IF NOT SymTab.Equal(m1, m2) THEN 442 SemError(202) END; 443 k := 0; 444 WHILE k < expCount DO 445 SymTab.ExportUp(expNames[k]); 446 INC(k) 447 END; 448 SymTab.PopScope; .) . 449 Priority 450 = "[" integer "]" (. SemError(230); .) . 451 (* Imports (4.3): FROM materializes the names (unqualified use); 452 plain IMPORT only demands the module exists — qualified `L.x` 453 materializes on first use (Design). *) 454 (* Unknown modules stay unchecked stubs (legacy, so hand-written 455 import lines don't fail); a known module's missing export is 456 201. *) 457 Import (. VAR n: SymTab.Name; 458 astImport: AST.Node; .) 459 = "FROM" 460 GetIdent (. astImport := AST.MakeNode(AST.NkImport); 461 AST.SetChild(astImport, 0, 462 AST.MakeLeaf(AST.NkIdent, n)); .) 463 "IMPORT" 464 ImpList ";" (. astDecl := astImport; .) 465 | "IMPORT" (. astImport := AST.MakeNode(AST.NkImport); .) 466 ImpModList ";" (. astDecl := astImport; .) . 467 ImpList 468 (. VAR n: SymTab.Name; .) 469 = ImpName 470 { "," ImpName } . 471 (* Pervasive built-ins imported from SYSTEM (e.g. TSIZE) are 472 accepted and ignored: the built-in applies regardless. *) 473 ImpName 474 (. VAR n: SymTab.Name; .) 475 = GetIdent (. AST.SetChild(node, AST.NChild(node), 476 AST.MakeLeaf(AST.NkIdent, n)); 477 IF SymTab.Equal(mod, "libc") THEN 478 (* intrinsic C library: 479 permissive external *) 480 IF NOT SymTab.DeclareCProc(n) THEN 481 SemError(201) END 482 ELSIF SymTab.ModKnown(mod) 483 AND NOT SymTab.ImportFrom(mod, n) THEN 484 SemError(201) END; .) 485 | ( "TSIZE" | "SIZE" | "ADR" | "HIGH" | "LEN" 486 | "CHR" | "ORD" | "ORDL" | "VAL" | "ABS" | "CAP" 487 | "UCHR" | "CHR8" | "UORD" 488 | "INC" | "DEC" ) . 489 ImpModList (. VAR n: SymTab.Name; .) 490 = GetIdent (. AST.SetChild(node, AST.NChild(node), 491 AST.MakeLeaf(AST.NkIdent, n)); .) 492 { "," GetIdent (. AST.SetChild(node, AST.NChild(node), 493 AST.MakeLeaf(AST.NkIdent, n)); .) } . 494 (* Opaque TYPE declarations (definition modules). The targetless 495 alias resolves to InvalidType until step 4 completes it. *) 496 (* Scalar-phase TYPEs: named types, integer subranges, enumerations. 497 Opaque "TYPE T;" needs isDef (definition units); elsewhere 231. 498 Composite forms (ARRAY/RECORD/SET/POINTER) arrive with step 3. *) 499 TypeBlock (. VAR astSeq, astTail: AST.Node; .) 500 = "TYPE" (. SymTab.BeginTypeBlock; 501 astSeq := AST.NoNode; 502 astTail := AST.NoNode; .) 503 { (. astDecl := AST.NoNode; .) 504 ( TypeItem ";" | ClassItem ";" ) 505 (. AstAppend(AST.NkDeclSeq, 506 astSeq, astTail, astDecl); .) } 507 (. SymTab.EndTypeBlock; 508 astDecl := astSeq; .) . 509 TypeItem (. VAR n: SymTab.Name; 510 t, op: SymTab.TypeIndex; 511 astNode: AST.Node; .) 512 = GetIdent (. op := SymTab.OpaqueBase(n); 513 IF op = SymTab.InvalidType THEN 514 IF NOT SymTab.Enter(n, 515 SymTab.KindType) THEN 516 SemError(200) END 517 END; .) 518 ( "=" Type (. astNode := AST.MakeNode(AST.NkTypeDecl); 519 AST.SetChild(astNode, 0, 520 AST.MakeLeaf(AST.NkIdent, n)); 521 AST.SetTy(astNode, t); 522 astDecl := astNode; 523 IF op # SymTab.InvalidType THEN 524 SymTab.SetTarget(op, t) 525 ELSE SymTab.SetSymType(n, t) 526 END; .) 527 | (. IF op # SymTab.InvalidType THEN 528 (* stays opaque *) 529 ELSIF NOT isDef THEN 530 SemError(231) 531 ELSE SymTab.SetSymType(n, 532 SymTab.NewAlias()) END; .) ) . 533 Type 534 = TypeIdent [ Subrange ] (* anchored subrange: T[lo..hi] *) 535 | Subrange 536 | Enum 537 | ArrayType 538 | SetType 539 | RecordType 540 | PointerType 541 | ProcType . 542 PointerType (. VAR base: SymTab.TypeIndex; .) 543 = "POINTER" "TO" Type(. t := SymTab.NewPtr(base); .) . 544 (* Procedure types (step 8.5): PROCEDURE (params): result. Values 545 are code pointers; params are collected into the descriptor. *) 546 ProcType (. VAR res, pt: SymTab.TypeIndex; 547 isV: BOOLEAN; .) 548 = "PROCEDURE" (. res := SymTab.InvalidType; 549 t := SymTab.NewProcType(res); .) 550 [ "(" [ ProcTypeSection { ";" ProcTypeSection } ] ")" ] 551 [ ":" TypeIdent (. SymTab.SetProcTypeRes(t, res); .) ] . 552 ProcTypeSection (. VAR pt: SymTab.TypeIndex; 553 isV: BOOLEAN; 554 cnt, k: CARDINAL; 555 names: ARRAY [0 .. 15] OF SymTab.Name; .) 556 = (. isV := FALSE; cnt := 0; .) 557 [ "VAR" (. isV := TRUE; .) ] 558 ( GetIdent (. INC(cnt); .) 559 { "," GetIdent (. INC(cnt); .) } 560 ( ":" Type (. k := 0; 561 WHILE k < cnt DO 562 SymTab.ProcTypeAdd(t, isV, pt); 563 INC(k) 564 END; .) 565 | (. (* type-only parameter list: 566 each name is a type (GNU 567 shorthand used by the 568 Coco/R scanner frame) *) 569 k := 0; 570 WHILE k < cnt DO 571 IF SymTab.Lookup(names[k]) 572 AND ((SymTab.SymKind(names[k]) = SymTab.KindType) 573 OR (SymTab.SymKind(names[k]) = SymTab.KindPredef)) THEN 574 pt := SymTab.SymType(names[k]) 575 ELSE SemError(201); 576 pt := SymTab.InvalidType 577 END; 578 SymTab.ProcTypeAdd(t, isV, pt); 579 INC(k) 580 END; .) ) 581 | Type (. (* unnamed parameter (PIM): 582 e.g. PROCEDURE (VAR ARRAY OF REAL) *) 583 SymTab.ProcTypeAdd(t, isV, pt); .) ) . 584 (* Arrays: "OF" without bounds is an open formal (allowed only 585 where allowOpen); "[lo..hi, ...]" nests bounded levels inside 586 out. Bounds are folded literals (int/char); anything else 230. 587 Bare-type indices ("ARRAY Color OF") wait for enum ordinals. *) 588 ArrayType 589 (. VAR elem: SymTab.TypeIndex; 590 ok: BOOLEAN; 591 bnds, bndh: ARRAY [0 .. 7] OF INTEGER; 592 nb, k: CARDINAL; 593 idx: SymTab.TypeIndex; 594 ilo, ihi: INTEGER; .) 595 = "ARRAY" 596 ( "OF" Type (. IF NOT allowOpen THEN 597 SemError(230) END; 598 t := SymTab.NewOpenArray(elem); .) 599 | TypeIdent [ Subrange ] 600 "OF" Type (. (* index-type array: the index 601 type's ordinal bounds give the 602 [lo..hi] pair *) 603 IF SymTab.TypeBounds(idx, ilo, 604 ihi) 605 THEN t := SymTab.NewArrayB(elem, 606 ilo, ihi) 607 ELSE SemError(230); 608 t := SymTab.InvalidType 609 END; .) 610 | "[" (. SymTab.BoundBegin; ok := TRUE; .) 611 BoundPair 612 { "," BoundPair } 613 "]" (. (* snapshot before the element 614 type, which reuses the bound 615 buffer for a nested ARRAY *) 616 nb := SymTab.BoundCount(); 617 k := 0; 618 WHILE k < nb DO 619 bnds[k] := SymTab.BoundLo(k); 620 bndh[k] := SymTab.BoundHi(k); 621 INC(k) 622 END; .) 623 "OF" Type 624 (. IF ok THEN 625 k := nb; 626 WHILE k > 0 DO 627 DEC(k); 628 elem := SymTab.NewArrayB( 629 elem, bnds[k], bndh[k]) 630 END; 631 t := elem 632 ELSE t := SymTab.InvalidType 633 END; .) ) . 634 BoundPair (. VAR tlo, thi: SymTab.TypeIndex; 635 qlo, qhi: QbeGen.QVal; 636 lo, hi: INTEGER; 637 cl, cl2: INTEGER; .) 638 = Expr ".." Expr 639 (. IF (tlo = SymTab.InvalidType) 640 OR (thi = SymTab.InvalidType) THEN 641 ok := FALSE 642 ELSE cl := SymTab.ClassOf(tlo); 643 cl2 := SymTab.ClassOf(thi); 644 IF ((cl # SymTab.ClInt) 645 AND (cl # SymTab.ClChar)) 646 OR ((cl2 # SymTab.ClInt) 647 AND (cl2 # SymTab.ClChar)) THEN 648 SemError(230); ok := FALSE 649 ELSIF NOT SymTab.ConstInt(qlo, lo) 650 OR NOT SymTab.ConstInt(qhi, hi) 651 OR (lo > hi) THEN 652 SemError(230); ok := FALSE 653 ELSIF NOT SymTab.BoundAdd(lo, hi) THEN 654 SemError(230); ok := FALSE 655 END; 656 END; .) . 657 (* Sets: multi-word masks over bases ≤ 256 values (bool, char, 658 bounded subranges; enums wait for ordinals, INTEGER is 659 unbounded). Literals are SET OF [0..255]; assignment and 660 comparison across suitable bases are lenient (masks over min 661 words + zero-check extras), out-of-span literals are 222. *) 662 SetType (. VAR base: SymTab.TypeIndex; 663 blo, bhi, bspan: INTEGER; 664 bcls: INTEGER; .) 665 = "SET" "OF" Type 666 (. IF base = SymTab.InvalidType THEN 667 t := SymTab.InvalidType 668 ELSE bcls := 669 SymTab.ClassOf(base); 670 IF bcls = SymTab.ClBool THEN 671 blo := 0; bspan := 2 672 ELSIF bcls = SymTab.ClChar THEN 673 blo := 0; bspan := 256 674 ELSIF bcls = SymTab.ClEnum THEN 675 blo := 0; 676 bspan := VAL(INTEGER, 677 SymTab.EnumCount(base)) 678 ELSIF SymTab.SubBounds(base, 679 blo, bhi) THEN 680 bspan := bhi - blo + 1 681 ELSE bspan := 0 END; 682 IF (bspan <= 0) 683 OR (bspan > 65536) THEN 684 SemError(230); 685 t := SymTab.InvalidType 686 ELSE t := SymTab.NewSet(base) 687 END 688 END; .) . 689 (* Records: flat blobs; array fields are pointers to static 690 descriptors (locked amendment), nested records inline. Field 691 offsets static and declaration-ordered. *) 692 (* Field list: plain fields and (optionally) one variant part. The 693 variant part is a `CASE ... END` item; because it starts with the 694 CASE keyword it is unambiguously distinguishable from a field 695 (which starts with an identifier). *) 696 RecordType (. VAR t2: SymTab.TypeIndex; 697 tagOk: BOOLEAN; .) 698 = "RECORD" (. t := SymTab.NewRecord(); .) 699 [ RecItem { ";" [ RecItem ] } ] 700 "END" . 701 RecItem (. VAR tt: SymTab.TypeIndex; .) 702 = RecField 703 | CaseField (. SymTab.MarkVariant(rec); .) . 704 (* A variant part: CASE tag : Type OF variants. The layout overlays 705 every branch from the tag slot (see SymTab.ComputeOffsets). *) 706 CaseField (. VAR tagT: SymTab.TypeIndex; 707 tagN: SymTab.Name; .) 708 = "CASE" (. SymTab.ResetFields(rec); .) 709 GetIdent (. IF NOT SymTab.FieldPending(rec, 710 tagN) THEN 711 SemError(200) END; .) 712 ":" Type (. IF (tagT # SymTab.InvalidType) 713 AND NOT SymTab.IsOrdinal(tagT) THEN 714 SemError(224) 715 END; 716 SymTab.FixPendingF(rec, tagT); 717 SymTab.SetVariantTag(rec, tagN); .) 718 "OF" 719 RecFieldList 720 { "|" (. SymTab.ResetFields(rec); .) 721 RecFieldList } 722 "END" . 723 RecFieldList (. VAR lt, lq: SymTab.TypeIndex; 724 lv1, lv2: QbeGen.QVal; .) 725 = VarLabel [ ".." VarLabel ] ":" 726 RecField { ";" [ RecField ] } . 727 (* Variant case label: a constant (or a constant range). Values are 728 not interpreted (the layout overlays regardless). *) 729 VarLabel 730 (. VAR lname: SymTab.Name; .) 731 = ( ident (. LexName(lname); 732 QbeGen.CopyOp("0", q); 733 t := SymTab.IntType(); .) 734 | integer (. LexString(lname); 735 QbeGen.CopyOp("0", q); 736 t := SymTab.IntType(); .) 737 | charConst (. LexString(lname); 738 QbeGen.CopyOp("0", q); 739 t := SymTab.CharType(); .) ) . 740 RecField (. VAR n: SymTab.Name; 741 t2: SymTab.TypeIndex; .) 742 = RecIdents ":" Type(. SymTab.FixPendingF(rec, t2); .) . 743 RecIdents (. VAR n: SymTab.Name; .) 744 = GetIdent (. IF NOT SymTab.FieldPending(rec, 745 n) THEN 746 SemError(200) END; .) 747 { "," GetIdent (. IF NOT SymTab.FieldPending(rec, 748 n) THEN 749 SemError(200) END; .) } . 750 TypeIdent (. VAR n, qid: SymTab.Name; 751 k: INTEGER; 752 dotted: BOOLEAN; .) 753 = GetIdent (. dotted := FALSE; 754 IF NOT SymTab.Lookup(n) THEN 755 k := -1; 756 t := SymTab.ForwardType(n); 757 IF t = SymTab.InvalidType THEN 758 SemError(201) 759 END 760 ELSE k := SymTab.SymKind(n); 761 IF (k = SymTab.KindType) 762 OR (k = SymTab.KindPredef) THEN 763 t := SymTab.SymType(n) 764 ELSE t := SymTab.InvalidType 765 END 766 END; .) 767 [ "." GetIdent (. dotted := TRUE; 768 IF k = SymTab.KindModule THEN 769 t := SymTab.QualType(n, qid); 770 IF t = SymTab.InvalidType THEN 771 SemError(201) 772 END 773 ELSE SemError(221); 774 t := SymTab.InvalidType 775 END; .) ] 776 (. IF NOT dotted THEN 777 IF (k = SymTab.KindModule) 778 OR ((k # SymTab.KindType) 779 AND (k # SymTab.KindPredef) 780 AND (k # SymTab.KindImport) 781 AND (k # -1)) THEN 782 SemError(221) 783 END 784 END; .) . 785 Subrange (. VAR tlo, thi: SymTab.TypeIndex; 786 qlo, qhi: QbeGen.QVal; 787 lo, hi: INTEGER; .) 788 = "[" Expr ".." Expr 789 (. IF (tlo = SymTab.InvalidType) 790 OR (thi = SymTab.InvalidType) THEN 791 t := SymTab.InvalidType 792 ELSIF NOT SymTab.IsOrdinal(tlo) 793 OR NOT SymTab.IsOrdinal(thi) THEN 794 SemError(230); 795 t := SymTab.InvalidType 796 ELSIF NOT SymTab.ConstInt(qlo, lo) 797 OR NOT SymTab.ConstInt(qhi, hi) 798 OR (lo > hi) THEN 799 SemError(230); 800 t := SymTab.InvalidType 801 ELSE t := SymTab.NewSubR(lo, hi) 802 END; .) 803 "]" . 804 Enum (. VAR n: SymTab.Name; 805 ord: INTEGER; 806 qv: QbeGen.QVal; .) 807 = "(" (. t := SymTab.NewEnum(); 808 ord := 0; .) 809 GetIdent (. IF NOT SymTab.Enter(n, 810 SymTab.KindConst) THEN 811 SemError(200) END; 812 SymTab.SetSymType(n, t); 813 QbeGen.IntStr(ord, qv); 814 SymTab.SetSymVal(n, qv); 815 INC(ord); .) 816 { "," GetIdent (. IF NOT SymTab.Enter(n, 817 SymTab.KindConst) THEN 818 SemError(200) END; 819 SymTab.SetSymType(n, t); 820 QbeGen.IntStr(ord, qv); 821 SymTab.SetSymVal(n, qv); 822 INC(ord); .) } 823 ")" (. SymTab.SetEnumCount(t, 824 VAL(CARDINAL, ord)); .) . 825 (* Clarion-form classes (docs/OOP.txt): declaration + single 826 inheritance + IMPLEMENTATION blocks. Scopes and member checks 827 now; lowering (vtable, dispatch, THIS) later — one 230 per 828 class/impl block. Methods end with ";" per the Table example 829 (not "," as in the sketch). No underscores in identifiers. *) 830 (* Single CLASS item in both loops: separating declaration from 831 IMPLEMENTATION at the loop level needs 2-token lookahead 832 (CLASS ident vs CLASS IMPLEMENTATION), which LL(1) cannot do. 833 The second token decides after CLASS is consumed. A misplaced 834 CLASS IMPLEMENTATION inside TYPE still parses (harmless: the 835 whole unit ends 230 until lowering). *) 836 ClassItem 837 = "CLASS" ( "IMPLEMENTATION" ClassImplRest | ClassRest ) . 838 ClassRest (. VAR cn, m2, pn: SymTab.Name; 839 ct: SymTab.TypeIndex; .) 840 = GetIdent (. IF NOT SymTab.Enter(cn, 841 SymTab.KindType) THEN 842 SemError(200) END; 843 ct := SymTab.NewClass(); 844 SymTab.SetSymType(cn, ct); 845 SymTab.PushClassScope(ct); 846 astCls := AST.MakeNode(AST.NkClassDecl); 847 AST.SetChild(astCls, 0, 848 AST.MakeLeaf(AST.NkIdent, cn)); 849 astClsP := AST.NoNode; 850 astClsPTail := AST.NoNode; 851 astClsF := AST.NoNode; 852 astClsFTail := AST.NoNode; 853 astClsM := AST.NoNode; 854 astClsMTail := AST.NoNode; .) 855 [ Parents ] 856 ";" 857 { ClassField ";" } 858 { MethodHeading ";" 859 (. SymTab.CloseProc; 860 QbeGen.AbortFunc; .) } 861 "END" 862 GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN 863 SemError(202) END; 864 SymTab.LayoutClass(ct); 865 SymTab.PopScope; 866 AST.SetChild(astCls, 1, astClsP); 867 AST.SetChild(astCls, 2, astClsF); 868 AST.SetChild(astCls, 3, astClsM); 869 astDecl := astCls; .) . 870 Parents (. VAR p: SymTab.Name; .) 871 = "(" Parent1 872 { "," GetIdent

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

(. IF NOT SymTab.Lookup(p) THEN 877 SemError(201) 878 ELSE pt := SymTab.SymType(p); 879 IF SymTab.ClassOf(pt) # 880 SymTab.ClClass THEN 881 SemError(230) 882 ELSE SymTab.SetParent(ct, pt) 883 END 884 END; 885 AstAppend(AST.NkFieldDecl, 886 astClsP, astClsPTail, 887 AST.MakeLeaf(AST.NkIdent, p)); .) . 888 ClassField (. VAR n, rhs: SymTab.Name; 889 t: SymTab.TypeIndex; 890 astNode: AST.Node; .) 891 = GetIdent 892 ( "=" GetIdent (. IF NOT SymTab.Enter(n, 893 SymTab.KindConst) THEN 894 SemError(200) END; 895 astNode := AST.MakeNode(AST.NkConstDecl); 896 AST.SetChild(astNode, 0, 897 AST.MakeLeaf(AST.NkIdent, n)); 898 AST.SetChild(astNode, 1, 899 AST.MakeLeaf(AST.NkIdent, rhs)); 900 AstAppend(AST.NkFieldDecl, 901 astClsF, astClsFTail, astNode); 902 IF SymTab.Lookup(rhs) THEN 903 SymTab.SetSymType(n, 904 SymTab.SymType(rhs)) 905 END; .) 906 | (. IF NOT SymTab.FieldPending(ct, 907 n) THEN 908 SemError(200) END; 909 astNode := AST.MakeNode(AST.NkVarDecl); 910 AST.SetChild(astNode, 0, 911 AST.MakeLeaf(AST.NkIdent, n)); .) 912 { "," GetIdent (. IF NOT SymTab.FieldPending(ct, 913 n) THEN 914 SemError(200) END; 915 AST.SetChild(astNode, 916 AST.NChild(astNode), 917 AST.MakeLeaf(AST.NkIdent, n)); .) } 918 ":" Type (. SymTab.FixPendingF(ct, t); 919 AST.SetTy(astNode, t); 920 AstAppend(AST.NkFieldDecl, 921 astClsF, astClsFTail, astNode); .) ) . 922 MethodHeading 923 (. VAR wantVirt: BOOLEAN; .) 924 = (. wantVirt := FALSE; .) 925 [ "VIRTUAL" (. wantVirt := TRUE; .) ] 926 ProcHeading (. IF wantVirt THEN 927 SymTab.MarkVirtual END; 928 astMethod := AST.MakeNode(AST.NkProcDecl); 929 AST.SetChild(astMethod, 0, 930 AST.MakeLeaf(AST.NkIdent, pn)); 931 IF wantVirt THEN 932 AST.SetOp(astMethod, 3) 933 ELSE AST.SetOp(astMethod, 0) 934 END; 935 AstAppend(AST.NkFieldDecl, 936 astClsM, astClsMTail, astMethod); .) . 937 ClassImplRest (. VAR cn, m2: SymTab.Name; 938 ct: SymTab.TypeIndex; .) 939 = GetIdent (. IF NOT SymTab.Lookup(cn) THEN 940 SemError(201); 941 ct := SymTab.InvalidType 942 ELSE ct := SymTab.SymType(cn); 943 IF SymTab.ClassOf(ct) # 944 SymTab.ClClass THEN 945 SemError(230); 946 ct := SymTab.InvalidType 947 END 948 END; 949 astCls := AST.MakeNode(AST.NkClassDecl); 950 AST.SetOp(astCls, 1); 951 AST.SetChild(astCls, 0, 952 AST.MakeLeaf(AST.NkIdent, cn)); 953 astClsM := AST.NoNode; 954 astClsMTail := AST.NoNode; 955 astStmt := AST.NoNode; 956 IF ct # 957 SymTab.InvalidType THEN 958 IF NOT SymTab.PushClassMembers( 959 ct) THEN 960 SemError(230) END; 961 SymTab.PushImplClass(ct) 962 END; .) 963 ";" { MethodImpl ";" } 964 (. astStmt := AST.NoNode; .) 965 [ "BEGIN" (. astStmt := AST.MakeNode(AST.NkBlock); 966 QbeGen.BeginInit(cn); .) 967 [ StatSeq ] (. QbeGen.EndInit; .) ] 968 "END" 969 GetIdent (. IF NOT SymTab.Equal(cn, m2) THEN 970 SemError(202) END; 971 SymTab.PopImplClass; 972 SymTab.PopScope; 973 AST.SetChild(astCls, 1, AST.NoNode); 974 AST.SetChild(astCls, 2, astStmt); 975 AST.SetChild(astCls, 3, astClsM); 976 astDecl := astCls; .) . 977 MethodImpl (. VAR pn: SymTab.Name; 978 thisQ: QbeGen.QVal; 979 methRes: SymTab.TypeIndex; .) 980 = MethodHeading ";" 981 (. IF (ct # 982 SymTab.InvalidType) 983 AND NOT SymTab.MethodExists(ct, 984 pn) THEN 985 SemError(201) END; .) 986 ( "FORWARD" (. AST.SetOp(astMethod, 1); 987 SymTab.MarkFwd; 988 QbeGen.AbortFunc; 989 SymTab.CloseProc; .) 990 | (. QbeGen.EndFuncHeader; 991 (* bind the receiver: bare 992 field names resolve 993 against THIS *) 994 QbeGen.ThisBase(thisQ); 995 QbeGen.PushWith(thisQ); .) 996 Block (. AST.SetChild(astMethod, 1, astStmt); 997 QbeGen.PopWith; 998 methRes := SymTab.CurRes(); 999 SymTab.CloseProc; 1000 QbeGen.EndFunc(methRes); .) ) . 1001 ConstBlock (. VAR astSeq, astTail: AST.Node; .) 1002 = "CONST" (. astSeq := AST.NoNode; 1003 astTail := AST.NoNode; .) 1004 { ConstDecl ";" (. AstAppend(AST.NkDeclSeq, 1005 astSeq, astTail, astDecl); .) } 1006 (. astDecl := astSeq; .) . 1007 ConstDecl (. VAR n: SymTab.Name; 1008 t: SymTab.TypeIndex; 1009 qv: QbeGen.QVal; 1010 cls: INTEGER; 1011 astNode: AST.Node; .) 1012 = GetIdent (. IF NOT SymTab.Enter(n, 1013 SymTab.KindConst) THEN 1014 SemError(200) END; .) 1015 "=" 1016 Expr (. astNode := AST.MakeNode(AST.NkConstDecl); 1017 AST.SetChild(astNode, 0, 1018 AST.MakeLeaf(AST.NkIdent, n)); 1019 AST.SetChild(astNode, 1, astCur); 1020 AST.SetTy(astNode, t); 1021 astDecl := astNode; 1022 Lower.NoteVar(n, SymTab.KindConst, t); 1023 SymTab.SetSymType(n, t); 1024 cls := SymTab.ClassOf(t); 1025 IF (cls = SymTab.ClArray) 1026 OR (cls = SymTab.ClRecord) 1027 OR (cls = SymTab.ClClass) 1028 OR (cls = SymTab.ClStr) 1029 OR (cls = SymTab.ClUStr) THEN 1030 (* an aggregate/string 1031 constant: qv is its 1032 descriptor address; no 1033 scalar data *) 1034 SymTab.SetSymVal(n, qv) 1035 ELSIF NOT QbeGen.IsImm(qv) THEN 1036 SemError(230) 1037 ELSE 1038 SymTab.SetSymVal(n, qv); 1039 QbeGen.DeclConst(n, qv, t) 1040 END; .) . 1041 VarBlock (. VAR astSeq, astTail: AST.Node; .) 1042 = "VAR" (. astSeq := AST.NoNode; 1043 astTail := AST.NoNode; .) 1044 { VarDecl ";" (. AstAppend(AST.NkDeclSeq, 1045 astSeq, astTail, astDecl); .) } 1046 (. astDecl := astSeq; .) . 1047 VarDecl (. VAR nm: SymTab.Name; 1048 t: SymTab.TypeIndex; 1049 i: CARDINAL; 1050 cls: INTEGER; 1051 astNode: AST.Node; .) 1052 = VarIdents ":" 1053 Type (. astNode := AST.MakeNode(AST.NkVarDecl); 1054 i := 0; 1055 WHILE i < SymTab.PendCount() DO 1056 SymTab.PendName(i, nm); 1057 Lower.NoteVar(nm, SymTab.KindVar, t); 1058 AST.SetChild(astNode, 1059 AST.NChild(astNode), 1060 AST.MakeLeaf(AST.NkIdent, nm)); 1061 INC(i) 1062 END; 1063 AST.SetTy(astNode, t); 1064 astDecl := astNode; 1065 cls := SymTab.ClassOf(t); 1066 IF (t # SymTab.InvalidType) 1067 AND NOT SymTab.IsUnresolved(t) 1068 AND (cls # SymTab.ClInt) 1069 AND (cls # SymTab.ClBool) 1070 AND (cls # SymTab.ClChar) 1071 AND (cls # SymTab.ClReal) 1072 AND (cls # SymTab.ClArray) 1073 AND (cls # SymTab.ClSet) 1074 AND (cls # SymTab.ClRecord) 1075 AND (cls # SymTab.ClPtr) 1076 AND (cls # SymTab.ClLong) 1077 AND (cls # SymTab.ClProc) 1078 AND (cls # SymTab.ClUChar) 1079 AND (cls # SymTab.ClUStr) 1080 AND (cls # SymTab.ClEnum) 1081 AND (cls # SymTab.ClClass) THEN 1082 SemError(230) END; 1083 IF QbeGen.LocFull() THEN 1084 SemError(233) END; 1085 i := 0; 1086 IF SymTab.IsUnresolved(t) 1087 AND NOT SymTab.InProc() THEN 1088 (* a forward-typed global: 1089 defer emission until the 1090 TYPE block completes *) 1091 WHILE i < SymTab.PendCount() DO 1092 SymTab.PendName(i, nm); 1093 IF nPendVar <= 1094 HIGH(pendVarName) THEN 1095 pendVarName[nPendVar] := nm; 1096 pendVarT[nPendVar] := t; 1097 INC(nPendVar) 1098 END; 1099 INC(i) 1100 END 1101 ELSE 1102 WHILE i < SymTab.PendCount() DO 1103 SymTab.PendName(i, nm); 1104 QbeGen.DeclVar(nm, t); 1105 INC(i) 1106 END 1107 END; 1108 (* a plain VAR list, not a 1109 heading: the signature 1110 result is discarded *) 1111 IF NOT SymTab.FixPending(t) THEN 1112 END; .) . 1113 VarIdents (. VAR n: SymTab.Name; .) 1114 = GetIdent (. IF NOT SymTab.EnterPending(n, 1115 SymTab.KindVar) THEN 1116 SemError(200) END; .) 1117 { "," 1118 GetIdent (. IF NOT SymTab.EnterPending(n, 1119 SymTab.KindVar) THEN 1120 SemError(200) END; .) } . 1121 ParIdents (. VAR n: SymTab.Name; .) 1122 = GetIdent (. IF NOT SymTab.EnterParam(n, isV) THEN 1123 SemError(200) END; .) 1124 { "," GetIdent (. IF NOT SymTab.EnterParam(n, isV) THEN 1125 SemError(200) END; .) } . 1126 (* Procedure headings enter scopes/params/result and buffer the 1127 QBE header; bodies lower to functions (4.1, module level only). 1128 FORWARD marks; the body heading re-enters (signature compare 1129 deferred). Nested procedures parse + check, lowering = 4.2. *) 1130 ProcHeading 1131 (. VAR t: SymTab.TypeIndex; 1132 mg: QbeGen.QVal; .) 1133 = "PROCEDURE" 1134 GetIdent (. IF methCls # 1135 SymTab.InvalidType THEN 1136 (* a method: resume the 1137 declared symbol (reuse 1138 its uid) *) 1139 IF NOT SymTab.ResumeMethod( 1140 methCls, pn) THEN 1141 SemError(200) END 1142 ELSIF NOT SymTab.EnterProc(pn) THEN 1143 IF NOT SymTab.ReenterProc(pn) THEN 1144 IF NOT SymTab.ResumeProc(pn) THEN 1145 SemError(200) END 1146 END 1147 END; 1148 Lower.ScopeEnter; 1149 Lower.NoteProc(pn, 1150 SymTab.ProcUid(pn), 1151 SymTab.InvalidType, 1152 SymTab.ProcDepthOf(pn), 1153 FALSE); 1154 IF methCls # 1155 SymTab.InvalidType THEN 1156 QbeGen.Mangled(pn, 1157 SymTab.MethUid(), mg) 1158 ELSE 1159 QbeGen.Mangled(pn, 1160 SymTab.ProcUid(pn), mg) 1161 END; 1162 QbeGen.BeginFunc(mg); 1163 IF methCls # 1164 SymTab.InvalidType THEN 1165 (* hidden THIS receiver: 1166 a VAR param of the 1167 class type, pushed as 1168 the WITH base *) 1169 IF NOT SymTab.EnterThisParam( 1170 methCls) THEN 1171 SemError(200) END; 1172 IF NOT QbeGen.FuncParam( 1173 "THIS", TRUE, 1174 methCls) THEN 1175 SemError(233) END 1176 END; .) 1177 [ FormalParams ] 1178 [ ":" TypeIdent (. IF NOT SymTab.SetProcRes(t) THEN 1179 SemError(235) END; 1180 Lower.SetProcRes(t); 1181 QbeGen.SetFuncRes(t); 1182 IF (t # 1183 SymTab.InvalidType) 1184 AND ((SymTab.ClassOf(t) 1185 = SymTab.ClArray) 1186 OR (SymTab.ClassOf(t) 1187 = SymTab.ClRecord) 1188 OR (SymTab.ClassOf(t) 1189 = SymTab.ClSet) 1190 OR (SymTab.ClassOf(t) 1191 = SymTab.ClClass)) THEN 1192 SemError(230) END; .) ] . 1193 FormalParams 1194 = "(" [ ParamSection { ";" ParamSection } ] ")" . 1195 ParamSection (. VAR t: SymTab.TypeIndex; 1196 nm: SymTab.Name; 1197 i: CARDINAL; 1198 isV: BOOLEAN; .) 1199 = (. isV := FALSE; .) 1200 [ "VAR" (. isV := TRUE; .) ] 1201 ParIdents ":" Type (. i := 0; 1202 WHILE i < SymTab.PendCount() DO 1203 SymTab.PendName(i, nm); 1204 Lower.NoteParam(nm, t, isV); 1205 Lower.NoteVar(nm, SymTab.KindParam, t); 1206 (* value open arrays are 1207 passed as descriptor 1208 addresses (no copy): 1209 same representation as 1210 VAR formals *) 1211 IF NOT QbeGen.FuncParam(nm, 1212 isV 1213 OR SymTab.IsOpenArray(t), 1214 t) THEN 1215 SemError(233) END; 1216 INC(i) 1217 END; 1218 IF NOT SymTab.FixPending(t) THEN 1219 SemError(235) END; .) . 1220 (* Nested procedures lower like top-level ones (4.2): the 1221 static link gives them their parent's frame. Methods keep 1222 parse-now/230-later. *) 1223 ProcDecl (. VAR pn: SymTab.Name; 1224 astNode: AST.Node; .) 1225 = ProcHeading ";" 1226 (. astNode := AST.MakeNode(AST.NkProcDecl); 1227 AST.SetOp(astNode, 0); 1228 AST.SetChild(astNode, 0, 1229 AST.MakeLeaf(AST.NkIdent, pn)); .) 1230 ( "FORWARD" (. AST.SetOp(astNode, 1); 1231 astDecl := astNode; 1232 Lower.ScopeLeave; 1233 SymTab.MarkFwd; 1234 SymTab.CloseProc; 1235 QbeGen.AbortFunc; .) 1236 | "EXTERNAL" (. AST.SetOp(astNode, 2); 1237 astDecl := astNode; 1238 Lower.ScopeLeave; 1239 SymTab.MarkExternal(""); 1240 SymTab.CloseProc; 1241 QbeGen.AbortFunc; .) 1242 | (. QbeGen.EndFuncHeader; .) 1243 Block (. AST.SetChild(astNode, 1, astStmt); 1244 AST.SetChild(astNode, 2, astBlkDecls); 1245 astDecl := astNode; 1246 Lower.ScopeLeave; 1247 SymTab.CloseProc; 1248 QbeGen.EndFunc( 1249 SymTab.ProcRes(pn)); .) ) . 1250 Block (. VAR m2: SymTab.Name; .) 1251 = DeclSeq (. astBlkDecls := astDecl; 1252 astStmt := AST.NoNode; .) 1253 [ "BEGIN" 1254 [ StatSeq ] ] 1255 "END" 1256 GetIdent (. IF NOT SymTab.Equal(pn, m2) THEN 1257 SemError(202) END; .) . 1258 StatSeq (. VAR astSeq, astTail: AST.Node; .) 1259 = (. astSeq := AST.NoNode; 1260 astTail := AST.NoNode; .) 1261 Statement (. AstAppend(AST.NkBlock, 1262 astSeq, astTail, astStmt); .) 1263 { ";" [ Statement (. AstAppend(AST.NkBlock, 1264 astSeq, astTail, astStmt); .) ] } 1265 (. astStmt := astSeq; .) . 1266 (* Trailing/empty statements (`a; ; b`, Coco/R's generated `;;`) 1267 are accepted: the statement after ';' is optional. *) 1268 Statement (. VAR lx: QbeGen.QVal; .) 1269 = (. astStmt := AST.NoNode; .) 1270 ( AssOrCall 1271 | IfStat 1272 | WhileStat 1273 | RepeatStat 1274 | LoopStat 1275 | ForStat 1276 | CaseStat 1277 | WithStat 1278 | ReturnStat 1279 | HaltStat 1280 | NewStat 1281 | DisposeStat 1282 | IncDecStat 1283 | InclExclStat 1284 | "EXIT" (. IF QbeGen.TopLoop(lx) THEN 1285 QbeGen.Jmp(lx) 1286 ELSE SemError(230) END; 1287 astStmt := AST.MakeNode(AST.NkExit); .) ) . 1288 (* INCL(set, elem) / EXCL(set, elem): PIM set-element builtins. *) 1289 InclExclStat (. VAR at, et2: SymTab.TypeIndex; 1290 dk: INTEGER; 1291 qd, qe: QbeGen.QVal; 1292 qn: SymTab.Name; 1293 sfx, isInc: BOOLEAN; 1294 astNode, astD: AST.Node; .) 1295 = ( "INCL" (. isInc := TRUE; .) 1296 | "EXCL" (. isInc := FALSE; .) ) 1297 "(" Design (. astD := astCur; .) "," 1298 Expr ")" 1299 (. astNode := AST.MakeNode(AST.NkCall); 1300 IF isInc THEN 1301 AST.SetChild(astNode, 0, 1302 AST.MakeLeaf(AST.NkIdent, "INCL")) 1303 ELSE AST.SetChild(astNode, 0, 1304 AST.MakeLeaf(AST.NkIdent, "EXCL")) 1305 END; 1306 IF astD # AST.NoNode THEN 1307 AST.SetChild(astNode, 1, astD) END; 1308 IF astCur # AST.NoNode THEN 1309 AST.SetChild(astNode, 2, astCur) END; 1310 astStmt := astNode; .) 1311 (. IF at = SymTab.InvalidType THEN 1312 ELSIF SymTab.ClassOf(at) # 1313 SymTab.ClSet THEN 1314 SemError(222) 1315 ELSE 1316 IF isInc THEN 1317 QbeGen.SetBit(qd, qe, 1318 SymTab.SetBaseLo(at), 1319 SymTab.SetCount(at)) 1320 ELSE 1321 QbeGen.SetClearBit(qd, qe, 1322 SymTab.SetBaseLo(at), 1323 SymTab.SetCount(at)) 1324 END 1325 END; .) . 1326 (* INC(v [,step]) / DEC(v [,step]) as builtin statements over an 1327 integer designator. *) 1328 IncDecStat (. VAR dt, et2: SymTab.TypeIndex; 1329 dk: INTEGER; 1330 qd, qv, qn2, qstep: 1331 QbeGen.QVal; 1332 qn: SymTab.Name; 1333 sfx, isInc: BOOLEAN; 1334 astNode, astD, astStep: 1335 AST.Node; .) 1336 = (. isInc := TRUE; .) 1337 ( "INC" (. isInc := TRUE; .) 1338 | "DEC" (. isInc := FALSE; .) ) 1339 "(" (. QbeGen.CopyOp("1", qstep); astStep := AST.NoNode; .) 1340 Design (. astD := astCur; .) 1341 [ "," Expr (. astStep := astCur; .) ] 1342 ")" (. astNode := AST.MakeNode(AST.NkCall); 1343 IF isInc THEN 1344 AST.SetChild(astNode, 0, 1345 AST.MakeLeaf(AST.NkIdent, "INC")) 1346 ELSE AST.SetChild(astNode, 0, 1347 AST.MakeLeaf(AST.NkIdent, "DEC")) 1348 END; 1349 IF astD # AST.NoNode THEN 1350 AST.SetChild(astNode, 1, astD) END; 1351 IF astStep # AST.NoNode THEN 1352 AST.SetChild(astNode, 2, astStep) END; 1353 astStmt := astNode; .) (. IF dt = SymTab.InvalidType THEN 1354 ELSIF (dk # SymTab.KindVar) 1355 AND (dk # SymTab.KindParam) 1356 AND (dk # SymTab.KindField) THEN 1357 SemError(210) 1358 ELSIF NOT SymTab.IsIntFamily(dt) THEN 1359 SemError(211) 1360 ELSE 1361 IF sfx 1362 OR (dk = SymTab.KindField) THEN 1363 QbeGen.ElemLoad(qd, dt, qv) 1364 ELSE QbeGen.LoadVar(qn, 1365 FALSE, qv) 1366 END; 1367 QbeGen.NewTemp(qn2); 1368 IF isInc THEN 1369 QbeGen.Op3("add", qn2, qv, 1370 qstep, FALSE) 1371 ELSE QbeGen.Op3("sub", qn2, qv, 1372 qstep, FALSE) 1373 END; 1374 IF sfx 1375 OR (dk = SymTab.KindField) THEN 1376 QbeGen.ElemStore(qd, qn2, 1377 dt) 1378 ELSE QbeGen.StoreVar(qn, 1379 qn2, FALSE) 1380 END 1381 END; .) . 1382 (* NEW/DISPOSE as builtin statements (no call syntax until step 4). 1383 Targets are pointer designators; DISPOSE nils afterwards (safer 1384 than Wirth-undefined; documented). DISPOSE is shallow. *) 1385 NewStat (. VAR dt: SymTab.TypeIndex; 1386 dk: INTEGER; 1387 qd, qm: QbeGen.QVal; 1388 qn: SymTab.Name; 1389 sfx: BOOLEAN; 1390 bt: SymTab.TypeIndex; 1391 astNode, astD: AST.Node; .) 1392 = "NEW" "(" Design (. astD := astCur; .) ")" 1393 (. astNode := AST.MakeNode(AST.NkCall); 1394 AST.SetChild(astNode, 0, 1395 AST.MakeLeaf(AST.NkIdent, "NEW")); 1396 IF astD # AST.NoNode THEN 1397 AST.SetChild(astNode, 1, astD) END; 1398 astStmt := astNode; .) 1399 (. IF dt = SymTab.InvalidType THEN 1400 ELSIF (dk # SymTab.KindVar) 1401 AND (dk # SymTab.KindParam) 1402 AND (dk # SymTab.KindField) THEN 1403 SemError(210) 1404 ELSIF SymTab.ClassOf(dt) # 1405 SymTab.ClPtr THEN 1406 SemError(219) 1407 ELSE bt := SymTab.PtrBase(dt); 1408 IF bt # 1409 SymTab.InvalidType THEN 1410 QbeGen.NewHeap(bt, qm); 1411 QbeGen.InitHeap(qm, bt); 1412 IF sfx 1413 OR (dk = 1414 SymTab.KindField) THEN 1415 QbeGen.ElemStore(qd, qm, 1416 dt) 1417 ELSE QbeGen.StorePtr(qn, 1418 qm) 1419 END 1420 END 1421 END; .) . 1422 DisposeStat (. VAR dt: SymTab.TypeIndex; 1423 dk: INTEGER; 1424 qd, qv: QbeGen.QVal; 1425 qn: SymTab.Name; 1426 sfx: BOOLEAN; 1427 astNode, astD: AST.Node; .) 1428 = "DISPOSE" "(" Design (. astD := astCur; .) ")" 1429 (. astNode := AST.MakeNode(AST.NkCall); 1430 AST.SetChild(astNode, 0, 1431 AST.MakeLeaf(AST.NkIdent, "DISPOSE")); 1432 IF astD # AST.NoNode THEN 1433 AST.SetChild(astNode, 1, astD) END; 1434 astStmt := astNode; .) 1435 (. IF dt = SymTab.InvalidType THEN 1436 ELSIF (dk # SymTab.KindVar) 1437 AND (dk # SymTab.KindParam) 1438 AND (dk # SymTab.KindField) THEN 1439 SemError(210) 1440 ELSIF SymTab.ClassOf(dt) # 1441 SymTab.ClPtr THEN 1442 SemError(219) 1443 ELSE 1444 IF sfx 1445 OR (dk = 1446 SymTab.KindField) THEN 1447 QbeGen.ElemLoad(qd, dt, 1448 qv) 1449 ELSE QbeGen.LoadPtr(qn, qv) 1450 END; 1451 QbeGen.FreeHeap(qv); 1452 IF sfx 1453 OR (dk = 1454 SymTab.KindField) THEN 1455 QbeGen.ElemStore(qd, "0", 1456 dt) 1457 ELSE QbeGen.StorePtr(qn, 1458 "0") 1459 END 1460 END; .) . 1461 (* WITH pushes each record's fields (inner wins) plus its base 1462 address; field designators resolve through both stacks. *) 1463 WithStat (. VAR nW: CARDINAL; 1464 astNode: AST.Node; .) 1465 = "WITH" (. nW := 0; 1466 astNode := AST.MakeNode(AST.NkWith); .) 1467 WithItem { "," WithItem } 1468 "DO" (. astStmt := AST.NoNode; .) 1469 [ StatSeq ] "END" (. AST.SetChild(astNode, 1470 AST.NChild(astNode), astStmt); 1471 astStmt := astNode; 1472 WHILE nW > 0 DO 1473 SymTab.PopScope; 1474 QbeGen.PopWith; 1475 DEC(nW) 1476 END; .) . 1477 WithItem 1478 (. VAR dt: SymTab.TypeIndex; 1479 dk: INTEGER; 1480 qd, qe: QbeGen.QVal; 1481 qn: SymTab.Name; 1482 sfx: BOOLEAN; .) 1483 = Design 1484 (. IF astCur # AST.NoNode THEN 1485 AST.SetChild(wnode, 1486 AST.NChild(wnode), astCur) END; 1487 IF dt = SymTab.InvalidType THEN 1488 ELSIF (SymTab.ClassOf(dt) # 1489 SymTab.ClRecord) 1490 AND (SymTab.ClassOf(dt) # 1491 SymTab.ClClass) THEN 1492 SemError(215) 1493 ELSIF SymTab.PushRecord(dt) THEN 1494 QbeGen.PushWith(qd); 1495 INC(nW) 1496 END; .) . 1497 (* Assignment or procedure-statement call (4.1, module level). 1498 Bare `P;` is a syntax error; function-as-statement is 233. *) 1499 AssOrCall (. VAR dt, et: SymTab.TypeIndex; 1500 dk: INTEGER; 1501 qd, qe, qt, ql: QbeGen.QVal; 1502 qn: SymTab.Name; 1503 ct2, res0: SymTab.TypeIndex; 1504 q2, mg0: QbeGen.QVal; 1505 isR, conv, wconv: BOOLEAN; 1506 called, sfx: BOOLEAN; 1507 astLhs: AST.Node; .) 1508 = Design 1509 (. astLhs := astCur; astNArgs := 0; .) 1510 ( ":=" 1511 Expr (. astStmt := AST.MakeBin( 1512 AST.NkAssign, 0, astLhs, astCur); 1513 IF (dt # SymTab.InvalidType) 1514 AND (dk # SymTab.KindVar) 1515 AND (dk # SymTab.KindParam) 1516 AND (dk # SymTab.KindField) THEN 1517 SemError(210) 1518 ELSIF NOT SymTab.Assignable(et, 1519 dt) THEN 1520 SemError(210) 1521 ELSIF (dt # SymTab.InvalidType) 1522 AND (SymTab.ClassOf(dt) = 1523 SymTab.ClClass) THEN 1524 SemError(230) END; 1525 isR := (dt # 1526 SymTab.InvalidType) 1527 AND (SymTab.ClassOf(dt) 1528 = SymTab.ClReal); 1529 conv := isR 1530 AND SymTab.IsIntFamily(et); 1531 wconv := (dt # 1532 SymTab.InvalidType) 1533 AND SymTab.IsLongFamily(dt) 1534 AND SymTab.IsIntFamily(et); 1535 IF ((dk = SymTab.KindVar) 1536 OR (dk = SymTab.KindParam) 1537 OR (dk = SymTab.KindField)) 1538 AND (dt # SymTab.InvalidType) 1539 AND (et # SymTab.InvalidType) 1540 AND (SymTab.ClassOf(dt) # 1541 SymTab.ClClass) THEN 1542 IF sfx 1543 OR (dk = SymTab.KindField) THEN 1544 IF SymTab.ClassOf(dt) = 1545 SymTab.ClArray THEN 1546 IF (et # SymTab.InvalidType) 1547 AND (SymTab.ClassOf(et) = SymTab.ClUStr) 1548 AND SymTab.IsUCharArray(dt) THEN 1549 QbeGen.UAssign(qd, qe) 1550 ELSIF SymTab.StrCompat(dt, 1551 et) THEN 1552 QbeGen.StrAssign(qd, 1553 qe) 1554 ELSE 1555 QbeGen.CopyArray(qd, 1556 qe, dt) 1557 END 1558 ELSIF SymTab.ClassOf(dt) = 1559 SymTab.ClSet THEN 1560 QbeGen.CopySet(qd, qe, 1561 SymTab.SetWords(dt), 1562 SymTab.SetWords(et)) 1563 ELSIF SymTab.ClassOf(dt) = 1564 SymTab.ClRecord THEN 1565 QbeGen.CopyRecord(qd, qe, 1566 dt) 1567 ELSIF SymTab.IsLongFamily(dt) THEN 1568 IF wconv THEN 1569 QbeGen.WidenLong(qe, ql); 1570 QbeGen.ElemStore(qd, ql, 1571 dt) 1572 ELSE QbeGen.ElemStore(qd, qe, 1573 dt) 1574 END 1575 ELSIF conv THEN 1576 QbeGen.ConvIR(qe, qt); 1577 QbeGen.ElemStore(qd, qt, 1578 dt) 1579 ELSE QbeGen.ElemStore(qd, qe, 1580 dt) 1581 END 1582 ELSIF SymTab.ClassOf(dt) = 1583 SymTab.ClArray THEN 1584 IF (et # SymTab.InvalidType) 1585 AND (SymTab.ClassOf(et) = SymTab.ClUStr) 1586 AND SymTab.IsUCharArray(dt) THEN 1587 QbeGen.UAssign(qd, qe) 1588 ELSIF SymTab.StrCompat(dt, 1589 et) THEN 1590 QbeGen.StrAssign(qd, qe) 1591 ELSE 1592 QbeGen.CopyArray(qd, qe, 1593 dt) 1594 END 1595 ELSIF SymTab.ClassOf(dt) = 1596 SymTab.ClSet THEN 1597 QbeGen.CopySet(qd, qe, 1598 SymTab.SetWords(dt), 1599 SymTab.SetWords(et)) 1600 ELSIF SymTab.ClassOf(dt) = 1601 SymTab.ClRecord THEN 1602 QbeGen.CopyRecord(qd, qe, dt) 1603 ELSIF (SymTab.ClassOf(dt) = 1604 SymTab.ClPtr) 1605 OR (SymTab.ClassOf(dt) = 1606 SymTab.ClProc) THEN 1607 QbeGen.StorePtr(qn, qe) 1608 ELSIF SymTab.IsLongFamily(dt) THEN 1609 IF wconv THEN 1610 QbeGen.WidenLong(qe, ql); 1611 QbeGen.StoreLong(qn, ql) 1612 ELSE QbeGen.StoreLong(qn, qe) 1613 END 1614 ELSIF conv THEN 1615 QbeGen.ConvIR(qe, qt); 1616 QbeGen.StoreVar(qn, qt, TRUE) 1617 ELSE 1618 QbeGen.StoreVar(qn, qe, isR) 1619 END 1620 END; .) 1621 | ArgList 1622 (. astStmt := AstCallNode(astLhs); .) 1623 | (* bare `P;`: proper parameterless 1624 procedure call; anything else 1625 here is 233 (was a bare syntax 1626 error before 4.2) *) 1627 (. astStmt := AstCallNode(astLhs); 1628 IF (dk = SymTab.KindProc) 1629 AND NOT sfx THEN 1630 res0 := SymTab.ProcRes(qn); 1631 IF res0 # 1632 SymTab.InvalidType THEN 1633 SemError(233) 1634 ELSIF SymTab.ProcNPar(qn) # 1635 0 THEN 1636 SemError(233) 1637 ELSE QbeGen.Mangled(qn, 1638 SymTab.ProcUid(qn), mg0); 1639 QbeGen.CallBegin(mg0, 1640 res0, 1641 SymTab.ProcDepthOf(qn), 1642 SymTab.IsExternal(qn)); 1643 QbeGen.CallEnd(FALSE, q2) 1644 END 1645 ELSE SemError(233) 1646 END; .) ) . 1647 (* Actual-parameter list shared by statement and expression calls. 1648 want selects CallEnd's result handling; t/q carry the call 1649 value (statement calls discard). Arity/type failures are 233; 1650 evaluation code still emits so the .ssa stays assembleable. *) 1651 ArgList (. VAR i, np: CARDINAL; 1655 vs: INTEGER; 1656 res: SymTab.TypeIndex; 1657 mg: QbeGen.QVal; 1658 ok, ind, isMeth, va: BOOLEAN; .) 1659 = "(" (. called := TRUE; 1660 ok := TRUE; 1661 ind := FALSE; 1662 isMeth := methCls # 1663 SymTab.InvalidType; 1664 IF isMeth THEN 1665 (* class method: the 1666 receiver is armed. 1667 Virtual -> dispatch 1668 through the vtable; 1669 otherwise a static 1670 call. *) 1671 res := SymTab.ClassMethodRes( 1672 methCls, pn); 1673 vs := SymTab.VirtSlot( 1674 methCls, pn); 1675 IF vs >= 0 THEN 1676 QbeGen.VirtCallBegin( 1677 callee, vs, res) 1678 ELSE 1679 QbeGen.Mangled(pn, 1680 SymTab.ClassMethodUid( 1681 methCls, pn), mg); 1682 QbeGen.CallBegin(mg, res, 0, 1683 FALSE) 1684 END 1685 ELSIF SymTab.SymKind(pn) = 1686 SymTab.KindProc THEN 1687 res := SymTab.ProcRes(pn); 1688 QbeGen.Mangled(pn, 1689 SymTab.ProcUid(pn), mg); 1690 QbeGen.CallBegin(mg, res, 1691 SymTab.ProcDepthOf(pn), 1692 SymTab.IsExternal(pn)) 1693 ELSIF (pt # SymTab.InvalidType) 1694 AND (SymTab.ClassOf(pt) = SymTab.ClProc) THEN 1695 ind := TRUE; 1696 res := 1697 SymTab.ProcTypeRes(pt); 1698 QbeGen.CallBeginInd(callee, 1699 res, FALSE) 1700 ELSE SemError(233); 1701 ok := FALSE; 1702 res := SymTab.InvalidType 1703 END; 1704 i := 0; .) 1705 [ ActParam (. INC(i); .) 1706 { "," ActParam (. INC(i); .) } ] 1707 ")" (. IF ok THEN 1708 IF isMeth THEN 1709 np := SymTab.ClassMethodNPar( 1710 methCls, pn) 1711 ELSIF ind THEN 1712 np := SymTab.ProcTypeNPar(pt) 1713 ELSE np := SymTab.ProcNPar(pn) 1714 END; 1715 va := (NOT isMeth) AND (NOT ind) 1716 AND (SymTab.SymKind(pn) = 1717 SymTab.KindProc) 1718 AND SymTab.Varargs(pn); 1719 IF (i # np) AND NOT va THEN 1720 SemError(233); ok := FALSE 1721 END 1722 END; 1723 IF NOT ok THEN 1724 t := SymTab.InvalidType; 1725 QbeGen.CopyOp("0", q) 1726 ELSIF want THEN 1727 IF res = 1728 SymTab.InvalidType THEN 1729 SemError(233); 1730 t := SymTab.InvalidType; 1731 QbeGen.CopyOp("0", q) 1732 ELSE t := res; 1733 QbeGen.CallEnd(TRUE, q) 1734 END 1735 ELSE 1736 IF res # 1737 SymTab.InvalidType THEN 1738 SemError(233) 1739 END; 1740 t := SymTab.InvalidType; 1741 QbeGen.CopyOp("0", q); 1742 QbeGen.CallEnd(FALSE, q) 1743 END; .) . 1744 (* One actual: VAR formals take recorded designator addresses 1745 (233 otherwise); value formals take converted expressions. *) 1746 ActParam 1748 (. VAR at, ft: SymTab.TypeIndex; 1749 qe, qa, qt: QbeGen.QVal; 1750 isV, conv, va: BOOLEAN; 1751 cl: CHAR; .) 1752 = Expr (. IF astNArgs <= HIGH(astArgs) THEN 1753 astArgs[astNArgs] := astCur; 1754 INC(astNArgs) 1755 END; 1756 va := (NOT ind) 1757 AND (methCls = 1758 SymTab.InvalidType) 1759 AND (SymTab.SymKind(pn) = 1760 SymTab.KindProc) 1761 AND SymTab.Varargs(pn); 1762 IF ind THEN 1763 ft := 1764 SymTab.ProcTypeParamType(pt, 1765 i); 1766 isV := 1767 SymTab.ProcTypeParamIsVar(pt, 1768 i) 1769 ELSIF methCls # 1770 SymTab.InvalidType THEN 1771 ft := 1772 SymTab.ClassMethodParamType( 1773 methCls, pn, i); 1774 isV := 1775 SymTab.ClassMethodParamIsVar( 1776 methCls, pn, i) 1777 ELSE 1778 ft := SymTab.ParamType(pn, i); 1779 isV := SymTab.ParamIsVar(pn, i) 1780 END; 1781 IF (at = SymTab.InvalidType) THEN 1782 ELSIF ft = SymTab.InvalidType THEN 1783 IF va THEN 1784 QbeGen.CArgAdd(qe, at, qa, cl) 1785 END 1786 ELSIF isV THEN 1787 IF (SymTab.ClassOf(at) 1788 = SymTab.ClChar) 1789 AND (SymTab.ClassOf(ft) = SymTab.ClArray) 1790 AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) 1791 = SymTab.ClChar) 1792 AND QbeGen.IsImm(qe) THEN 1793 (* 1-char string 1794 literal passed to 1795 a VAR ARRAY OF CHAR *) 1796 QbeGen.DeclCharStr(qe, 1797 qa); 1798 IF NOT QbeGen.CallArg(qa, 1799 "l") THEN 1800 SemError(233) 1801 END 1802 ELSIF NOT QbeGen.AddrOfVal(qe, 1803 qa) THEN 1804 SemError(233) 1805 ELSIF NOT SymTab.VarParamOk(at, 1806 ft) THEN 1807 SemError(233) 1808 ELSIF NOT QbeGen.CallArg(qa, 1809 "l") THEN 1810 SemError(233) 1811 END 1812 ELSE 1813 IF (SymTab.ClassOf(at) 1814 = SymTab.ClChar) 1815 AND (SymTab.ClassOf(ft) = SymTab.ClArray) 1816 AND (SymTab.ClassOf(SymTab.ArrayElem(ft)) 1817 = SymTab.ClChar) 1818 AND QbeGen.IsImm(qe) THEN 1819 (* 1-char string 1820 literal passed to 1821 ARRAY OF CHAR *) 1822 QbeGen.DeclCharStr(qe, 1823 qa); 1824 IF NOT QbeGen.CallArg(qa, 1825 "l") THEN 1826 SemError(233) 1827 END 1828 ELSIF NOT SymTab.Assignable(at, 1829 ft) THEN 1830 SemError(233) 1831 ELSE 1832 conv := (SymTab.ClassOf( 1833 ft) = SymTab.ClReal) 1834 AND SymTab.IsIntFamily(at); 1835 IF conv THEN 1836 QbeGen.ConvIR(qe, qt); 1837 IF NOT QbeGen.CallArg(qt, 1838 "d") THEN 1839 SemError(233) 1840 END 1841 ELSIF NOT QbeGen.CallArg(qe, 1842 QbeGen.ArgClass(ft)) THEN 1843 SemError(233) 1844 END 1845 END 1846 END; .) . 1847 IfStat (. VAR t: SymTab.TypeIndex; 1848 q, lThen, lElse, lEnd: 1849 QbeGen.QVal; 1850 hasElse: BOOLEAN; 1851 astCond, astIf, astLast, 1852 astNode: AST.Node; .) 1853 = "IF" (. hasElse := FALSE; .) 1854 Expr (. astCond := astCur; astStmt := AST.NoNode; 1855 IF NOT SymTab.BoolCheck(t) THEN 1856 SemError(214) END; 1857 QbeGen.NewLabel(lThen); 1858 QbeGen.NewLabel(lElse); 1859 QbeGen.NewLabel(lEnd); 1860 QbeGen.Jnz(q, lThen, lElse); 1861 QbeGen.EmitLabel(lThen); .) 1862 "THEN" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkIf); 1863 AST.SetChild(astNode, 0, astCond); 1864 AST.SetChild(astNode, 1, astStmt); 1865 astIf := astNode; 1866 astLast := astNode; 1867 QbeGen.Jmp(lEnd); .) 1868 { "ELSIF" (. QbeGen.EmitLabel(lElse); 1869 QbeGen.NewLabel(lElse); .) 1870 Expr (. astCond := astCur; astStmt := AST.NoNode; 1871 IF NOT SymTab.BoolCheck(t) THEN 1872 SemError(214) END; 1873 QbeGen.NewLabel(lThen); 1874 QbeGen.Jnz(q, lThen, lElse); 1875 QbeGen.EmitLabel(lThen); .) 1876 "THEN" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkIf); 1877 AST.SetChild(astNode, 0, astCond); 1878 AST.SetChild(astNode, 1, astStmt); 1879 AST.SetChild(astLast, 2, astNode); 1880 astLast := astNode; 1881 QbeGen.Jmp(lEnd); .) } 1882 [ "ELSE" (. QbeGen.EmitLabel(lElse); 1883 hasElse := TRUE; 1884 astStmt := AST.NoNode; .) 1885 [ StatSeq ] (. AST.SetChild(astLast, 2, astStmt); .) ] 1886 "END" (. astStmt := astIf; 1887 IF hasElse THEN 1888 QbeGen.EmitLabel(lEnd) 1889 ELSE QbeGen.EmitLabel(lElse); 1890 QbeGen.EmitLabel(lEnd) 1891 END; .) . 1892 WhileStat (. VAR t: SymTab.TypeIndex; 1893 q, lTop, lBody, lEnd: 1894 QbeGen.QVal; 1895 astCond, astNode: AST.Node; .) 1896 = "WHILE" (. astStmt := AST.NoNode; 1897 QbeGen.NewLabel(lTop); 1898 QbeGen.NewLabel(lBody); 1899 QbeGen.NewLabel(lEnd); 1900 QbeGen.EmitLabel(lTop); .) 1901 Expr (. astCond := astCur; 1902 IF NOT SymTab.BoolCheck(t) THEN 1903 SemError(214) END; 1904 QbeGen.Jnz(q, lBody, lEnd); 1905 QbeGen.EmitLabel(lBody); .) 1906 "DO" [ StatSeq ] (. astNode := AST.MakeNode(AST.NkWhile); 1907 AST.SetChild(astNode, 0, astCond); 1908 AST.SetChild(astNode, 1, astStmt); 1909 astStmt := astNode; 1910 QbeGen.Jmp(lTop); .) 1911 "END" (. QbeGen.EmitLabel(lEnd); .) . 1912 RepeatStat (. VAR t: SymTab.TypeIndex; 1913 q, lTop, lEnd: QbeGen.QVal; 1914 astCond, astBody, astNode: 1915 AST.Node; .) 1916 = "REPEAT" (. astStmt := AST.NoNode; 1917 QbeGen.NewLabel(lTop); 1918 QbeGen.NewLabel(lEnd); 1919 QbeGen.EmitLabel(lTop); .) 1920 [ StatSeq ] (. astBody := astStmt; .) 1921 "UNTIL" Expr (. astCond := astCur; 1922 astNode := AST.MakeNode(AST.NkRepeat); 1923 AST.SetChild(astNode, 0, astBody); 1924 AST.SetChild(astNode, 1, astCond); 1925 astStmt := astNode; 1926 IF NOT SymTab.BoolCheck(t) THEN 1927 SemError(214) END; 1928 QbeGen.Jnz(q, lEnd, lTop); 1929 QbeGen.EmitLabel(lEnd); .) . 1930 LoopStat (. VAR lTop, lEnd: QbeGen.QVal; astNode: AST.Node; .) 1931 = "LOOP" (. QbeGen.NewLabel(lTop); 1932 astStmt := AST.NoNode; 1933 QbeGen.NewLabel(lEnd); 1934 QbeGen.PushLoop(lEnd); 1935 QbeGen.EmitLabel(lTop); .) 1936 [ StatSeq ] 1937 "END" (. astNode := AST.MakeNode(AST.NkLoop); 1938 AST.SetChild(astNode, 0, astStmt); 1939 astStmt := astNode; 1940 QbeGen.Jmp(lTop); 1941 QbeGen.PopLoop; 1942 QbeGen.EmitLabel(lEnd); .) . 1943 (* FOR with static-sign BY (literal, non-zero; 220 otherwise). 1944 Runtime direction would need a compare-select; the literal 1945 sign picks cslew/csegew at "DO" time. *) 1946 ForStat (. VAR lv: SymTab.Name; 1947 tlo, thi, tby: 1948 SymTab.TypeIndex; 1949 qlo, qhi, qby, qt, qk, qb: 1950 QbeGen.QVal; 1951 lTop, lBody, lEnd: 1952 QbeGen.QVal; 1953 by: INTEGER; 1954 ok: BOOLEAN; 1955 astVar, astLo, astHi, astBy, 1956 astNode: AST.Node; .) 1957 = "FOR" (. by := 1; .) 1958 GetIdent (. astVar := AST.MakeLeaf(AST.NkIdent, lv); 1959 astStmt := AST.NoNode; 1960 astBy := AST.NoNode; 1961 ok := SymTab.Lookup(lv); 1962 IF NOT ok THEN 1963 SemError(201) 1964 ELSIF (SymTab.SymKind(lv) # 1965 SymTab.KindVar) 1966 AND (SymTab.SymKind(lv) # 1967 SymTab.KindParam) THEN 1968 SemError(220); ok := FALSE 1969 ELSIF NOT SymTab.IsIntFamily( 1970 SymTab.SymType(lv)) THEN 1971 SemError(220); ok := FALSE 1972 END; .) 1973 ":=" Expr (. astLo := astCur; 1974 IF NOT SymTab.IsIntFamily(tlo) THEN 1975 SemError(220); ok := FALSE 1976 END; .) 1977 "TO" Expr (. astHi := astCur; 1978 IF NOT SymTab.IsIntFamily(thi) THEN 1979 SemError(220); ok := FALSE 1980 END; .) 1981 [ "BY" Expr (. astBy := astCur; 1982 IF (tby # 1983 SymTab.InvalidType) 1984 AND NOT SymTab.IsIntFamily(tby) THEN 1985 SemError(220); ok := FALSE 1986 END; 1987 IF NOT SymTab.ConstInt(qby, by) THEN 1988 SemError(230); by := 1 1989 ELSIF by = 0 THEN 1990 SemError(220); by := 1 1991 END; .) ] 1992 "DO" (. IF ok THEN 1993 QbeGen.StoreVar(lv, qlo, 1994 FALSE) END; 1995 QbeGen.NewLabel(lTop); 1996 QbeGen.NewLabel(lBody); 1997 QbeGen.NewLabel(lEnd); 1998 QbeGen.EmitLabel(lTop); 1999 QbeGen.LoadVar(lv, FALSE, qt); 2000 QbeGen.NewTemp(qk); 2001 IF by > 0 THEN 2002 QbeGen.Op3("cslew", qk, 2003 qt, qhi, FALSE) 2004 ELSE QbeGen.Op3("csgew", qk, 2005 qt, qhi, FALSE) 2006 END; 2007 QbeGen.Jnz(qk, lBody, lEnd); 2008 QbeGen.EmitLabel(lBody); .) 2009 [ StatSeq ] 2010 "END" (. astNode := AST.MakeNode(AST.NkFor); 2011 AST.SetChild(astNode, 0, astVar); 2012 AST.SetChild(astNode, 1, astLo); 2013 AST.SetChild(astNode, 2, astHi); 2014 AST.SetChild(astNode, 3, astBy); 2015 AST.SetChild(astNode, 4, astStmt); 2016 astStmt := astNode; 2017 IF ok THEN 2018 QbeGen.LoadVar(lv, FALSE, 2019 qt); 2020 QbeGen.IntStr(by, qb); 2021 QbeGen.NewTemp(qk); 2022 QbeGen.Op3("add", qk, 2023 qt, qb, FALSE); 2024 QbeGen.StoreVar(lv, qk, 2025 FALSE) END; 2026 QbeGen.Jmp(lTop); 2027 QbeGen.EmitLabel(lEnd); .) . 2028 CaseStat (. VAR tsel: SymTab.TypeIndex; 2029 qsel, lEnd: QbeGen.QVal; 2030 arm, astNode: AST.Node; .) 2031 = "CASE" Expr (. astNode := AST.MakeNode(AST.NkCase); 2032 AST.SetChild(astNode, 0, astCur); 2033 QbeGen.NewLabel(lEnd); .) 2034 "OF" CaseAlt 2035 { "|" CaseAlt } 2036 [ "ELSE" (. astStmt := AST.NoNode; .) 2037 [ StatSeq ] (. arm := AST.MakeNode(AST.NkCaseArm); 2038 AST.SetOp(arm, 1); 2039 AST.SetChild(arm, 0, astStmt); 2040 AST.SetChild(astNode, 2041 AST.NChild(astNode), arm); .) ] 2042 "END" (. astStmt := astNode; 2043 QbeGen.EmitLabel(lEnd); .) . 2044 (* Compare-chain lowering: each alternative ends its match-tests 2045 with "jmp lAfter", so the no-match fallthrough skips the body: 2046 "cmp; jnz(lBody,lF); lF: ... ; jmp lAfter; lBody: S; jmp lEnd; 2047 lAfter:". Falls into the next alternative, ELSE, or END. *) 2048 CaseAlt 2050 (. VAR lBody, lAfter: QbeGen.QVal; 2051 arm: AST.Node; .) 2052 = (. arm := AST.MakeNode(AST.NkCaseArm); 2053 QbeGen.NewLabel(lBody); 2054 QbeGen.NewLabel(lAfter); .) 2055 CaseLabel 2056 { "," CaseLabel } 2057 ":" (. astStmt := AST.NoNode; 2058 QbeGen.Jmp(lAfter); 2059 QbeGen.EmitLabel(lBody); .) 2060 [ StatSeq ] (. AST.SetChild(arm, AST.NChild(arm), 2061 astStmt); 2062 AST.SetChild(cnode, 2063 AST.NChild(cnode), arm); 2064 QbeGen.Jmp(lEnd); 2065 QbeGen.EmitLabel(lAfter); .) . 2066 CaseLabel 2068 (. VAR t2, t3: SymTab.TypeIndex; 2069 q2, q3, qc, qd, qe: 2070 QbeGen.QVal; 2071 astLab: AST.Node; 2072 lNext: QbeGen.QVal; .) 2073 = Expr (. astLab := astCur; 2074 IF (t2 # 2075 SymTab.InvalidType) 2076 AND (tsel # 2077 SymTab.InvalidType) 2078 AND ((SymTab.ClassOf(t2) = 2079 SymTab.ClSet) 2080 OR (SymTab.ClassOf(tsel) = 2081 SymTab.ClSet)) THEN 2082 SemError(230) 2083 ELSIF (t2 # 2084 SymTab.InvalidType) 2085 AND (tsel # 2086 SymTab.InvalidType) 2087 AND NOT SymTab.EqCheck(t2, 2088 tsel) THEN 2089 SemError(213) END; 2090 IF NOT QbeGen.IsImm(q2) THEN 2091 SemError(230); 2092 QbeGen.CopyOp("0", q2) 2093 END; 2094 QbeGen.NewLabel(lNext); 2095 QbeGen.Cmp(SymTab.OpEq, 2096 qsel, q2, qc, FALSE); 2097 QbeGen.Jnz(qc, lBody, lNext); 2098 QbeGen.EmitLabel(lNext); .) 2099 [ ".." Expr (. astLab := AST.MakeBin( 2100 AST.NkSubrange, 0, astLab, astCur); 2101 IF (t3 # 2102 SymTab.InvalidType) 2103 AND (tsel # 2104 SymTab.InvalidType) 2105 AND NOT SymTab.EqCheck(t3, 2106 tsel) THEN 2107 SemError(213) END; 2108 IF NOT QbeGen.IsImm(q3) THEN 2109 SemError(230); 2110 QbeGen.CopyOp("0", q3) 2111 END; 2112 QbeGen.Cmp(SymTab.OpGe, 2113 qsel, q2, qc, FALSE); 2114 QbeGen.Cmp(SymTab.OpLe, 2115 qsel, q3, qd, FALSE); 2116 QbeGen.NewTemp(qe); 2117 QbeGen.Op3("and", qe, qc, qd, 2118 FALSE); 2119 QbeGen.NewLabel(lNext); 2120 QbeGen.Jnz(qe, lBody, lNext); 2121 QbeGen.EmitLabel(lNext); .) ] 2122 (. AST.SetChild(arm, 2123 AST.NChild(arm), astLab); .) . 2124 ReturnStat (. VAR t: SymTab.TypeIndex; 2125 q, qt: QbeGen.QVal; 2126 res: SymTab.TypeIndex; 2127 hadE, conv: BOOLEAN; 2128 astVal, astNode: AST.Node; .) 2129 = "RETURN" (. hadE := FALSE; astStmt := AST.NoNode; .) 2130 [ Expr (. hadE := TRUE; astVal := astCur; .) ] 2131 (. astNode := AST.MakeNode(AST.NkReturn); 2132 IF hadE THEN 2133 AST.SetChild(astNode, 0, astVal) 2134 END; 2135 astStmt := astNode; 2136 conv := FALSE; 2137 IF NOT SymTab.InProc() THEN 2138 SemError(232) 2139 ELSE res := SymTab.CurRes(); 2140 IF NOT hadE THEN 2141 IF res # 2142 SymTab.InvalidType THEN 2143 SemError(232) 2144 ELSE QbeGen.EmitRet(q, 2145 FALSE) 2146 END 2147 ELSIF (res = 2148 SymTab.InvalidType) 2149 OR (t # 2150 SymTab.InvalidType) 2151 AND NOT SymTab.Assignable(t, 2152 res) THEN 2153 SemError(232) 2154 ELSE 2155 conv := (SymTab.ClassOf( 2156 res) = SymTab.ClReal) 2157 AND SymTab.IsIntFamily(t); 2158 IF conv THEN 2159 QbeGen.ConvIR(q, qt); 2160 QbeGen.EmitRet(qt, TRUE) 2161 ELSE QbeGen.EmitRet(q, TRUE) 2162 END 2163 END 2164 END; .) . 2165 HaltStat (. VAR t: SymTab.TypeIndex; 2166 q: QbeGen.QVal; 2167 astVal, astNode: AST.Node; .) 2168 = "HALT" (. astVal := AST.NoNode; .) 2169 [ "(" Expr (. astVal := astCur; .) ")" ] 2170 (. astNode := AST.MakeNode(AST.NkHalt); 2171 IF astVal # AST.NoNode THEN 2172 AST.SetChild(astNode, 0, astVal) 2173 END; 2174 astStmt := astNode; 2175 QbeGen.HaltQ; .) . 2176 (* Designator: scalar loads, array addresses, and index suffixes. 2177 Each index descends one level (bounds-checked, trap on breach); 2178 nested levels reload the inner descriptor address. q ends as the 2179 value (scalars), the descriptor address (plain arrays), or the 2180 element address (indexed); sfx marks the indexed form. *) 2181 Design 2183 (. VAR n, fn, mal: SymTab.Name; 2184 cls: INTEGER; 2185 ic: SymTab.TypeIndex; 2186 curT, it, eT, bt: 2187 SymTab.TypeIndex; 2188 iq, ql, qlo, qhi, qe: 2189 QbeGen.QVal; 2190 lo, hi: INTEGER; 2191 fo: INTEGER; 2192 isOpen: BOOLEAN; 2193 qb, cv: QbeGen.QVal; 2194 fid, fref, slot: INTEGER; 2195 r: BOOLEAN; 2196 astDes, astSel: AST.Node; .) 2197 = GetIdent (. methCls := SymTab.InvalidType; 2198 QbeGen.CopyOp(n, qn); 2199 sfx := FALSE; 2200 fid := 0; fref := 0; slot := 0; 2201 IF NOT SymTab.Lookup(n) THEN 2202 (* a bare method name inside 2203 a CLASS IMPLEMENTATION 2204 is a sibling call on 2205 THIS *) 2206 ic := SymTab.CurImplClass(); 2207 IF (ic # 2208 SymTab.InvalidType) 2209 AND SymTab.MethodExists(ic, n) THEN 2210 sfx := FALSE; 2211 QbeGen.ThisBase(q); 2212 QbeGen.ArmRecv(q); 2213 methCls := ic; 2214 k := SymTab.KindProc; 2215 t := SymTab.InvalidType 2216 ELSIF SymTab.InProc() THEN 2217 (* not declared yet: a 2218 forward reference to a 2219 module-level variable 2220 declared further down. *) 2221 k := SymTab.KindVar; 2222 r := SymTab.FwdVarRef(n, k, 2223 fref, t); 2224 slot := QbeGen.FwdDesignator(); 2225 FwdVarNote(fref, slot); 2226 fid := slot; 2227 QbeGen.FwdAddrOper(fid, q); 2228 sfx := TRUE 2229 ELSE 2230 SemError(201); 2231 t := 2232 SymTab.InvalidType; 2233 k := -1; 2234 QbeGen.CopyOp("0", q) 2235 END 2236 ELSE 2237 t := SymTab.SymType(n); 2238 k := SymTab.SymKind(n); 2239 IF k = SymTab.KindConst THEN 2240 IF SymTab.Equal(n, 2241 "TRUE") THEN 2242 t := SymTab.BoolType(); 2243 QbeGen.CopyOp("1", q) 2244 ELSIF SymTab.Equal(n, 2245 "FALSE") THEN 2246 t := SymTab.BoolType(); 2247 QbeGen.CopyOp("0", q) 2248 ELSIF SymTab.Equal(n, 2249 "NIL") THEN 2250 QbeGen.CopyOp("0", q) 2251 ELSE 2252 cls := 2253 SymTab.ClassOf(t); 2254 IF (t # 2255 SymTab.InvalidType) 2256 AND ((cls = SymTab.ClInt) 2257 OR (cls 2258 = SymTab.ClChar) 2259 OR (cls 2260 = SymTab.ClEnum) 2261 OR (cls 2262 = SymTab.ClReal) 2263 OR (cls 2264 = SymTab.ClLong) 2265 OR (cls 2266 = SymTab.ClNil)) THEN 2267 IF cls = SymTab.ClNil THEN 2268 QbeGen.CopyOp("0", q) 2269 ELSIF ((cls 2270 = SymTab.ClInt) 2271 OR (cls 2272 = SymTab.ClChar) 2273 OR (cls 2274 = SymTab.ClEnum) 2275 OR (cls 2276 = SymTab.ClLong)) 2277 AND SymTab.GetSymVal(n, cv) 2278 AND QbeGen.IsImm(cv) THEN 2279 QbeGen.CopyOp(cv, q) 2280 ELSE 2281 QbeGen.LoadVar(n, 2282 cls = SymTab.ClReal, 2283 q) 2284 END 2285 ELSIF (cls = SymTab.ClArray) 2286 OR (cls = SymTab.ClRecord) 2287 OR (cls = SymTab.ClClass) 2288 OR (cls = SymTab.ClStr) 2289 OR (cls = SymTab.ClUStr) THEN 2290 (* aggregate constant: 2291 its value IS the 2292 descriptor address *) 2293 IF SymTab.GetSymVal(n, cv) THEN 2294 QbeGen.CopyOp(cv, q) 2295 ELSE 2296 QbeGen.CopyOp("0", q) 2297 END 2298 ELSE 2299 IF t # 2300 SymTab.InvalidType THEN 2301 SemError(230) 2302 END; 2303 QbeGen.CopyOp("0", q) 2304 END 2305 END 2306 ELSIF (k = SymTab.KindVar) 2307 OR (k = SymTab.KindParam) THEN 2308 cls := 2309 SymTab.ClassOf(t); 2310 IF (cls = SymTab.ClInt) 2311 OR (cls = SymTab.ClBool) 2312 OR (cls = SymTab.ClChar) 2313 OR (cls = SymTab.ClUChar) 2314 OR (cls = SymTab.ClEnum) 2315 OR (cls 2316 = SymTab.ClReal) THEN 2317 QbeGen.LoadVar(n, 2318 cls = SymTab.ClReal, q) 2319 ELSIF (cls = SymTab.ClPtr) 2320 OR (cls = SymTab.ClProc) THEN 2321 QbeGen.LoadPtr(n, q) 2322 ELSIF cls = SymTab.ClLong THEN 2323 QbeGen.LoadLong(n, q) 2324 ELSIF (cls 2325 = SymTab.ClArray) 2326 OR (cls 2327 = SymTab.ClSet) 2328 OR (cls 2329 = SymTab.ClRecord) 2330 OR (cls 2331 = SymTab.ClUStr) 2332 OR (cls 2333 = SymTab.ClClass) THEN 2334 QbeGen.AddrOf(n, q) 2335 ELSE SemError(230); 2336 QbeGen.CopyOp("0", q) 2337 END 2338 ELSE QbeGen.CopyOp("0", q); 2339 IF k = SymTab.KindImport THEN 2340 SemError(230) 2341 ELSIF k = 2342 SymTab.KindProc THEN 2343 (* bare procedure name: 2344 a following ArgList 2345 makes it a call; 2346 otherwise Fact 2347 reports 230 *) 2348 ELSE 2349 IF k = SymTab.KindField THEN 2350 IF QbeGen.TopWith(qb) THEN 2351 fo := 2352 SymTab.FieldOffset( 2353 SymTab.FieldOwner(n), 2354 n); 2355 QbeGen.FieldAddr(qb, 2356 fo, q); 2357 sfx := TRUE 2358 ELSE SemError(230); 2359 QbeGen.CopyOp("0", q) 2360 END 2361 END 2362 END 2363 END 2364 END; .) 2365 (. astDes := AST.MakeNode(AST.NkDesignator); 2366 AST.SetChild(astDes, AST.NChild(astDes), AST.MakeLeaf(AST.NkIdent, n)); .) 2367 { "[" Expr 2368 (. AST.SetChild(astDes, AST.NChild(astDes), 2369 AST.MakeUn(AST.NkSelector, AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN 2370 ELSIF SymTab.ClassOf(t) # 2371 SymTab.ClArray THEN 2372 SemError(217); 2373 t := SymTab.InvalidType 2374 ELSIF NOT SymTab.IsIntFamily(it) 2375 AND (SymTab.ClassOf(it) # 2376 SymTab.ClChar) 2377 AND (SymTab.ClassOf(it) # 2378 SymTab.ClEnum) THEN 2379 SemError(218); 2380 t := SymTab.InvalidType 2381 ELSE 2382 QbeGen.WidenIndex(iq, ql); 2383 isOpen := 2384 SymTab.IsOpenArray(t); 2385 IF isOpen THEN 2386 QbeGen.CopyOp("0", qlo); 2387 IF SymTab.IsCharArray(t) 2388 OR SymTab.IsUCharArray(t) THEN 2389 QbeGen.OpenHiChar(q, qhi) 2390 ELSE QbeGen.OpenHi(q, qhi) 2391 END 2392 ELSE 2393 lo := SymTab.ArrayLo(t); 2394 hi := SymTab.ArrayHi(t); 2395 IF SymTab.IsCharArray(t) 2396 OR SymTab.IsUCharArray(t) THEN 2397 hi := hi + 1 2398 END; 2399 QbeGen.IntStr(lo, qlo); 2400 QbeGen.IntStr(hi, qhi) 2401 END; 2402 QbeGen.CheckRange(ql, qlo, 2403 qhi); 2404 eT := SymTab.ArrayElem(t); 2405 QbeGen.ElemAddr(q, ql, qlo, 2406 t, qe); 2407 IF SymTab.ClassOf(eT) = 2408 SymTab.ClArray THEN 2409 QbeGen.ElemLoad(qe, eT, q) 2410 ELSE QbeGen.CopyOp(qe, q) 2411 END; 2412 t := eT; sfx := TRUE 2413 END; .) 2414 { "," Expr 2415 (. AST.SetChild(astDes, AST.NChild(astDes), 2416 AST.MakeUn(AST.NkSelector, AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN 2417 ELSIF SymTab.ClassOf(t) # 2418 SymTab.ClArray THEN 2419 SemError(217); 2420 t := SymTab.InvalidType 2421 ELSIF NOT SymTab.IsIntFamily(it) 2422 AND (SymTab.ClassOf(it) # 2423 SymTab.ClChar) 2424 AND (SymTab.ClassOf(it) # 2425 SymTab.ClEnum) THEN 2426 SemError(218); 2427 t := SymTab.InvalidType 2428 ELSE 2429 QbeGen.WidenIndex(iq, ql); 2430 isOpen := 2431 SymTab.IsOpenArray(t); 2432 IF isOpen THEN 2433 QbeGen.CopyOp("0", qlo); 2434 IF SymTab.IsCharArray(t) 2435 OR SymTab.IsUCharArray(t) THEN 2436 QbeGen.OpenHiChar(q, qhi) 2437 ELSE QbeGen.OpenHi(q, qhi) 2438 END 2439 ELSE 2440 lo := SymTab.ArrayLo(t); 2441 hi := SymTab.ArrayHi(t); 2442 IF SymTab.IsCharArray(t) 2443 OR SymTab.IsUCharArray(t) THEN 2444 hi := hi + 1 2445 END; 2446 QbeGen.IntStr(lo, qlo); 2447 QbeGen.IntStr(hi, qhi) 2448 END; 2449 QbeGen.CheckRange(ql, qlo, 2450 qhi); 2451 eT := SymTab.ArrayElem(t); 2452 QbeGen.ElemAddr(q, ql, qlo, 2453 t, qe); 2454 IF SymTab.ClassOf(eT) = 2455 SymTab.ClArray THEN 2456 QbeGen.ElemLoad(qe, eT, q) 2457 ELSE QbeGen.CopyOp(qe, q) 2458 END; 2459 t := eT; sfx := TRUE 2460 END; .) } 2461 "]" 2462 | "." GetIdent 2463 (. astSel := AST.MakeNode(AST.NkSelector); 2464 AST.SetOp(astSel, AST.SelField); 2465 AST.SetChild(astSel, 0, AST.MakeLeaf(AST.NkIdent, fn)); 2466 AST.SetChild(astDes, AST.NChild(astDes), astSel); IF k = SymTab.KindModule THEN 2467 (* qualified L.x: materialize 2468 the export, then load it *) 2469 IF NOT SymTab.MaterializeAlias(n, 2470 fn, mal) THEN 2471 SemError(201); 2472 t := SymTab.InvalidType; 2473 QbeGen.CopyOp("0", q) 2474 ELSE 2475 QbeGen.CopyOp(mal, qn); 2476 t := SymTab.SymType(mal); 2477 k := SymTab.SymKind(mal); 2478 sfx := FALSE; 2479 IF k = SymTab.KindProc THEN 2480 (* call: ArgList supplies 2481 the value *) 2482 QbeGen.CopyOp("0", q) 2483 ELSIF NOT QbeGen.LoadDesignator( 2484 mal, t, k, q) THEN 2485 SemError(230); 2486 QbeGen.CopyOp("0", q) 2487 END 2488 END 2489 ELSIF t = SymTab.InvalidType THEN 2490 ELSIF (SymTab.ClassOf(t) # 2491 SymTab.ClRecord) 2492 AND (SymTab.ClassOf(t) # 2493 SymTab.ClClass) THEN 2494 SemError(215); 2495 t := SymTab.InvalidType 2496 ELSIF (SymTab.ClassOf(t) = 2497 SymTab.ClClass) 2498 AND SymTab.MethodExists(t, fn) THEN 2499 (* obj.Method: bind the 2500 method and pass obj as 2501 the hidden receiver; q 2502 already holds the 2503 object's address *) 2504 QbeGen.ArmRecv(q); 2505 QbeGen.CopyOp(fn, n); 2506 QbeGen.CopyOp(fn, qn); 2507 methCls := t; 2508 k := SymTab.KindProc; 2509 t := SymTab.InvalidType 2510 ELSIF NOT SymTab.FieldExists(t, 2511 fn) THEN 2512 SemError(216); 2513 t := SymTab.InvalidType 2514 ELSE 2515 fo := SymTab.FieldOffset(t, 2516 fn); 2517 t := SymTab.FieldType(t, fn); 2518 QbeGen.FieldAddr(q, fo, qe); 2519 (* array fields are inline: 2520 the field address is the 2521 descriptor, like records *) 2522 QbeGen.CopyOp(qe, q); 2523 sfx := TRUE 2524 END; .) 2525 | "^" 2526 (. astSel := AST.MakeNode(AST.NkSelector); 2527 AST.SetOp(astSel, AST.SelDeref); 2528 AST.SetChild(astDes, AST.NChild(astDes), astSel); IF t = SymTab.InvalidType THEN 2529 ELSIF SymTab.ClassOf(t) # 2530 SymTab.ClPtr THEN 2531 SemError(219); 2532 t := SymTab.InvalidType 2533 ELSE 2534 bt := SymTab.PtrBase(t); 2535 IF bt = SymTab.InvalidType THEN 2536 ELSE 2537 IF sfx THEN 2538 QbeGen.ElemLoad(q, t, 2539 qb); 2540 QbeGen.CopyOp(qb, q) 2541 END; 2542 t := bt; 2543 (* q holds the pointee 2544 address: Fact loads 2545 scalars/pointers and uses 2546 the address for 2547 aggregates; the VAR-actual 2548 note is q itself. *) 2549 sfx := TRUE 2550 END 2551 END; .) } (. astCur := astDes; .) . 2552 (* Result suffix (ISO component after a function call): `F()^`, 2553 `F()[i]`, `F().field`. The call result is in t/q with sfx FALSE 2554 (a value, or a descriptor address for aggregates); each component 2555 descends one level exactly like the Design components. *) 2556 ResultComp (. VAR it, eT, bt: SymTab.TypeIndex; 2558 iq, ql, qlo, qhi, qe, qb: 2559 QbeGen.QVal; 2560 lo, hi, fo: INTEGER; 2561 isOpen: BOOLEAN; 2562 fname: SymTab.Name; 2563 astWrap, astSel: AST.Node; .) 2564 = "[" Expr 2565 (. IF AST.Kind(node) # AST.NkDesignator THEN 2566 astWrap := AST.MakeNode( 2567 AST.NkDesignator); 2568 AST.SetChild(astWrap, 0, node); 2569 node := astWrap 2570 END; 2571 AST.SetChild(node, AST.NChild(node), 2572 AST.MakeUn(AST.NkSelector, 2573 AST.SelIndex, astCur)); IF t = SymTab.InvalidType THEN 2574 ELSIF SymTab.ClassOf(t) # 2575 SymTab.ClArray THEN 2576 SemError(217); 2577 t := SymTab.InvalidType 2578 ELSIF NOT SymTab.IsIntFamily(it) 2579 AND (SymTab.ClassOf(it) # SymTab.ClChar) 2580 AND (SymTab.ClassOf(it) # SymTab.ClEnum) THEN 2581 SemError(218); 2582 t := SymTab.InvalidType 2583 ELSE 2584 QbeGen.WidenIndex(iq, ql); 2585 isOpen := 2586 SymTab.IsOpenArray(t); 2587 IF isOpen THEN 2588 QbeGen.CopyOp("0", qlo); 2589 IF SymTab.IsCharArray(t) 2590 OR SymTab.IsUCharArray(t) THEN 2591 QbeGen.OpenHiChar(q, qhi) 2592 ELSE QbeGen.OpenHi(q, qhi) 2593 END 2594 ELSE 2595 lo := SymTab.ArrayLo(t); 2596 hi := SymTab.ArrayHi(t); 2597 IF SymTab.IsCharArray(t) 2598 OR SymTab.IsUCharArray(t) THEN 2599 hi := hi + 1 2600 END; 2601 QbeGen.IntStr(lo, qlo); 2602 QbeGen.IntStr(hi, qhi) 2603 END; 2604 QbeGen.CheckRange(ql, qlo, 2605 qhi); 2606 eT := SymTab.ArrayElem(t); 2607 QbeGen.ElemAddr(q, ql, qlo, 2608 t, qe); 2609 IF SymTab.ClassOf(eT) = 2610 SymTab.ClArray THEN 2611 QbeGen.ElemLoad(qe, eT, q) 2612 ELSE QbeGen.CopyOp(qe, q) 2613 END; 2614 t := eT; sfx := TRUE 2615 END; .) 2616 "]" 2617 | "." GetIdent 2618 (. IF AST.Kind(node) # AST.NkDesignator THEN 2619 astWrap := AST.MakeNode( 2620 AST.NkDesignator); 2621 AST.SetChild(astWrap, 0, node); 2622 node := astWrap 2623 END; 2624 AST.SetChild(node, AST.NChild(node), 2625 AST.MakeUn(AST.NkSelector, 2626 AST.SelField, 2627 AST.MakeLeaf(AST.NkIdent, 2628 fname))); IF t = SymTab.InvalidType THEN 2629 ELSIF (SymTab.ClassOf(t) # 2630 SymTab.ClRecord) 2631 AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN 2632 SemError(215); 2633 t := SymTab.InvalidType 2634 ELSIF NOT SymTab.FieldExists(t, 2635 fname) THEN 2636 SemError(216); 2637 t := SymTab.InvalidType 2638 ELSE 2639 fo := SymTab.FieldOffset(t, 2640 fname); 2641 t := SymTab.FieldType(t, fname); 2642 QbeGen.FieldAddr(q, fo, qe); 2643 QbeGen.CopyOp(qe, q); 2644 sfx := TRUE 2645 END; .) 2646 | "^" (. IF AST.Kind(node) # AST.NkDesignator THEN 2647 astWrap := AST.MakeNode( 2648 AST.NkDesignator); 2649 AST.SetChild(astWrap, 0, node); 2650 node := astWrap 2651 END; 2652 astSel := AST.MakeNode(AST.NkSelector); 2653 AST.SetOp(astSel, AST.SelDeref); 2654 AST.SetChild(node, 2655 AST.NChild(node), astSel); IF t = SymTab.InvalidType THEN 2656 ELSIF SymTab.ClassOf(t) # 2657 SymTab.ClPtr THEN 2658 SemError(219); 2659 t := SymTab.InvalidType 2660 ELSE 2661 bt := SymTab.PtrBase(t); 2662 IF bt # SymTab.InvalidType THEN 2663 IF sfx THEN 2664 QbeGen.ElemLoad(q, t, qb); 2665 QbeGen.CopyOp(qb, q) 2666 END; 2667 t := bt; sfx := TRUE 2668 END 2669 END; .) . 2670 Expr 2671 (. VAR t2: SymTab.TypeIndex; 2672 op: INTEGER; 2673 q2, qt, wl: QbeGen.QVal; 2674 astA, astB: AST.Node; 2675 astOp: INTEGER; 2676 astMade: BOOLEAN; 2677 isR: BOOLEAN; .) 2678 = SimExpr (. astA := astCur; astMade := FALSE; .) 2679 [ Rel SimExpr 2680 (. astB := astCur; astMade := TRUE; 2681 astOp := AST.OpEq; 2682 IF op = SymTab.OpNeq1 THEN astOp := AST.OpNe 2683 ELSIF op = SymTab.OpNeq2 THEN astOp := AST.OpNe 2684 ELSIF op = SymTab.OpLt THEN astOp := AST.OpLt 2685 ELSIF op = SymTab.OpLe THEN astOp := AST.OpLe 2686 ELSIF op = SymTab.OpGt THEN astOp := AST.OpGt 2687 ELSIF op = SymTab.OpGe THEN astOp := AST.OpGe 2688 ELSIF op = SymTab.OpIn THEN astOp := AST.OpIn 2689 END; 2690 IF op = SymTab.OpIn THEN 2691 IF SymTab.InCheck(t, t2) THEN 2692 IF (t = SymTab.InvalidType) 2693 OR (t2 = SymTab.InvalidType) THEN 2694 t := SymTab.BoolType(); QbeGen.CopyOp("0", q) 2695 ELSE 2696 QbeGen.InSet(q, q2, SymTab.SetBaseLo(t2), 2697 SymTab.SetCount(t2), qt); 2698 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2699 END 2700 ELSE SemError(222); t := SymTab.InvalidType; 2701 QbeGen.CopyOp("0", q) 2702 END 2703 ELSIF SymTab.RelCheck(t, t2, op) THEN 2704 IF (t = SymTab.InvalidType) 2705 OR (t2 = SymTab.InvalidType) THEN 2706 t := SymTab.BoolType(); QbeGen.CopyOp("0", q) 2707 ELSIF (SymTab.ClassOf(t) = SymTab.ClPtr) 2708 OR (SymTab.ClassOf(t2) = SymTab.ClPtr) THEN 2709 IF SymTab.IsFwdVar(t) OR SymTab.IsFwdVar(t2) THEN 2710 QbeGen.Cmp(op, q, q2, qt, FALSE); 2711 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2712 ELSIF (op # SymTab.OpEq) AND (op # SymTab.OpNeq1) 2713 AND (op # SymTab.OpNeq2) THEN 2714 SemError(213); t := SymTab.InvalidType; 2715 QbeGen.CopyOp("0", q) 2716 ELSE 2717 QbeGen.CmpL(op, q, q2, qt); 2718 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2719 END 2720 ELSIF (SymTab.ClassOf(t) = SymTab.ClSet) 2721 OR (SymTab.ClassOf(t2) = SymTab.ClSet) THEN 2722 QbeGen.CmpSet(op, q, q2, 2723 SymTab.SetWords(t), SymTab.SetWords(t2), qt); 2724 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2725 ELSIF SymTab.StrCompat(t, t2) THEN 2726 QbeGen.StrEq(op, q, q2, qt); 2727 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2728 ELSIF SymTab.IsLongFamily(t) 2729 OR SymTab.IsLongFamily(t2) THEN 2730 IF SymTab.IsIntFamily(t) THEN 2731 QbeGen.WidenLong(q, wl); QbeGen.CopyOp(wl, q) 2732 END; 2733 IF SymTab.IsIntFamily(t2) THEN 2734 QbeGen.WidenLong(q2, wl); QbeGen.CopyOp(wl, q2) 2735 END; 2736 QbeGen.CmpLong(op, q, q2, qt); 2737 t := SymTab.BoolType(); QbeGen.CopyOp(qt, q) 2738 ELSE 2739 isR := SymTab.ClassOf(t) = SymTab.ClReal; 2740 t := SymTab.BoolType(); 2741 QbeGen.Cmp(op, q, q2, qt, isR); 2742 QbeGen.CopyOp(qt, q) 2743 END 2744 ELSE SemError(213); t := SymTab.InvalidType; 2745 QbeGen.CopyOp("0", q) 2746 END; 2747 astCur := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); .) ] 2748 (. IF NOT astMade THEN astCur := astA END; .) . 2749 Rel 2750 = "=" (. op := SymTab.OpEq; .) 2751 | "#" (. op := SymTab.OpNeq1; .) 2752 | "<" (. op := SymTab.OpLt; .) 2753 | "<=" (. op := SymTab.OpLe; .) 2754 | ">" (. op := SymTab.OpGt; .) 2755 | ">=" (. op := SymTab.OpGe; .) 2756 | "IN" (. op := SymTab.OpIn; .) . 2757 SimExpr 2758 (. VAR t2, res2, lt, rt: 2759 SymTab.TypeIndex; 2760 op: INTEGER; 2761 q2, qt, wq, qf, q2a, q2b: 2762 QbeGen.QVal; 2763 neg, isR, isL, folded: 2764 BOOLEAN; 2765 fok: BOOLEAN; 2766 lw, rw, mw: CARDINAL; 2767 lTrue, lNext, lDone, qr, qs: QbeGen.QVal; 2768 astA, astB: AST.Node; 2769 astSign, astOp: INTEGER; .) 2770 = (. neg := FALSE; astSign := 0; .) 2771 [ "+" (. neg := TRUE; astSign := 1; .) 2772 | "-" (. neg := TRUE; astSign := -1; .) ] 2773 Term (. astA := astCur; IF neg THEN 2774 IF QbeGen.IsImm(q) THEN 2775 QbeGen.NegFold(q, q) 2776 ELSE QbeGen.NewTemp(qt); 2777 QbeGen.NegQ(q, qt, 2778 SymTab.ClassOf(t) 2779 = SymTab.ClReal); 2780 QbeGen.CopyOp(qt, q) 2781 END 2782 END; 2783 IF astSign < 0 THEN 2784 astCur := AST.MakeUn( 2785 AST.NkUnary, AST.OpSub, astA); 2786 astA := astCur 2787 END; .) 2788 { AddOp (. IF op = SymTab.OpOr THEN 2789 QbeGen.DelayBegin END; .) 2790 Term (. astB := astCur; IF op = SymTab.OpOr THEN 2791 QbeGen.DelayEnd END; .) 2792 (. astOp := AST.OpAdd; 2793 IF op = SymTab.OpSub THEN astOp := AST.OpSub 2794 ELSIF op = SymTab.OpOr THEN astOp := AST.OpOr END; 2795 astA := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); 2796 astCur := astA; 2797 IF op = SymTab.OpOr THEN 2798 (* short-circuit: if q is true the RHS is skipped *) 2799 IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN 2800 t := SymTab.BoolType() 2801 ELSE SemError(212); t := SymTab.InvalidType END; 2802 IF t # SymTab.InvalidType THEN 2803 QbeGen.Slot4(qs); 2804 QbeGen.NewLabel(lTrue); 2805 QbeGen.NewLabel(lNext); 2806 QbeGen.NewLabel(lDone); 2807 QbeGen.Jnz(q, lTrue, lNext); 2808 QbeGen.EmitLabel(lTrue); 2809 QbeGen.StoreW(qs, "1"); 2810 QbeGen.Jmp(lDone); 2811 QbeGen.EmitLabel(lNext); 2812 QbeGen.DelayFlush; 2813 QbeGen.StoreW(qs, q2); 2814 QbeGen.Jmp(lDone); 2815 QbeGen.EmitLabel(lDone); 2816 QbeGen.LoadW(qs, qr); 2817 QbeGen.CopyOp(qr, q) 2818 ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) 2819 END 2820 ELSIF (op = SymTab.OpAdd) 2821 AND (SymTab.UStrCompat(t, t2) 2822 OR ((SymTab.ClassOf(t) = SymTab.ClUChar) 2823 AND (SymTab.ClassOf(t2) = SymTab.ClUStr)) 2824 OR ((SymTab.ClassOf(t) = SymTab.ClUStr) 2825 AND (SymTab.ClassOf(t2) = SymTab.ClUChar)) 2826 OR ((SymTab.ClassOf(t) = SymTab.ClUChar) 2827 AND (SymTab.ClassOf(t2) = SymTab.ClUChar))) THEN 2828 (* UString concatenation: a UCHAR operand becomes a 2829 1-codepoint UString; the result is a descriptor in the 2830 shim's concat buffer. Work on copies so neither 2831 operand is clobbered. *) 2832 IF SymTab.ClassOf(t) = SymTab.ClUStr THEN 2833 QbeGen.CopyOp(q, q2a) 2834 ELSE 2835 QbeGen.UStrFrom(q, q2a) 2836 END; 2837 IF SymTab.ClassOf(t2) = SymTab.ClUStr THEN 2838 QbeGen.UStrCat(q2a, q2, qt) 2839 ELSE 2840 QbeGen.UStrFrom(q2, q2b); 2841 QbeGen.UStrCat(q2a, q2b, qt) 2842 END; 2843 t := SymTab.NewUStr(); 2844 QbeGen.CopyOp(qt, q) 2845 ELSIF (op = SymTab.OpAdd) 2846 AND (SymTab.StrCompat(t, t2) 2847 OR (SymTab.IsStrType(t) 2848 AND (SymTab.ClassOf(t2) = SymTab.ClChar)) 2849 OR ((SymTab.ClassOf(t) = SymTab.ClChar) 2850 AND SymTab.IsStrType(t2))) THEN 2851 (* string concatenation; a CHAR operand becomes a 2852 1-character string literal. When both operands are 2853 constants, fold to a single string literal so a 2854 constructor element stays compile-time. *) 2855 QbeGen.StrFold(q, q2, SymTab.ClassOf(t), SymTab.ClassOf(t2), 2856 qt, fok); 2857 IF NOT fok THEN 2858 IF SymTab.StrCompat(t, t2) THEN 2859 QbeGen.StrCat(q, q2, qt) 2860 ELSIF SymTab.IsStrType(t) THEN 2861 QbeGen.DeclCharStr(q2, qs); 2862 QbeGen.StrCat(q, qs, qt) 2863 ELSE 2864 QbeGen.DeclCharStr(q, qs); 2865 QbeGen.StrCat(qs, q2, qt) 2866 END 2867 END; 2868 t := SymTab.NewStr(); 2869 QbeGen.CopyOp(qt, q) 2870 ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) 2871 AND (SymTab.ClassOf(t) = SymTab.ClSet) 2872 AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN 2873 lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); 2874 mw := lw; 2875 IF rw > mw THEN mw := rw END; 2876 IF op = SymTab.OpAdd THEN 2877 QbeGen.SetBinOp(0, q, q2, lw, rw, qt) 2878 ELSE 2879 QbeGen.SetBinOp(2, q, q2, lw, rw, qt) 2880 END; 2881 t := SymTab.NewSet( 2882 SymTab.NewSubR(0, 2883 VAL(INTEGER, mw) * 32 - 1)); 2884 QbeGen.CopyOp(qt, q) 2885 ELSE 2886 IF SymTab.ArithCheck(t, t2, FALSE, res2) THEN 2887 lt := t; rt := t2; t := res2 2888 ELSE SemError(211); t := SymTab.InvalidType END; 2889 IF t # SymTab.InvalidType THEN 2890 isL := SymTab.IsLongFamily(t); 2891 isR := SymTab.ClassOf(t) = SymTab.ClReal; 2892 folded := FALSE; 2893 IF (NOT isL) AND (NOT isR) 2894 AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN 2895 IF op = SymTab.OpAdd THEN 2896 folded := QbeGen.Fold2(0, q, q2, qf) 2897 ELSE 2898 folded := QbeGen.Fold2(1, q, q2, qf) 2899 END 2900 END; 2901 IF folded THEN QbeGen.CopyOp(qf, q) 2902 ELSE 2903 IF isL THEN 2904 IF SymTab.IsIntFamily(lt) THEN 2905 QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) 2906 END; 2907 IF SymTab.IsIntFamily(rt) THEN 2908 QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) 2909 END; 2910 QbeGen.NewTemp(qt); 2911 IF op = SymTab.OpAdd THEN 2912 QbeGen.Op3L("add", qt, q, q2) 2913 ELSE 2914 QbeGen.Op3L("sub", qt, q, q2) 2915 END 2916 ELSE 2917 QbeGen.NewTemp(qt); 2918 IF op = SymTab.OpAdd THEN 2919 QbeGen.Op3("add", qt, q, q2, isR) 2920 ELSE 2921 QbeGen.Op3("sub", qt, q, q2, isR) 2922 END 2923 END; 2924 QbeGen.CopyOp(qt, q) 2925 END 2926 ELSE QbeGen.CopyOp("0", q) 2927 END 2928 END; .) } . 2929 AddOp 2930 = "+" (. op := SymTab.OpAdd; .) 2931 | "-" (. op := SymTab.OpSub; .) 2932 | "OR" (. op := SymTab.OpOr; .) . 2933 Term 2934 (. VAR t2, res2, lt, rt: 2935 SymTab.TypeIndex; 2936 op: INTEGER; 2937 q2, qt, wq, qf: 2938 QbeGen.QVal; 2939 isR, isL, folded: BOOLEAN; 2940 lw, rw, mw: CARDINAL; 2941 lNext, lFalse, lDone, qr, qs: QbeGen.QVal; 2942 astA, astB: AST.Node; 2943 astOp: INTEGER; .) 2944 = Fact (. astA := astCur; .) { MulOp (. IF op = SymTab.OpAnd THEN 2945 QbeGen.DelayBegin END; .) 2946 Fact (. astB := astCur; IF op = SymTab.OpAnd THEN 2947 QbeGen.DelayEnd END; .) 2948 (. astOp := AST.OpMul; 2949 IF op = SymTab.OpSlash THEN astOp := AST.OpDiv 2950 ELSIF op = SymTab.OpDiv THEN astOp := AST.OpDiv 2951 ELSIF op = SymTab.OpMod THEN astOp := AST.OpMod 2952 ELSIF op = SymTab.OpAnd THEN astOp := AST.OpAnd END; 2953 astA := AST.MakeBin(AST.NkBinExpr, astOp, astA, astB); 2954 astCur := astA; 2955 IF op = SymTab.OpAnd THEN 2956 (* short-circuit: if q is false the RHS is skipped *) 2957 IF SymTab.BoolCheck(t) AND SymTab.BoolCheck(t2) THEN 2958 t := SymTab.BoolType() 2959 ELSE SemError(212); t := SymTab.InvalidType END; 2960 IF t # SymTab.InvalidType THEN 2961 QbeGen.Slot4(qs); 2962 QbeGen.NewLabel(lNext); 2963 QbeGen.NewLabel(lFalse); 2964 QbeGen.NewLabel(lDone); 2965 QbeGen.Jnz(q, lNext, lFalse); 2966 QbeGen.EmitLabel(lNext); 2967 QbeGen.DelayFlush; 2968 QbeGen.StoreW(qs, q2); 2969 QbeGen.Jmp(lDone); 2970 QbeGen.EmitLabel(lFalse); 2971 QbeGen.StoreW(qs, "0"); 2972 QbeGen.Jmp(lDone); 2973 QbeGen.EmitLabel(lDone); 2974 QbeGen.LoadW(qs, qr); 2975 QbeGen.CopyOp(qr, q) 2976 ELSE QbeGen.DelayFlush; QbeGen.CopyOp("0", q) 2977 END 2978 ELSIF (t # SymTab.InvalidType) AND (t2 # SymTab.InvalidType) 2979 AND (SymTab.ClassOf(t) = SymTab.ClSet) 2980 AND (SymTab.ClassOf(t2) = SymTab.ClSet) THEN 2981 lw := SymTab.SetWords(t); rw := SymTab.SetWords(t2); 2982 mw := lw; 2983 IF rw > mw THEN mw := rw END; 2984 IF op = SymTab.OpTimes THEN 2985 QbeGen.SetBinOp(1, q, q2, lw, rw, qt) 2986 ELSE 2987 QbeGen.SetBinOp(3, q, q2, lw, rw, qt) 2988 END; 2989 t := SymTab.NewSet( 2990 SymTab.NewSubR(0, 2991 VAL(INTEGER, mw) * 32 - 1)); 2992 QbeGen.CopyOp(qt, q) 2993 ELSE 2994 IF SymTab.ArithCheck(t, t2, 2995 (op = SymTab.OpDiv) OR (op = SymTab.OpMod), 2996 res2) THEN 2997 lt := t; rt := t2; t := res2 2998 ELSE SemError(211); t := SymTab.InvalidType END; 2999 IF t # SymTab.InvalidType THEN 3000 isL := SymTab.IsLongFamily(t); 3001 isR := SymTab.ClassOf(t) = SymTab.ClReal; 3002 folded := FALSE; 3003 IF (NOT isL) AND (NOT isR) 3004 AND QbeGen.IsImm(q) AND QbeGen.IsImm(q2) THEN 3005 IF op = SymTab.OpTimes THEN 3006 folded := QbeGen.Fold2(2, q, q2, qf) 3007 ELSIF op = SymTab.OpDiv THEN 3008 folded := QbeGen.Fold2(3, q, q2, qf) 3009 ELSIF op = SymTab.OpMod THEN 3010 folded := QbeGen.Fold2(4, q, q2, qf) 3011 END 3012 END; 3013 IF folded THEN QbeGen.CopyOp(qf, q) 3014 ELSE 3015 IF isL THEN 3016 IF SymTab.IsIntFamily(lt) THEN 3017 QbeGen.WidenLong(q, wq); QbeGen.CopyOp(wq, q) 3018 END; 3019 IF SymTab.IsIntFamily(rt) THEN 3020 QbeGen.WidenLong(q2, wq); QbeGen.CopyOp(wq, q2) 3021 END; 3022 QbeGen.NewTemp(qt); 3023 IF op = SymTab.OpTimes THEN 3024 QbeGen.Op3L("mul", qt, q, q2) 3025 ELSIF (op = SymTab.OpDiv) 3026 OR (op = SymTab.OpSlash) THEN 3027 QbeGen.Op3L("div", qt, q, q2) 3028 ELSE 3029 QbeGen.Op3L("rem", qt, q, q2) 3030 END 3031 ELSE 3032 QbeGen.NewTemp(qt); 3033 IF op = SymTab.OpTimes THEN 3034 QbeGen.Op3("mul", qt, q, q2, isR) 3035 ELSIF (op = SymTab.OpDiv) 3036 OR (op = SymTab.OpSlash) THEN 3037 QbeGen.Op3("div", qt, q, q2, isR) 3038 ELSE 3039 QbeGen.Op3("rem", qt, q, q2, isR) 3040 END 3041 END; 3042 QbeGen.CopyOp(qt, q) 3043 END 3044 ELSE QbeGen.CopyOp("0", q) 3045 END 3046 END; .) } . 3047 MulOp 3048 = "*" (. op := SymTab.OpTimes; .) 3049 | "/" (. op := SymTab.OpSlash; .) 3050 | "DIV" (. op := SymTab.OpDiv; .) 3051 | "MOD" (. op := SymTab.OpMod; .) 3052 | ( "AND" | "&" ) (. op := SymTab.OpAnd; .) . 3053 Fact 3054 (. VAR s: ARRAY [0 .. 255] OF CHAR; 3055 et, dt, t2, st, ct2, et2: 3056 SymTab.TypeIndex; 3057 dk: INTEGER; 3058 qd, q2, sq, qa, qm0, qr, qt: 3059 QbeGen.QVal; 3060 qn, vn: SymTab.Name; 3061 vt: SymTab.TypeIndex; 3062 c1, c2: INTEGER; 3063 lo, hi: INTEGER; 3064 isMax: BOOLEAN; 3065 called, isHigh, sfx, isCh, 3066 isU, uok, isStr: BOOLEAN; 3067 ucp: INTEGER; astIsLit: BOOLEAN; 3068 astD: AST.Node; 3069 astCall: BOOLEAN; 3070 astNode, astNot: AST.Node; 3071 j: CARDINAL; 3072 astArg2: AST.Node; 3073 astBrace: AST.Node; 3074 astRes: AST.Node; .) 3075 = (. astIsLit := FALSE; .) 3076 ( integer (. LexString(s); 3077 QbeGen.NormInt(s, q); IF twoPhase THEN astIsLit := TRUE; astCur := AST.MakeLeaf(AST.NkIntLit, s) END; 3078 t := SymTab.IntType(); .) 3079 | charConst (. LexString(s); 3080 QbeGen.NormLit(s, q, isCh); 3081 IF twoPhase THEN 3082 astIsLit := TRUE; 3083 astCur := AST.MakeLeaf( 3084 AST.NkCharLit, s) 3085 END; 3086 t := SymTab.CharType(); .) 3087 | real (. LexString(s); 3088 QbeGen.NormReal(s, q); 3089 IF twoPhase THEN 3090 astIsLit := TRUE; 3091 astCur := AST.MakeLeaf( 3092 AST.NkRealLit, s) 3093 END; 3094 t := SymTab.RealType(); .) 3095 | string (. LexString(s); 3096 IF twoPhase THEN 3097 astIsLit := TRUE; 3098 astCur := AST.MakeLeaf( 3099 AST.NkStrLit, s) 3100 END; 3101 IF SymTab.StrLen(s) = 3 THEN 3102 t := SymTab.CharType(); 3103 QbeGen.IntStr( 3104 QbeGen.CharVal(s), q) 3105 ELSE t := SymTab.NewStr(); 3106 QbeGen.DeclStr(s, q); 3107 (* a literal's value IS its 3108 static descriptor address *) 3109 QbeGen.NoteAddr(q, q) 3110 END; .) 3111 | ustring (. LexString(s); 3112 IF twoPhase THEN 3113 astIsLit := TRUE; 3114 astCur := AST.MakeLeaf( 3115 AST.NkStrLit, s) 3116 END; 3117 QbeGen.DeclUStr(s, q, isU, ucp, 3118 uok); 3119 IF NOT uok THEN 3120 SemError(234); 3121 t := SymTab.InvalidType 3122 ELSIF isU THEN 3123 t := SymTab.UCharType(); 3124 QbeGen.IntStr(ucp, q) 3125 ELSE 3126 t := SymTab.NewUStr(); 3127 QbeGen.NoteAddr(q, q) 3128 END; .) 3129 | Design (. astD := astCur; astCall := FALSE; astBrace := AST.NoNode; 3130 astNArgs := 0; called := FALSE; 3131 t := dt; 3132 IF sfx THEN 3133 IF dt = 3134 SymTab.InvalidType THEN 3135 QbeGen.CopyOp("0", q) 3136 ELSIF (SymTab.ClassOf(dt) = 3137 SymTab.ClRecord) 3138 OR (SymTab.ClassOf(dt) = 3139 SymTab.ClSet) 3140 OR (SymTab.ClassOf(dt) = 3141 SymTab.ClArray) 3142 OR (SymTab.ClassOf(dt) = 3143 SymTab.ClClass) THEN 3144 QbeGen.CopyOp(qd, q) 3145 ELSE QbeGen.ElemLoad(qd, dt, 3146 q) 3147 END 3148 ELSE QbeGen.CopyOp(qd, q) 3149 END; 3150 IF (dk = SymTab.KindVar) 3151 OR (dk = SymTab.KindParam) 3152 OR (dk = 3153 SymTab.KindField) THEN 3154 IF sfx THEN 3155 QbeGen.NoteAddr(q, qd) 3156 ELSE 3157 QbeGen.AddrOf(qn, qa); 3158 QbeGen.NoteAddr(q, qa) 3159 END 3160 ELSIF sfx 3161 AND (dt # 3162 SymTab.InvalidType) 3163 AND ((SymTab.ClassOf(dt) = 3164 SymTab.ClArray) 3165 OR (SymTab.ClassOf(dt) = 3166 SymTab.ClSet) 3167 OR (SymTab.ClassOf(dt) = 3168 SymTab.ClRecord)) THEN 3169 QbeGen.NoteAddr(qd, qd) 3170 END; .) 3171 [ TypedBraceLit (. t := dt; astCall := TRUE; 3172 astBrace := astCur; .) ] 3173 [ ArgList 3174 (. astCall := TRUE; 3175 astNode := AstCallNode(astD); 3176 astRes := astNode; 3177 t := ct2; 3178 QbeGen.CopyOp(q2, q); 3179 sfx := FALSE; .) 3180 { ResultComp } 3181 (. IF sfx THEN 3182 IF t = SymTab.InvalidType THEN 3183 QbeGen.CopyOp("0", q) 3184 ELSIF (SymTab.ClassOf(t) # 3185 SymTab.ClRecord) 3186 AND (SymTab.ClassOf(t) # SymTab.ClSet) 3187 AND (SymTab.ClassOf(t) # SymTab.ClArray) 3188 AND (SymTab.ClassOf(t) # SymTab.ClClass) THEN 3189 QbeGen.ElemLoad(q, t, q2); 3190 QbeGen.CopyOp(q2, q) 3191 END 3192 END; .) ] 3193 (. IF called THEN 3194 astCur := astRes 3195 ELSIF astCall THEN 3196 astCur := astBrace 3197 ELSE astCur := astD 3198 END; 3199 astIsLit := TRUE; 3200 IF NOT called 3201 AND (dk = SymTab.KindProc) THEN 3202 (* bare zero-arg function 3203 call (parentheses may be 3204 omitted); a proper or 3205 parameterised proc here 3206 is 230 *) 3207 IF (SymTab.ProcNPar(qn) = 0) 3208 AND (SymTab.ProcRes(qn) # 3209 SymTab.InvalidType) THEN 3210 QbeGen.Mangled(qn, 3211 SymTab.ProcUid(qn), qm0); 3212 QbeGen.CallBegin(qm0, 3213 SymTab.ProcRes(qn), 3214 SymTab.ProcDepthOf(qn), 3215 SymTab.IsExternal(qn)); 3216 QbeGen.CallEnd(TRUE, q); 3217 t := SymTab.ProcRes(qn) 3218 ELSE 3219 (* procedure used as a 3220 value (assign to a 3221 procedure variable): 3222 its code address *) 3223 t := SymTab.ProcTypeOf(qn); 3224 QbeGen.Mangled(qn, 3225 SymTab.ProcUid(qn), qm0); 3226 QbeGen.ProcAddr(qm0, q) 3227 END 3228 END; .) 3229 | ( "HIGH" (. isHigh := TRUE; .) 3230 | ( "LEN" | "LENGTH" ) (. isHigh := FALSE; .) ) 3231 "(" ( Design (. isStr := FALSE; 3232 isU := FALSE; .) 3233 | string (. LexString(s); astCur := AST.MakeLeaf(AST.NkStrLit, s); 3234 isStr := TRUE; 3235 isU := FALSE; 3236 IF SymTab.StrLen(s) = 3 THEN 3237 dt := SymTab.CharType(); 3238 QbeGen.IntStr(QbeGen.CharVal(s), 3239 qd) 3240 ELSE 3241 dt := SymTab.NewStr(); 3242 QbeGen.DeclStr(s, qd); 3243 QbeGen.NoteAddr(qd, qd) 3244 END; 3245 dk := -1; 3246 qn[0] := CHR(0); .) 3247 | ustring (. LexString(s); astCur := AST.MakeLeaf(AST.NkStrLit, s); 3248 QbeGen.DeclUStr(s, qd, isU, ucp, 3249 uok); 3250 isStr := FALSE; 3251 IF NOT uok THEN 3252 SemError(234); 3253 dt := SymTab.InvalidType 3254 ELSIF isU THEN 3255 (* one codepoint: a UCHAR; 3256 LEN is 1, HIGH is 0 *) 3257 dt := SymTab.UCharType(); 3258 QbeGen.IntStr(ucp, qd) 3259 ELSE 3260 dt := SymTab.NewUStr(); 3261 QbeGen.NoteAddr(qd, qd) 3262 END; 3263 dk := -1; 3264 qn[0] := CHR(0); .) ) 3265 ")" 3266 (. astNode := AST.MakeNode(AST.NkCall); 3267 IF isHigh THEN AST.SetChild(astNode, 0, 3268 AST.MakeLeaf(AST.NkIdent, "HIGH")) 3269 ELSE AST.SetChild(astNode, 0, 3270 AST.MakeLeaf(AST.NkIdent, "LEN")) END; 3271 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3272 astCur := astNode; astIsLit := TRUE; 3273 IF (dt # SymTab.InvalidType) 3274 AND (SymTab.ClassOf(dt) = SymTab.ClUStr) THEN 3275 (* UString: the count is 3276 the descriptor header *) 3277 IF isHigh THEN 3278 QbeGen.UStrLen(qd, qr); 3279 QbeGen.DecQ(qr) 3280 ELSE 3281 QbeGen.UStrLen(qd, qr) 3282 END; 3283 t := SymTab.IntType(); 3284 QbeGen.CopyOp(qr, q) 3285 ELSIF (dt # SymTab.InvalidType) 3286 AND (SymTab.ClassOf(dt) = SymTab.ClUChar) THEN 3287 (* single UCHAR codepoint *) 3288 IF isHigh THEN 3289 QbeGen.CopyOp("0", qr) 3290 ELSE 3291 QbeGen.CopyOp("1", qr) 3292 END; 3293 t := SymTab.IntType(); 3294 QbeGen.CopyOp(qr, q) 3295 ELSIF isStr THEN 3296 (* fold: content length at 3297 compile time *) 3298 IF SymTab.StrLen(s) = 3 THEN 3299 c1 := 1 3300 ELSE 3301 c1 := 3302 SymTab.StrLen(s) - 2 3303 END; 3304 IF isHigh THEN 3305 DEC(c1) 3306 END; 3307 QbeGen.IntStr(c1, qr); 3308 t := SymTab.IntType(); 3309 QbeGen.CopyOp(qr, q) 3310 ELSIF dt = SymTab.InvalidType THEN 3311 t := SymTab.InvalidType; 3312 QbeGen.CopyOp("0", q) 3313 ELSIF SymTab.ClassOf(dt) # 3314 SymTab.ClArray THEN 3315 SemError(217); 3316 t := SymTab.InvalidType; 3317 QbeGen.CopyOp("0", q) 3318 ELSE 3319 IF isHigh THEN 3320 IF SymTab.IsOpenArray(dt) THEN 3321 QbeGen.OpenHi(qd, qr) 3322 ELSE 3323 QbeGen.IntStr( 3324 SymTab.ArrayHi(dt), qr) 3325 END 3326 ELSE 3327 IF SymTab.IsOpenArray(dt) THEN 3328 QbeGen.LoadCount(qd, qr) 3329 ELSE 3330 QbeGen.IntStr(VAL( 3331 INTEGER, 3332 SymTab.ArrayLen(dt)), 3333 qr) 3334 END 3335 END; 3336 t := SymTab.IntType(); 3337 QbeGen.CopyOp(qr, q) 3338 END; .) 3339 | ( "SIZE" | "TSIZE" ) "(" Design ")" 3340 (. astNode := AST.MakeNode(AST.NkCall); 3341 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "SIZE")); 3342 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3343 astCur := astNode; astIsLit := TRUE; .) 3344 (. IF dt = SymTab.InvalidType THEN 3345 t := SymTab.InvalidType; 3346 QbeGen.CopyOp("0", q) 3347 ELSE 3348 QbeGen.IntStr(VAL(INTEGER, 3349 SymTab.ObjectSize(dt)), q); 3350 t := SymTab.IntType() 3351 END; .) 3352 | ( "SHIFT" (. isMax := FALSE; .) 3353 | "ROTATE" (. isMax := TRUE; .) ) 3354 "(" Expr (. astArg2 := astCur; .) "," Expr ")" 3355 (. astNode := AST.MakeNode(AST.NkCall); 3356 IF isMax THEN AST.SetChild(astNode, 0, 3357 AST.MakeLeaf(AST.NkIdent, "ROTATE")) 3358 ELSE AST.SetChild(astNode, 0, 3359 AST.MakeLeaf(AST.NkIdent, "SHIFT")) END; 3360 IF astArg2 # AST.NoNode THEN AST.SetChild(astNode, 1, astArg2) END; 3361 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; 3362 astCur := astNode; astIsLit := TRUE; 3363 (* set shift/rotate: isMax 3364 doubles as "rotate" *) 3365 IF (et # SymTab.InvalidType) 3366 AND (SymTab.ClassOf(et) = 3367 SymTab.ClSet) THEN 3368 QbeGen.SetShift(q, q2, 3369 SymTab.SetWords(et), 3370 SymTab.SetCount(et), isMax, 3371 qt); 3372 t := et; 3373 QbeGen.CopyOp(qt, q) 3374 ELSE SemError(230); 3375 t := SymTab.InvalidType; 3376 QbeGen.CopyOp("0", q) 3377 END; .) 3378 | ( "MIN" (. isMax := FALSE; .) 3379 | "MAX" (. isMax := TRUE; .) ) 3380 "(" Design ")" 3381 (. astNode := AST.MakeNode(AST.NkCall); 3382 IF isMax THEN AST.SetChild(astNode, 0, 3383 AST.MakeLeaf(AST.NkIdent, "MAX")) 3384 ELSE AST.SetChild(astNode, 0, 3385 AST.MakeLeaf(AST.NkIdent, "MIN")) END; 3386 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3387 astCur := astNode; astIsLit := TRUE; 3388 IF (dt # SymTab.InvalidType) 3389 AND (SymTab.ClassOf(dt) = SymTab.ClReal) THEN 3390 (* REAL/LONGREAL: the 3391 implementation bounds *) 3392 IF isMax THEN 3393 QbeGen.NormReal( 3394 "3.402823e38", q) 3395 ELSE QbeGen.NormReal( 3396 "-3.402823e38", q) 3397 END; 3398 t := SymTab.RealType() 3399 ELSIF (dt # 3400 SymTab.InvalidType) 3401 AND (SymTab.ClassOf(dt) = 3402 SymTab.ClLong) THEN 3403 IF isMax THEN 3404 QbeGen.CopyOp( 3405 "9223372036854775807", q) 3406 ELSE QbeGen.CopyOp( 3407 "-9223372036854775808", q) 3408 END; 3409 t := SymTab.LongType() 3410 ELSIF SymTab.TypeBounds(dt, lo, 3411 hi) THEN 3412 IF isMax THEN 3413 QbeGen.IntStr(hi, q) 3414 ELSE QbeGen.IntStr(lo, q) 3415 END; 3416 t := SymTab.IntType() 3417 ELSE SemError(230); 3418 t := SymTab.InvalidType; 3419 QbeGen.CopyOp("0", q) 3420 END; .) 3421 | "ADR" "(" Design ")" 3422 (. astNode := AST.MakeNode(AST.NkCall); 3423 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ADR")); 3424 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3425 astCur := astNode; astIsLit := TRUE; .) 3426 (. IF dt = SymTab.InvalidType THEN 3427 t := SymTab.InvalidType; 3428 QbeGen.CopyOp("0", q) 3429 ELSE 3430 IF sfx THEN 3431 QbeGen.CopyOp(qd, q) 3432 ELSIF (dk = SymTab.KindVar) 3433 OR (dk = SymTab.KindParam) THEN 3434 QbeGen.AddrOf(qn, q) 3435 ELSE SemError(230); 3436 QbeGen.CopyOp("0", q) 3437 END; 3438 t := SymTab.AddrType() 3439 END; .) 3440 | "CHR" "(" Expr ")" 3441 (. astNode := AST.MakeNode(AST.NkCall); 3442 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CHR")); 3443 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3444 astCur := astNode; astIsLit := TRUE; .) 3445 (. IF (et # SymTab.InvalidType) 3446 AND NOT SymTab.IsIntFamily(et) THEN 3447 SemError(211) END; 3448 t := SymTab.CharType(); .) 3449 | ( "ORD" | "ORDL" ) "(" Expr ")" 3450 (. astNode := AST.MakeNode(AST.NkCall); 3451 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ORD")); 3452 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3453 astCur := astNode; astIsLit := TRUE; .) 3454 (. IF et # SymTab.InvalidType THEN 3455 IF (SymTab.ClassOf(et) # 3456 SymTab.ClChar) 3457 AND (SymTab.ClassOf(et) # 3458 SymTab.ClBool) 3459 AND (SymTab.ClassOf(et) # 3460 SymTab.ClEnum) 3461 AND NOT SymTab.IsIntFamily(et) THEN 3462 SemError(211) END 3463 END; 3464 t := SymTab.IntType(); .) 3465 | "CAP" "(" Expr ")" 3466 (. astNode := AST.MakeNode(AST.NkCall); 3467 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CAP")); 3468 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3469 astCur := astNode; astIsLit := TRUE; .) 3470 (. QbeGen.CapQ(q, qa); 3471 QbeGen.CopyOp(qa, q); 3472 t := SymTab.CharType(); .) 3473 | "UCHR" "(" Expr ")" 3474 (. astNode := AST.MakeNode(AST.NkCall); 3475 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "UCHR")); 3476 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3477 astCur := astNode; astIsLit := TRUE; .) 3478 (. (* UCHR: the UCHAR constructor. 3479 CHAR -> UCHAR (identity); 3480 INTEGER familly -> UCHAR 3481 (codepoint value). *) 3482 IF (et # SymTab.InvalidType) 3483 AND (SymTab.ClassOf(et) # SymTab.ClChar) 3484 AND NOT SymTab.IsIntFamily(et) THEN 3485 SemError(211) END; 3486 t := SymTab.UCharType(); .) 3487 | "CHR8" "(" Expr ")" 3488 (. astNode := AST.MakeNode(AST.NkCall); 3489 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "CHR8")); 3490 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3491 astCur := astNode; astIsLit := TRUE; .) 3492 (. IF (et # SymTab.InvalidType) 3493 AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN 3494 SemError(211) END; 3495 QbeGen.WidenLong(q, qa); 3496 QbeGen.CheckRange(qa, "0", "255"); 3497 t := SymTab.CharType(); .) 3498 | "UORD" "(" Expr ")" 3499 (. astNode := AST.MakeNode(AST.NkCall); 3500 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "UORD")); 3501 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3502 astCur := astNode; astIsLit := TRUE; .) 3503 (. (* UORD(u): the codepoint as a 3504 32-bit ordinal (INTEGER), 3505 cf. ORD for CHAR. *) 3506 IF (et # SymTab.InvalidType) 3507 AND (SymTab.ClassOf(et) # SymTab.ClUChar) THEN 3508 SemError(211) END; 3509 t := SymTab.IntType(); .) 3510 | "ABS" "(" Expr ")" 3511 (. astNode := AST.MakeNode(AST.NkCall); 3512 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "ABS")); 3513 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 1, astCur) END; 3514 astCur := astNode; astIsLit := TRUE; .) 3515 (. IF (et # SymTab.InvalidType) 3516 AND NOT SymTab.IsIntFamily(et) 3517 AND (SymTab.ClassOf(et) # 3518 SymTab.ClReal) THEN 3519 SemError(211) 3520 ELSE QbeGen.AbsQ(q, qa, 3521 SymTab.ClassOf(et) = 3522 SymTab.ClReal); 3523 QbeGen.CopyOp(qa, q) 3524 END; 3525 t := et; .) 3526 | "VAL" "(" GetIdent (. astArg2 := AST.MakeLeaf(AST.NkIdent, vn); .) "," Expr ")" 3527 (. astNode := AST.MakeNode(AST.NkCall); 3528 AST.SetChild(astNode, 0, AST.MakeLeaf(AST.NkIdent, "VAL")); 3529 IF astArg2 # AST.NoNode THEN AST.SetChild(astNode, 1, astArg2) END; 3530 IF astCur # AST.NoNode THEN AST.SetChild(astNode, 2, astCur) END; 3531 astCur := astNode; astIsLit := TRUE; .) 3532 (. IF NOT SymTab.Lookup(vn) THEN 3533 SemError(201); 3534 t := SymTab.InvalidType 3535 ELSE vt := SymTab.SymType(vn); 3536 IF vt = SymTab.InvalidType THEN 3537 t := SymTab.InvalidType 3538 ELSIF et = 3539 SymTab.InvalidType THEN 3540 t := vt 3541 ELSE 3542 c1 := SymTab.ClassOf(et); 3543 c2 := SymTab.ClassOf(vt); 3544 IF (c1 = SymTab.ClInt) 3545 AND (c2 = SymTab.ClLong) THEN 3546 QbeGen.WidenLong(q, qa); 3547 QbeGen.CopyOp(qa, q); 3548 t := vt 3549 ELSIF (c1 = SymTab.ClLong) 3550 AND (c2 = SymTab.ClInt) THEN 3551 QbeGen.NarrowLong(q, qa); 3552 QbeGen.CopyOp(qa, q); 3553 t := vt 3554 ELSIF (c1 = SymTab.ClInt) 3555 AND (c2 = SymTab.ClReal) THEN 3556 QbeGen.ConvIR(q, qa); 3557 QbeGen.CopyOp(qa, q); 3558 t := vt 3559 ELSIF (c1 = SymTab.ClLong) 3560 AND (c2 = SymTab.ClReal) THEN 3561 QbeGen.ConvLR(q, qa); 3562 QbeGen.CopyOp(qa, q); 3563 t := vt 3564 ELSIF (c1 = SymTab.ClReal) 3565 AND (c2 = SymTab.ClInt) THEN 3566 QbeGen.ConvRI(q, qa); 3567 QbeGen.CopyOp(qa, q); 3568 t := vt 3569 ELSIF (c1 = SymTab.ClReal) 3570 AND (c2 = SymTab.ClLong) THEN 3571 QbeGen.ConvRL(q, qa); 3572 QbeGen.CopyOp(qa, q); 3573 t := vt 3574 ELSIF ((c1 = SymTab.ClInt) 3575 OR (c1 = 3576 SymTab.ClChar) 3577 OR (c1 = 3578 SymTab.ClBool) 3579 OR (c1 = 3580 SymTab.ClEnum)) 3581 AND ((c2 = SymTab.ClInt) 3582 OR (c2 = 3583 SymTab.ClChar) 3584 OR (c2 = 3585 SymTab.ClBool) 3586 OR (c2 = 3587 SymTab.ClEnum)) THEN 3588 t := vt 3589 ELSIF (c1 = SymTab.ClPtr) 3590 AND (c2 = SymTab.ClPtr) THEN 3591 t := vt 3592 ELSIF (c1 = SymTab.ClReal) 3593 AND (c2 = SymTab.ClReal) THEN 3594 t := vt 3595 ELSE SemError(230); 3596 t := SymTab.InvalidType 3597 END 3598 END 3599 END; .) 3600 | "(" Expr ")" (. t := et; astIsLit := TRUE; .) 3601 | SetLit (. astIsLit := TRUE; t := st; 3602 QbeGen.CopyOp(sq, q); .) 3603 | ( "NOT" | "~" ) Fact (. astNot := astCur; 3604 IF SymTab.BoolCheck(t2) THEN 3605 t := SymTab.BoolType() 3606 ELSE SemError(212); 3607 t := SymTab.InvalidType END; 3608 IF t # SymTab.InvalidType THEN 3609 QbeGen.NotQ(q2, q) 3610 ELSE QbeGen.CopyOp("0", q) 3611 END; 3612 astIsLit := TRUE; 3613 astCur := AST.MakeUn( 3614 AST.NkUnary, AST.OpNot, astNot); .) 3615 ) 3616 (. IF NOT astIsLit THEN astCur := AST.NoNode END; .) . 3617 (* Set literals are SET OF [0..255] (8 words); elements validated 3618 0..255 statically when foldable (222 otherwise), runtime trap 3619 for computed elements. Ranges always lower via SetRange. *) 3620 SetLit 3621 (. VAR astNode: AST.Node; .) 3622 = "{" (. t := SymTab.NewSet( 3623 SymTab.NewSubR(0, 255)); 3624 astNode := AST.MakeNode(AST.NkSetLit); 3625 QbeGen.NewSetTemp(8, q); 3626 QbeGen.SetZero(q, 8); .) 3627 [ SetElem { "," SetElem } ] 3628 "}" (. astCur := astNode; .) . 3629 (* Typed brace constructor: TypeName{ elems } — BITSET{0} (a set) 3630 or ArrayName{...} (an array constructor, GNU Modula-2). The 3631 declared type sets the width (set) or element type (array). *) 3632 TypedBraceLit 3633 (. VAR nw: CARDINAL; 3634 astNode: AST.Node; 3635 savedCls: INTEGER; .) 3636 = "{" (. savedCls := braceCls; 3637 astNode := AST.MakeNode(AST.NkBraceLit); 3638 IF vt = SymTab.InvalidType THEN 3639 braceCls := -1 3640 ELSE braceCls := 3641 SymTab.ClassOf(vt) 3642 END; 3643 IF braceCls = SymTab.ClSet THEN 3644 IF vt = SymTab.InvalidType THEN 3645 nw := 8 3646 ELSE nw := SymTab.SetWords(vt); 3647 IF nw = 0 THEN nw := 8 END 3648 END; 3649 QbeGen.NewSetTemp(nw, q); 3650 QbeGen.SetZero(q, nw) 3651 ELSIF (braceCls = 3652 SymTab.ClArray) 3653 OR (braceCls = 3654 SymTab.ClRecord) 3655 OR (braceCls = 3656 SymTab.ClClass) THEN 3657 QbeGen.CtorBegin(vt) 3658 ELSE 3659 IF vt # SymTab.InvalidType THEN 3660 SemError(230) END; 3661 braceCls := -1 3662 END; .) 3663 [ BraceElem { "," BraceElem } ] 3664 "}" (. IF (braceCls = SymTab.ClArray) 3665 OR (braceCls = 3666 SymTab.ClRecord) 3667 OR (braceCls = 3668 SymTab.ClClass) THEN 3669 QbeGen.CtorEnd(q) 3670 ELSIF braceCls # SymTab.ClSet THEN 3671 QbeGen.CopyOp("0", q) 3672 END; 3673 braceCls := savedCls; .) 3674 (. astCur := astNode; .) . 3675 BraceElem 3676 (. VAR et, et2: SymTab.TypeIndex; 3677 qe, q2: QbeGen.QVal; 3678 v, v2, reps, k: INTEGER; 3679 elem: SymTab.TypeIndex; 3680 lo: INTEGER; 3681 span: CARDINAL; 3682 cl, cl2: INTEGER; 3683 hasR, hasB: BOOLEAN; 3684 astEl: AST.Node; .) 3685 = (. hasR := FALSE; hasB := FALSE; .) 3686 Expr (. astEl := astCur; .) 3687 [ ".." Expr (. astEl := AST.MakeBin( 3688 AST.NkSubrange, 0, astEl, astCur); 3689 hasR := TRUE; .) ] 3690 [ "BY" Expr (. hasB := TRUE; .) ] 3691 (. IF braceCls = SymTab.ClSet THEN 3692 IF hasB THEN SemError(230) END; 3693 lo := SymTab.SetBaseLo(vt); 3694 span := SymTab.SetCount(vt); 3695 IF (et = SymTab.InvalidType) 3696 OR (hasR AND (et2 = 3697 SymTab.InvalidType)) THEN 3698 ELSE cl := 3699 SymTab.ClassOf(et); 3700 IF hasR THEN 3701 cl2 := 3702 SymTab.ClassOf(et2) 3703 ELSE cl2 := SymTab.ClInt 3704 END; 3705 IF NOT SymTab.SetElemClassOk(cl) 3706 OR (hasR AND NOT 3707 SymTab.SetElemClassOk(cl2)) 3708 THEN 3709 SemError(222) 3710 ELSIF hasR 3711 AND SymTab.ConstInt(qe, v) 3712 AND SymTab.ConstInt(q2, 3713 v2) 3714 AND ((v < lo) 3715 OR (v2 < lo) 3716 OR (v >= lo + 3717 VAL(INTEGER, span)) 3718 OR (v2 >= lo + 3719 VAL(INTEGER, span)) 3720 OR (v > v2)) THEN 3721 SemError(222) 3722 ELSIF hasR THEN 3723 QbeGen.SetRange(sq, qe, q2, 3724 lo, span) 3725 ELSIF SymTab.ConstInt(qe, 3726 v) 3727 AND ((v < lo) 3728 OR (v >= lo + 3729 VAL(INTEGER, 3730 span))) THEN 3731 SemError(222) 3732 ELSE QbeGen.SetBit(sq, qe, 3733 lo, span) 3734 END 3735 END 3736 ELSIF (braceCls = SymTab.ClArray) 3737 OR (braceCls = 3738 SymTab.ClRecord) 3739 OR (braceCls = 3740 SymTab.ClClass) THEN 3741 IF hasR THEN SemError(230) END; 3742 reps := 1; 3743 IF hasB THEN 3744 IF SymTab.ConstInt(q2, v2) 3745 AND (v2 >= 1) THEN 3746 reps := v2 3747 ELSE SemError(230) 3748 END 3749 END; 3750 k := 0; 3751 WHILE k < reps DO 3752 QbeGen.CtorElem(qe); 3753 INC(k) 3754 END 3755 END; .) 3756 (. AST.SetChild(node, 3757 AST.NChild(node), astEl); .) . 3758 SetElem (. VAR et, et2: SymTab.TypeIndex; 3759 qe, q2: QbeGen.QVal; 3760 v, v2: INTEGER; 3761 lo: INTEGER; 3762 span: CARDINAL; 3763 cl, cl2: INTEGER; 3764 hasR: BOOLEAN; 3765 astEl: AST.Node; .) 3766 = (. hasR := FALSE; .) 3767 Expr (. astEl := astCur; .) 3768 [ ".." Expr (. astEl := AST.MakeBin( 3769 AST.NkSubrange, 0, astEl, astCur); 3770 hasR := TRUE; .) ] 3771 (. lo := SymTab.SetBaseLo(st); 3772 span := SymTab.SetCount(st); 3773 IF (et = SymTab.InvalidType) 3774 OR (hasR AND (et2 = 3775 SymTab.InvalidType)) THEN 3776 ELSE cl := 3777 SymTab.ClassOf(et); 3778 IF hasR THEN 3779 cl2 := 3780 SymTab.ClassOf(et2) 3781 ELSE cl2 := SymTab.ClInt 3782 END; 3783 IF NOT SymTab.SetElemClassOk(cl) 3784 OR (hasR AND NOT 3785 SymTab.SetElemClassOk(cl2)) 3786 THEN 3787 SemError(222) 3788 ELSIF hasR 3789 AND SymTab.ConstInt(qe, v) 3790 AND SymTab.ConstInt(q2, 3791 v2) 3792 AND ((v < lo) 3793 OR (v2 < lo) 3794 OR (v >= lo + 3795 VAL(INTEGER, span)) 3796 OR (v2 >= lo + 3797 VAL(INTEGER, span)) 3798 OR (v > v2)) THEN 3799 SemError(222) 3800 ELSIF hasR THEN 3801 QbeGen.SetRange(sq, qe, q2, 3802 lo, span) 3803 ELSIF SymTab.ConstInt(qe, 3804 v) 3805 AND ((v < lo) 3806 OR (v >= lo + 3807 VAL(INTEGER, 3808 span))) THEN 3809 SemError(222) 3810 ELSE QbeGen.SetBit(sq, qe, 3811 lo, span) 3812 END 3813 END; .) 3814 (. AST.SetChild(node, 3815 AST.NChild(node), astEl); .) . 3816 GetIdent 3817 = ident (. LexName(n); .) . 3818 3819 END M2. 0 errors Statistics: nr of terminals: 104 (limit 400) nr of non-terminals: 85 (limit 210) nr of pragmas: 0 (limit 396) nr of symbolnodes: 189 (limit 500) nr of graphnodes: 1107 (limit 1500) nr of conditionsets: 11 (limit 100) nr of charactersets: 16 (limit 250)