fcl-passrc: scanner: bool switch $goto

git-svn-id: trunk@41125 -

packages/fcl-passrc/src/pparser.pp

@@ -6119,7 +6119,9 @@ begin
               end;
             tkColon:
               begin
-              if not (Left is TPrimitiveExpr) then
+              if not (bsGoto in Scanner.CurrentBoolSwitches) then
+                ParseExcTokenError(TokenInfos[tkSemicolon])
+              else if not (Left is TPrimitiveExpr) then
                 ParseExcTokenError(TokenInfos[tkSemicolon]);
               // label mark. todo: check mark identifier in the list of labels
               El:=TPasImplLabelMark(CreateElement(TPasImplLabelMark,'', CurBlock,SrcPos));

packages/fcl-passrc/src/pscanner.pp

@@ -334,7 +334,8 @@ type
     bsMacro,
     bsScopedEnums,
     bsObjectChecks,   // check methods 'Self' and object type casts
-    bsPointerMath     // pointer arithmetic
+    bsPointerMath,    // pointer arithmetic
+    bsGoto       // support label and goto, set by {$goto on|off}
     );
   TBoolSwitches = set of TBoolSwitch;
 const
@@ -370,8 +371,8 @@ const
   bsAll = [low(TBoolSwitch)..high(TBoolSwitch)];
   bsFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
   bsObjFPCMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
-  bsDelphiMode: TBoolSwitches = [bsWriteableConst];
+  bsDelphiMode: TBoolSwitches = [bsWriteableConst,bsGoto];
-  bsDelphiUnicodeMode: TBoolSwitches = [bsWriteableConst];
+  bsDelphiUnicodeMode: TBoolSwitches = [bsWriteableConst,bsGoto];
   bsMacPasMode: TBoolSwitches = [bsPointerMath,bsWriteableConst];
 
 type
@@ -1102,7 +1103,8 @@ const
     'Macro',
     'ScopedEnums',
     'ObjectChecks',
-    'PointerMath'
+    'PointerMath',
+    'Goto'
     );
 
   ValueSwitchNames: array[TValueSwitch] of string = (
@@ -3674,6 +3676,8 @@ begin
           DoBoolDirective(bsAssertions);
         'DEFINE':
           HandleDefine(Param);
+        'GOTO':
+          DoBoolDirective(bsGoto);
         'ERROR':
           HandleError(Param);
         'HINT':
@@ -3788,9 +3792,9 @@ begin
     DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,
       [BoolSwitchNames[bs]])
   else if NewValue then
-    Include(FCurrentBoolSwitches,bs)
+    CurrentBoolSwitches:=CurrentBoolSwitches+[bs]
   else
-    Exclude(FCurrentBoolSwitches,bs);
+    CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
 end;
 
 function TPascalScanner.DoFetchToken: TToken;
@@ -4510,9 +4514,24 @@ begin
 end;
 
 procedure TPascalScanner.SetCurrentBoolSwitches(const AValue: TBoolSwitches);
+var
+  OldBS, Removed, Added: TBoolSwitches;
 begin
   if FCurrentBoolSwitches=AValue then Exit;
+  OldBS:=FCurrentBoolSwitches;
   FCurrentBoolSwitches:=AValue;
+  Removed:=OldBS-FCurrentBoolSwitches;
+  Added:=FCurrentBoolSwitches-OldBS;
+  if bsGoto in Added then
+    begin
+    UnsetNonToken(tklabel);
+    UnsetNonToken(tkgoto);
+    end;
+  if bsGoto in Removed then
+    begin
+    SetNonToken(tklabel);
+    SetNonToken(tkgoto);
+    end;
 end;
 
 procedure TPascalScanner.SetCurrentModeSwitches(AValue: TModeSwitches);

packages/fcl-passrc/tests/tcresolver.pas

@@ -348,6 +348,8 @@ type
     Procedure TestForLoopStartIncompFail;
     Procedure TestForLoopEndIncompFail;
     Procedure TestSimpleStatement_VarFail;
+    Procedure TestLabelStatementFail;
+    Procedure TestLabelStatementDelphiFail;
 
     // units
     Procedure TestUnitForwardOverloads;
@@ -5299,6 +5301,26 @@ begin
   CheckResolverException('Illegal expression',nIllegalExpression);
 end;
 
+procedure TTestResolver.TestLabelStatementFail;
+begin
+  StartProgram(false);
+  Add('var i: longint;');
+  Add('begin');
+  Add('  i: i;');
+  CheckParserException('Expected ";"',nParserExpectTokenError);
+end;
+
+procedure TTestResolver.TestLabelStatementDelphiFail;
+begin
+  StartProgram(false);
+  Add('{$mode delphi}');
+  Add('{$goto off}');
+  Add('var i: longint;');
+  Add('begin');
+  Add('  i: i;');
+  CheckParserException('Expected ";"',nParserExpectTokenError);
+end;
+
 procedure TTestResolver.TestUnitForwardOverloads;
 begin
   StartUnit(false);

packages/fcl-passrc/tests/tcstatements.pas

@@ -1794,7 +1794,9 @@ end;
 procedure TTestStatementParser.TestGotoInIfThen;
 
 begin
-  AddStatements(['if expr then',
+  AddStatements([
+  '{$goto on}',
+  'if expr then',
   '  dosomething',
   '   else if expr2 then',
   '    goto try_qword',

utils/pas2js/dist/rtl.js

@@ -344,6 +344,31 @@ var rtl = {
     rtl.initClass(c,parent,name,initfn);
   },
 
+  createHelper: function(parent,name,ancestor,initfn){
+    // create a helper,
+    // ancestor must be null or a helper,
+    var c = null;
+    if (ancestor != null){
+      c = Object.create(ancestor);
+      c.$ancestor = ancestor;
+      // c.$ancestor === Object.getPrototypeOf(c)
+    } else {
+      c = {};
+    };
+    parent[name] = c;
+    c.$class = c; // Note: o.$class === Object.getPrototypeOf(o)
+    c.$classname = name;
+    parent = rtl.initStruct(c,parent,name);
+    c.$fullname = parent.$name+'.'+name;
+    // rtti
+    var t = c.$module.$rtti.$Helper(c.$name,{ "helper": c });
+    c.$rtti = t;
+    if (rtl.isObject(ancestor)) t.ancestor = ancestor.$rtti;
+    if (!t.ancestor) t.ancestor = null;
+    // init members
+    initfn.call(c);
+  },
+
   tObjectDestroy: "Destroy",
 
   free: function(obj,name){
@@ -1163,7 +1188,8 @@ var rtl = {
     newBaseTI("tTypeInfoRecord",12 /* tkRecord */,rtl.tTypeInfoStruct);
     newBaseTI("tTypeInfoClass",13 /* tkClass */,rtl.tTypeInfoStruct);
     newBaseTI("tTypeInfoClassRef",14 /* tkClassRef */);
-    newBaseTI("tTypeInfoInterface",15 /* tkInterface */,rtl.tTypeInfoStruct);
+    newBaseTI("tTypeInfoInterface",18 /* tkInterface */,rtl.tTypeInfoStruct);
+    newBaseTI("tTypeInfoHelper",19 /* tkHelper */,rtl.tTypeInfoStruct);
   },
 
   tSectionRTTI: {
@@ -1214,6 +1240,7 @@ var rtl = {
     $ClassRef: function(name,o){ return this.$inherited(name,rtl.tTypeInfoClassRef,o); },
     $Pointer: function(name,o){ return this.$inherited(name,rtl.tTypeInfoPointer,o); },
     $Interface: function(name,o){ return this.$Scope(name,rtl.tTypeInfoInterface,o); }
+    $Helper: function(name,o){ return this.$Scope(name,rtl.tTypeInfoHelper,o); }
   },
 
   newTIParam: function(param){