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

@@ -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;

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;

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;

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;

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);

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);