Press enter to see results or esc to cancel.

Processing Comments and Compiler Directives

This procedure processes compiler directives and skips comment. Here also conditional compilation directives (with support for nested directives) are processed.

Procedure ProcessComment (Var NextChar: PChar; StartChar: Char);
Var SecondDirective, Directive: TDirective;
    Switch: TCompilerSwitches;
    FileRecord: Pointer;
    UnitPtr: PUnitHeader;
    IntegerNumericConstant: LongInt;

  Procedure SkipComment (Var NextChar: PChar);
  Var C: Char;
      TwoChars: TTwoChars;
  begin
    If CommentCharacter = '{' then
      Repeat
        C := NextChar^;
        Inc (NextChar);
        If C = #0 then
          begin
            If not NextLine then Error (UnexpectedEndOfFile);
            NextChar := CurrentLine;
            Continue;
          end;
      until C = '}'
        else Repeat
               TwoChars := PTwoChars (NextChar - 1)^;
               Inc (NextChar);
               If TwoChars.Second = #0 then
                 begin
                   If not NextLine then Error (UnexpectedEndOfFile);
                   NextChar := CurrentLine;
                   Continue;
                 end;
             until TwoChars.Both = '*)';
  end;

  Procedure ExpectIdentifierInDirective;
  begin
    SkipSeparators (NextChar);
    ErrorSourcePosition := NextChar;
    CopyToIdentifier (NextChar);
    If Identifier = '' then Error (IdentifierExpected);
  end;

  Function Find_ENDIF: Boolean;
  Type TDirectiveData = Record
                          EndsENDIF: Boolean;
                          IfLevelIncrement: Integer;
                        end;
  Var IfLevel: Byte;
      StringFlag: Boolean;
      DirectiveData: TDirectiveData;
      NewDirective: TDirective;
      TwoChars: TTwoChars;
  begin
    IfLevel := 0;
    StringFlag := False;
    Repeat
      Case NextChar^ of
        #0: begin
              If not NextLine then Error (ENDIF_directiveMissing);
              NextChar := CurrentLine;
              StringFlag := False;
              Continue;
            end;
        '''': begin
                StringFlag := not StringFlag;
                Inc (NextChar);
                Continue;
              end;
      end;
      If StringFlag then
        begin
          Inc (NextChar);
          Continue;
        end;
      TwoChars := PTwoChars (NextChar)^;
      Inc (NextChar);
      If (TwoChars.First = '{') or (TwoChars.Both = '(*') then
        begin
          If TwoChars.First <> '{' then Inc (NextChar);
          CommentCharacter := TwoChars.First;
          With DirectiveData do
            begin
              EndsENDIF := False;
              IfLevelIncrement := 0;
            end;
          If NextChar^ = '$' then
            begin
              Inc (NextChar);
              If IsCompilerDirective (NextChar, NewDirective) then With DirectiveData do
                Case NewDirective of
                  Directive_ELSE:   begin
                                      EndsENDIF := True;
                                      IfLevelIncrement :=   0;
                                    end;
                  Directive_ENDIF:  begin
                                      EndsENDIF := True;
                                      IfLevelIncrement := - 1;
                                    end;
                  Directive_IFDEF,
                  Directive_IFNDEF,
                  Directive_IFOPT:  begin
                                      EndsENDIF := False;
                                      IfLevelIncrement :=   1;
                                    end;
                end;
            end;
          SkipComment (NextChar);
          If DirectiveData.EndsENDIF and (IfLevel = 0) then
            begin
              Find_ENDIF := DirectiveData.IfLevelIncrement <> 0;
              Exit;
            end;
          Inc (IfLevel, DirectiveData.IfLevelIncrement);
          StringFlag := False;
        end;
    until False;
  end;

  Procedure GetDirectiveFileName;
  Var Len: Byte;
  begin
    SkipSeparators (NextChar);
    ErrorSourcePosition := NextChar;
    Len := 0;
    Repeat
      Case NextChar^ of
        #0..' ',
        '*', '}': Break;
        else Identifier [Len] := UpCase (NextChar^);
      end;
      Inc (Len);
      Inc (NextChar);
    until Len = 79;
    Identifier [Len] := #0;
  end;

  Procedure ProcessIF (Cond: Boolean);
  begin
    SkipComment (NextChar);
    Inc (CurrentSourceFile^.IF_Level);
    If not Cond then
      If Find_ENDIF then Dec (CurrentSourceFile^.IF_Level);
  end;

  Function IsIntegerNumericConstantNext: Boolean;
  begin
    SkipSeparators (NextChar);
    ErrorSourcePosition := NextChar;
    IsIntegerNumericConstantNext := IsIntegerNumericConstant (NextChar);
  end;

  Function IsSegmentNext: Boolean;
  begin
    IsSegmentNext := False;
    If not IsIntegerNumericConstantNext then Exit;
    With IntegerNumericConstantRec do If (WordH = $FFFF) and (WordL > $FFF0) then Exit;
    IntegerNumericConstant := (IntegerNumericConstant + $F) shr 4;
    IsSegmentNext := IntegerNumericConstantRec.WordH = 0;
  end;

  Procedure RemoveConditionalDefine;
  Var SrcPtr, DestPtr: PChar;
      Len: Byte;
  begin
    If not IdentifierInConditionalDefines then Exit;
    Len := Byte (DestPtr^);
    SrcPtr := DestPtr + Len + 1;
    Move (SrcPtr^, DestPtr^, Ofs (ConditionalDefinesEnd^) - Ofs (SrcPtr^));
    ConditionalDefinesEnd := Ptr (Seg (ConditionalDefinesEnd^), Ofs (ConditionalDefinesEnd^) - Len - 1);
  end;

  Function UnitFound (Name: PString; Var TempUnit: PUnitHeader): Boolean;
  Var UnitSegment: Word;
      UnitName: PString;
  begin
    UnitFound := True;
    UnitSegment := LastLoadedUsedUnit;
    Repeat
      TempUnit := Ptr (UnitSegment, 0);
      UnitName := @PIdentifier (Ptr (UnitSegment, TempUnit^.UnitNameIdentifierOffset))^.Name;
      If IdentifiersEqual (Name, UnitName) then Exit;
      UnitSegment := TempUnit^.PreviousUnitSegment;
    until UnitSegment = 0;
    UnitFound := False;
  end;

  Function SetSwitch (CompilerSwitch: TCompilerSwitches; ReportError: Boolean): Boolean;
  begin
    SetSwitch := False;
    If not (NextChar^ in ['+', '-']) then
      Case ReportError of
        True: Error (InvalidCompilerDirective);
        else Exit;
      end;
    If ModuleHeadingEnded then If CompilerSwitch in GlobalCompilerSwitches then Error (InvalidCompilerDirective);
    Case NextChar^ of
      '+': Include (ModuleCompilerSwitches, CompilerSwitch);
      '-': Exclude (ModuleCompilerSwitches, CompilerSwitch);
    end;
    SetSwitch := True;
    Inc (NextChar);
  end;

begin
  CommentCharacter := StartChar;
  If NextChar^ = '$' then
    Repeat
      Inc (NextChar);
      If not IsCompilerDirective (NextChar, Directive) then Error (InvalidCompilerDirective);
      Case Directive of
        Directive_A: SetSwitch (WordAlignment, True);
        Directive_B: SetSwitch (FullBooleanEval, True);
        Directive_C: Break;
        Directive_D: SetSwitch (DebugInformation, True);
        Directive_DEFINE: begin
                            ExpectIdentifierInDirective;
                            AddConditionalDefine;
                            Break;
                          end;
        Directive_E: SetSwitch (Emulation80x87, True);
        Directive_ELSE: begin
                          If CurrentSourceFile^.IF_Level = 0 then Error (MisplacedConditionalDirective);
                          SkipComment (NextChar);
                          If Find_ENDIF then Dec (CurrentSourceFile^.IF_Level);
                          Exit;
                        end;
        Directive_ENDIF: begin
                           If CurrentSourceFile^.IF_Level = 0 then Error (MisplacedConditionalDirective);
                           Dec (CurrentSourceFile^.IF_Level);
                           Break;
                         end;
        Directive_F: SetSwitch (ForceFarCalls, True);
        Directive_G: If not SetSwitch (Instructions80286, False) then Break;
        Directive_I: begin
                       If SetSwitch (IOErrorChecking, False) then Continue;
                       GetDirectiveFileName;
                       SkipComment (NextChar);
                       CurrentSourceFile^.CurrentPosition := Ofs (NextChar^);
                       ErrorSourcePosition := NextChar;
                       CreateSourceFilesRecord;
                       FindFilePath (@Identifier, Dir_None or Ext_PAS);
                       FileRecord := StoreFileNameToFilesBlock (@Identifier, ufIncludeFile);
                       FindFilePath (@Identifier, Dir_Include or Ext_Original);
                       OpenSourceFile (FileRecord, @Identifier);
                       SetFileDateTime;
                       NextChar := Ptr (Seg (NextChar^), CurrentSourceFile^.CurrentPosition);
                       Exit;
                     end;
        Directive_IFDEF: begin
                           ExpectIdentifierInDirective;
                           ProcessIF (IdentifierInConditionalDefines);
                           Exit;
                         end;
        Directive_IFNDEF: begin
                            ExpectIdentifierInDirective;
                            ProcessIF (not IdentifierInConditionalDefines);
                            Exit;
                          end;
        Directive_IFOPT: begin
                           SkipSeparators (NextChar);
                           If not IsCompilerDirective (NextChar, SecondDirective) then Error (InvalidCompilerDirective);
                           Case SecondDirective of
                             Directive_A: Switch := WordAlignment;
                             Directive_B: Switch := FullBooleanEval;
                             Directive_D: Switch := DebugInformation;
                             Directive_E: Switch := Emulation80x87;
                             Directive_F: Switch := ForceFarCalls;
                             Directive_G: Switch := Instructions80286;
                             Directive_I: Switch := IOErrorChecking;
                             Directive_K: Switch := CompilerDirective_K;
                             Directive_L: Switch := LocalDebugSymbols;
                             Directive_N: Switch := Instructions80x87;
                             Directive_O: Switch := OverlaysAllowed;
                             Directive_P: Switch := OpenStringParams;
                             Directive_Q: Switch := OverflowChecking;
                             Directive_R: Switch := RangeChecking;
                             Directive_S: Switch := StackChecking;
                             Directive_T: Switch := TypedPointers;
                             Directive_V: Switch := StrictVarStrings;
                             Directive_W: Switch := CompilerDirective_W;
                             Directive_X: Switch := ExtendedSyntax;
                             Directive_Y: Switch := CompilerDirective_Y;
                             else Error (InvalidCompilerDirective);
                           end;
                           Case NextChar^ of
                             '+': ProcessIF (Switch in ModuleCompilerSwitches);
                             '-': ProcessIF (not (Switch in ModuleCompilerSwitches));
                             else Error (InvalidCompilerDirective);
                           end;
                           Exit;
                         end;
        Directive_K: SetSwitch (CompilerDirective_K, True);
        Directive_L: begin
                       If SetSwitch (LocalDebugSymbols, False) then Continue;
                       GetDirectiveFileName;
                       FindFilePath (@Identifier, Dir_None or Ext_OBJ);
                       StoreFileNameToFilesBlock (@Identifier, ufObjectFile);
                       Break;
                     end;
        Directive_M: begin
                       If not IsIntegerNumericConstantNext then Error (InvalidCompilerDirective);
                       If IntegerNumericConstantRec.WordH <> 0 then Error (InvalidCompilerDirective);
                       IntegerNumericConstantRec.WordL := IntegerNumericConstantRec.WordL and $FFFE;
                       If (IntegerNumericConstantRec.WordL < $4000) or (IntegerNumericConstantRec.WordL > $FFF0) then
                         Error (InvalidCompilerDirective);
                       ModuleStack := IntegerNumericConstantRec.WordL;
                       If not IsSegmentNext then Error (InvalidCompilerDirective);
                       If IntegerNumericConstantRec.WordL > $A000 then Error (InvalidCompilerDirective);
                       ModuleHeapMin := IntegerNumericConstantRec.WordL;
                       If not IsSegmentNext then Error (InvalidCompilerDirective);
                       If IntegerNumericConstantRec.WordL < ModuleHeapMin then Error (InvalidCompilerDirective);
                       If IntegerNumericConstantRec.WordL > $A000 then Error (InvalidCompilerDirective);
                       ModuleHeapMax := IntegerNumericConstantRec.WordL;
                       Break;
                     end;
        Directive_N: SetSwitch (Instructions80x87, True);
        Directive_O: begin
                       If SetSwitch (OverlaysAllowed, False) then Continue;
                       If SourceType >= stUnit then Error (InvalidCompilerDirective);
                       If not (cmoCompileToDisk in CompilerModeOptions) then Error (CannotCompileOverlaysToMemory);
                       ExpectIdentifierInDirective;
                       If not UnitFound (@Identifier, UnitPtr) then Error (UnknownIdentifier);
                       If not (ufOverlaysAllowed in UnitPtr^.Flags) then Error (CannotOverlayThisUnit);
                       UnitPtr^.OverlayedUnitCodeSize := $FFFF;
                       Break;
                     end;
        Directive_P: SetSwitch (OpenStringParams, True);
        Directive_Q: SetSwitch (OverflowChecking, True);
        Directive_R: If not SetSwitch (RangeChecking, False) then Break;
        Directive_S: If not SetSwitch (StackChecking, False) then Break;
        Directive_T: SetSwitch (TypedPointers, True);
        Directive_UNDEF: begin
                           ExpectIdentifierInDirective;
                           RemoveConditionalDefine;
                           Break;
                         end;
        Directive_V: SetSwitch (StrictVarStrings, True);
        Directive_W: SetSwitch (CompilerDirective_W, True);
        Directive_X: SetSwitch (ExtendedSyntax, True);
        Directive_Y: SetSwitch (CompilerDirective_Y, True);
      end;
    until NextChar^ <> ',';
  SkipComment (NextChar);
end;

This function checks if comment is actually a compiler directive.

TDirective = (
    Directive_A,
    Directive_B,
    Directive_C,
    Directive_D,
    Directive_DEFINE,
    Directive_E,
    Directive_ELSE,
    Directive_ENDIF,
    Directive_F,
    Directive_G,
    Directive_I,
    Directive_IFDEF,
    Directive_IFNDEF,
    Directive_IFOPT,
    Directive_K,
    Directive_L,
    Directive_M,
    Directive_N,
    Directive_O,
    Directive_P,
    Directive_Q,
    Directive_R,
    Directive_S,
    Directive_T,
    Directive_UNDEF,
    Directive_V,
    Directive_W,
    Directive_X,
    Directive_Y,
    InvalidDirective);

Function IsCompilerDirective (Var NextChar: PChar; Var Directive: TDirective): Boolean;
Const DirectiveStr: Array [Directive_A..Directive_Y] of PChar = (
        'A',
        'B',
        'C',
        'D',
        'DEFINE',
        'E',
        'ELSE',
        'ENDIF',
        'F',
        'G',
        'I',
        'IFDEF',
        'IFNDEF',
        'IFOPT',
        'K',
        'L',
        'M',
        'N',
        'O',
        'P',
        'Q',
        'R',
        'S',
        'T',
        'UNDEF',
        'V',
        'W',
        'X',
        'Y');
begin
  ErrorSourcePosition := NextChar;
  CopyToIdentifier (NextChar);
  IsCompilerDirective := True;
  Directive := Directive_A;
  Repeat
    If Identifier = StrPas (DirectiveStr [Directive]) then Exit;
    Inc (Directive);
  until Directive = InvalidDirective;
  IsCompilerDirective := False;
end;