Press enter to see results or esc to cancel.

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;