From 4105a0f03b1fc5526174dad20ab036731c0babf3 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Mon, 20 Apr 2026 22:24:51 +0100 Subject: [PATCH] Add while loops while/do loops with Boolean condition type-checking and compound begin/end body support. QBE emits an explicit jmp into the condition block, jnz to branch into body or exit, and a back-edge jmp at the end of the body block. 13 new tests; 307 total, 0 failures. --- compiler/src/main/pascal/uAST.pas | 16 ++ compiler/src/main/pascal/uCodeGenQBE.pas | 33 +++- compiler/src/main/pascal/uLexer.pas | 4 + compiler/src/main/pascal/uParser.pas | 23 +++ compiler/src/main/pascal/uSemantic.pas | 14 +- compiler/src/test/pascal/cp.test.control.pas | 149 +++++++++++++++++++ 6 files changed, 237 insertions(+), 2 deletions(-) diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 13899ac..2443db2 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -87,6 +87,13 @@ type destructor Destroy; override; end; + TWhileStmt = class(TASTStmt) + public + Condition: TASTExpr; { owned } + Body: TASTStmt; { owned } + destructor Destroy; override; + end; + TFieldAssignment = class(TASTStmt) public RecordName: string; @@ -286,6 +293,15 @@ begin inherited Destroy; end; +{ TWhileStmt } + +destructor TWhileStmt.Destroy; +begin + Condition.Free; + Body.Free; + inherited Destroy; +end; + { TBinaryExpr } destructor TBinaryExpr.Destroy; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index a2c0f06..391bea5 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -39,6 +39,7 @@ type procedure EmitStringCleanup(ABlock: TBlock); procedure EmitStmt(AStmt: TASTStmt); procedure EmitIfStmt(AStmt: TIfStmt); + procedure EmitWhileStmt(AStmt: TWhileStmt); procedure EmitCompoundStmt(AStmt: TCompoundStmt); procedure EmitAssignment(AAssign: TAssignment); procedure EmitFieldAssignment(AAssign: TFieldAssignment); @@ -235,7 +236,9 @@ end; procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt); begin - if AStmt is TIfStmt then + if AStmt is TWhileStmt then + EmitWhileStmt(TWhileStmt(AStmt)) + else if AStmt is TIfStmt then EmitIfStmt(TIfStmt(AStmt)) else if AStmt is TCompoundStmt then EmitCompoundStmt(TCompoundStmt(AStmt)) @@ -285,6 +288,34 @@ begin EmitLine('@' + LblEnd); end; +procedure TCodeGenQBE.EmitWhileStmt(AStmt: TWhileStmt); +var + LblCond: string; + LblBody: string; + LblEnd: string; + CondTemp: string; +begin + LblCond := AllocLabel('while_cond'); + LblBody := AllocLabel('while_body'); + LblEnd := AllocLabel('while_end'); + + { Jump into the condition block (terminates current block) } + EmitLine(Format(' jmp @%s', [LblCond])); + + { Condition evaluation block } + EmitLine('@' + LblCond); + CondTemp := EmitExpr(AStmt.Condition); + EmitLine(Format(' jnz %s, @%s, @%s', [CondTemp, LblBody, LblEnd])); + + { Loop body block } + EmitLine('@' + LblBody); + EmitStmt(AStmt.Body); + EmitLine(Format(' jmp @%s', [LblCond])); + + { Continuation block } + EmitLine('@' + LblEnd); +end; + procedure TCodeGenQBE.EmitCompoundStmt(AStmt: TCompoundStmt); var I: Integer; diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index 70de86d..87e9ba6 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -31,6 +31,8 @@ type tkIf, tkThen, tkElse, + tkWhile, + tkDo, { Identifier } tkIdent, { Arithmetic operators } @@ -105,6 +107,8 @@ begin else if AUpper = 'IF' then Result := tkIf else if AUpper = 'THEN' then Result := tkThen else if AUpper = 'ELSE' then Result := tkElse + else if AUpper = 'WHILE' then Result := tkWhile + else if AUpper = 'DO' then Result := tkDo else Result := tkIdent; { keyword outside Phase 1 grammar treated as ident } end; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 34ed402..9b3c80c 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -63,6 +63,7 @@ type procedure ParseStmtList(ABlock: TBlock); function ParseStmt: TASTStmt; function ParseIfStmt: TIfStmt; + function ParseWhileStmt: TWhileStmt; function ParseCompoundStmt: TCompoundStmt; function ParseExpr: TASTExpr; function ParseAddSub: TASTExpr; @@ -502,6 +503,12 @@ begin Exit; end; + if Check(tkWhile) then + begin + Result := ParseWhileStmt; + Exit; + end; + if Check(tkBegin) then begin Result := ParseCompoundStmt; @@ -584,6 +591,22 @@ begin end; end; +function TParser.ParseWhileStmt: TWhileStmt; +begin + Result := TWhileStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkWhile); + Result.Condition := ParseExpr; + Expect(tkDo); + Result.Body := ParseStmt; + except + Result.Free; + raise; + end; +end; + function TParser.ParseIfStmt: TIfStmt; begin Result := TIfStmt.Create; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 738835c..0691541 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -455,7 +455,19 @@ var I: Integer; CondType: TTypeDesc; begin - if AStmt is TIfStmt then + if AStmt is TWhileStmt then + begin + with TWhileStmt(AStmt) do + begin + CondType := AnalyseExpr(Condition); + if CondType.Kind <> tyBoolean then + SemanticError( + Format('while condition must be Boolean, got ''%s''', [CondType.Name]), + AStmt.Line, AStmt.Col); + AnalyseStmt(Body); + end; + end + else if AStmt is TIfStmt then begin IfS := TIfStmt(AStmt); CondType := AnalyseExpr(IfS.Condition); diff --git a/compiler/src/test/pascal/cp.test.control.pas b/compiler/src/test/pascal/cp.test.control.pas index b7cd16f..2654f7d 100644 --- a/compiler/src/test/pascal/cp.test.control.pas +++ b/compiler/src/test/pascal/cp.test.control.pas @@ -74,6 +74,23 @@ type procedure TestCodegen_Comparison_GT_UsescGtw; procedure TestCodegen_Comparison_NE_UsescNew; procedure TestCodegen_Compound_EmitsAllStmts; + + { ------------------------------------------------------------------ } + { While loops } + { ------------------------------------------------------------------ } + procedure TestLexer_While_Keyword; + procedure TestLexer_Do_Keyword; + procedure TestParse_While_IsWhileStmt; + procedure TestParse_While_HasCondition; + procedure TestParse_While_BodyIsAssignment; + procedure TestParse_While_CompoundBody; + procedure TestSemantic_While_Resolves; + procedure TestSemantic_While_NonBooleanCondition_RaisesError; + procedure TestCodegen_While_EmitsCondLabel; + procedure TestCodegen_While_EmitsBodyLabel; + procedure TestCodegen_While_EmitsEndLabel; + procedure TestCodegen_While_LoopsBack; + procedure TestCodegen_While_EmitsJnz; end; implementation @@ -607,6 +624,138 @@ begin AssertTrue('printf in compound branch', Pos('printf', IR) > 0); end; +{ ------------------------------------------------------------------ } +{ While loop tests } +{ ------------------------------------------------------------------ } + +const + SrcWhile = + 'program P;' + LineEnding + + 'var N: Integer;' + LineEnding + + 'begin' + LineEnding + + ' N := 5;' + LineEnding + + ' while N > 0 do' + LineEnding + + ' N := N - 1' + LineEnding + + 'end.'; + + SrcWhileCompound = + 'program P;' + LineEnding + + 'var N, S: Integer;' + LineEnding + + 'begin' + LineEnding + + ' N := 3;' + LineEnding + + ' S := 0;' + LineEnding + + ' while N > 0 do' + LineEnding + + ' begin' + LineEnding + + ' S := S + N;' + LineEnding + + ' N := N - 1' + LineEnding + + ' end' + LineEnding + + 'end.'; + +procedure TControlTests.TestLexer_While_Keyword; +var L: TLexer; T: TToken; +begin + L := TLexer.Create('while'); + try + T := L.Next; + AssertEquals('while token', Ord(tkWhile), Ord(T.Kind)); + finally L.Free; end; +end; + +procedure TControlTests.TestLexer_Do_Keyword; +var L: TLexer; T: TToken; +begin + L := TLexer.Create('do'); + try + T := L.Next; + AssertEquals('do token', Ord(tkDo), Ord(T.Kind)); + finally L.Free; end; +end; + +procedure TControlTests.TestParse_While_IsWhileStmt; +var Prog: TProgram; +begin + Prog := ParseSrc(SrcWhile); + try + AssertTrue('second stmt is TWhileStmt', Prog.Block.Stmts[1] is TWhileStmt); + finally Prog.Free; end; +end; + +procedure TControlTests.TestParse_While_HasCondition; +var Prog: TProgram; S: TWhileStmt; +begin + Prog := ParseSrc(SrcWhile); + try + S := TWhileStmt(Prog.Block.Stmts[1]); + AssertNotNull('condition not nil', S.Condition); + AssertTrue('condition is TBinaryExpr', S.Condition is TBinaryExpr); + finally Prog.Free; end; +end; + +procedure TControlTests.TestParse_While_BodyIsAssignment; +var Prog: TProgram; S: TWhileStmt; +begin + Prog := ParseSrc(SrcWhile); + try + S := TWhileStmt(Prog.Block.Stmts[1]); + AssertTrue('body is TAssignment', S.Body is TAssignment); + finally Prog.Free; end; +end; + +procedure TControlTests.TestParse_While_CompoundBody; +var Prog: TProgram; S: TWhileStmt; +begin + Prog := ParseSrc(SrcWhileCompound); + try + S := TWhileStmt(Prog.Block.Stmts[2]); + AssertTrue('body is TCompoundStmt', S.Body is TCompoundStmt); + AssertEquals('two stmts in body', 2, + TCompoundStmt(S.Body).Stmts.Count); + finally Prog.Free; end; +end; + +procedure TControlTests.TestSemantic_While_Resolves; +begin + AnalyseSrc(SrcWhile).Free; +end; + +procedure TControlTests.TestSemantic_While_NonBooleanCondition_RaisesError; +begin + AnalyseExpectError( + 'program P;' + LineEnding + + 'var N: Integer;' + LineEnding + + 'begin' + LineEnding + + ' N := 1;' + LineEnding + + ' while N do' + LineEnding + + ' N := N - 1' + LineEnding + + 'end.'); +end; + +procedure TControlTests.TestCodegen_While_EmitsCondLabel; +begin + AssertTrue('@while_cond label', Pos('@while_cond', GenIR(SrcWhile)) > 0); +end; + +procedure TControlTests.TestCodegen_While_EmitsBodyLabel; +begin + AssertTrue('@while_body label', Pos('@while_body', GenIR(SrcWhile)) > 0); +end; + +procedure TControlTests.TestCodegen_While_EmitsEndLabel; +begin + AssertTrue('@while_end label', Pos('@while_end', GenIR(SrcWhile)) > 0); +end; + +procedure TControlTests.TestCodegen_While_LoopsBack; +begin + { The body block must jump back to @while_cond } + AssertTrue('jmp @while_cond', Pos('jmp @while_cond', GenIR(SrcWhile)) > 0); +end; + +procedure TControlTests.TestCodegen_While_EmitsJnz; +begin + AssertTrue('jnz in while', Pos('jnz', GenIR(SrcWhile)) > 0); +end; + initialization RegisterTest(TControlTests);