* Modeswitches now parsed correctly (bug ID 30724)

git-svn-id: trunk@35357 -

packages/fcl-passrc/src/pparser.pp

@@ -238,6 +238,7 @@ type
     FDumpIndent : String;
     function CheckOverloadList(AList: TFPList; AName: String; out OldMember: TPasElement): TPasOverloadedProc;
     procedure DumpCurToken(Const Msg : String; IndentAction : TIndentAction = iaNone);
+    function GetCurrentModeSwitches: TModeSwitches;
     function GetVariableModifiers(Out VarMods : TVariableModifiers; Out Libname,ExportName : string): string;
     function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
     procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
@@ -377,6 +378,7 @@ type
     property CurToken: TToken read FCurToken;
     property CurTokenString: String read FCurTokenString;
     Property Options : TPOptions Read FOptions Write SetOptions;
+    Property CurrentModeswitches : TModeSwitches Read GetCurrentModeSwitches;
     Property CurModule : TPasModule Read FCurModule;
     Property LogEvents : TPParserLogEvents Read FLogEvents Write FLogEvents;
     Property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog;
@@ -520,8 +522,14 @@ var
           if  (length(s)>2) then
             case S[3] of
               'c' : Scanner.Options:=Scanner.Options+[po_cassignments];
-              'd','2' : Parser.Options:=Parser.Options+[po_delphi];
+              'd' : Scanner.SetCompilerMode('DELPHI');
+              '2' : Scanner.SetCompilerMode('OBJFPC');
             end;
+        'M' :
+           begin
+           delete(S,1,2);
+           Scanner.SetCompilerMode(S);
+           end;
       end;
     end else
       if Filename <> '' then
@@ -3420,7 +3428,7 @@ begin
         end
       // In Delphi mode, the implementation in the implementation section can be without result as it was declared
       // We actually check if the function exists in the interface section.
-      else if (po_delphi in Options) and Assigned(CurModule.ImplementationSection) then
+      else if (msDelphi in CurrentModeswitches) and Assigned(CurModule.ImplementationSection) then
         begin
         I:=-1;
         if Assigned(CurModule.InterfaceSection) then
@@ -3780,7 +3788,7 @@ begin
     FTokenBufferSize:=1;
     FCommentsBuffer[0].Clear;
     repeat
-      Scanner.ReadNonPascalTilEndToken(true);
+      Scanner.ReadNonPascalTillEndToken(true);
       case Scanner.CurToken of
       tkLineEnding:
         AsmBlock.Tokens.Add(Scanner.CurTokenString);
@@ -4478,6 +4486,14 @@ begin
   Flush(output);
 end;
 
+function TPasParser.GetCurrentModeSwitches: TModeSwitches;
+begin
+  if Assigned(FScanner) then
+    Result:=FScanner.CurrentModeSwitches
+  else
+    Result:=[msNone];
+end;
+
 // Starts on first token after Record or (. Ends on AEndToken
 procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
   AEndToken: TToken; AllowMethods: Boolean);
@@ -4540,10 +4556,9 @@ begin
       tkGeneric, // Counts as field name
       tkIdentifier :
         begin
-//        If (po_delphi in Scanner.Options) then
           if CheckVisibility(CurtokenString,v) then
             begin
-            If not (po_delphi in Scanner.Options) then
+            If not (msAdvancedRecords in Scanner.CurrentModeSwitches) then
               ParseExc(nErrRecordVisibilityNotAllowed,SErrRecordVisibilityNotAllowed);
             if not (v in [visPrivate,visPublic,visStrictPrivate]) then
               ParseExc(nParserInvalidRecordVisibility,SParserInvalidRecordVisibility);

packages/fcl-passrc/src/pscanner.pp

@@ -39,6 +39,8 @@ const
   nLogIFNDefRejected = 1012;
   nLogIFOPTIgnored = 1013;
   nLogIFIgnored = 1014;
+  nErrInvalidMode = 1015;
+  nErrInvalidModeSwitch = 1016;
 
 // resourcestring patterns of messages
 resourcestring
@@ -56,6 +58,8 @@ resourcestring
   SLogIFNDefRejected = 'IFNDEF %s found, rejecting.';
   SLogIFOPTIgnored = 'IFOPT %s found, ignoring (rejected).';
   SLogIFIgnored = 'IF %s found, ignoring (rejected).';
+  SErrInvalidMode = 'Invalid mode: "%s"';
+  SErrInvalidModeSwitch = 'Invalid mode switch: "%s"';
 
 type
   TMessageType = (
@@ -190,6 +194,53 @@ type
     );
   TTokens = set of TToken;
 
+  TModeSwitch = (
+    msNone,
+    { generic }
+    msFpc, msObjfpc, msDelphi, msTP7, msMac, msIso, msExtpas, msGPC,
+    { more specific }
+    msClass,               { delphi class model }
+    msObjpas,              { load objpas unit }
+    msResult,              { result in functions }
+    msStringPchar,         { pchar 2 string conversion }
+    msCVarSupport,         { cvar variable directive }
+    msNestedComment,       { nested comments }
+    msTPProcVar,           { tp style procvars (no @ needed) }
+    msMacProcVar,          { macpas style procvars }
+    msRepeatForward,       { repeating forward declarations is needed }
+    msPointer2Procedure,   { allows the assignement of pointers to
+                             procedure variables                     }
+    msAutoDeref,           { does auto dereferencing of struct. vars }
+    msInitFinal,           { initialization/finalization for units }
+    msDefaultAnsistring,   { ansistring turned on by default }
+    msOut,                 { support the calling convention OUT }
+    msDefaultPara,         { support default parameters }
+    msHintDirective,       { support hint directives }
+    msDuplicateNames,      { allow locals/paras to have duplicate names of globals }
+    msProperty,            { allow properties }
+    msDefaultInline,       { allow inline proc directive }
+    msExcept,              { allow exception-related keywords }
+    msObjectiveC1,         { support interfacing with Objective-C (1.0) }
+    msObjectiveC2,         { support interfacing with Objective-C (2.0) }
+    msNestedProcVars,      { support nested procedural variables }
+    msNonLocalGoto,        { support non local gotos (like iso pascal) }
+    msAdvancedRecords,     { advanced record syntax with visibility sections, methods and properties }
+    msISOLikeUnaryMinus,   { unary minus like in iso pascal: same precedence level as binary minus/plus }
+    msSystemCodePage,      { use system codepage as compiler codepage by default, emit ansistrings with system codepage }
+    msFinalFields,         { allows declaring fields as "final", which means they must be initialised
+                             in the (class) constructor and are constant from then on (same as final
+                             fields in Java) }
+    msDefaultUnicodestring, { makes the default string type in $h+ mode unicodestring rather than
+                               ansistring; similarly, char becomes unicodechar rather than ansichar }
+    msTypeHelpers,         { allows the declaration of "type helper" (non-Delphi) or "record helper"
+                             (Delphi) for primitive types }
+    msBlocks,              { support for http://en.wikipedia.org/wiki/Blocks_(C_language_extension) }
+    msISOLikeIO,           { I/O as it required by an ISO compatible compiler }
+    msISOLikeProgramsPara, { program parameters as it required by an ISO compatible compiler }
+    msISOLikeMod           { mod operation as it is required by an iso compatible compiler }
+  );
+  TModeSwitches = Set of TModeSwitch;
+
   { TMacroDef }
 
   TMacroDef = Class(TObject)
@@ -326,13 +377,13 @@ type
   TPascalScannerPPSkipMode = (ppSkipNone, ppSkipIfBranch, ppSkipElseBranch, ppSkipAll);
 
   TPOption = (
-    po_delphi, // Delphi mode: forbid nested comments
-    po_cassignments,  // allow C-operators += -= *= /=
+    po_delphi,               // DEPRECATED Delphi mode: forbid nested comments
+    po_cassignments,         // allow C-operators += -= *= /=
     po_resolvestandardtypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
-    po_asmwhole,  // store whole text between asm..end in TPasImplAsmStatement.Tokens
-    po_nooverloadedprocs,  // do not create TPasOverloadedProc for procs with same name
-    po_keepclassforward,   // disabled: delete class fowards when there is a class declaration
-    po_arrayrangeexpr    // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
+    po_asmwhole,             // store whole text between asm..end in TPasImplAsmStatement.Tokens
+    po_nooverloadedprocs,    // do not create TPasOverloadedProc for procs with same name
+    po_keepclassforward,     // disabled: delete class fowards when there is a class declaration
+    po_arrayrangeexpr        // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
     );
   TPOptions = set of TPOption;
 
@@ -351,6 +402,7 @@ type
 
   TPascalScanner = class
   private
+    FCurrentModeSwitches: TModeSwitches;
     FLastMsg: string;
     FLastMsgArgs: TMessageArgs;
     FLastMsgNumber: integer;
@@ -379,7 +431,6 @@ type
     PPSkipStackIndex: Integer;
     PPSkipModeStack: array[0..255] of TPascalScannerPPSkipMode;
     PPIsSkippingStack: array[0..255] of Boolean;
-
     function GetCurColumn: Integer;
     procedure SetOptions(AValue: TPOptions);
   protected
@@ -402,6 +453,7 @@ type
     procedure HandleUnDefine(Param: String);virtual;
     function HandleInclude(const Param: String): TToken;virtual;
     procedure HandleMode(const Param: String);virtual;
+    procedure HandleModeSwitch(const Param: String);virtual;
     function HandleMacro(AIndex: integer): TToken;virtual;
     procedure PushStackItem; virtual;
     function DoFetchTextToken: TToken;
@@ -415,9 +467,10 @@ type
     destructor Destroy; override;
     procedure OpenFile(const AFilename: string);
     function FetchToken: TToken;
-    function ReadNonPascalTilEndToken(StopAtLineEnd: boolean): TToken;
+    function ReadNonPascalTillEndToken(StopAtLineEnd: boolean): TToken;
     Procedure AddDefine(S : String);
     Procedure RemoveDefine(S : String);
+    Procedure SetCompilerMode(S : String);
     function CurSourcePos: TPasSourcePos;
 
     property FileResolver: TBaseFileResolver read FFileResolver;
@@ -443,6 +496,7 @@ type
     property LastMsgType: TMessageType read FLastMsgType write FLastMsgType;
     property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
     property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
+    Property CurrentModeSwitches : TModeSwitches Read FCurrentModeSwitches Write FCurrentModeSwitches;
   end;
 
 const
@@ -562,6 +616,77 @@ const
     'Tab'
   );
 
+  SModeSwitchNames : array[TModeSwitch] of string[18] =
+  ( '', '','','','','','','', '',
+    { more specific }
+    'CLASS',
+    'OBJPAS',
+    'RESULT',
+    'PCHARTOSTRING',
+    'CVAR',
+    'NESTEDCOMMENTS',
+    'CLASSICPROCVARS',
+    'MACPROCVARS',
+    'REPEATFORWARD',
+    'POINTERTOPROCVAR',
+    'AUTODEREF',
+    'INITFINAL',
+    'ANSISTRINGS',
+    'OUT',
+    'DEFAULTPARAMETERS',
+    'HINTDIRECTIVE',
+    'DUPLICATELOCALS',
+    'PROPERTIES',
+    'ALLOWINLINE',
+    'EXCEPTIONS',
+    'OBJECTIVEC1',
+    'OBJECTIVEC2',
+    'NESTEDPROCVARS',
+    'NONLOCALGOTO',
+    'ADVANCEDRECORDS',
+    'ISOUNARYMINUS',
+    'SYSTEMCODEPAGE',
+    'FINALFIELDS',
+    'UNICODESTRINGS',
+    'TYPEHELPERS',
+    'CBLOCKS',
+    'ISOIO',
+    'ISOPROGRAMPARAS',
+    'ISOMOD'
+    );
+
+const
+  AllLanguageModes = [msFPC,msObjFPC,msDelphi,msTP7,msMac,msISO,msExtPas];
+
+const
+
+  DelphiModeSwitches = [msDelphi,msClass,msObjpas,msresult,msstringpchar,
+     mspointer2procedure,msautoderef,msTPprocvar,msinitfinal,msdefaultansistring,
+     msout,msdefaultpara,msduplicatenames,mshintdirective,
+     msproperty,msdefaultinline,msexcept,msadvancedrecords,mstypehelpers];
+
+  DelphiUnicodeModeSwitches = delphimodeswitches + [mssystemcodepage,msdefaultunicodestring];
+
+  FPCModeSwitches = [msfpc,msstringpchar,msnestedcomment,msrepeatforward,
+    mscvarsupport,msinitfinal,mshintdirective, msproperty,msdefaultinline];
+
+  OBJFPCModeSwitches =  [msobjfpc,msfpc,msclass,msobjpas,msresult,msstringpchar,msnestedcomment,
+    msrepeatforward,mscvarsupport,msinitfinal,msout,msdefaultpara,mshintdirective,
+    msproperty,msdefaultinline,msexcept];
+
+  TPModeSwitches = [mstp7,mstpprocvar,msduplicatenames];
+
+  GPCModeSwitches = [msgpc,mstpprocvar];
+
+  MacModeSwitches = [msmac,mscvarsupport,msmacprocvar,msnestedprocvars,msnonlocalgoto,
+    msisolikeunaryminus,msdefaultinline];
+
+  ISOModeSwitches =  [msiso,mstpprocvar,msduplicatenames,msnestedprocvars,msnonlocalgoto,msisolikeunaryminus,msisolikeio,
+    msisolikeprogramspara, msisolikemod];
+
+  ExtPasModeSwitches = [msextpas,mstpprocvar,msduplicatenames,msnestedprocvars,msnonlocalgoto,msisolikeunaryminus,msisolikeio,
+    msisolikeprogramspara, msisolikemod];
+
 function FilenameIsAbsolute(const TheFilename: string):boolean;
 function FilenameIsWinAbsolute(const TheFilename: string): boolean;
 function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
@@ -1081,6 +1206,7 @@ begin
   FIncludeStack := TFPList.Create;
   FDefines := CS;
   FMacros:=CS;
+  FCurrentModeSwitches:=FPCModeSwitches;
 end;
 
 destructor TPascalScanner.Destroy;
@@ -1176,7 +1302,7 @@ begin
 //  Writeln(Result, '(',CurTokenString,')');
 end;
 
-function TPascalScanner.ReadNonPascalTilEndToken(StopAtLineEnd: boolean
+function TPascalScanner.ReadNonPascalTillEndToken(StopAtLineEnd: boolean
   ): TToken;
 var
   StartPos: PChar;
@@ -1455,10 +1581,82 @@ begin
   P:=UpperCase(Param);
   // Eventually, we'll need to make the distinction...
   // For now, treat OBJFPC as Delphi mode.
-  if (P='DELPHI') or (P='OBJFPC') then
-    Options:=Options+[po_delphi]
+  Case P of
+  'DELPHI':
+     begin
+     CurrentModeSwitches:=delphimodeswitches;
+     FOptions:=FOptions+[po_delphi]
+     end;
+  'DELPHIUNICODE':
+     begin
+     CurrentModeSwitches:=DelphiUnicodeModeSwitches;
+     FOptions:=FOptions+[po_delphi]
+     end;
+  'TP':
+     begin
+     CurrentModeSwitches:=TPModeSwitches;
+     FOptions:=FOptions-[po_delphi]
+     end;
+  'GPC':
+     begin
+     CurrentModeSwitches:=GPCModeSwitches;
+     FOptions:=FOptions-[po_delphi]
+     end;
+  'ISO':
+     begin
+     CurrentModeSwitches:=ISOModeSwitches;
+     FOptions:=FOptions-[po_delphi]
+     end;
+  'EXTENDED':
+     begin
+     CurrentModeSwitches:=ExtPasModeSwitches;
+     FOptions:=FOptions-[po_delphi]
+     end;
+  'MACPAS':
+     begin
+     CurrentModeSwitches:=MacModeSwitches;
+     FOptions:=FOptions-[po_delphi]
+     end;
+  'OBJFPC':
+    begin
+    CurrentModeSwitches:=ObjFPCModeSwitches;
+    FOptions:=FOptions+[po_delphi]
+    end;
+  'FPC',
+  'DEFAULT':
+    begin
+      CurrentModeSwitches:=FPCModeSwitches;
+      FOptions:=FOptions-[po_delphi]
+    end;
+  else
+    Error(nErrInvalidMode,SErrInvalidMode,[Param])
+  end;
+end;
+
+procedure TPascalScanner.HandleModeSwitch(const Param: String);
+
+Var
+  MS : TModeSwitch;
+  MSN,PM : String;
+  P : Integer;
+
+begin
+  MSN:=Uppercase(Param);
+  MS:=High(TModeSwitch);
+  P:=Pos(' ',MSN);
+  if P<>0 then
+    begin
+    PM:=Trim(Copy(MSN,P+1,Length(MSN)-P));
+    MSN:=Copy(MSN,1,P-1);
+    end;
+  While (MS<>msNone) and (SModeSwitchNames[MS]<>MSN) do
+   MS:=Pred(MS);
+  if MS=msNone then
+    Error(nErrInvalidModeSwitch,SErrInvalidModeSwitch,[Param]);
+  if (PM='') or (PM='+') or (PM='ON') then
+    CurrentModeSwitches:=CurrentModeSwitches+[MS]
   else
-    Options:=Options-[po_delphi]
+    CurrentModeSwitches:=CurrentModeSwitches-[MS];
 end;
 
 Procedure TPascalScanner.PushSkipMode;
@@ -1615,6 +1813,9 @@ begin
   'MODE':
      if not PPIsSkipping then
       HandleMode(Param);
+  'MODESWITCH':
+     if not PPIsSkipping then
+      HandleModeSwitch(Param);
   'DEFINE':
      if not PPIsSkipping then
        HandleDefine(Param);
@@ -2007,7 +2208,7 @@ begin
             TokenStart := TokenStr;
           end else
           begin
-            if not(po_delphi in Options) and (TokenStr[0] = '{') then
+            if (msNestedComment in CurrentModeSwitches) and (TokenStr[0] = '{') then
               Inc(NestingLevel)
             else if (TokenStr[0] = '}') and not PPIsSkipping then
               Dec(NestingLevel);
@@ -2088,9 +2289,20 @@ begin
 end;
 
 procedure TPascalScanner.SetOptions(AValue: TPOptions);
+
+Var
+  isModeSwitch : Boolean;
+
 begin
   if FOptions=AValue then Exit;
+  // Change of mode ?
+  IsModeSwitch:=(po_delphi in Avalue) <> (po_delphi in FOptions);
   FOptions:=AValue;
+  if isModeSwitch then
+    if (po_delphi in FOptions) then
+      CurrentModeSwitches:=DelphiModeSwitches
+    else
+      CurrentModeSwitches:=FPCModeSwitches
 end;
 
 function TPascalScanner.FetchLine: boolean;
@@ -2139,6 +2351,11 @@ begin
     FDefines.Delete(I);
 end;
 
+procedure TPascalScanner.SetCompilerMode(S: String);
+begin
+  HandleMode(S);
+end;
+
 function TPascalScanner.CurSourcePos: TPasSourcePos;
 begin
   Result.FileName:=CurFilename;

packages/fcl-passrc/tests/tcscanner.pas

@@ -60,6 +60,8 @@ type
     procedure TearDown; override;
     Function TokenToString(tk : TToken) : string;
     Procedure AssertEquals(Msg : String; Expected,Actual : TToken); overload;
+    Procedure AssertEquals(Msg : String; Expected,Actual : TModeSwitch); overload;
+    Procedure AssertEquals(Msg : String; Expected,Actual : TModeSwitches); overload;
     procedure NewSource(Const Source : string; DoClear : Boolean = True);
     Procedure DoTestToken(t : TToken; Const ASource : String; Const CheckEOF : Boolean = True);
     Procedure TestToken(t : TToken; Const ASource : String; Const CheckEOF : Boolean = True);
@@ -67,6 +69,7 @@ type
     Property LastIDentifier : String Read FLI Write FLi;
     Property Scanner : TPascalScanner Read FScanner;
   published
+    Procedure TestEmpty;
     procedure TestEOF;
     procedure TestWhitespace;
     procedure TestComment1;
@@ -218,6 +221,7 @@ type
     procedure TestMacro2;
     procedure TestMacro3;
     procedure TestMacroHandling;
+    Procedure TestModeSwitch;
   end;
 
 implementation
@@ -366,12 +370,40 @@ begin
   AssertEquals(Msg,TokenToString(Expected),TokenToString(Actual));
 end;
 
+procedure TTestScanner.AssertEquals(Msg: String; Expected, Actual: TModeSwitch);
+begin
+  AssertEquals(Msg,GetEnumName(TypeInfo(TModeSwitch),Ord(Expected)),
+                   GetEnumName(TypeInfo(TModeSwitch),Ord(Actual)))
+end;
+
+procedure TTestScanner.AssertEquals(Msg: String; Expected, Actual: TModeSwitches);
+
+  Function ToString(S : TModeSwitches) : String;
+
+  Var
+    M : TModeSwitch;
+
+  begin
+    Result:='';
+    For M in TModeswitch do
+      if M in S then
+        begin
+        If (Result<>'') then
+          Result:=Result+', ';
+        Result:=Result+GetEnumName(TypeInfo(TModeSwitch), Ord(M));
+        end;
+  end;
+
+begin
+  AssertEquals(Msg,ToString(Expected),ToString(Actual));
+end;
+
 procedure TTestScanner.NewSource(const Source: string; DoClear : Boolean = True);
 begin
   if DoClear then
     FResolver.Clear;
   FResolver.AddStream('afile.pp',TStringStream.Create(Source));
-  Writeln('// TestName');
+  Writeln('// '+TestName);
   Writeln(Source);
   FScanner.OpenFile('afile.pp');
 end;
@@ -435,6 +467,13 @@ begin
     end;
 end;
 
+procedure TTestScanner.TestEmpty;
+begin
+  AssertNotNull('Have Scanner',Scanner);
+  AssertTrue('Options is empty',[]=Scanner.Options);
+  AssertEquals('FPC modes is default',FPCModeSwitches,Scanner.CurrentModeSwitches);
+end;
+
 procedure TTestScanner.TestEOF;
 begin
   TestToken(tkEOF,'')
@@ -1476,6 +1515,29 @@ begin
   AssertEQuals('Correct identifier', 'somethingweird',LastIdentifier);
 end;
 
+procedure TTestScanner.TestModeSwitch;
+
+Const
+   PlusMinus = [' ','+','-'];
+
+Var
+  M : TModeSwitch;
+  C : Char;
+begin
+  For M in TModeSwitch do
+    for C in PlusMinus do
+      if SModeSwitchNames[M]<>'' then
+        begin
+        Scanner.CurrentModeSwitches:=[];
+        NewSource('{$MODESWITCH '+SModeSwitchNames[M]+' '+C+'}');
+        While not (Scanner.FetchToken=tkEOF) do;
+        if C in [' ','+'] then
+          AssertTrue(SModeSwitchNames[M]+C+' sets '+GetEnumName(TypeInfo(TModeSwitch),Ord(M)),M in Scanner.CurrentModeSwitches)
+        else
+          AssertFalse(SModeSwitchNames[M]+C+' removes '+GetEnumName(TypeInfo(TModeSwitch),Ord(M)),M in Scanner.CurrentModeSwitches);
+        end;
+end;
+
 initialization
   RegisterTests([TTestTokenFinder,TTestStreamLineReader,TTestScanner]);
 end.