CASE Statement

This procedure processes Case statement. It expects ordinal expression, processes Case constants and constant ranges and generates comparison intermediate code.

Procedure TStatement.Process_CASE_Statement;
Var CaseExpression: TExpression;
    LastJumpToStartOfCaseStatement, LastJumpToNextCaseComparison, LastJumpToEndOf_CASE_Statement: Word;
    IntermediateCodeOffsets: TIntermediateCodeOffsets;
    CaseExpressionOrdinalType: PTypeDefinition;
    Statement: TStatement;

  Procedure ExpectCaseConstantsCompareAndJump;
  Var OpCodeL, OpCodeH: Byte;

    Procedure ExpectCaseConstantAndCompare;
    Var LowestCommonIntegerType: TIntegerTypeSet;
        CaseConstant: TExpression;
    begin
      With CaseConstant do
        begin
          ExpectConstantExpression;
          If TypeDefPtr <> CaseExpressionOrdinalType then Error (ConstantAnd_CASE_TypesDoNotMatch);
          SetLowestCommonIntegerType (CaseExpression.DataType, DataType, LowestCommonIntegerType);
          If LowestCommonIntegerType <> CaseExpression.DataType then Error (CASE_ConstantOutOfRange);
          Case it16Bit in LowestCommonIntegerType of
            True: begin
                    GenerateInstruction_Byte (CMP_AX_Immediate);
                    GenerateInstruction_Word (Value.Word);
                  end;
            else GenerateInstruction_TwoBytes (CMP_AL_Immediate, Value.Byte);
          end;
        end;
    end;

  begin
    MarkSourceLineNumber (GetCurrentProgramBlockSourceLineNumber);
    Repeat
      ExpectCaseConstantAndCompare;
      OpCodeH := JE;
      If CheckAndGetNextToken (Token_PeriodPeriod) then
        begin
          OpCodeL := JL;
          OpCodeH := JLE;
          If itUnsigned in CaseExpression.DataType then
            begin
              OpCodeL := JB;
              OpCodeH := JBE;
            end;
          GenerateCodeForNearJump (LastJumpToNextCaseComparison, OpCodeL);
          ExpectCaseConstantAndCompare;
        end;
      If not CheckAndGetNextToken (Token_Comma) then Break;
      GenerateCodeForNearJump (LastJumpToStartOfCaseStatement, OpCodeH);
      GenerateLabelAndSetJumpsToIt (LastJumpToNextCaseComparison);
    until False;
    GenerateCodeForNearJump (LastJumpToNextCaseComparison, OpCodeH xor $01);
    GenerateLabelAndSetJumpsToIt (LastJumpToStartOfCaseStatement);
    ExpectTokenAndGetNext (Token_Colon);
  end;

begin
  GetNextToken;
  LastJumpToStartOfCaseStatement := 0;
  LastJumpToNextCaseComparison := 0;
  LastJumpToEndOf_CASE_Statement := 0;
  IntermediateCodeOffsets.NumberOfStatements := 0;
  With CaseExpression do
    begin
      ExpectOrdinalExpression;
      CaseExpressionOrdinalType := PointerFromOffsets (POrdinalTypeDefinition (TypeDefPtr)^.OrdinalType);
      If it32Bit in DataType then CheckOrdinalRange (Ptr (SystemUnitSegment, Integer_TypeOffset));
      Calculate;
      LoadExpressionToRegisters (urAX);
    end;
  AddCallToIntermediateCodeSubroutine (IntermediateCodeOffsets, EndSubroutine);
  ExpectTokenAndGetNext (Token_OF);
  Repeat
    ExpectCaseConstantsCompareAndJump;
    AddCallToIntermediateCodeSubroutine (IntermediateCodeOffsets, EndSubroutine);
    Statement.ProcessStatement;
    AddCallToIntermediateCodeSubroutine (IntermediateCodeOffsets, Statement.StatementCode);
    If not CheckAndGetNextToken (Token_Semicolon) then Break;
    Case Token of
      Token_END,
      Token_ELSE: Break;
    end;
    GenerateCodeForNearJump (LastJumpToEndOf_CASE_Statement, JMP_ShortDirect);
    GenerateLabelAndSetJumpsToIt (LastJumpToNextCaseComparison);
  until False;
  If CheckAndGetNextToken (Token_ELSE) then
    begin
      GenerateCodeForNearJump (LastJumpToEndOf_CASE_Statement, JMP_ShortDirect);
      GenerateLabelAndSetJumpsToIt (LastJumpToNextCaseComparison);
      AddCallToIntermediateCodeSubroutine (IntermediateCodeOffsets, EndSubroutine);
      Repeat
        Statement.ProcessStatement;
        AddCallToIntermediateCodeSubroutine (IntermediateCodeOffsets, Statement.StatementCode);
        If Token = Token_END then Break;
        ExpectTokenAndGetNext (Token_Semicolon);
      until False;
    end;
  ExpectTokenAndGetNext (Token_END);
  Generate_icGoSub_ForEachSubroutine (IntermediateCodeOffsets);
  JoinJumpsOfBothExpressions (LastJumpToEndOf_CASE_Statement, LastJumpToNextCaseComparison);
  GenerateLabelAndSetJumpsToIt (LastJumpToEndOf_CASE_Statement);
  StatementCode := EndSubroutine;
end;