Add for-loop support (to and downto forms)

Adds tkFor/tkTo/tkDownto lexer tokens, TForStmt AST node, parser
support, semantic validation (ordinal loop variable, type-matched
bounds), and QBE codegen (init storew, cslew/csgew condition,
add/sub increment, jmp back to condition label).
26 new tests in cp.test.forloop (352 total, all passing).

compiler/src/main/pascal/uAST.pas

@@ -96,6 +96,16 @@ type
     destructor Destroy; override;
   end;
 
+  TForStmt = class(TASTStmt)
+  public
+    VarName:   string;
+    StartExpr: TASTExpr;  { owned }
+    EndExpr:   TASTExpr;  { owned }
+    IsDownTo:  Boolean;
+    Body:      TASTStmt;  { owned }
+    destructor Destroy; override;
+  end;
+
   TFieldAssignment = class(TASTStmt)
   public
     RecordName:    string;
@@ -305,6 +315,16 @@ begin
   inherited Destroy;
 end;
 
+{ TForStmt }
+
+destructor TForStmt.Destroy;
+begin
+  StartExpr.Free;
+  EndExpr.Free;
+  Body.Free;
+  inherited Destroy;
+end;
+
 { TBinaryExpr }
 
 destructor TBinaryExpr.Destroy;

compiler/src/main/pascal/uCodeGenQBE.pas

@@ -40,6 +40,7 @@ type
     procedure EmitStmt(AStmt: TASTStmt);
     procedure EmitIfStmt(AStmt: TIfStmt);
     procedure EmitWhileStmt(AStmt: TWhileStmt);
+    procedure EmitForStmt(AStmt: TForStmt);
     procedure EmitCompoundStmt(AStmt: TCompoundStmt);
     procedure EmitAssignment(AAssign: TAssignment);
     procedure EmitFieldAssignment(AAssign: TFieldAssignment);
@@ -236,7 +237,9 @@ end;
 
 procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt);
 begin
-  if AStmt is TWhileStmt then
+  if AStmt is TForStmt then
+    EmitForStmt(TForStmt(AStmt))
+  else if AStmt is TWhileStmt then
     EmitWhileStmt(TWhileStmt(AStmt))
   else if AStmt is TIfStmt then
     EmitIfStmt(TIfStmt(AStmt))
@@ -288,6 +291,65 @@ begin
   EmitLine('@' + LblEnd);
 end;
 
+procedure TCodeGenQBE.EmitForStmt(AStmt: TForStmt);
+var
+  LblCond:  string;
+  LblBody:  string;
+  LblEnd:   string;
+  StartT:   string;
+  EndT:     string;
+  CurT:     string;
+  CmpT:     string;
+  StepT:    string;
+  CmpOp:    string;
+  StepOp:   string;
+begin
+  LblCond := AllocLabel('for_cond');
+  LblBody := AllocLabel('for_body');
+  LblEnd  := AllocLabel('for_end');
+
+  { Evaluate start and store into loop variable }
+  StartT := EmitExpr(AStmt.StartExpr);
+  EmitLine(Format('  storew %s, %%_var_%s', [StartT, AStmt.VarName]));
+
+  { Evaluate end value once into a temp }
+  EndT := EmitExpr(AStmt.EndExpr);
+
+  { Jump to condition (terminates current block) }
+  EmitLine(Format('  jmp @%s', [LblCond]));
+
+  { Condition block: test loop variable against end value }
+  EmitLine('@' + LblCond);
+  CurT := AllocTemp;
+  EmitLine(Format('  %s =w loadw %%_var_%s', [CurT, AStmt.VarName]));
+  CmpT := AllocTemp;
+  if AStmt.IsDownTo then
+    CmpOp := 'csgew'   { I >= End }
+  else
+    CmpOp := 'cslew';  { I <= End }
+  EmitLine(Format('  %s =w %s %s, %s', [CmpT, CmpOp, CurT, EndT]));
+  EmitLine(Format('  jnz %s, @%s, @%s', [CmpT, LblBody, LblEnd]));
+
+  { Body block }
+  EmitLine('@' + LblBody);
+  EmitStmt(AStmt.Body);
+
+  { Increment or decrement loop variable }
+  CurT  := AllocTemp;
+  StepT := AllocTemp;
+  EmitLine(Format('  %s =w loadw %%_var_%s', [CurT, AStmt.VarName]));
+  if AStmt.IsDownTo then
+    StepOp := 'sub'
+  else
+    StepOp := 'add';
+  EmitLine(Format('  %s =w %s %s, 1', [StepT, StepOp, CurT]));
+  EmitLine(Format('  storew %s, %%_var_%s', [StepT, AStmt.VarName]));
+  EmitLine(Format('  jmp @%s', [LblCond]));
+
+  { Continuation block }
+  EmitLine('@' + LblEnd);
+end;
+
 procedure TCodeGenQBE.EmitWhileStmt(AStmt: TWhileStmt);
 var
   LblCond: string;

compiler/src/main/pascal/uLexer.pas

@@ -33,6 +33,9 @@ type
     tkElse,
     tkWhile,
     tkDo,
+    tkFor,
+    tkTo,
+    tkDownto,
     tkNil,
     { Identifier }
     tkIdent,
@@ -110,6 +113,9 @@ begin
   else if AUpper = 'ELSE'      then Result := tkElse
   else if AUpper = 'WHILE'     then Result := tkWhile
   else if AUpper = 'DO'        then Result := tkDo
+  else if AUpper = 'FOR'       then Result := tkFor
+  else if AUpper = 'TO'        then Result := tkTo
+  else if AUpper = 'DOWNTO'   then Result := tkDownto
   else if AUpper = 'NIL'       then Result := tkNil
   else
     Result := tkIdent;  { keyword outside Phase 1 grammar treated as ident }

compiler/src/main/pascal/uParser.pas

@@ -64,6 +64,7 @@ type
     function  ParseStmt: TASTStmt;
     function  ParseIfStmt: TIfStmt;
     function  ParseWhileStmt: TWhileStmt;
+    function  ParseForStmt: TForStmt;
     function  ParseCompoundStmt: TCompoundStmt;
     function  ParseExpr: TASTExpr;
     function  ParseAddSub: TASTExpr;
@@ -509,6 +510,12 @@ begin
     Exit;
   end;
 
+  if Check(tkFor) then
+  begin
+    Result := ParseForStmt;
+    Exit;
+  end;
+
   if Check(tkBegin) then
   begin
     Result := ParseCompoundStmt;
@@ -628,6 +635,43 @@ begin
   end;
 end;
 
+function TParser.ParseForStmt: TForStmt;
+begin
+  Result := TForStmt.Create;
+  try
+    Result.Line := FCurrent.Line;
+    Result.Col  := FCurrent.Col;
+    Expect(tkFor);
+    if not Check(tkIdent) then
+      raise EParseError.CreateFmt('Expected loop variable at line %d col %d',
+        [FCurrent.Line, FCurrent.Col]);
+    Result.VarName := FCurrent.Value;
+    Advance;
+    Expect(tkAssign);
+    Result.StartExpr := ParseExpr;
+    if Check(tkTo) then
+    begin
+      Result.IsDownTo := False;
+      Advance;
+    end
+    else if Check(tkDownto) then
+    begin
+      Result.IsDownTo := True;
+      Advance;
+    end
+    else
+      raise EParseError.CreateFmt(
+        'Expected ''to'' or ''downto'' at line %d col %d',
+        [FCurrent.Line, FCurrent.Col]);
+    Result.EndExpr := ParseExpr;
+    Expect(tkDo);
+    Result.Body := ParseStmt;
+  except
+    Result.Free;
+    raise;
+  end;
+end;
+
 function TParser.ParseCompoundStmt: TCompoundStmt;
 var
   Stmt: TASTStmt;

compiler/src/main/pascal/uSemantic.pas

@@ -505,12 +505,41 @@ end;
 
 procedure TSemanticAnalyser.AnalyseStmt(AStmt: TASTStmt);
 var
-  IfS:  TIfStmt;
-  CmpS: TCompoundStmt;
-  I:    Integer;
-  CondType: TTypeDesc;
+  IfS:       TIfStmt;
+  CmpS:      TCompoundStmt;
+  ForS:      TForStmt;
+  I:         Integer;
+  CondType:  TTypeDesc;
+  VarSym:    TSymbol;
+  StartType: TTypeDesc;
+  EndType:   TTypeDesc;
 begin
-  if AStmt is TWhileStmt then
+  if AStmt is TForStmt then
+  begin
+    ForS := TForStmt(AStmt);
+    VarSym := FTable.Lookup(ForS.VarName);
+    if VarSym = nil then
+      SemanticError(
+        Format('Undeclared loop variable ''%s''', [ForS.VarName]),
+        ForS.Line, ForS.Col);
+    if VarSym.Kind <> skVariable then
+      SemanticError(
+        Format('''%s'' is not a variable', [ForS.VarName]),
+        ForS.Line, ForS.Col);
+    if not VarSym.TypeDesc.IsOrdinal then
+      SemanticError(
+        Format('Loop variable ''%s'' must be an ordinal type, got ''%s''',
+          [ForS.VarName, VarSym.TypeDesc.Name]),
+        ForS.Line, ForS.Col);
+    StartType := AnalyseExpr(ForS.StartExpr);
+    CheckTypesMatch(VarSym.TypeDesc, StartType,
+      'for-loop start expression', ForS.Line, ForS.Col);
+    EndType := AnalyseExpr(ForS.EndExpr);
+    CheckTypesMatch(VarSym.TypeDesc, EndType,
+      'for-loop end expression', ForS.Line, ForS.Col);
+    AnalyseStmt(ForS.Body);
+  end
+  else if AStmt is TWhileStmt then
   begin
     with TWhileStmt(AStmt) do
     begin

compiler/src/test/pascal/TestRunner.pas

@@ -22,7 +22,8 @@ uses
   cp.test.functions,
   cp.test.procs,
   cp.test.control,
-  cp.test.inherit;
+  cp.test.inherit,
+  cp.test.forloop;
 
 var
   Application: TTestRunner;

compiler/src/test/pascal/cp.test.forloop.pas

@@ -0,0 +1,416 @@
+unit cp.test.forloop;
+
+{$mode objfpc}{$H+}
+
+{ Tests for for-loop: to and downto forms. }
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testregistry,
+  uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
+
+type
+  TForTests = class(TTestCase)
+  private
+    function ParseSrc(const ASrc: string): TProgram;
+    function AnalyseSrc(const ASrc: string): TProgram;
+    function GenIR(const ASrc: string): string;
+    procedure AnalyseExpectError(const ASrc: string);
+  published
+    { ------------------------------------------------------------------ }
+    { Lexer                                                                }
+    { ------------------------------------------------------------------ }
+    procedure TestLexer_For_Keyword;
+    procedure TestLexer_To_Keyword;
+    procedure TestLexer_Downto_Keyword;
+
+    { ------------------------------------------------------------------ }
+    { Parser                                                               }
+    { ------------------------------------------------------------------ }
+    procedure TestParse_For_IsTForStmt;
+    procedure TestParse_For_VarName;
+    procedure TestParse_For_IsUpward;
+    procedure TestParse_Downto_IsDownward;
+    procedure TestParse_For_StartIsIntLiteral;
+    procedure TestParse_For_EndIsIntLiteral;
+    procedure TestParse_For_BodyIsAssignment;
+    procedure TestParse_For_CompoundBody;
+
+    { ------------------------------------------------------------------ }
+    { Semantic                                                             }
+    { ------------------------------------------------------------------ }
+    procedure TestSemantic_For_Upward_OK;
+    procedure TestSemantic_For_Downto_OK;
+    procedure TestSemantic_For_NonOrdinalVar_RaisesError;
+    procedure TestSemantic_For_StartTypeMismatch_RaisesError;
+    procedure TestSemantic_For_EndTypeMismatch_RaisesError;
+
+    { ------------------------------------------------------------------ }
+    { Codegen                                                              }
+    { ------------------------------------------------------------------ }
+    procedure TestCodegen_For_InitStoresStart;
+    procedure TestCodegen_For_CondUsesSlew;
+    procedure TestCodegen_Downto_CondUsesSgew;
+    procedure TestCodegen_For_BodyIncrementsVar;
+    procedure TestCodegen_Downto_BodyDecrementsVar;
+    procedure TestCodegen_For_HasForCondLabel;
+    procedure TestCodegen_For_HasForBodyLabel;
+    procedure TestCodegen_For_HasForEndLabel;
+    procedure TestCodegen_For_JumpsBackToCond;
+    procedure TestCodegen_For_Compound_OK;
+  end;
+
+implementation
+
+{ ------------------------------------------------------------------ }
+{ Helpers                                                             }
+{ ------------------------------------------------------------------ }
+
+function TForTests.ParseSrc(const ASrc: string): TProgram;
+var L: TLexer; P: TParser;
+begin
+  L := TLexer.Create(ASrc);
+  P := TParser.Create(L);
+  try
+    Result := P.Parse;
+  finally
+    P.Free; L.Free;
+  end;
+end;
+
+function TForTests.AnalyseSrc(const ASrc: string): TProgram;
+var A: TSemanticAnalyser;
+begin
+  Result := ParseSrc(ASrc);
+  A := TSemanticAnalyser.Create;
+  try
+    A.Analyse(Result);
+  finally
+    A.Free;
+  end;
+end;
+
+function TForTests.GenIR(const ASrc: string): string;
+var Prog: TProgram; CG: TCodeGenQBE;
+begin
+  Prog := AnalyseSrc(ASrc);
+  try
+    CG := TCodeGenQBE.Create;
+    try
+      CG.Generate(Prog);
+      Result := CG.GetOutput;
+    finally
+      CG.Free;
+    end;
+  finally
+    Prog.Free;
+  end;
+end;
+
+procedure TForTests.AnalyseExpectError(const ASrc: string);
+var Prog: TProgram;
+begin
+  try
+    Prog := AnalyseSrc(ASrc);
+    Prog.Free;
+    Fail('Expected ESemanticError');
+  except
+    on E: ESemanticError do ;
+  end;
+end;
+
+{ ------------------------------------------------------------------ }
+{ Shared source snippets                                               }
+{ ------------------------------------------------------------------ }
+
+const
+  SrcForUpward =
+    'program P;'             + LineEnding +
+    'var I: Integer;'        + LineEnding +
+    'var S: Integer;'        + LineEnding +
+    'begin'                  + LineEnding +
+    '  S := 0;'              + LineEnding +
+    '  for I := 1 to 5 do'  + LineEnding +
+    '    S := S + I'         + LineEnding +
+    'end.';
+
+  SrcForDownto =
+    'program P;'                  + LineEnding +
+    'var I: Integer;'             + LineEnding +
+    'var S: Integer;'             + LineEnding +
+    'begin'                       + LineEnding +
+    '  S := 0;'                   + LineEnding +
+    '  for I := 5 downto 1 do'   + LineEnding +
+    '    S := S + I'              + LineEnding +
+    'end.';
+
+  SrcForCompound =
+    'program P;'             + LineEnding +
+    'var I: Integer;'        + LineEnding +
+    'var S: Integer;'        + LineEnding +
+    'begin'                  + LineEnding +
+    '  S := 0;'              + LineEnding +
+    '  for I := 1 to 3 do'  + LineEnding +
+    '  begin'                + LineEnding +
+    '    S := S + I;'        + LineEnding +
+    '    S := S + 1'         + LineEnding +
+    '  end'                  + LineEnding +
+    'end.';
+
+{ ------------------------------------------------------------------ }
+{ Lexer tests                                                          }
+{ ------------------------------------------------------------------ }
+
+procedure TForTests.TestLexer_For_Keyword;
+var L: TLexer; T: TToken;
+begin
+  L := TLexer.Create('for');
+  try
+    T := L.Next;
+    AssertEquals('for token', Ord(tkFor), Ord(T.Kind));
+  finally L.Free; end;
+end;
+
+procedure TForTests.TestLexer_To_Keyword;
+var L: TLexer; T: TToken;
+begin
+  L := TLexer.Create('to');
+  try
+    T := L.Next;
+    AssertEquals('to token', Ord(tkTo), Ord(T.Kind));
+  finally L.Free; end;
+end;
+
+procedure TForTests.TestLexer_Downto_Keyword;
+var L: TLexer; T: TToken;
+begin
+  L := TLexer.Create('downto');
+  try
+    T := L.Next;
+    AssertEquals('downto token', Ord(tkDownto), Ord(T.Kind));
+  finally L.Free; end;
+end;
+
+{ ------------------------------------------------------------------ }
+{ Parser tests                                                         }
+{ ------------------------------------------------------------------ }
+
+procedure TForTests.TestParse_For_IsTForStmt;
+var Prog: TProgram;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    { second stmt (index 1): for I := 1 to 5 do ... }
+    AssertTrue('stmt is TForStmt', Prog.Block.Stmts[1] is TForStmt);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_VarName;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertEquals('loop var is I', 'I', FS.VarName);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_IsUpward;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertFalse('to loop: IsDownTo is False', FS.IsDownTo);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_Downto_IsDownward;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForDownto);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertTrue('downto loop: IsDownTo is True', FS.IsDownTo);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_StartIsIntLiteral;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertTrue('start is TIntLiteral', FS.StartExpr is TIntLiteral);
+    AssertEquals('start value = 1', 1, TIntLiteral(FS.StartExpr).Value);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_EndIsIntLiteral;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertTrue('end is TIntLiteral', FS.EndExpr is TIntLiteral);
+    AssertEquals('end value = 5', 5, TIntLiteral(FS.EndExpr).Value);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_BodyIsAssignment;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForUpward);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertTrue('body is TAssignment', FS.Body is TAssignment);
+  finally Prog.Free; end;
+end;
+
+procedure TForTests.TestParse_For_CompoundBody;
+var Prog: TProgram; FS: TForStmt;
+begin
+  Prog := ParseSrc(SrcForCompound);
+  try
+    FS := TForStmt(Prog.Block.Stmts[1]);
+    AssertTrue('body is TCompoundStmt', FS.Body is TCompoundStmt);
+    AssertEquals('compound body has 2 stmts', 2,
+      TCompoundStmt(FS.Body).Stmts.Count);
+  finally Prog.Free; end;
+end;
+
+{ ------------------------------------------------------------------ }
+{ Semantic tests                                                       }
+{ ------------------------------------------------------------------ }
+
+procedure TForTests.TestSemantic_For_Upward_OK;
+begin
+  AnalyseSrc(SrcForUpward).Free;
+end;
+
+procedure TForTests.TestSemantic_For_Downto_OK;
+begin
+  AnalyseSrc(SrcForDownto).Free;
+end;
+
+procedure TForTests.TestSemantic_For_NonOrdinalVar_RaisesError;
+begin
+  AnalyseExpectError(
+    'program P;'              + LineEnding +
+    'var S: string;'          + LineEnding +
+    'begin'                   + LineEnding +
+    '  for S := 1 to 5 do'   + LineEnding +
+    '    S := S'              + LineEnding +
+    'end.');
+end;
+
+procedure TForTests.TestSemantic_For_StartTypeMismatch_RaisesError;
+begin
+  AnalyseExpectError(
+    'program P;'                + LineEnding +
+    'var I: Integer;'           + LineEnding +
+    'var S: string;'            + LineEnding +
+    'begin'                     + LineEnding +
+    '  for I := S to 5 do'     + LineEnding +
+    '    I := I'                + LineEnding +
+    'end.');
+end;
+
+procedure TForTests.TestSemantic_For_EndTypeMismatch_RaisesError;
+begin
+  AnalyseExpectError(
+    'program P;'                + LineEnding +
+    'var I: Integer;'           + LineEnding +
+    'var S: string;'            + LineEnding +
+    'begin'                     + LineEnding +
+    '  for I := 1 to S do'     + LineEnding +
+    '    I := I'                + LineEnding +
+    'end.');
+end;
+
+{ ------------------------------------------------------------------ }
+{ Codegen tests                                                        }
+{ ------------------------------------------------------------------ }
+
+procedure TForTests.TestCodegen_For_InitStoresStart;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  { Start value 1 is stored into the loop var slot }
+  AssertTrue('storew for loop init', Pos('storew', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_CondUsesSlew;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  { "to" loop: I <= End uses cslew }
+  AssertTrue('cslew for upward condition', Pos('cslew', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_Downto_CondUsesSgew;
+var IR: string;
+begin
+  IR := GenIR(SrcForDownto);
+  { "downto" loop: I >= End uses csgew }
+  AssertTrue('csgew for downto condition', Pos('csgew', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_BodyIncrementsVar;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  { Loop var is incremented by 1 after each iteration }
+  AssertTrue('add 1 for increment', Pos(', 1', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_Downto_BodyDecrementsVar;
+var IR: string;
+begin
+  IR := GenIR(SrcForDownto);
+  { Loop var is decremented by 1 after each iteration }
+  AssertTrue('sub for decrement', Pos('sub', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_HasForCondLabel;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  AssertTrue('for_cond label present', Pos('for_cond', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_HasForBodyLabel;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  AssertTrue('for_body label present', Pos('for_body', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_HasForEndLabel;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  AssertTrue('for_end label present', Pos('for_end', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_JumpsBackToCond;
+var IR: string;
+begin
+  IR := GenIR(SrcForUpward);
+  { After body, must jump back to condition block }
+  AssertTrue('jmp @for_cond in IR', Pos('jmp @for_cond', IR) > 0);
+end;
+
+procedure TForTests.TestCodegen_For_Compound_OK;
+var IR: string;
+begin
+  IR := GenIR(SrcForCompound);
+  { Just verify it compiles without error and produces a for_cond label }
+  AssertTrue('compound body for loop generates IR', Pos('for_cond', IR) > 0);
+end;
+
+initialization
+  RegisterTest(TForTests);
+
+end.