--- Merging r35428 into '.':

U    packages/pastojs/tests/tcconverter.pp
U    packages/pastojs/tests/tcmodules.pas
U    packages/pastojs/src/fppas2js.pp
U    packages/fcl-js/src/jstree.pp
U    packages/fcl-passrc/src/pasresolver.pp
U    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/src/pastree.pp
U    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35428 into '.':
 U   .
--- Merging r35468 into '.':
U    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35468 into '.':
 G   .
--- Merging r35469 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35469 into '.':
 G   .
--- Merging r35470 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35470 into '.':
 G   .
--- Merging r35472 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
U    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35472 into '.':
 G   .
--- Merging r35487 into '.':
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35487 into '.':
 G   .
--- Merging r35488 into '.':
U    packages/fcl-passrc/tests/tcbaseparser.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35488 into '.':
 G   .
--- Merging r35489 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35489 into '.':
 G   .
--- Merging r35490 into '.':
G    packages/fcl-js/src/jstree.pp
--- Recording mergeinfo for merge of r35490 into '.':
 G   .
--- Merging r35491 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
G    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35491 into '.':
 G   .
--- Merging r35502 into '.':
U    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r35502 into '.':
 G   .
--- Merging r35503 into '.':
G    packages/fcl-passrc/src/pparser.pp
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
U    packages/fcl-passrc/src/passrcutil.pp
G    packages/fcl-passrc/src/pscanner.pp
U    packages/fcl-passrc/tests/tcexprparser.pas
G    packages/fcl-passrc/tests/tcresolver.pas
U    packages/fcl-passrc/tests/tcvarparser.pas
--- Recording mergeinfo for merge of r35503 into '.':
 G   .
--- Merging r35504 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35504 into '.':
 G   .
--- Merging r35505 into '.':
G    utils/pas2js/dist/rtl.js
--- Recording mergeinfo for merge of r35505 into '.':
 G   .
--- Merging r35512 into '.':
U    packages/fcl-web/src/base/httpdefs.pp
--- Recording mergeinfo for merge of r35512 into '.':
 G   .
--- Merging r35513 into '.':
G    packages/fcl-web/src/base/httpdefs.pp
--- Recording mergeinfo for merge of r35513 into '.':
 G   .
--- Merging r35514 into '.':
U    packages/fcl-web/src/base/custcgi.pp
--- Recording mergeinfo for merge of r35514 into '.':
 G   .
--- Merging r35515 into '.':
U    packages/fcl-web/src/base/httproute.pp
--- Recording mergeinfo for merge of r35515 into '.':
 G   .
--- Merging r35516 into '.':
U    packages/fcl-web/src/base/fphttpclient.pp
--- Recording mergeinfo for merge of r35516 into '.':
 G   .
--- Merging r35522 into '.':
U    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35522 into '.':
 G   .
--- Merging r35524 into '.':
G    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/tcprocfunc.pas
--- Recording mergeinfo for merge of r35524 into '.':
 G   .
--- Merging r35561 into '.':
U    packages/fcl-json/src/fpjsonrtti.pp
U    packages/fcl-json/tests/testjsonrtti.pp
--- Recording mergeinfo for merge of r35561 into '.':
 G   .
--- Merging r35562 into '.':
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/tcscanner.pas
--- Recording mergeinfo for merge of r35562 into '.':
 G   .

# revisions: 35428,35468,35469,35470,35472,35487,35488,35489,35490,35491,35502,35503,35504,35505,35512,35513,35514,35515,35516,35522,35524,35561,35562

git-svn-id: branches/fixes_3_0@35984 -

packages/fcl-js/src/jstree.pp

@@ -121,7 +121,7 @@ Type
 
   TJSString = jsbase.TJSString; // beware of jstoken.tjsString
 
-  { TJSFuncDef - e.g. 'function Name(Params)Body' }
+  { TJSFuncDef - part of TJSFunctionDeclarationStatement, e.g. 'function Name(Params)Body' }
 
   TJSFuncDef = Class(TJSObject)
   private
@@ -457,7 +457,7 @@ Type
 
   TJSVariableDeclarationList = Class(TJSBinary); // A->first variable, B->next in list, chained.
 
-  { TJSWithStatement }
+  { TJSWithStatement - with(A)do B; }
 
   TJSWithStatement = Class(TJSBinary); // A-> with expression, B->statement(s)
 

packages/fcl-js/src/jswriter.pp

@@ -20,7 +20,7 @@ unit jswriter;
 interface
 
 uses
-  {Classes, } SysUtils, jstoken, jsbase, jstree;
+  SysUtils, jstoken, jsbase, jstree;
 
 Type
 
@@ -31,7 +31,7 @@ Type
     Function DoWrite(Const S : AnsiString) : Integer; virtual; abstract;
     Function DoWrite(Const S : UnicodeString) : Integer; virtual; abstract;
   Public
-    // All functions return the numberof bytes copied to output stream.
+    // All functions return the number of bytes copied to output stream.
     Function Write(Const S : UnicodeString) : Integer;
     Function Write(Const S : AnsiString) : Integer;
     Function WriteLn(Const S : AnsiString) : Integer;
@@ -58,6 +58,7 @@ Type
   end;
 
   { TBufferWriter }
+
   TBytes = Array of byte;
   TBufferWriter = Class(TTextWriter)
   private
@@ -157,8 +158,7 @@ Type
     Procedure WritePrimaryExpression(El: TJSPrimaryExpression);virtual;
     Procedure WriteBinary(El: TJSBinary);virtual;
   Public
-    Function EscapeString(const S: TJSString; Quote: TJSEscapeQuote = jseqDouble): String;
-    Function JSStringToStr(const S: TJSString): string;
+    Function EscapeString(const S: TJSString; Quote: TJSEscapeQuote = jseqDouble): TJSString;
     Constructor Create(AWriter : TTextWriter);
     Constructor Create(Const AFileName : String);
     Destructor Destroy; override;
@@ -172,12 +172,31 @@ Type
   end;
   EJSWriter = Class(Exception);
 
+Function UTF16ToUTF8(const S: UnicodeString): string;
+
 implementation
 
 Resourcestring
   SErrUnknownJSClass = 'Unknown javascript element class : %s';
   SErrNilNode = 'Nil node in Javascript';
 
+function HexDump(p: PChar; Count: integer): string;
+var
+  i: Integer;
+begin
+  Result:='';
+  for i:=0 to Count-1 do
+    Result:=Result+HexStr(ord(p[i]),2);
+end;
+
+function UTF16ToUTF8(const S: UnicodeString): string;
+begin
+  Result:=UTF8Encode(S);
+  // prevent UTF8 codepage appear in the strings - we don't need codepage
+  // conversion magic
+  SetCodePage(RawByteString(Result), CP_ACP, False);
+end;
+
 { TBufferWriter }
 
 function TBufferWriter.GetBufferLength: Integer;
@@ -332,13 +351,13 @@ end;
 procedure TJSWriter.Write(const U: UnicodeString);
 
 Var
-  S : UTF8String;
+  S : String;
 
 begin
   WriteIndent;
   if UseUTF8 then
     begin
-    S:=UTF8Encode(U);
+    S:=UTF16ToUTF8(U);
     FLinePos:=FLinePos+Writer.Write(S);
     end
   else
@@ -370,12 +389,12 @@ end;
 
 procedure TJSWriter.WriteLn(const U: UnicodeString);
 Var
-  S : UTF8String;
+  S : String;
 
 begin
   if UseUTF8 then
     begin
-    S:=UTF8Encode(U);
+    S:=UTF16ToUTF8(U);
     Writeln(S);
     end
   else
@@ -387,81 +406,153 @@ begin
 end;
 
 function TJSWriter.EscapeString(const S: TJSString; Quote: TJSEscapeQuote
-  ): String;
+  ): TJSString;
 
 Var
   I,J,L : Integer;
   P : TJSPChar;
+  R: TJSString;
 
 begin
   I:=1;
   J:=1;
-  Result:='';
+  R:='';
   L:=Length(S);
   P:=TJSPChar(S);
   While I<=L do
     begin
     if (P^ in [#0..#31,'"','''','/','\']) then
       begin
-      Result:=Result+JSStringToStr(Copy(S,J,I-J));
+      R:=R+Copy(S,J,I-J);
       Case P^ of
-        '\' : Result:=Result+'\\';
-        '/' : Result:=Result+'\/';
-        '"' : if Quote=jseqSingle then Result:=Result+'"' else Result:=Result+'\"';
-        '''': if Quote=jseqDouble then Result:=Result+'''' else Result:=Result+'\''';
-        #0..#7,#11,#14..#31: Result:=Result+'\x'+hexStr(ord(P^),2);
-        #8  : Result:=Result+'\b';
-        #9  : Result:=Result+'\t';
-        #10 : Result:=Result+'\n';
-        #12 : Result:=Result+'\f';
-        #13 : Result:=Result+'\r';
+        '\' : R:=R+'\\';
+        '/' : R:=R+'\/';
+        '"' : if Quote=jseqSingle then R:=R+'"' else R:=R+'\"';
+        '''': if Quote=jseqDouble then R:=R+'''' else R:=R+'\''';
+        #0..#7,#11,#14..#31: R:=R+'\x'+TJSString(hexStr(ord(P^),2));
+        #8  : R:=R+'\b';
+        #9  : R:=R+'\t';
+        #10 : R:=R+'\n';
+        #12 : R:=R+'\f';
+        #13 : R:=R+'\r';
       end;
       J:=I+1;
       end;
     Inc(I);
     Inc(P);
     end;
-  Result:=Result+JSStringToStr(Copy(S,J,I-1));
-end;
-
-function TJSWriter.JSStringToStr(const S: TJSString): string;
-begin
-  if UseUTF8 then
-    Result:=UTF8Encode(S)
-  else
-    Result:=String(S);
+  R:=R+Copy(S,J,I-1);
+  Result:=R;
 end;
 
 procedure TJSWriter.WriteValue(V: TJSValue);
+const
+  TabWidth = 4;
+
+  function GetLineIndent(var p: PWideChar): integer;
+  var
+    h: PWideChar;
+  begin
+    h:=p;
+    Result:=0;
+    repeat
+      case h^ of
+      #0: break;
+      #9: Result:=Result+(TabWidth-Result mod TabWidth);
+      ' ': inc(Result);
+      else break;
+      end;
+      inc(h);
+    until false;
+    p:=h;
+  end;
+
+  function SkipToNextLineStart(p: PWideChar): PWideChar;
+  begin
+    repeat
+      case p^ of
+      #0: break;
+      #10,#13:
+        begin
+        if (p[1] in [#10,#13]) and (p^<>p[1]) then
+          inc(p,2)
+        else
+          inc(p);
+        break;
+        end
+      else inc(p);
+      end;
+    until false;
+    Result:=p;
+  end;
 
 Var
   S : String;
   JS: TJSString;
+  p, StartP: PWideChar;
+  MinIndent, CurLineIndent: Integer;
 begin
   if V.CustomValue<>'' then
-    S:=JSStringToStr(V.CustomValue)
-  else
-    Case V.ValueType of
-      jstUNDEFINED : S:='undefined';
-      jstNull : s:='null';
-      jstBoolean : if V.AsBoolean then s:='true' else s:='false';
-      jstString :
-        begin
-        JS:=V.AsString;
-        if Pos('"',JS)>0 then
-          S:=''''+EscapeString(JS,jseqSingle)+''''
-        else
-          S:='"'+EscapeString(JS,jseqDouble)+'"';
-        end;
-      jstNumber :
-        if Frac(V.AsNumber)=0 then // this needs to be improved
-          Str(Round(V.AsNumber),S)
-        else
-          Str(V.AsNumber,S);
-      jstObject : ;
-      jstReference : ;
-      JSTCompletion : ;
+    begin
+    JS:=V.CustomValue;
+    if JS='' then exit;
+
+    p:=SkipToNextLineStart(PWideChar(JS));
+    if p^=#0 then
+      begin
+      // simple value
+      Write(JS);
+      exit;
+      end;
+
+    // multi line value
+
+    // find minimum indent
+    MinIndent:=-1;
+    repeat
+      CurLineIndent:=GetLineIndent(p);
+      if (MinIndent<0) or (MinIndent>CurLineIndent) then
+        MinIndent:=CurLineIndent;
+      p:=SkipToNextLineStart(p);
+    until p^=#0;
+
+    // write value lines indented
+    p:=PWideChar(JS);
+    GetLineIndent(p); // the first line is already indented, skip
+    repeat
+      StartP:=p;
+      p:=SkipToNextLineStart(StartP);
+      Write(copy(JS,StartP-PWideChar(JS)+1,p-StartP));
+      if p^=#0 then break;
+      CurLineIndent:=GetLineIndent(p);
+      Write(StringOfChar(FIndentChar,FCurIndent+CurLineIndent-MinIndent));
+    until false;
+
+    exit;
     end;
+  Case V.ValueType of
+    jstUNDEFINED : S:='undefined';
+    jstNull : s:='null';
+    jstBoolean : if V.AsBoolean then s:='true' else s:='false';
+    jstString :
+      begin
+      JS:=V.AsString;
+      if Pos('"',JS)>0 then
+        JS:=''''+EscapeString(JS,jseqSingle)+''''
+      else
+        JS:='"'+EscapeString(JS,jseqDouble)+'"';
+      Write(JS);
+      exit;
+      end;
+    jstNumber :
+      if Frac(V.AsNumber)=0 then // this needs to be improved
+        Str(Round(V.AsNumber),S)
+      else
+        Str(V.AsNumber,S);
+    jstObject : ;
+    jstReference : ;
+    JSTCompletion : ;
+  end;
   Write(S);
 end;
 
@@ -680,10 +771,24 @@ end;
 
 procedure TJSWriter.WriteMemberExpression(El: TJSMemberExpression);
 
+var
+  MExpr: TJSElement;
 begin
   if El is TJSNewMemberExpression then
     Write('new ');
-  WriteJS(El.MExpr);
+  MExpr:=El.MExpr;
+  if (MExpr is TJSPrimaryExpression)
+      or (MExpr is TJSDotMemberExpression)
+      or (MExpr is TJSBracketMemberExpression)
+      or (MExpr is TJSCallExpression)
+      or (MExpr is TJSLiteral) then
+    WriteJS(MExpr)
+  else
+    begin
+    Write('(');
+    WriteJS(MExpr);
+    Write(')');
+    end;
   if El is TJSDotMemberExpression then
     begin
     write('.');
@@ -1309,23 +1414,23 @@ begin
   Result:=DoWrite(S);
 end;
 
-Function TTextWriter.Write(Const S: String) : integer;
+Function TTextWriter.Write(Const S: AnsiString) : integer;
 begin
   Result:=DoWrite(S);
 end;
 
-Function TTextWriter.WriteLn(Const S: String) : Integer;
+Function TTextWriter.WriteLn(Const S: AnsiString) : Integer;
 begin
   Result:=DoWrite(S)+DoWrite(sLineBreak);
 end;
 
-Function TTextWriter.Write(Const Fmt: String; Args: Array of const) : Integer;
+Function TTextWriter.Write(Const Fmt: AnsiString; Args: Array of const) : Integer;
 
 begin
   Result:=DoWrite(Format(Fmt,Args));
 end;
 
-Function TTextWriter.WriteLn(Const Fmt: String; Args: Array of const) : integer;
+Function TTextWriter.WriteLn(Const Fmt: AnsiString; Args: Array of const) : integer;
 begin
   Result:=WriteLn(Format(Fmt,Args));
 end;

packages/fcl-json/src/fpjsonrtti.pp

@@ -28,7 +28,10 @@ Type
                        jsoDateTimeAsString,       // Format a TDateTime value as a string
                        jsoUseFormatString,        // Use FormatString when creating JSON strings.
                        jsoCheckEmptyDateTime,     // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string
-                       jsoLegacyDateTime);         // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
+                       jsoLegacyDateTime,         // Set this to enable old date/time formatting. Current behaviour is to save date/time as a ISO 9601 value.
+                       jsoLowerPropertyNames,     // Set this to force lowercase names when streaming to JSON.
+                       jsoStreamTList             // Set this to assume that TList contains a list of TObjects. Use with care!
+                       );  
   TJSONStreamOptions = Set of TJSONStreamOption;
 
   TJSONFiler = Class(TComponent)
@@ -70,6 +73,8 @@ Type
     function StreamCollection(Const ACollection: TCollection): TJSONArray;
     // Stream an objectlist - always returns an array
     function StreamObjectList(Const AnObjectList: TObjectList): TJSONArray;
+    // Stream a List - always returns an array
+    function StreamTList(Const AList: TList): TJSONArray;
     // Stream a TStrings instance as an array
     function StreamTStringsArray(Const AStrings: TStrings): TJSONArray;
     // Stream a TStrings instance as an object
@@ -406,6 +411,7 @@ Var
   PI : PPropInfo;
   TI : PTypeInfo;
   I,J,S : Integer;
+  D : Double;
   A : TJSONArray;
   JS : TJSONStringType;
 begin
@@ -550,6 +556,8 @@ procedure TJSONDeStreamer.JSONToCollection(const JSON: TJSONData;
 Var
   I : integer;
   A : TJSONArray;
+  O : TJSONObject;
+
 begin
   If (JSON.JSONType=jtArray) then
     A:=JSON As TJSONArray
@@ -738,6 +746,8 @@ begin
       Result.Add('Items',StreamCollection(TCollection(AObject)))
     else If AObject is TObjectList then
       Result.Add('Objects',StreamObjectList(TObjectList(AObject)))
+    else if (jsoStreamTlist in Options) and (AObject is TList) then
+      Result := TJSONObject(StreamTList(TList(AObject)))
     else
       begin
       PIL:=TPropInfoList.Create(AObject,tkProperties);
@@ -745,9 +755,13 @@ begin
         For I:=0 to PIL.Count-1 do
           begin
           PD:=StreamProperty(AObject,PIL.Items[i]);
-          If (PD<>Nil) then
+            If (PD<>Nil) then begin
+              if jsoLowerPropertyNames in Options then
+                Result.Add(LowerCase(PIL.Items[I]^.Name),PD)
+              else
             Result.Add(PIL.Items[I]^.Name,PD);
           end;
+          end;
       finally
         FReeAndNil(Pil);
       end;
@@ -893,6 +907,24 @@ begin
   end;
 end;
 
+function TJSONStreamer.StreamTList(const AList: TList): TJSONArray;
+var
+  I : Integer;
+  o : TJSONObject;
+begin
+  Result:=TJSONArray.Create;
+  try
+    for I:=0 to AList.Count-1 do begin
+      o := ObjectToJSON(TObject(AList.Items[i]));
+      if Assigned(o) then
+        Result.Add(o);
+    end;
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
 Function TJSONStreamer.StreamTStringsArray(Const AStrings : TStrings) : TJSONArray;
 
 Var
@@ -977,6 +1009,10 @@ end;
 
 function TJSONStreamer.StreamClassProperty(const AObject: TObject): TJSONData;
 
+Var
+  C : TCollection;
+  I : integer;
+
 begin
   Result:=Nil;
   If (AObject=Nil) then

packages/fcl-json/tests/testjsonrtti.pp

@@ -106,8 +106,10 @@ type
     Procedure TestObjectToJSONString;
     Procedure TestStringsToJSONString;
     Procedure TestCollectionToJSONString;
+    procedure TestTListToJSONString;
     Procedure TestChildren;
     Procedure TestChildren2;
+    Procedure TestLowercase;
   end;
 
   { TTestJSONDeStreamer }
@@ -1753,6 +1755,38 @@ begin
   end;
 end;
 
+procedure TTestJSONStreamer.TestTListToJSONString ;
+
+
+Var
+  C : TList;
+  D : TJSONData;
+  P : Pointer;
+
+  Function Add : TTestItem;
+
+  begin
+    Result:=TTestItem.Create(Nil);
+    C.Add(Result);
+  end;
+
+begin
+  RJ.Options:=RJ.Options + [jsoStreamTList];
+  C:=TList.Create;
+  try
+    Add.StrProp:='one';
+    Add.StrProp:='two';
+    Add.StrProp:='three';
+    D:=RJ.StreamTList(C);
+    AssertEquals('StreamTlist','[{ "StrProp" : "one" }, { "StrProp" : "two" }, { "StrProp" : "three" }]',D.AsJSON);
+  finally
+    D.Free;
+    For P in C do
+      TObject(P).Free;
+    FreeAndNil(C);
+  end;
+end;
+
 procedure TTestJSONStreamer.TestCollectionToJSONString;
 
 Var
@@ -1813,6 +1847,14 @@ begin
   end;
 end;
 
+procedure TTestJSONStreamer.TestLowercase;
+begin
+  RJ.Options:=RJ.Options+[jsoLowerPropertyNames];
+  StreamObject(TBooleanComponent.Create(nil));
+  AssertPropCount(1);
+  AssertProp('booleanprop',False);
+end;
+
 initialization
 
   RegisterTests([TTestJSONStreamer,TTestJSONDeStreamer]);

packages/fcl-passrc/src/passrcutil.pp

@@ -74,6 +74,7 @@ end;
 
 function TSrcContainer.FindElement(const AName: String): TPasElement;
 begin
+  if AName='' then ;
   Result:=Nil;
 end;
 

packages/fcl-passrc/src/pastree.pp

@@ -82,9 +82,17 @@ type
   // Visitor pattern.
   TPassTreeVisitor = class;
 
+  { TPasElementBase }
+
   TPasElementBase = class
-    procedure Accept(Visitor: TPassTreeVisitor); virtual; abstract;
+  private
+    FData: TObject;
+  protected
+    procedure Accept(Visitor: TPassTreeVisitor); virtual;
+  public
+    Property CustomData : TObject Read FData Write FData;
   end;
+  TPasElementBaseClass = class of TPasElementBase;
 
 
   TPasModule = class;
@@ -109,7 +117,6 @@ type
 
   TPasElement = class(TPasElementBase)
   private
-    FData: TObject;
     FDocComment: String;
     FRefCount: LongWord;
     FName: string;
@@ -145,7 +152,6 @@ type
     property Name: string read FName write FName;
     property Parent: TPasElement read FParent Write FParent;
     Property Hints : TPasMemberHints Read FHints Write FHints;
-    Property CustomData : TObject Read FData Write FData;
     Property HintMessage : String Read FHintMessage Write FHintMessage;
     Property DocComment : String Read FDocComment Write FDocComment;
   end;
@@ -197,12 +203,16 @@ type
       const Arg: Pointer); override;
   end;
 
+  { TPrimitiveExpr }
+
   TPrimitiveExpr = class(TPasExpr)
     Value     : AnsiString;
     constructor Create(AParent : TPasElement; AKind: TPasExprKind; const AValue : Ansistring); overload;
     function GetDeclaration(full : Boolean) : string; override;
   end;
   
+  { TBoolConstExpr }
+
   TBoolConstExpr = class(TPasExpr)
     Value     : Boolean;
     constructor Create(AParent : TPasElement; AKind: TPasExprKind; const ABoolValue : Boolean); overload;
@@ -515,7 +525,7 @@ type
   public
     constructor Create(const AName: string; AParent: TPasElement); override;
     destructor Destroy; override;
-     function ElementTypeName: string; override;
+    function ElementTypeName: string; override;
     function GetDeclaration(full : boolean) : string; override;
     Procedure GetEnumNames(Names : TStrings);
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
@@ -622,7 +632,7 @@ type
       const Arg: Pointer); override;
   public
     Access: TArgumentAccess;
-    ArgType: TPasType;
+    ArgType: TPasType; // can be nil, when Access<>argDefault
     ValueExpr: TPasExpr; // the default value
     Function Value : String;
   end;
@@ -723,7 +733,8 @@ type
   public
     VarType: TPasType;
     VarModifiers : TVariableModifiers;
-    LibraryName,ExportName : string;
+    LibraryName : TPasExpr; // libname of modifier external
+    ExportName : TPasExpr; // symbol name of modifier external, export and public
     Modifiers : string;
     AbsoluteLocation : String;
     Expr: TPasExpr;
@@ -810,7 +821,7 @@ type
   TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
                         pmExport, pmOverload, pmMessage, pmReintroduce,
                         pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
-                        pmCompilerProc,pmExternal,pmForward, pmdispid, pmnoreturn);
+                        pmCompilerProc,pmExternal,pmForward, pmDispId, pmNoReturn);
   TProcedureModifiers = Set of TProcedureModifier;
   TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
                         
@@ -1313,17 +1324,20 @@ Type
     ExceptAddr : TPasExpr;
   end;
 
-  { TPassTreeVisitor }
-
-  TPassTreeVisitor = class
-    procedure Visit(obj: TPasElement); virtual;
-  end;
+  { TPasImplLabelMark }
 
   TPasImplLabelMark = class(TPasImplElement)
   public
     LabelId: AnsiString;
   end;
 
+  { TPassTreeVisitor }
+
+  TPassTreeVisitor = class
+  public
+    procedure Visit(obj: TPasElement); virtual;
+  end;
+
 const
   AccessNames: array[TArgumentAccess] of string[9] = ('', 'const ', 'var ', 'out ','constref ');
   AllVisibilities: TPasMemberVisibilities =
@@ -1404,10 +1418,18 @@ uses SysUtils;
 procedure ReleaseAndNil(var El: TPasElement);
 begin
   if El=nil then exit;
+  {$IFDEF VerbosePasTreeMem}writeln('ReleaseAndNil ',El.Name,' ',El.ClassName);{$ENDIF}
   El.Release;
   El:=nil;
 end;
 
+{ TPasElementBase }
+
+procedure TPasElementBase.Accept(Visitor: TPassTreeVisitor);
+begin
+  if Visitor=nil then ;
+end;
+
 { TPasTypeRef }
 
 procedure TPasTypeRef.ForEachCall(const aMethodCall: TOnForEachPasElement;
@@ -1580,8 +1602,11 @@ end;
 
 destructor TPasProgram.Destroy;
 begin
+  {$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy ProgramSection');{$ENDIF}
   ReleaseAndNil(TPasElement(ProgramSection));
+  {$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy inherited');{$ENDIF}
   inherited Destroy;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasProgram.Destroy END');{$ENDIF}
 end;
 
 function TPasProgram.ElementTypeName: string;
@@ -1845,8 +1870,11 @@ end;
 
 destructor TPasElement.Destroy;
 begin
-  if FRefCount>0 then
+  if (FRefCount>0) and (FRefCount<high(FRefCount)) then
+    begin
+    {$if defined(debugrefcount) or defined(VerbosePasTreeMem)}writeln('TPasElement.Destroy ',Name,':',ClassName);{$ENDIF}
     raise Exception.Create('');
+    end;
   inherited Destroy;
 end;
 
@@ -1859,24 +1887,32 @@ end;
 
 procedure TPasElement.Release;
 
-{$ifdef debugrefcount}
+{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}
 Var
   Cn : String;
   {$endif}
 
 begin
-{$ifdef debugrefcount}
-  CN:=ClassName;
+{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}
+  CN:=ClassName+' '+Name;
   CN:=CN+' '+IntToStr(FRefCount);
-  If Assigned(Parent) then
-    CN:=CN+' ('+Parent.ClassName+')';
-  Writeln('Release : ',Cn);
+  //If Assigned(Parent) then
+  //  CN:=CN+' ('+Parent.ClassName+')';
+  Writeln('TPasElement.Release : ',Cn);
 {$endif}
   if FRefCount = 0 then
-    Free
+    begin
+    FRefCount:=High(FRefCount);
+    Free;
+    end
+  else if FRefCount=High(FRefCount) then
+    begin
+    {$if defined(debugrefcount) or defined(VerbosePasTreeMem)}  Writeln('TPasElement.Released OUCH: ',Cn); {$endif}
+    raise Exception.Create('');
+    end
   else
     Dec(FRefCount);
-{$ifdef debugrefcount}  Writeln('Released : ',Cn); {$endif}
+{$if defined(debugrefcount) or defined(VerbosePasTreeMem)}  Writeln('TPasElement.Released : ',Cn); {$endif}
 end;
 
 procedure TPasElement.ForEachCall(const aMethodCall: TOnForEachPasElement;
@@ -2012,30 +2048,38 @@ destructor TPasDeclarations.Destroy;
 var
   i: Integer;
 begin
-  ExportSymbols.Free;
-  Variables.Free;
-  Functions.Free;
-  Classes.Free;
-  Consts.Free;
-  Types.Free;
-  ResStrings.Free;
-  Properties.Free;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy START');{$ENDIF}
+  FreeAndNil(ExportSymbols);
+  FreeAndNil(Properties);
+  FreeAndNil(Variables);
+  FreeAndNil(Functions);
+  FreeAndNil(Classes);
+  FreeAndNil(Consts);
+  FreeAndNil(Types);
+  FreeAndNil(ResStrings);
+  {$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy Declarations');{$ENDIF}
   for i := 0 to Declarations.Count - 1 do
     TPasElement(Declarations[i]).Release;
-  Declarations.Free;
+  FreeAndNil(Declarations);
 
+  {$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy inherited');{$ENDIF}
   inherited Destroy;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasDeclarations.Destroy END');{$ENDIF}
 end;
 
 destructor TPasModule.Destroy;
 begin
-  if Assigned(InterfaceSection) then
-    InterfaceSection.Release;
-  if Assigned(ImplementationSection) then
-    ImplementationSection.Release;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy interface');{$ENDIF}
+  ReleaseAndNil(TPasElement(InterfaceSection));
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy implementation');{$ENDIF}
+  ReleaseAndNil(TPasElement(ImplementationSection));
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy initialization');{$ENDIF}
   ReleaseAndNil(TPasElement(InitializationSection));
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy finalization');{$ENDIF}
   ReleaseAndNil(TPasElement(FinalizationSection));
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy inherited');{$ENDIF}
   inherited Destroy;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasModule.Destroy END');{$ENDIF}
 end;
 
 
@@ -2054,7 +2098,7 @@ var
 begin
   for i := 0 to Modules.Count - 1 do
     TPasModule(Modules[i]).Release;
-  Modules.Free;
+  FreeAndNil(Modules);
   inherited Destroy;
 end;
 
@@ -2106,7 +2150,7 @@ var
 begin
   for i := 0 to Values.Count - 1 do
     TPasEnumValue(Values[i]).Release;
-  Values.Free;
+  FreeAndNil(Values);
   inherited Destroy;
 end;
 
@@ -2134,16 +2178,6 @@ begin
 end;
 
 
-destructor TPasSetType.Destroy;
-begin
-  if Assigned(EnumType) then
-    begin
-    EnumType.Release;
-    end;
-  inherited Destroy;
-end;
-
-
 constructor TPasVariant.Create(const AName: string; AParent: TPasElement);
 begin
   inherited Create(AName, AParent);
@@ -2158,9 +2192,9 @@ Var
 begin
   For I:=0 to Values.Count-1 do
     TPasElement(Values[i]).Release;
-  Values.Free;
+  FreeAndNil(Values);
   if Assigned(Members) then
-    Members.Release;
+    ReleaseAndNil(TpasElement(Members));
   inherited Destroy;
 end;
 
@@ -2186,6 +2220,7 @@ begin
       S.Free;
     end;
     Result:=Result+');';
+    if Full then ;
     end;
 end;
 
@@ -2214,16 +2249,16 @@ var
 begin
   for i := 0 to Members.Count - 1 do
     TPasVariable(Members[i]).Release;
-  Members.Free;
+  FreeAndNil(Members);
 
   if Assigned(VariantEl) then
-    VariantEl.Release;
+    ReleaseAndNil(TPasElement(VariantEl));
 
   if Assigned(Variants) then
   begin
     for i := 0 to Variants.Count - 1 do
       TPasVariant(Variants[i]).Release;
-    Variants.Free;
+    FreeAndNil(Variants);
   end;
 
   inherited Destroy;
@@ -2250,17 +2285,17 @@ begin
     TPasElement(Members[i]).Release;
   for i := 0 to Interfaces.Count - 1 do
     TPasElement(Interfaces[i]).Release;
-  Members.Free;
+  FreeAndNil(Members);
   if Assigned(AncestorType) then
     AncestorType.Release;
   if Assigned(HelperForType) then
     HelperForType.Release;
   ReleaseAndNil(TPasElement(GUIDExpr));
-  Modifiers.Free;
-  Interfaces.Free;
+  FreeAndNil(Modifiers);
+  FreeAndNil(Interfaces);
   for i := 0 to GenericTemplateTypes.Count - 1 do
     TPasElement(GenericTemplateTypes[i]).Release;
-  GenericTemplateTypes.Free;
+  FreeAndNil(GenericTemplateTypes);
   inherited Destroy;
 end;
 
@@ -2440,6 +2475,8 @@ begin
     (e.g. in Constants) }
   ReleaseAndNil(TPasElement(VarType));
   ReleaseAndNil(TPasElement(Expr));
+  ReleaseAndNil(TPasElement(LibraryName));
+  ReleaseAndNil(TPasElement(ExportName));
   inherited Destroy;
 end;
 
@@ -2492,7 +2529,7 @@ var
 begin
   for i := 0 to Overloads.Count - 1 do
     TPasProcedure(Overloads[i]).Release;
-  Overloads.Free;
+  FreeAndNil(Overloads);
   inherited Destroy;
 end;
 
@@ -2559,7 +2596,7 @@ begin
 
   for i := 0 to Locals.Count - 1 do
     TPasElement(Locals[i]).Release;
-  Locals.Free;
+  FreeAndNil(Locals);
 
   if Assigned(ProcType) then
     ProcType.Release;
@@ -2592,7 +2629,7 @@ end;
 
 destructor TPasImplCommands.Destroy;
 begin
-  Commands.Free;
+  FreeAndNil(Commands);
   inherited Destroy;
 end;
 
@@ -2708,7 +2745,7 @@ var
 begin
   for i := 0 to Elements.Count - 1 do
     TPasImplElement(Elements[i]).Release;
-  Elements.Free;
+  FreeAndNil(Elements);
   inherited Destroy;
 end;
 
@@ -2882,6 +2919,7 @@ end;
 function TPasModule.GetDeclaration(full : boolean): string;
 begin
   Result := 'Unit ' + Name;
+  if full then ;
 end;
 
 procedure TPasModule.ForEachCall(const aMethodCall: TOnForEachPasElement;
@@ -3114,6 +3152,12 @@ begin
   end;
 end;
 
+destructor TPasSetType.Destroy;
+begin
+  ReleaseAndNil(TPasElement(EnumType));
+  inherited Destroy;
+end;
+
 function TPasSetType.GetDeclaration (full : boolean) : string;
 
 Var
@@ -3763,6 +3807,7 @@ end;
 procedure TPassTreeVisitor.Visit(obj: TPasElement);
 begin
   // Needs to be implemented by descendents.
+  if Obj=nil then ;
 end;
 
 { TPasSection }
@@ -3777,11 +3822,14 @@ destructor TPasSection.Destroy;
 var
   i: Integer;
 begin
+  {$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy UsesList');{$ENDIF}
   for i := 0 to UsesList.Count - 1 do
     TPasType(UsesList[i]).Release;
   FreeAndNil(UsesList);
 
+  {$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy inherited');{$ENDIF}
   inherited Destroy;
+  {$IFDEF VerbosePasTreeMem}writeln('TPasSection.Destroy END');{$ENDIF}
 end;
 
 procedure TPasSection.AddUnitToUsesList(const AUnitName: string);
@@ -4105,9 +4153,10 @@ end;
 
 { TPrimitiveExpr }
 
-function TPrimitiveExpr.GetDeclaration(Full : Boolean):AnsiString;
+function TPrimitiveExpr.GetDeclaration(full: Boolean): string;
 begin
   Result:=Value;
+  if full then ;
 end;
 
 constructor TPrimitiveExpr.Create(AParent : TPasElement; AKind: TPasExprKind; const AValue : Ansistring);
@@ -4124,13 +4173,14 @@ begin
   Value:=ABoolValue;
 end;
 
-Function TBoolConstExpr.GetDeclaration(Full: Boolean):AnsiString;
+function TBoolConstExpr.GetDeclaration(full: Boolean): string;
 
 begin
   If Value then
     Result:='True'
   else
-    Result:='False';  
+    Result:='False';
+  if full then ;
 end;
 
 
@@ -4343,6 +4393,7 @@ var
 begin
   for i:=0 to length(Fields)-1 do
     Fields[i].ValueExp.Release;
+  Fields:=nil;
   inherited Destroy;
 end;
 
@@ -4354,13 +4405,15 @@ begin
   SetLength(Fields, i+1);
   Fields[i].Name:=AName;
   Fields[i].ValueExp:=Value;
+  Value.Parent:=Self;
 end;
 
 { TNilExpr }
 
-Function TNilExpr.GetDeclaration(Full :Boolean):AnsiString;
+function TNilExpr.GetDeclaration(full: Boolean): string;
 begin
   Result:='Nil';
+  if full then ;
 end;
 
 { TInheritedExpr }
@@ -4368,13 +4421,15 @@ end;
 function TInheritedExpr.GetDeclaration(full: Boolean): string;
 begin
   Result:='Inherited';
+  if full then ;
 end;
 
 { TSelfExpr }
 
-Function TSelfExpr.GetDeclaration(Full :Boolean):AnsiString;
+function TSelfExpr.GetDeclaration(full: Boolean): string;
 begin
   Result:='Self';
+  if full then ;
 end;
 
 { TArrayValues }
@@ -4416,6 +4471,7 @@ var
 begin
   for i:=0 to length(Values)-1 do
     Values[i].Release;
+  Values:=nil;
   inherited Destroy;
 end;
 
@@ -4426,6 +4482,7 @@ begin
   i:=length(Values);
   SetLength(Values, i+1);
   Values[i]:=AValue;
+  AValue.Parent:=Self;
 end;
 
 { TNilExpr }
@@ -4460,7 +4517,7 @@ end;
 
 destructor TPasLabels.Destroy;
 begin
-  Labels.Free;
+  FreeAndNil(Labels);
   inherited Destroy;
 end;
 

packages/fcl-passrc/src/pparser.pp

@@ -239,7 +239,8 @@ type
     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;
+    Procedure SetCurrentModeSwitches(AValue: TModeSwitches);
+    function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr): string;
     function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
     procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
     procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
@@ -367,6 +368,7 @@ type
     procedure ParseStatement(Parent: TPasImplBlock;  out NewImplElement: TPasImplElement);
     procedure ParseLabels(AParent: TPasElement);
     procedure ParseProcBeginBlock(Parent: TProcedureBody);
+    procedure ParseProcAsmBlock(Parent: TProcedureBody);
     // Function/Procedure declaration
     function  ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure;
     procedure ParseArgList(Parent: TPasElement;
@@ -381,7 +383,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 CurrentModeswitches : TModeSwitches Read GetCurrentModeSwitches Write SetCurrentModeSwitches;
     Property CurModule : TPasModule Read FCurModule;
     Property LogEvents : TPParserLogEvents Read FLogEvents Write FLogEvents;
     Property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog;
@@ -885,7 +887,7 @@ end;
 
 function TPasParser.CurTokenIsIdentifier(const S: String): Boolean;
 begin
-  Result:=(Curtoken=tkidentifier) and (CompareText(S,CurtokenText)=0);
+  Result:=(Curtoken=tkIdentifier) and (CompareText(S,CurtokenText)=0);
 end;
 
 
@@ -930,7 +932,7 @@ function TPasParser.CheckHint(Element: TPasElement; ExpectSemiColon: Boolean
 Var
   Found : Boolean;
   h : TPasMemberHint;
-  
+
 begin
   Result:=[];
   Repeat
@@ -1421,7 +1423,7 @@ begin
   NextToken;
   If CurToken=tkOf then
     Result.ElType := ParseType(Result,Scanner.CurSourcePos)
-  else 
+  else
    ungettoken;
 end;
 
@@ -1447,10 +1449,12 @@ var
 begin
   Result:=nil;
   if paramskind in [pekArrayParams, pekSet] then begin
-    if CurToken<>tkSquaredBraceOpen then Exit;
+    if CurToken<>tkSquaredBraceOpen then
+      ParseExc(nParserExpectTokenError,SParserExpectTokenError,['[']);
     PClose:=tkSquaredBraceClose;
   end else begin
-    if CurToken<>tkBraceOpen then Exit;
+    if CurToken<>tkBraceOpen then
+      ParseExc(nParserExpectTokenError,SParserExpectTokenError,['(']);
     PClose:=tkBraceClose;
   end;
 
@@ -1461,11 +1465,12 @@ begin
     if not isEndOfExp then begin
       repeat
         p:=DoParseExpression(params);
-        if not Assigned(p) then Exit; // bad param syntax
+        if not Assigned(p) then
+          ParseExcSyntaxError;
         params.AddParam(p);
         if (CurToken=tkColon) then
           if Not AllowFormatting then
-            ParseExcSyntaxError
+            ParseExc(nParserExpectTokenError,SParserExpectTokenError,[','])
           else
             begin
             NextToken;
@@ -1476,15 +1481,14 @@ begin
               p.format2:=DoParseExpression(p);
               end;
             end;
-        if not (CurToken in [tkComma, PClose]) then begin
-          Exit;
-        end;
+        if not (CurToken in [tkComma, PClose]) then
+          ParseExc(nParserExpectTokenError,SParserExpectTokenError,[',']);
 
         if CurToken = tkComma then begin
           NextToken;
           if CurToken = PClose then begin
             //ErrorExpected(parser, 'identifier');
-            Exit;
+            ParseExcSyntaxError;
           end;
         end;
       until CurToken=PClose;
@@ -1512,7 +1516,7 @@ begin
     tkLessEqualThan         : Result:=eopLessthanEqual;
     tkGreaterEqualThan      : Result:=eopGreaterThanEqual;
     tkPower                 : Result:=eopPower;
-    tkSymmetricalDifference : Result:=eopSymmetricalDifference;                                                                                              
+    tkSymmetricalDifference : Result:=eopSymmetricalDifference;
     tkIs                    : Result:=eopIs;
     tkAs                    : Result:=eopAs;
     tkSHR                   : Result:=eopSHR;
@@ -1530,7 +1534,7 @@ begin
     ParseExc(nParserNotAnOperand,SParserNotAnOperand,[AToken,TokenInfos[AToken]]);
   end;
 end;
- 
+
 function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
 
   Function IsWriteOrstr(P : TPasExpr) : boolean;
@@ -1546,6 +1550,30 @@ function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
       Result:=(N='write') or (N='str') or (N='writeln');
       end;
   end;
+
+  Procedure HandleSelf(Var Last: TPasExpr);
+
+  Var
+    b       : TBinaryExpr;
+    optk    : TToken;
+
+  begin
+    NextToken;
+    if CurToken = tkDot then
+      begin // self.Write(EscapeText(AText));
+      optk:=CurToken;
+      NextToken;
+      b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
+      if not Assigned(b.right) then
+        begin
+        b.Release;
+        ParseExcExpectedIdentifier;
+        end;
+      Last:=b;
+      end;
+    UngetToken;
+  end;
+
 var
   Last    , Expr: TPasExpr;
   prm     : TParamsExpr;
@@ -1559,7 +1587,16 @@ begin
     tkString:           Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString);
     tkChar:             Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText);
     tkNumber:           Last:=CreatePrimitiveExpr(AParent,pekNumber, CurTokenString);
-    tkIdentifier:       Last:=CreatePrimitiveExpr(AParent,pekIdent, CurTokenText);
+    tkIdentifier:
+      begin
+      if CompareText(CurTokenText,'self')=0 then
+        begin
+        Last:=CreateSelfExpr(AParent);
+        HandleSelf(Last)
+        end
+      Else
+        Last:=CreatePrimitiveExpr(AParent,pekIdent, CurTokenText)
+      end;
     tkfalse, tktrue:    Last:=CreateBoolConstExpr(Aparent,pekBoolConst, CurToken=tktrue);
     tknil:              Last:=CreateNilExpr(AParent);
     tkSquaredBraceOpen: Last:=ParseParams(AParent,pekSet);
@@ -1573,33 +1610,17 @@ begin
         b:=CreateBinaryExpr(AParent,Last, DoParseExpression(AParent), eopNone);
         if not Assigned(b.right) then
           begin
-          B.Release;
-          Exit; // error
+          b.Release;
+          ParseExcExpectedIdentifier;
           end;
         Last:=b;
-        UngetToken;
-        end
-      else
-        UngetToken;
+        end;
+      UngetToken;
       end;
     tkself:
       begin
-      //Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText); //function(self);
       Last:=CreateSelfExpr(AParent);
-      NextToken;
-      if CurToken = tkDot then
-        begin // self.Write(EscapeText(AText));
-        optk:=CurToken;
-        NextToken;
-        b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
-        if not Assigned(b.right) then
-          begin
-          B.Release;
-          Exit; // error
-          end;
-        Last:=b;
-        end;
-      UngetToken;
+      HandleSelf(Last);
       end;
     tkAt:
       begin
@@ -1633,7 +1654,7 @@ begin
 
   ok:=false;
   try
-    if Last.Kind=pekIdent then
+    if Last.Kind in [pekIdent,pekSelf] then
       begin
       while CurToken in [tkDot] do
         begin
@@ -1672,14 +1693,20 @@ begin
           end;
       until false;
       // Needed for TSDOBaseDataObjectClass(Self.ClassType).Create
-      if CurToken in [tkdot,tkas] then
+      if CurToken in [tkDot,tkas] then
         begin
         optk:=CurToken;
         NextToken;
         Expr:=ParseExpIdent(AParent);
         if Expr=nil then
-          Exit; // error
-        AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk));
+          ParseExcExpectedIdentifier;
+        if optk=tkDot then
+          AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk))
+        else
+          begin
+          // a as b
+          Result:=CreateBinaryExpr(AParent,Result,Expr,TokenToExprOp(tkas));
+          end;
       end;
     end;
     ok:=true;
@@ -1717,7 +1744,7 @@ var
   i         : Integer;
   tempop    : TToken;
   NotBinary : Boolean;
-  
+
 const
   PrefixSym = [tkPlus, tkMinus, tknot, tkAt]; // + - not @
   BinaryOP  = [tkMul, tkDivision, tkdiv, tkmod,  tkDotDot,
@@ -1906,10 +1933,12 @@ end;
 
 function GetExprIdent(p: TPasExpr): String;
 begin
-  if Assigned(p) and (p is TPrimitiveExpr) and (p.Kind=pekIdent) then
+  Result:='';
+  if not Assigned(p) then exit;
+  if (p.ClassType=TPrimitiveExpr) and (p.Kind=pekIdent) then
     Result:=TPrimitiveExpr(p).Value
-  else
-    Result:='';
+  else if (p.ClassType=TSelfExpr) then
+    Result:='Self';
 end;
 
 function TPasParser.DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
@@ -1937,50 +1966,77 @@ begin
   if CurToken <> tkBraceOpen then
     Result:=DoParseExpression(AParent)
   else begin
+    Result:=nil;
     NextToken;
     x:=DoParseConstValueExpression(AParent);
     case CurToken of
       tkComma: // array of values (a,b,c);
-        begin
+        try
           a:=CreateArrayValues(AParent);
           a.AddValues(x);
+          x:=nil;
           repeat
             NextToken;
             x:=DoParseConstValueExpression(AParent);
             a.AddValues(x);
+            x:=nil;
           until CurToken<>tkComma;
           Result:=a;
+        finally
+          if Result=nil then
+            begin
+            a.Free;
+            x.Free;
+            end;
         end;
 
       tkColon: // record field (a:xxx;b:yyy;c:zzz);
         begin
-          n:=GetExprIdent(x);
-          x.Release;
-          r:=CreateRecordValues(AParent);
-          NextToken;
-          x:=DoParseConstValueExpression(AParent);
-          r.AddField(n, x);
-          if not lastfield then
-            repeat
-              n:=ExpectIdentifier;
-              ExpectToken(tkColon);
-              NextToken;
-              x:=DoParseConstValueExpression(AParent);
-              r.AddField(n, x)
-            until lastfield; // CurToken<>tkSemicolon;
-          Result:=r;
+          r:=nil;
+          try
+            n:=GetExprIdent(x);
+            ReleaseAndNil(TPasElement(x));
+            r:=CreateRecordValues(AParent);
+            NextToken;
+            x:=DoParseConstValueExpression(AParent);
+            r.AddField(n, x);
+            x:=nil;
+            if not lastfield then
+              repeat
+                n:=ExpectIdentifier;
+                ExpectToken(tkColon);
+                NextToken;
+                x:=DoParseConstValueExpression(AParent);
+                r.AddField(n, x);
+                x:=nil;
+              until lastfield; // CurToken<>tkSemicolon;
+            Result:=r;
+          finally
+            if Result=nil then
+              begin
+              r.Free;
+              x.Free;
+              end;
+          end;
         end;
     else
-      // Binary expression!  ((128 div sizeof(longint)) - 3);       ;
+      // Binary expression!  ((128 div sizeof(longint)) - 3);
       Result:=DoParseExpression(AParent,x);
-      if CurToken<>tkBraceClose then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
+      if CurToken<>tkBraceClose then
+        begin
+        ReleaseAndNil(TPasElement(Result));
+        ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
+        end;
       NextToken;
-      if CurToken <> tkSemicolon then // the continue of expresion
+      if CurToken <> tkSemicolon then // the continue of expression
         Result:=DoParseExpression(AParent,Result);
       Exit;
     end;
     if CurToken<>tkBraceClose then
+      begin
+      ReleaseAndNil(TPasElement(Result));
       ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
+      end;
     NextToken;
   end;
 end;
@@ -2336,6 +2392,7 @@ var
     if CurBlock=declType then
       Engine.FinishScope(stTypeSection,Declarations);
     CurBlock:=NewBlock;
+    Scanner.SetForceCaret(NewBlock=declType);
   end;
 
 var
@@ -2353,6 +2410,7 @@ var
   PT : TProcType;
   NamePos: TPasSourcePos;
   ok: Boolean;
+  Proc: TPasProcedure;
 
 begin
   CurBlock := declNone;
@@ -2455,7 +2513,6 @@ begin
               end;
             declType:
               begin
-              Scanner.SetForceCaret(True);
               TypeEl := ParseTypeDecl(Declarations);
               // Scanner.SetForceCaret(OldForceCaret); // It may have been switched off
               if Assigned(TypeEl) then        // !!!
@@ -2586,6 +2643,9 @@ begin
         begin
         if Declarations is TProcedureBody then
           begin
+          Proc:=Declarations.Parent as TPasProcedure;
+          if pmAssembler in Proc.Modifiers then
+            ParseExc(nParserExpectTokenError,SParserExpectTokenError,['asm']);
           SetBlock(declNone);
           ParseProcBeginBlock(TProcedureBody(Declarations));
           break;
@@ -2600,6 +2660,20 @@ begin
         else
           ParseExcSyntaxError;
         end;
+      tkasm:
+        begin
+        if Declarations is TProcedureBody then
+          begin
+          Proc:=Declarations.Parent as TPasProcedure;
+          if not (pmAssembler in Proc.Modifiers) then
+            ParseExc(nParserExpectTokenError,SParserExpectTokenError,['begin']);
+          SetBlock(declNone);
+          ParseProcAsmBlock(TProcedureBody(Declarations));
+          break;
+          end
+        else
+          ParseExcSyntaxError;
+        end;
       tklabel:
         begin
           SetBlock(declNone);
@@ -2879,7 +2953,7 @@ var
   TypeName: String;
   NamePos: TPasSourcePos;
   OldForceCaret : Boolean;
-  
+
 begin
   TypeName := CurTokenString;
   NamePos:=Scanner.CurSourcePos;
@@ -2923,13 +2997,16 @@ begin
     UngetToken;
 end;
 
-function TPasParser.GetVariableModifiers(out VarMods: TVariableModifiers; out
-  Libname, ExportName: string): string;
+function TPasParser.GetVariableModifiers(Parent: TPasElement; out
+  VarMods: TVariableModifiers; out LibName, ExportName: TPasExpr): string;
 
 Var
   S : String;
+  ExtMod: TVariableModifier;
 begin
   Result := '';
+  LibName := nil;
+  ExportName := nil;
   VarMods := [];
   NextToken;
   If CurTokenIsIdentifier('cvar') then
@@ -2940,46 +3017,47 @@ begin
     NextToken;
     end;
   s:=LowerCase(CurTokenText);
-  if Not ((s='external') or (s='public') or (s='export')) then
-    UngetToken
+  if s='external' then
+    ExtMod:=vmExternal
+  else if (s='public') then
+    ExtMod:=vmPublic
+  else if (s='export') then
+    ExtMod:=vmExport
   else
     begin
-    if s='external' then
-      Include(VarMods,vmexternal)
-    else if (s='public') then
-      Include(varMods,vmpublic)
-    else if (s='export') then
-      Include(varMods,vmexport);
-    Result:=Result+';'+CurTokenText;
-    NextToken;
-    if (Curtoken<>tksemicolon) then
-      begin
-      if (s='external') then
-        begin
-        Include(VarMods,vmexternal);
-        if (CurToken in [tkString,tkIdentifier])
-            and Not (CurTokenIsIdentifier('name')) then
-          begin
-          Result := Result + ' ' + CurTokenText;
-          LibName:=CurTokenText;
-          NextToken;
-          end;
-        end;
-      if CurTokenIsIdentifier('name') then
-        begin
-        Result := Result + ' name ';
-        NextToken;
-        if (CurToken in [tkString,tkIdentifier]) then
-          Result := Result + CurTokenText
-        else
-          ParseExcSyntaxError;
-        ExportName:=CurTokenText;
-        NextToken;
-        end
-      else
-        ParseExcSyntaxError;
-      end;
+    UngetToken;
+    exit;
     end;
+  Include(varMods,ExtMod);
+  Result:=Result+';'+CurTokenText;
+
+  NextToken;
+  if not (CurToken in [tkString,tkIdentifier]) then
+    begin
+    if (CurToken=tkSemicolon) and (ExtMod in [vmExternal,vmPublic]) then
+      exit;
+    ParseExcSyntaxError;
+    end;
+  // export name exportname;
+  // public;
+  // public name exportname;
+  // external;
+  // external libname;
+  // external libname name exportname;
+  // external name exportname;
+  if (ExtMod=vmExternal) and (CurToken in [tkString,tkIdentifier])
+      and Not (CurTokenIsIdentifier('name')) then
+    begin
+    Result := Result + ' ' + CurTokenText;
+    LibName:=DoParseExpression(Parent);
+    end;
+  if not CurTokenIsIdentifier('name') then
+    ParseExcSyntaxError;
+  NextToken;
+  if not (CurToken in [tkString,tkIdentifier]) then
+    ParseExcTokenError(TokenInfos[tkString]);
+  Result := Result + ' ' + CurTokenText;
+  ExportName:=DoParseExpression(Parent);
 end;
 
 
@@ -2989,15 +3067,18 @@ procedure TPasParser.ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibi
 
 var
   i, OldListCount: Integer;
-  Value : TPasExpr;
+  Value , aLibName, aExpName: TPasExpr;
   VarType: TPasType;
   VarEl: TPasVariable;
   H : TPasMemberHints;
   VarMods: TVariableModifiers;
-  D,Mods,Loc,aLibName,aExpName : string;
+  D,Mods,Loc: string;
   OldForceCaret,ok: Boolean;
 
 begin
+  Value:=Nil;
+  aLibName:=nil;
+  aExpName:=nil;
   OldListCount:=VarList.Count;
   ok:=false;
   try
@@ -3025,22 +3106,22 @@ begin
       VarEl:=TPasVariable(VarList[i]);
       // Writeln(VarEl.Name, AVisibility);
       VarEl.VarType := VarType;
-      //VarType.Parent := VarEl; // this is wrong for references types
+      //VarType.Parent := VarEl; // this is wrong for references
       if (i>=OldListCount) then
         VarType.AddRef;
       end;
 
-    Value:=Nil;
     H:=CheckHint(Nil,False);
     If Full then
       GetVariableValueAndLocation(Parent,Value,Loc);
     if (Value<>nil) and (VarList.Count>OldListCount+1) then
       ParseExc(nParserOnlyOneVariableCanBeInitialized,SParserOnlyOneVariableCanBeInitialized);
     TPasVariable(VarList[OldListCount]).Expr:=Value;
+    Value:=nil;
 
     H:=H+CheckHint(Nil,Full);
     if Full then
-      Mods:=GetVariableModifiers(VarMods,aLibName,aExpName)
+      Mods:=GetVariableModifiers(Parent,VarMods,aLibName,aExpName)
     else
       begin
       NextToken;
@@ -3061,15 +3142,26 @@ begin
       VarEl.Modifiers:=Mods;
       VarEl.VarModifiers:=VarMods;
       VarEl.AbsoluteLocation:=Loc;
-      VarEl.LibraryName:=aLibName;
-      VarEl.ExportName:=aExpName;
+      if aLibName<>nil then
+        begin
+        VarEl.LibraryName:=aLibName;
+        aLibName.AddRef;
+        end;
+      if aExpName<>nil then
+        begin
+        VarEl.ExportName:=aExpName;
+        aExpName.AddRef;
+        end;
       end;
     for i := OldListCount to VarList.Count - 1 do
       Engine.FinishScope(stDeclaration,TPasVariable(VarList[i]));
     ok:=true;
   finally
+    if aLibName<>nil then aLibName.Release;
+    if aExpName<>nil then aExpName.Release;
     if not ok then
       begin
+        if Value<>nil then Value.Release;
         for i:=OldListCount to VarList.Count-1 do
           TPasElement(VarList[i]).Release;
         VarList.Count:=OldListCount;
@@ -3319,11 +3411,11 @@ begin
     NextToken;
     if CurToken in [tkString,tkIdentifier] then
       begin
-      // extrenal libname
+      // external libname
       // external libname name XYZ
       // external name XYZ
       Tok:=UpperCase(CurTokenString);
-      if Not ((curtoken=tkIdentifier) and (Tok='NAME')) then
+      if Not ((CurToken=tkIdentifier) and (Tok='NAME')) then
         begin
         E:=DoParseExpression(Parent);
         if Assigned(P) then
@@ -3334,7 +3426,7 @@ begin
       else
         begin
         Tok:=UpperCase(CurTokenString);
-        if ((curtoken=tkIdentifier) and (Tok='NAME')) then
+        if ((CurToken=tkIdentifier) and (Tok='NAME')) then
           begin
           NextToken;
           if not (CurToken in [tkString,tkIdentifier]) then
@@ -3407,6 +3499,35 @@ end;
 procedure TPasParser.ParseProcedureOrFunctionHeader(Parent: TPasElement;
   Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
 
+  Function FindInSection(AName : String;ASection : TPasSection) : Boolean;
+
+  Var
+    I : integer;
+    Cn,FN : String;
+    CT : TPasClassType;
+
+  begin
+    // ToDo: add an event for the resolver to use a faster lookup
+    I:=ASection.Functions.Count-1;
+    While (I>=0) and (CompareText(TPasElement(ASection.Functions[I]).Name,AName)<>0) do
+      Dec(I);
+    Result:=I<>-1;
+    I:=Pos('.',AName);
+    if (Not Result) and (I<>0) then
+      begin
+      CN:=Copy(AName,1,I-1);
+      FN:=Aname;
+      Delete(FN,1,I);
+      I:=Asection.Classes.Count-1;
+      While Not Result and (I>=0) do
+        begin
+        CT:=TPasClassType(ASection.Classes[i]);
+        if CompareText(CT.Name,CN)=0 then
+          Result:=CT.FindMember(TPasFunction, FN)<>Nil;
+        Dec(I);
+        end;
+      end;
+  end;
   procedure ConsumeSemi;
   begin
     NextToken;
@@ -3441,6 +3562,7 @@ Var
   Done: Boolean;
   ResultEl: TPasResultElement;
   I : Integer;
+  OK : Boolean;
 
 begin
   // Element must be non-nil. Removed all checks for not-nil.
@@ -3457,17 +3579,15 @@ 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 (msDelphi in CurrentModeswitches) and Assigned(CurModule.ImplementationSection) then
+      else if (msDelphi in CurrentModeswitches) and
+              (Assigned(CurModule.ImplementationSection) or
+               (CurModule is TPasProgram)) then
         begin
-        I:=-1;
         if Assigned(CurModule.InterfaceSection) then
-          begin
-          // ToDo: add an event for the resolver to use a faster lookup
-          I:=CurModule.InterfaceSection.Functions.Count-1;
-          While (I>=0) and (CompareText(TPasElement(CurModule.InterfaceSection.Functions[i]).Name,Parent.Name)<>0) do
-            Dec(I);
-          end;
-        if (I=-1) then
+          OK:=FindInSection(Parent.Name,CurModule.InterfaceSection)
+        else if (CurModule is TPasProgram) and Assigned(TPasProgram(CurModule).ProgramSection) then
+          OK:=FindInSection(Parent.Name,TPasProgram(CurModule).ProgramSection);
+        if Not OK then
           CheckToken(tkColon)
         else
           begin
@@ -3505,7 +3625,7 @@ begin
       begin
       ExpectToken(tkObject);
       Element.IsOfObject := True;
-      end 
+      end
     else if (curToken = tkIs) then
       begin
       expectToken(tkIdentifier);
@@ -3514,8 +3634,8 @@ begin
       Element.IsNested:=True;
       end
     else
-      UnGetToken;  
-    end;  
+      UnGetToken;
+    end;
   NextToken;
   if CurToken = tkEqual then
     begin
@@ -3666,6 +3786,17 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
       ExpectToken(tkSquaredBraceClose);
       Result := Result + ']';
       end;
+    repeat
+      NextToken;
+      if CurToken <> tkDot then
+        begin
+        UngetToken;
+        break;
+        end;
+      ExpectIdentifier;
+      Result := Result + '.' + CurTokenString;
+      AddToBinaryExprChain(Expr,Last,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
+    until false;
   end;
 
 var
@@ -3789,7 +3920,6 @@ var
   BeginBlock: TPasImplBeginBlock;
   SubBlock: TPasImplElement;
 begin
-
   BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent));
   Parent.Body := BeginBlock;
   repeat
@@ -3809,7 +3939,17 @@ begin
 //  writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring);
 end;
 
-procedure TPasParser.ParseAsmBlock(AsmBlock : TPasImplAsmStatement);
+procedure TPasParser.ParseProcAsmBlock(Parent: TProcedureBody);
+var
+  AsmBlock: TPasImplAsmStatement;
+begin
+  AsmBlock:=TPasImplAsmStatement(CreateElement(TPasImplAsmStatement,'',Parent));
+  Parent.Body:=AsmBlock;
+  ParseAsmBlock(AsmBlock);
+  ExpectToken(tkSemicolon);
+end;
+
+procedure TPasParser.ParseAsmBlock(AsmBlock: TPasImplAsmStatement);
 begin
   if po_asmwhole in Options then
     begin
@@ -3917,9 +4057,9 @@ begin
   while True do
   begin
     NextToken;
-    //WriteLn(i,'Token=',CurTokenText);
+    //WriteLn('Token=',CurTokenText);
     case CurToken of
-    tkasm :
+    tkasm:
       begin
       El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock));
       ParseAsmBlock(TPasImplAsmStatement(El));
@@ -3940,9 +4080,10 @@ begin
       begin
         NextToken;
         Left:=DoParseExpression(CurBlock);
-        UNgettoken;
+        UngetToken;
         El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock));
         TPasImplIfElse(El).ConditionExpr:=Left;
+        Left.Parent:=El;
         //WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText);
         CreateBlock(TPasImplIfElse(El));
         ExpectToken(tkthen);
@@ -4003,8 +4144,8 @@ begin
       begin
         // while Condition do
         NextToken;
-        left:=DoParseExpression(Parent);
-        ungettoken;
+        left:=DoParseExpression(CurBlock);
+        UngetToken;
         //WriteLn(i,'WHILE Condition="',Condition,'" Token=',CurTokenText);
         El:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock));
         TPasImplWhileDo(El).ConditionExpr:=left;
@@ -4013,7 +4154,7 @@ begin
       end;
     tkgoto:
       begin
-        nexttoken;
+        NextToken;
         curblock.AddCommand('goto '+curtokenstring);
         expecttoken(tkSemiColon);
       end;
@@ -4080,17 +4221,18 @@ begin
         // with Expr, Expr do
         SrcPos:=Scanner.CurSourcePos;
         NextToken;
-        Left:=DoParseExpression(Parent);
+        Left:=DoParseExpression(CurBlock);
         //writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
         El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
         TPasImplWithDo(El).AddExpression(Left);
+        Left.Parent:=El;
         CreateBlock(TPasImplWithDo(El));
         repeat
           if CurToken=tkdo then break;
           if CurToken<>tkComma then
             ParseExcTokenError(TokenInfos[tkdo]);
           NextToken;
-          Left:=DoParseExpression(Parent);
+          Left:=DoParseExpression(CurBlock);
           //writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
           TPasImplWithDo(CurBlock).AddExpression(Left);
         until false;
@@ -4098,7 +4240,7 @@ begin
     tkcase:
       begin
         NextToken;
-        Left:=DoParseExpression(Parent);
+        Left:=DoParseExpression(CurBlock);
         UngetToken;
         //writeln(i,'CASE OF Expr="',Expr,'" Token=',CurTokenText);
         ExpectToken(tkof);
@@ -4299,7 +4441,7 @@ begin
         if CurBlock is TPasImplRepeatUntil then
         begin
           NextToken;
-          Left:=DoParseExpression(Parent);
+          Left:=DoParseExpression(CurBlock);
           UngetToken;
           TPasImplRepeatUntil(CurBlock).ConditionExpr:=Left;
           //WriteLn(i,'UNTIL Condition="',Condition,'" Token=',CurTokenString);
@@ -4308,7 +4450,7 @@ begin
           ParseExcSyntaxError;
       end;
     else
-      left:=DoParseExpression(Parent);
+      left:=DoParseExpression(CurBlock);
       case CurToken of
         tkAssign,
         tkAssignPlus,
@@ -4319,7 +4461,7 @@ begin
           // assign statement
           Ak:=TokenToAssignKind(CurToken);
           NextToken;
-          right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG
+          right:=DoParseExpression(CurBlock); // this may solve TPasImplWhileDo.AddElement BUG
           El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock));
           left.Parent:=El;
           right.Parent:=El;
@@ -4528,6 +4670,12 @@ begin
     Result:=[msNone];
 end;
 
+procedure TPasParser.SetCurrentModeSwitches(AValue: TModeSwitches);
+begin
+  if Assigned(FScanner) then
+    FScanner.CurrentModeSwitches:=AValue;
+end;
+
 // Starts on first token after Record or (. Ends on AEndToken
 procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
   AEndToken: TToken; AllowMethods: Boolean);

packages/fcl-passrc/src/pscanner.pp

@@ -383,7 +383,8 @@ type
     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_arrayrangeexpr,       // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
+    po_selftoken             // Self is a token. For backward compatibility.
     );
   TPOptions = set of TPOption;
 
@@ -929,6 +930,7 @@ begin
   S:=FindStream(AName,ScanIncludes);
   If (S<>Nil) then
     begin
+    S.Position:=0;
     SL:=TStreamLineReader.Create(AName);
     try
       SL.InitFromStream(S);
@@ -1166,7 +1168,7 @@ end;
 function TFileResolver.FindSourceFile(const AName: string): TLineReader;
 begin
   if not FileExists(AName) then
-    Raise EFileNotFoundError.create(Aname)
+    Raise EFileNotFoundError.create(AName)
   else
     try
       Result := CreateFileReader(AName)
@@ -1182,7 +1184,7 @@ Var
 
 begin
   Result:=Nil;
-  FN:=FindIncludeFileName(ANAme);
+  FN:=FindIncludeFileName(AName);
   If (FN<>'') then
     try
       Result := TFileLineReader.Create(FN);
@@ -1300,6 +1302,15 @@ begin
     tkComment:
       if not (FSkipComments or PPIsSkipping) then
         Break;
+    tkSelf:
+      begin
+      if Not (po_selftoken in Options) then
+        begin
+        FCurToken:=tkIdentifier;
+        Result:=FCurToken;
+        end;
+      Break;
+      end;
     else
       if not PPIsSkipping then
         break;
@@ -2073,35 +2084,25 @@ begin
       end;
     '0'..'9':
       begin
+        // 1, 12, 1.2, 1.2E3, 1.E2, 1E2, 1.2E-3, 1E+2
+        // beware of 1..2
         TokenStart := TokenStr;
-        while true do
-        begin
+        repeat
           Inc(TokenStr);
-          case TokenStr[0] of
-            '.':
-              begin
-                if TokenStr[1] in ['0'..'9', 'e', 'E'] then
-                begin
-                  Inc(TokenStr);
-                  repeat
-                    Inc(TokenStr);
-                  until not (TokenStr[0] in ['0'..'9', 'e', 'E']);
-                end;
-                break;
-              end;
-            '0'..'9': ;
-            'e', 'E':
-              begin
-                Inc(TokenStr);
-                if TokenStr[0] = '-'  then
-                  Inc(TokenStr);
-                while TokenStr[0] in ['0'..'9'] do
-                  Inc(TokenStr);
-                break;
-              end;
-            else
-              break;
+        until not (TokenStr[0] in ['0'..'9']);
+        if (TokenStr[0]='.') and (TokenStr[1]<>'.') then
+          begin
+          inc(TokenStr);
+          while TokenStr[0] in ['0'..'9'] do
+            Inc(TokenStr);
           end;
+        if TokenStr[0] in ['e', 'E'] then
+        begin
+          Inc(TokenStr);
+          if TokenStr[0] in ['-','+'] then
+            inc(TokenStr);
+          while TokenStr[0] in ['0'..'9'] do
+            Inc(TokenStr);
         end;
         SectionLength := TokenStr - TokenStart;
         SetLength(FCurTokenString, SectionLength);

packages/fcl-passrc/tests/tcbaseparser.pas

@@ -462,6 +462,9 @@ end;
 procedure TTestParser.CleanupParser;
 
 begin
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser START');
+  {$ENDIF}
   if Not Assigned(FModule) then
     FreeAndNil(FDeclarations)
   else
@@ -469,17 +472,38 @@ begin
   FImplementation:=False;
   FEndSource:=False;
   FIsUnit:=False;
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FModule');
+  {$ENDIF}
   if Assigned(FModule) then
-    begin
-    FModule.Release;
-    FModule:=nil;
-    end;
+    ReleaseAndNil(TPasElement(FModule));
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FSource');
+  {$ENDIF}
   FreeAndNil(FSource);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FParseResult');
+  {$ENDIF}
   FreeAndNil(FParseResult);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FParser');
+  {$ENDIF}
   FreeAndNil(FParser);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FEngine');
+  {$ENDIF}
   FreeAndNil(FEngine);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FScanner');
+  {$ENDIF}
   FreeAndNil(FScanner);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser FResolver');
+  {$ENDIF}
   FreeAndNil(FResolver);
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.CleanupParser END');
+  {$ENDIF}
 end;
 
 procedure TTestParser.ResetParser;
@@ -497,8 +521,17 @@ end;
 
 procedure TTestParser.TearDown;
 begin
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.TearDown START CleanupParser');
+  {$ENDIF}
   CleanupParser;
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.TearDown inherited');
+  {$ENDIF}
   Inherited;
+  {$IFDEF VerbosePasResolverMem}
+  writeln('TTestParser.TearDown END');
+  {$ENDIF}
 end;
 
 procedure TTestParser.CreateEngine(var TheEngine: TPasTreeContainer);

packages/fcl-passrc/tests/tcclasstype.pas

@@ -139,6 +139,7 @@ type
     Procedure TestPropertyImplements;
     Procedure TestPropertyImplementsFullyQualifiedName;
     Procedure TestPropertyReadFromRecordField;
+    procedure TestPropertyReadFromArrayField;
     procedure TestPropertyReadWriteFromRecordField;
     Procedure TestLocalSimpleType;
     Procedure TestLocalSimpleTypes;
@@ -1463,6 +1464,21 @@ begin
   Assertequals('Default value','',Property1.DefaultValue);
 end;
 
+procedure TTestClassType.TestPropertyReadFromArrayField;
+begin
+  StartVisibility(visPublished);
+  AddMember('Property Something : Integer Read FPoint.W[x].y.Z');
+  ParseClass;
+  AssertProperty(Property1,visPublished,'Something','FPoint.W[x].y.Z','','','',0,False,False);
+  AssertNotNull('Have type',Property1.VarType);
+  AssertEquals('Property type class type',TPasUnresolvedTypeRef,Property1.vartype.ClassType);
+  AssertEquals('Property type name','Integer',Property1.vartype.name);
+  Assertequals('No index','',Property1.IndexValue);
+  AssertNull('No Index expression',Property1.IndexExpr);
+  AssertNull('No default expression',Property1.DefaultExpr);
+  Assertequals('Default value','',Property1.DefaultValue);
+end;
+
 procedure TTestClassType.TestPropertyReadWriteFromRecordField;
 begin
   StartVisibility(visPublished);

packages/fcl-passrc/tests/tcexprparser.pas

@@ -45,6 +45,16 @@ type
     procedure TestPrimitiveIntegerOctal;
     procedure TestPrimitiveIntegerBinary;
     procedure TestPrimitiveDouble;
+    procedure TestPrimitiveDouble2;
+    procedure TestPrimitiveDouble3;
+    procedure TestPrimitiveDouble4;
+    procedure TestPrimitiveDouble5;
+    procedure TestPrimitiveDouble6;
+    procedure TestPrimitiveDouble7;
+    procedure TestPrimitiveDouble8;
+    procedure TestPrimitiveDouble9;
+    procedure TestPrimitiveDouble10;
+    procedure TestPrimitiveDouble11;
     procedure TestPrimitiveString;
     procedure TestPrimitiveIdent;
     procedure TestPrimitiveBooleanFalse;
@@ -164,6 +174,66 @@ begin
   AssertExpression('Simple double',theExpr,pekNumber,'1.2');
 end;
 
+procedure TTestExpressions.TestPrimitiveDouble2;
+begin
+  ParseExpression('1.200');
+  AssertExpression('Simple double',theExpr,pekNumber,'1.200');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble3;
+begin
+  ParseExpression('01.2');
+  AssertExpression('Simple double',theExpr,pekNumber,'01.2');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble4;
+begin
+  ParseExpression('1.2e10');
+  AssertExpression('Simple double',theExpr,pekNumber,'1.2e10');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble5;
+begin
+  ParseExpression('1.2e-10');
+  AssertExpression('Simple double',theExpr,pekNumber,'1.2e-10');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble6;
+begin
+  ParseExpression('12e10');
+  AssertExpression('Simple double',theExpr,pekNumber,'12e10');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble7;
+begin
+  ParseExpression('12e-10');
+  AssertExpression('Simple double',theExpr,pekNumber,'12e-10');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble8;
+begin
+  ParseExpression('8.5');
+  AssertExpression('Simple double',theExpr,pekNumber,'8.5');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble9;
+begin
+  ParseExpression('8.E5');
+  AssertExpression('Simple double',theExpr,pekNumber,'8.E5');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble10;
+begin
+  ParseExpression('8.E-5');
+  AssertExpression('Simple double',theExpr,pekNumber,'8.E-5');
+end;
+
+procedure TTestExpressions.TestPrimitiveDouble11;
+begin
+  ParseExpression('8E+5');
+  AssertExpression('Simple double',theExpr,pekNumber,'8E+5');
+end;
+
 procedure TTestExpressions.TestPrimitiveString;
 begin
   DeclareVar('string');

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -28,6 +28,7 @@ type
     procedure AssertProc(Mods: TProcedureModifiers; CC: TCallingConvention; ArgCount: Integer; P: TPasProcedure=nil);
     function BaseAssertArg(ProcType: TPasProcedureType; AIndex: Integer;
       AName: String; AAccess: TArgumentAccess; AValue: String=''): TPasArgument;
+    procedure CreateForwardTest;
     function GetFT: TPasFunctionType;
     function GetPT: TPasProcedureType;
     Procedure ParseProcedure;
@@ -146,6 +147,8 @@ type
     Procedure TestFunctionCDeclExport;
     Procedure TestProcedureExternal;
     Procedure TestFunctionExternal;
+    Procedure TestFunctionForwardNoReturnDelphi;
+    procedure TestFunctionForwardNoReturnNoDelphi;
     Procedure TestProcedureExternalLibName;
     Procedure TestFunctionExternalLibName;
     Procedure TestProcedureExternalLibNameName;
@@ -1055,6 +1058,39 @@ begin
   AssertNull('No Library name expression',Func.LibraryExpr);
 end;
 
+procedure TTestProcedureFunction.CreateForwardTest;
+
+begin
+  With Source do
+    begin
+    Add('type');
+    Add('');
+    Add('Entity=object');
+    Add('  function test:Boolean;');
+    Add('end;');
+    Add('');
+    Add('Function Entity.test;');
+    Add('begin');
+    Add('end;');
+    Add('');
+    Add('begin');
+    // End is added by ParseModule
+    end;
+end;
+
+procedure TTestProcedureFunction.TestFunctionForwardNoReturnDelphi;
+begin
+  Source.Add('{$MODE DELPHI}');
+  CreateForwardTest;
+  ParseModule;
+end;
+
+procedure TTestProcedureFunction.TestFunctionForwardNoReturnNoDelphi;
+begin
+  CreateForwardTest;
+  AssertException('Only in delphi mode can result be omitted',EParserError,@ParseModule);
+end;
+
 procedure TTestProcedureFunction.TestProcedureExternalLibName;
 begin
   ParseProcedure(';external ''libname''','');

packages/fcl-passrc/tests/tcscanner.pas

@@ -82,6 +82,8 @@ type
     procedure TestNestedComment3;
     procedure TestNestedComment4;
     procedure TestIdentifier;
+    procedure TestSelf;
+    procedure TestSelfNoToken;
     procedure TestString;
     procedure TestNumber;
     procedure TestChar;
@@ -170,7 +172,6 @@ type
     procedure TestRecord;
     procedure TestRepeat;
     procedure TestResourceString;
-    procedure TestSelf;
     procedure TestSet;
     procedure TestShl;
     procedure TestShr;
@@ -1161,9 +1162,15 @@ end;
 procedure TTestScanner.TestSelf;
 
 begin
+  FScanner.Options:=FScanner.Options + [po_selftoken];
   TestToken(tkself,'self');
 end;
 
+procedure TTestScanner.TestSelfNoToken;
+begin
+  TestToken(tkIdentifier,'self');
+end;
+
 
 procedure TTestScanner.TestSet;
 

packages/fcl-passrc/tests/tcvarparser.pas

@@ -273,16 +273,16 @@ procedure TTestVarParser.TestVarExternalLib;
 begin
   ParseVar('integer; external name ''mylib''','');
   AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
-  AssertEquals('Library name','',TheVar.LibraryName);
-  AssertEquals('Library name','''mylib''',TheVar.ExportName);
+  AssertNull('Library name',TheVar.LibraryName);
+  AssertNotNull('Library symbol',TheVar.ExportName);
 end;
 
 procedure TTestVarParser.TestVarExternalLibName;
 begin
   ParseVar('integer; external ''mylib'' name ''de''','');
   AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
-  AssertEquals('Library name','''mylib''',TheVar.LibraryName);
-  AssertEquals('Library name','''de''',TheVar.ExportName);
+  AssertNotNull('Library name',TheVar.LibraryName);
+  AssertNotNull('Library symbol',TheVar.ExportName);
 end;
 
 procedure TTestVarParser.TestVarCVar;
@@ -307,7 +307,7 @@ procedure TTestVarParser.TestVarPublicName;
 begin
   ParseVar('integer; public name ''ce''','');
   AssertEquals('Variable modifiers',[vmpublic],TheVar.VarModifiers);
-  AssertEquals('Public export name','''ce''',TheVar.ExportName);
+  AssertNotNull('Public export name',TheVar.ExportName);
 end;
 
 procedure TTestVarParser.TestVarDeprecatedExternalName;
@@ -315,7 +315,8 @@ begin
   ParseVar('integer deprecated; external name ''me''','');
   CheckHint(TPasMemberHint(Getenumvalue(typeinfo(TPasMemberHint),'hdeprecated')));
   AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
-  AssertEquals('Library name','''me''',TheVar.ExportName);
+  AssertNull('Library name',TheVar.LibraryName);
+  AssertNotNull('Library symbol',TheVar.ExportName);
 end;
 
 procedure TTestVarParser.TestVarHintPriorToInit;

packages/fcl-web/src/base/custcgi.pp

@@ -353,7 +353,7 @@ procedure TCGIRequest.InitFromEnvironment;
 
 Var
   I : Integer;
-  R,V,OV : String;
+  R,V : String;
   M : TMap;
   
 begin

packages/fcl-web/src/base/fphttpclient.pp

@@ -89,6 +89,7 @@ Type
     FServerHTTPVersion: String;
     FSocket : TInetSocket;
     FBuffer : Ansistring;
+    FTerminated: Boolean;
     FUserName: String;
     FOnGetSocketHandler : TGetSocketHandlerEvent;
     FProxy : TProxyData;
@@ -166,6 +167,9 @@ Type
     Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer;
     // Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet.
     Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String;
+    { Terminate the current request.
+      It will stop the client from trying to send and/or receive data after the current chunk is sent/received. }
+    Procedure Terminate;
     // Request Header management
     // Return index of header, -1 if not present.
     Function IndexOfHeader(Const AHeader : String) : Integer;
@@ -262,6 +266,8 @@ Type
     Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
     // Simple form of Posting a file
     Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
+    // Has Terminate been called ?
+    Property Terminated : Boolean Read FTerminated;
   Protected
     // Timeouts
     Property IOTimeout : Integer read FIOTimeout write SetIOTimeout;
@@ -676,8 +682,9 @@ begin
   FSentCookies:=FCookies;
   FCookies:=Nil;
   S:=S+CRLF;
-  FSocket.WriteBuffer(S[1],Length(S));
-  If Assigned(FRequestBody) then
+  if not Terminated then
+    FSocket.WriteBuffer(S[1],Length(S));
+  If Assigned(FRequestBody) and not Terminated then
     FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
 end;
 
@@ -689,11 +696,13 @@ function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
     R : Integer;
 
   begin
+    if Terminated then
+      Exit(False);
     SetLength(FBuffer,ReadBufLen);
     r:=FSocket.Read(FBuffer[1],ReadBufLen);
-    If r=0 Then
+    If (r=0) or Terminated Then
       Exit(False);
-    If r<0 then
+    If (r<0) then
       Raise EHTTPClient.Create(SErrReadingSocket);
     if (r<ReadBuflen) then
       SetLength(FBuffer,r);
@@ -746,7 +755,7 @@ begin
         Result:=True;
         end;
       end;
-  until Result;
+  until Result or Terminated;
 end;
 
 Function GetNextWord(Var S : String) : string;
@@ -807,7 +816,7 @@ function TFPCustomHTTPClient.ReadResponseHeaders: integer;
       C:=Trim(Copy(S,1,P-1));
       Cookies.Add(C);
       System.Delete(S,1,P);
-    Until (S='');
+    Until (S='') or Terminated;
   end;
 
 Const
@@ -827,8 +836,8 @@ begin
       If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then
         DoCookies(S);
       end
-  Until (S='');
-  If Assigned(FOnHeaders) then
+  Until (S='') or Terminated;
+  If Assigned(FOnHeaders) and not Terminated then
     FOnHeaders(Self);
 end;
 
@@ -990,6 +999,9 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
     function FetchData(out Cnt: integer): boolean;
 
     begin
+      Result:=False;
+      If Terminated then
+        exit;
       SetLength(FBuffer,ReadBuflen);
       Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
       If Cnt<0 then
@@ -1038,17 +1050,20 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
         '0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0');
         'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10;
         'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10;
-        else break;
+        else
+          break;
         end;
         if ChunkSize>1000000 then
           Raise EHTTPClient.Create(SErrChunkTooBig);
-      until false;
+      until Terminated;
       // read till line end
-      while (c<>#10) do
+      while (c<>#10) and not Terminated do
         if ReadData(@c,1)<1 then exit;
       if ChunkSize=0 then exit;
       // read data
       repeat
+        if Terminated then
+          exit;
         l:=length(FBuffer)-BufPos+1;
         if l=0 then
           if not FetchData(l) then
@@ -1064,14 +1079,18 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
           end;
       until ChunkSize=0;
       // read #13#10
-      if ReadData(@c,1)<1 then exit;
-      if c<>#13 then
-        Raise EHTTPClient.Create(SErrChunkLineEndMissing);
-      if ReadData(@c,1)<1 then exit;
-      if c<>#10 then
-        Raise EHTTPClient.Create(SErrChunkLineEndMissing);
-      // next chunk
-    until false;
+      if ReadData(@c,1)<1 then
+        exit;
+      if Not Terminated then
+        begin
+        if c<>#13 then
+          Raise EHTTPClient.Create(SErrChunkLineEndMissing);
+        if ReadData(@c,1)<1 then exit;
+        if c<>#10 then
+          Raise EHTTPClient.Create(SErrChunkLineEndMissing);
+        // next chunk
+        end;
+    until Terminated;
   end;
 
 Var
@@ -1112,14 +1131,14 @@ begin
           LB:=L;
         R:=Transfer(LB);
         L:=L-R;
-      until (L=0) or (R=0);
+      until (L=0) or (R=0) or Terminated;
       end
     else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then
       begin
       // No content-length, so we read till no more data available.
       Repeat
         R:=Transfer(ReadBufLen);
-      until (R=0);
+      until (R=0) or Terminated;
       end;
     end;
 end;
@@ -1176,7 +1195,8 @@ begin
   ConnectToServer(CHost,CPort,AIsHttps);
   Try
     SendRequest(AMethod,AURI);
-    ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
+    if not Terminated then
+      ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
   Finally
     DisconnectFromServer;
   End;
@@ -1199,15 +1219,20 @@ begin
     If Not IsConnected Then
       ConnectToServer(CHost,CPort,AIsHttps);
     Try
-      SendRequest(AMethod,AURI);
-      T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
-      If Not T Then
-        ReconnectToServer(CHost,CPort,AIsHttps);
+      if not Terminated then
+        SendRequest(AMethod,AURI);
+      if not Terminated then
+        begin
+        T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
+        If Not T Then
+          ReconnectToServer(CHost,CPort,AIsHttps);
+        end;
     Finally
-      If HasConnectionClose Then
+      // On terminate, we close the request
+      If HasConnectionClose or Terminated Then
         DisconnectFromServer;
     End;
-  Until T;
+  Until T or Terminated;
 end;
 
 Procedure TFPCustomHTTPClient.DoMethod(Const AMethod, AURL: String;
@@ -1302,6 +1327,11 @@ begin
     end;
 end;
 
+procedure TFPCustomHTTPClient.Terminate;
+begin
+  FTerminated:=True;
+end;
+
 procedure TFPCustomHTTPClient.ResetResponse;
 
 begin
@@ -1322,6 +1352,8 @@ Var
   RR : Boolean; // Repeat request ?
 
 begin
+  // Reset Terminated
+  FTerminated:=False;
   L:=AURL;
   RC:=0;
   RR:=False;
@@ -1332,7 +1364,7 @@ begin
     else
       begin
       DoMethod(M,L,Stream,AllowedResponseCodes);
-      if IsRedirect(FResponseStatusCode) then
+      if IsRedirect(FResponseStatusCode) and not Terminated then
         begin
         Inc(RC);
         if (RC>MaxRedirects) then
@@ -1359,7 +1391,7 @@ begin
       end
     else
       RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'');
-  until not RR;
+  until Terminated or not RR ;
 end;
 
 procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream);

packages/fcl-web/src/base/httpdefs.pp

@@ -287,7 +287,6 @@ type
     FContentFields: TStrings;
     FCookieFields: TStrings;
     FHTTPVersion: String;
-    FHTTPXRequestedWith: String;
     FFields : THeadersArray;
     FVariables : THTTPVariables;
     FQueryFields: TStrings;
@@ -299,7 +298,7 @@ type
     Function GetFieldCount : Integer;
     Function GetContentLength : Integer;
     Procedure SetContentLength(Value : Integer);
-    Function GetFieldOrigin(AIndex : Integer; Out H : THeader; V : THTTPVAriableType) : Boolean;
+    Function GetFieldOrigin(AIndex : Integer; Out H : THeader; Out V : THTTPVAriableType) : Boolean;
     Function GetServerPort : Word;
     Procedure SetServerPort(AValue : Word);
     Function GetSetFieldValue(Index : Integer) : String; virtual;
@@ -412,9 +411,7 @@ type
     FFiles : TUploadedFiles;
     FReturnedPathInfo : String;
     FLocalPathPrefix : string;
-    FServerPort : String;
     FContentRead : Boolean;
-    FContent : String;
     FRouteParams : TStrings;
     function GetLocalPathPrefix: string;
     function GetFirstHeaderLine: String;
@@ -606,9 +603,7 @@ Resourcestring
   SErrInternalUploadedFileError = 'Internal uploaded file configuration error';
   SErrNoSuchUploadedFile        = 'No such uploaded file : "%s"';
   SErrUnknownCookie             = 'Unknown cookie: "%s"';
-  SErrUnsupportedContentType    = 'Unsupported content type: "%s"';
   SErrNoRequestMethod           = 'No REQUEST_METHOD passed from server.';
-  SErrInvalidRequestMethod      = 'Invalid REQUEST_METHOD passed from server: %s.';
 
 const
    hexTable = '0123456789ABCDEF';
@@ -816,7 +811,7 @@ end;
 
 
 function THTTPHeader.GetFieldOrigin(AIndex: Integer; out H: THeader;
-  V: THTTPVAriableType): Boolean;
+  Out V: THTTPVAriableType): Boolean;
 
 
 begin
@@ -1241,10 +1236,9 @@ end;
 procedure TMimeItems.CreateUploadFiles(Files: TUploadedFiles; Vars : TStrings);
 
 Var
-  I,j : Integer;
+  I : Integer;
   P : TMimeItem;
-  LFN,Name,Value : String;
-  U : TUploadedFile;
+  Name,Value : String;
 
 begin
   For I:=Count-1 downto 0 do
@@ -1798,10 +1792,8 @@ procedure TRequest.ProcessMultiPart(Stream: TStream; const Boundary: String;
 Var
   L : TMimeItems;
   B : String;
-  I,J : Integer;
-  S,FF,key, Value : String;
-  FI : TMimeItem;
-  F : TStream;
+  I : Integer;
+  S : String;
 
 begin
 {$ifdef CGIDEBUG} SendMethodEnter('ProcessMultiPart');{$endif CGIDEBUG}
@@ -1936,9 +1928,6 @@ end;
 
 procedure TUploadedFile.DeleteTempUploadedFile;
 
-Var
-  s: String;
-
 begin
   if (FStream is TFileStream) then
     FreeStream;

packages/fcl-web/src/base/httproute.pp

@@ -224,6 +224,9 @@ Function RouteMethodToString (R : TRouteMethod)  : String;
 // Shortcut for THTTPRouter.Service;
 Function HTTPRouter : THTTPRouter;
 
+Const
+  RouteMethodNames : Array[TRouteMethod] of String = ('','','GET','POST','PUT','DELETE','OPTIONS','HEAD','TRACE');
+
 implementation
 
 uses strutils, typinfo;
@@ -395,8 +398,17 @@ begin
 end;
 
 class function THTTPRouter.StringToRouteMethod(const S: String): TRouteMethod;
-begin
 
+
+Var
+  MN : String;
+
+begin
+  Result:=High(TRouteMethod);
+  MN:=Uppercase(S);
+  While (Result>=Low(TRouteMethod)) and (RouteMethodNames[Result]<>MN) do
+    Result:=Pred(Result);
+  if Result=rmAll then Result:=rmUnknown;
 end;
 
 function THTTPRouter.RegisterRoute(const APattern: String;AData : Pointer;

packages/pastojs/tests/tcconverter.pp

@@ -268,7 +268,6 @@ begin
   E:=TJSExpressionStatement(Convert(R,TJSExpressionStatement));
   AssertNotNull('Have call node',E.A);
   AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
-  AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
   C:=TJSCallExpression(E.A);
   AssertIdentifier('Call expression',C.Expr,'a');
 end;
@@ -972,12 +971,15 @@ Procedure TTestExpressionConverter.TestBinaryDiv;
 Var
   B : TBinaryExpr;
   E : TJSMultiplicativeExpressionDiv;
-
+  C: TJSCallExpression;
+  Args: TJSArguments;
 begin
   B:=TBinaryExpr.Create(Nil,pekBinary,eopDiv);
   B.left:=CreateLiteral(1.23);
   B.Right:=CreateLiteral(3.45);
-  E:=TJSMultiplicativeExpressionDiv(TestBinaryExpression(B,TJSMultiplicativeExpressionDiv));
+  C:=TJSCallExpression(Convert(B,TJSCallExpression));
+  Args:=TJSArguments(AssertElement('Math.floor param',TJSArguments,C.Args));
+  E:=TJSMultiplicativeExpressionDiv(AssertElement('param',TJSMultiplicativeExpressionDiv,Args.Elements.Elements[0].Expr));
   AssertLiteral('Correct left literal for div',E.A,1.23);
   AssertLiteral('Correct right literal for div',E.B,3.45);
 end;
@@ -1013,13 +1015,13 @@ end;
 Procedure TTestExpressionConverter.TestBinarySHR;
 Var
   B : TBinaryExpr;
-  E : TJSRShiftExpression;
+  E : TJSURShiftExpression;
 
 begin
   B:=TBinaryExpr.Create(Nil,pekBinary,eopSHR);
   B.left:=CreateLiteral(13);
   B.Right:=CreateLiteral(3);
-  E:=TJSRShiftExpression(TestBinaryExpression(B,TJSRShiftExpression));
+  E:=TJSURShiftExpression(TestBinaryExpression(B,TJSURShiftExpression));
   AssertLiteral('Correct left literal for shr',E.A,13);
   AssertLiteral('Correct right literal for shr',E.B,3);
 end;

utils/pas2js/dist/rtl.js

@@ -40,38 +40,50 @@ var rtl = {
     rtl.debug('Warn: ',s);
   },
 
-  isArray: function isArray(a) {
+  isArray: function(a) {
     return a instanceof Array;
   },
 
-  isNumber: function isNumber(n){
+  isNumber: function(n){
     return typeof(n)=="number";
   },
 
-  isInteger: function isInteger(A){
+  isInteger: function(A){
     return Math.floor(A)===A;
   },
 
-  isBoolean: function isBoolean(b){
+  isBoolean: function(b){
     return typeof(b)=="boolean";
   },
 
-  isString: function isString(s){
+  isString: function(s){
     return typeof(s)=="string";
   },
 
-  isObject: function isObject(o){
+  isObject: function(o){
     return typeof(o)=="object";
   },
 
-  isFunction: function isFunction(f){
+  isFunction: function(f){
     return typeof(f)=="function";
   },
 
-  isNull: function isNull(o){
+  isNull: function(o){
     return (o==null && typeof(o)=='object') || o==undefined;
   },
 
+  isRecord: function(r){
+    return (typeof(r)=="function") && (typeof(r.$create) == "function");
+  },
+
+  isClass: function(c){
+    return (typeof(o)=="object") && (o.$class == o);
+  },
+
+  isClassInstance: function(c){
+    return (typeof(o)=="object") && (o.$class == Object.getPrototypeOf(o));
+  },
+
   hasString: function(s){
     return rtl.isString(s) && (s.length>0);
   },
@@ -97,11 +109,12 @@ var rtl = {
 
   run: function(module_name){
     if (module_name==undefined) module_name='program';
+    if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"');
     var module = pas[module_name];
     rtl.loadintf(module);
     rtl.loadimpl(module);
     if (module_name=='program'){
-      rtl.debug('running $main');
+      if (rtl.debug_load_units) rtl.debug('running $main');
       pas.program.$main();
     }
     return pas.System.ExitCode;
@@ -109,14 +122,14 @@ var rtl = {
 
   loadintf: function(module){
     if (module.state>rtl.m_loading_intf) return; // already finished
-    rtl.debug('loadintf: '+module.$name);
+    if (rtl.debug_load_units) rtl.debug('loadintf: '+module.$name);
     if (module.$state==rtl.m_loading_intf)
       rtl.error('unit cycle detected "'+module.$name+'"');
     module.$state=rtl.m_loading_intf;
     // load interfaces of interface useslist
     rtl.loaduseslist(module,module.$intfuseslist,rtl.loadintf);
     // run interface
-    rtl.debug('loadintf: run intf of '+module.$name);
+    if (rtl.debug_load_units) rtl.debug('loadintf: run intf of '+module.$name);
     module.$code(module.$intfuseslist,module);
     // success
     module.$state=rtl.m_intf_loaded;
@@ -127,7 +140,7 @@ var rtl = {
     if (useslist==undefined) return;
     for (var i in useslist){
       var unitname=useslist[i];
-      //rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"');
+      if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"');
       if (pas[unitname]==undefined)
         rtl.error('module "'+module.$name+'" misses "'+unitname+'"');
       f(pas[unitname]);
@@ -137,7 +150,7 @@ var rtl = {
   loadimpl: function(module){
     if (module.$state>=rtl.m_loading_impl) return; // already processing
     if (module.$state<rtl.m_loading_intf) rtl.loadintf(module);
-    rtl.debug('loadimpl: '+module.$name+' load uses');
+    if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' load uses');
     module.$state=rtl.m_loading_impl;
     // load implementation of interfaces useslist
     rtl.loaduseslist(module,module.$intfuseslist,rtl.loadimpl);
@@ -148,7 +161,7 @@ var rtl = {
     // initialized. This is by design.
 
     // run initialization
-    rtl.debug('loadimpl: '+module.$name+' run init');
+    if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' run init');
     module.$state=rtl.m_initializing;
     if (rtl.isFunction(module.$init))
       module.$init();
@@ -156,12 +169,25 @@ var rtl = {
     module.$state=rtl.m_initialized;
   },
 
-  createCallback: function(scope, fn){
-    var wrapper = function(){
-      return fn.apply(scope,arguments);
+  createCallback: function(scope, fnname){
+    var cb = function(){
+      return scope[fnname].apply(scope,arguments);
     };
-    wrapper.fn = fn;
-    return wrapper;
+    cb.scope = scope;
+    cb.fnname = fnname;
+    return cb;
+  },
+
+  cloneCallback: function(cb){
+    return rtl.createCallback(cb.scope,cb.fnname);
+  },
+
+  eqCallback: function(a,b){
+    if (a==null){
+      return (b==null);
+    } else {
+      return (b!=null) && (a.scope==b.scope) && (a.fnname==b.fnname);
+    }
   },
 
   createClass: function(owner,name,ancestor,initfn){
@@ -175,14 +201,15 @@ var rtl = {
         var o = Object.create(this);
         o.$class = this; // Note: o.$class == Object.getPrototypeOf(o)
         if (args == undefined) args = [];
-        o[fnname].apply(o,args);
         o.$init();
+        o[fnname].apply(o,args);
         o.AfterConstruction();
         return o;
       };
       c.$destroy = function(fnname){
         this.BeforeDestruction();
-        this[fnname].apply(obj,[]);
+        this[fnname]();
+        this.$final;
       };
     };
     c.$classname = name;
@@ -197,26 +224,32 @@ var rtl = {
     throw pas.System.EInvalidCast.$create("create");
   },
 
-  setArrayLength: function(arr,newlength,defaultvalue){
-    if (newlength == 0) return null;
-    if (arr == null) arr = [];
+  arraySetLength: function(arr,newlength,defaultvalue){
     var oldlen = arr.length;
     if (oldlen==newlength) return;
     arr.length = newlength;
     if (rtl.isArray(defaultvalue)){
       for (var i=oldlen; i<newlength; i++) arr[i]=[]; // new array
+    } else if (rtl.isFunction(defaultvalue)){
+      for (var i=oldlen; i<newlength; i++) arr[i]=new defaultvalue(); // new record
     } else {
       for (var i=oldlen; i<newlength; i++) arr[i]=defaultvalue;
     }
     return arr;
   },
 
-  setStringLength: function(s,newlength){
-    s.length = newlength;
-  },
-
-  length: function(a){
-    return (a!=null) ? a.length : 0;
+  arrayNewMultiDim: function(dims,defaultvalue){
+    function create(dim){
+      if (dim == dims.length-1){
+        return rtl.arraySetLength([],dims[dim],defaultvalue);
+      }
+      var a = [];
+      var count = dims[dim];
+      a.length = count;
+      for(var i=0; i<count; i++) a[i] = create(dim+1);
+      return a;
+    };
+    return create(0);
   },
 
   setCharAt: function(s,index,c){
@@ -243,9 +276,27 @@ var rtl = {
     return r;
   },
 
+  refSet: function(s){
+    s.$shared = true;
+    return s;
+  },
+
+  includeSet: function(s,enumvalue){
+    if (s.$shared) s = cloneSet(s);
+    s[enumvalue] = true;
+    return s;
+  },
+
+  excludeSet: function(s,enumvalue){
+    if (s.$shared) s = cloneSet(s);
+    delete s[enumvalue];
+    return s;
+  },
+
   diffSet: function(s,t){
     var r = {};
     for (var key in s) if (s.hasOwnProperty(key) && !t[key]) r[key]=true;
+    delete r.$shared;
     return r;
   },
 
@@ -253,12 +304,14 @@ var rtl = {
     var r = {};
     for (var key in s) if (s.hasOwnProperty(key)) r[key]=true;
     for (var key in t) if (t.hasOwnProperty(key)) r[key]=true;
+    delete r.$shared;
     return r;
   },
 
   intersectSet: function(s,t){
     var r = {};
     for (var key in s) if (s.hasOwnProperty(key) && t[key]) r[key]=true;
+    delete r.$shared;
     return r;
   },
 
@@ -266,12 +319,13 @@ var rtl = {
     var r = {};
     for (var key in s) if (s.hasOwnProperty(key) && !t[key]) r[key]=true;
     for (var key in t) if (t.hasOwnProperty(key) && !s[key]) r[key]=true;
+    delete r.$shared;
     return r;
   },
 
   eqSet: function(s,t){
-    for (var key in s) if (s.hasOwnProperty(key) && !t[key]) return false;
-    for (var key in t) if (t.hasOwnProperty(key) && !s[key]) return false;
+    for (var key in s) if (s.hasOwnProperty(key) && !t[key] && (key!='$shared')) return false;
+    for (var key in t) if (t.hasOwnProperty(key) && !s[key] && (key!='$shared')) return false;
     return true;
   },
 
@@ -280,12 +334,12 @@ var rtl = {
   },
 
   leSet: function(s,t){
-    for (var key in s) if (s.hasOwnProperty(key) && !t[key]) return false;
+    for (var key in s) if (s.hasOwnProperty(key) && !t[key] && (key!='$shared')) return false;
     return true;
   },
 
   geSet: function(s,t){
-    for (var key in t) if (t.hasOwnProperty(key) && !s[key]) return false;
+    for (var key in t) if (t.hasOwnProperty(key) && !s[key] && (key!='$shared')) return false;
     return true;
   },
 }