* Patch from Mattias Gaertner for pas2js:

  jsbase: Changed TJSString from WideString to UnicodeString to use ref counting on Windows.
  jsbase: Added TJSValue.CustomValue.
  fppas2js: Changed context from pas to js context. 
            The pas context is already in the resolver values. 
  fppas2js: Support for type alias
  fppas2js: Built in functions inc/dec for integers

git-svn-id: trunk@34851 -

packages/fcl-js/src/jsbase.pp

@@ -25,7 +25,7 @@ uses
 Type
   TJSType = (jstUNDEFINED,jstNull,jstBoolean,jstNumber,jstString,jstObject,jstReference,JSTCompletion);
 
-  TJSString = WideString;
+  TJSString = UnicodeString;
   TJSNumber = Double;
 
   { TJSValue }
@@ -39,6 +39,7 @@ Type
       1 : (F : TJSNumber);
       2 : (I : Integer);
     end;
+    FCustomValue: TJSString;
     procedure ClearValue(ANewValue: TJSType);
     function GetAsBoolean: Boolean;
     function GetAsCompletion: TObject;
@@ -64,6 +65,7 @@ Type
     Constructor Create(AString: TJSString);
     Destructor Destroy; override;
     Property ValueType : TJSType Read FValueType;
+    Property CustomValue: TJSString Read FCustomValue Write FCustomValue;
     Property IsUndefined : Boolean Read GetIsUndefined Write SetIsUndefined;
     Property IsNull : Boolean Read GetIsNull Write SetIsNull;
     Property AsNumber : TJSNumber Read GetAsNumber Write SetAsNumber;
@@ -144,6 +146,7 @@ begin
     FValue.I:=0;
   end;
   FValueType:=ANewValue;
+  FCustomValue:='';
 end;
 
 procedure TJSValue.SetAsBoolean(const AValue: Boolean);
@@ -184,40 +187,46 @@ end;
 
 procedure TJSValue.SetIsNull(const AValue: Boolean);
 begin
-  ClearValue(jstNull);
+  if AValue then
+    ClearValue(jstNull)
+  else if IsNull then
+    ClearValue(jstUNDEFINED);
 end;
 
 procedure TJSValue.SetIsUndefined(const AValue: Boolean);
 begin
-  ClearValue(jstUndefined);
+  if AValue then
+    ClearValue(jstUndefined)
+  else if IsUndefined then
+    ClearValue(jstNull);
 end;
 
-Constructor TJSValue.CreateNull;
+constructor TJSValue.CreateNull;
 begin
   IsNull:=True;
 end;
 
-Constructor TJSValue.Create;
+constructor TJSValue.Create;
 begin
   IsUndefined:=True;
 end;
 
-Constructor TJSValue.Create(ANumber: TJSNumber);
+constructor TJSValue.Create(ANumber: TJSNumber);
 begin
   AsNumber:=ANumber;
 end;
 
-Constructor TJSValue.Create(ABoolean: Boolean);
+constructor TJSValue.Create(ABoolean: Boolean);
 begin
   AsBoolean:=ABoolean;
 end;
 
-Constructor TJSValue.Create(AString: TJSString);
+constructor TJSValue.Create(AString: TJSString);
 begin
   AsString:=AString;
 end;
 
-Destructor TJSValue.Destroy;
+destructor TJSValue.Destroy;
 begin
   ClearValue(jstUndefined);
   inherited Destroy;

packages/fcl-js/src/jswriter.pp

@@ -425,20 +425,23 @@ procedure TJSWriter.WriteValue(V: TJSValue);
 Var
   S : String;
 begin
-  Case V.ValueType of
-     jstUNDEFINED : S:='undefined';
-     jstNull : s:='null';
-     jstBoolean : if V.AsBoolean then s:='true' else s:='false';
-     jstString : S:='"'+EscapeString(V.AsString)+'"';
-     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;
+  if V.CustomValue<>'' then
+    S:=V.CustomValue
+  else
+    Case V.ValueType of
+      jstUNDEFINED : S:='undefined';
+      jstNull : s:='null';
+      jstBoolean : if V.AsBoolean then s:='true' else s:='false';
+      jstString : S:='"'+EscapeString(V.AsString)+'"';
+      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;
 

packages/fcl-passrc/src/pasresolver.pp

@@ -91,10 +91,10 @@
   - arrays TPasArrayType
   - check if var initexpr fits vartype: var a: type = expr;
   - built-in functions high, low for range type and arrays
-
- ToDo:
   - procedure type
   - method type
+
+ ToDo:
   - char constant #0, #10, #13, UTF-8 char
   - const TArrayValues
   - classes - TPasClassType
@@ -370,6 +370,7 @@ const
 
 type
   TResolverBuiltInProc = (
+    bfCustom,
     bfLength,
     bfSetLength,
     bfInclude,
@@ -385,6 +386,7 @@ type
   TResolverBuiltInProcs = set of TResolverBuiltInProc;
 const
   ResolverBuiltInProcNames: array[TResolverBuiltInProc] of shortstring = (
+    'Custom',
     'Length',
     'SetLength',
     'Include',
@@ -397,7 +399,7 @@ const
     'Low',
     'High'
     );
-  bfAllStandardProcs = [low(TResolverBuiltInProc)..high(TResolverBuiltInProc)];
+  bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
 
 const
   ResolverResultVar = 'Result';
@@ -766,12 +768,13 @@ type
   TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
     out ResolvedEl: TPasResolverResult) of object;
 
-  { TResElDataBuiltInProc - CustomData for compiler built-in procs like 'length' }
+  { TResElDataBuiltInProc - TPasUnresolvedSymbolRef(aType).CustomData for compiler built-in procs like 'length' }
 
   TResElDataBuiltInProc = Class(TResElDataBuiltInSymbol)
   public
     Proc: TPasUnresolvedSymbolRef;
     Signature: string;
+    BuiltIn: TResolverBuiltInProc;
     GetCallCompatibility: TOnGetCallCompatibility;
     GetCallResult: TOnGetCallResult;
   end;
@@ -982,7 +985,8 @@ type
     function IsBaseType(aType: TPasType; BaseType: TResolverBaseType): boolean;
     function AddBuiltInProc(aName: shortstring; Signature: string;
       const GetCallCompatibility: TOnGetCallCompatibility;
-      const GetCallResult: TOnGetCallResult): TResElDataBuiltInProc;
+      const GetCallResult: TOnGetCallResult;
+      BuiltIn: TResolverBuiltInProc = bfCustom): TResElDataBuiltInProc;
     // add extra TResolveData (E.CustomData) to free list
     procedure AddResolveData(El: TPasElement; Data: TResolveData;
       Kind: TResolveDataListKind);
@@ -6214,37 +6218,37 @@ begin
     AddBaseType(BaseTypeNames[bt],bt);
   if bfLength in BaseProcs then
     AddBuiltInProc('Length','function Length(const String or Array): sizeint',
-        @OnGetCallCompatibility_Length,@OnGetCallResult_Length);
+        @OnGetCallCompatibility_Length,@OnGetCallResult_Length,bfLength);
   if bfSetLength in BaseProcs then
     AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)',
-        @OnGetCallCompatibility_SetLength,nil);
+        @OnGetCallCompatibility_SetLength,nil,bfSetLength);
   if bfInclude in BaseProcs then
     AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)',
-        @OnGetCallCompatibility_InExclude,nil);
+        @OnGetCallCompatibility_InExclude,nil,bfInclude);
   if bfExclude in BaseProcs then
     AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)',
-        @OnGetCallCompatibility_InExclude,nil);
+        @OnGetCallCompatibility_InExclude,nil,bfExclude);
   if bfOrd in BaseProcs then
     AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
-        @OnGetCallCompatibility_Ord,@OnGetCallResult_Ord);
+        @OnGetCallCompatibility_Ord,@OnGetCallResult_Ord,bfOrd);
   if bfExit in BaseProcs then
     AddBuiltInProc('Exit','procedure Exit(result)',
-        @OnGetCallCompatibility_Exit,nil);
+        @OnGetCallCompatibility_Exit,nil,bfExit);
   if bfInc in BaseProcs then
     AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)',
-        @OnGetCallCompatibility_IncDec,nil);
+        @OnGetCallCompatibility_IncDec,nil,bfInc);
   if bfDec in BaseProcs then
     AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)',
-        @OnGetCallCompatibility_IncDec,nil);
+        @OnGetCallCompatibility_IncDec,nil,bfDec);
   if bfAssigned in BaseProcs then
     AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean',
-        @OnGetCallCompatibility_Assigned,@OnGetCallResult_Assigned);
+        @OnGetCallCompatibility_Assigned,@OnGetCallResult_Assigned,bfAssigned);
   if bfLow in BaseProcs then
     AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
-        @OnGetCallCompatibility_LowHigh,@OnGetCallResult_LowHigh);
+        @OnGetCallCompatibility_LowHigh,@OnGetCallResult_LowHigh,bfLow);
   if bfHigh in BaseProcs then
     AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer',
-        @OnGetCallCompatibility_LowHigh,@OnGetCallResult_LowHigh);
+        @OnGetCallCompatibility_LowHigh,@OnGetCallResult_LowHigh,bfHigh);
 end;
 
 function TPasResolver.AddBaseType(aName: shortstring; Typ: TResolverBaseType
@@ -6272,7 +6276,8 @@ end;
 
 function TPasResolver.AddBuiltInProc(aName: shortstring; Signature: string;
   const GetCallCompatibility: TOnGetCallCompatibility;
-  const GetCallResult: TOnGetCallResult): TResElDataBuiltInProc;
+  const GetCallResult: TOnGetCallResult; BuiltIn: TResolverBuiltInProc
+  ): TResElDataBuiltInProc;
 var
   El: TPasUnresolvedSymbolRef;
 begin
@@ -6280,6 +6285,7 @@ begin
   Result:=TResElDataBuiltInProc.Create;
   Result.Proc:=El;
   Result.Signature:=Signature;
+  Result.BuiltIn:=BuiltIn;
   Result.GetCallCompatibility:=GetCallCompatibility;
   Result.GetCallResult:=GetCallResult;
   AddResolveData(El,Result,lkBuiltIn);

packages/pastojs/tests/tcconverter.pp

@@ -611,7 +611,7 @@ begin
   AssertNull('No second statement',L.B);
   L:=AssertListStatement('try..except block is statement list',El.BCatch);
   AssertAssignStatement('Correct assignment in except..end block',L.A,'b','c');
-  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),El.Ident);
+  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
   AssertNull('No second statement',L.B);
 end;
 
@@ -648,7 +648,7 @@ begin
   O.Body:=CreateAssignStatement('b','c');
   // Convert
   El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement));
-  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident);
+  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
   L:=AssertListStatement('try..except block is statement list',El.BCatch);
   AssertNull('No second statement',L.B);
   I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
@@ -696,7 +696,7 @@ begin
   O.Body:=TPasImplRaise.Create('',Nil);
   // Convert
   El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement));
-  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident);
+  AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
   L:=AssertListStatement('try..except block is statement list',El.BCatch);
   AssertNull('No second statement',L.B);
   I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
@@ -782,7 +782,7 @@ begin
   S:=TPrimitiveExpr.Create(Nil,pekString,'''me''');
   E:=TestLiteralExpression(S,TJSLiteral);
   AssertEquals('Correct literal type',jstString,E.Value.ValueType);
-  AssertEquals('Correct literal value','me',E.Value.AsString);
+  AssertEquals('Correct literal value','me',String(E.Value.AsString));
 end;
 
 Procedure TTestExpressionConverter.TestPrimitiveNumber;
@@ -843,7 +843,7 @@ Var
 begin
   Id:=TPrimitiveExpr.Create(Nil,pekIdent,'a');
   Res:=TJSPrimaryExpressionIdent(Convert(Id,TJSPrimaryExpressionIdent));
-  AssertEquals('Correct identifier name','a',Res.Name);
+  AssertEquals('Correct identifier name','a',String(Res.Name));
 end;
 
 Procedure TTestExpressionConverter.TestUnaryMinus;
@@ -1203,7 +1203,7 @@ begin
   Uni:=TJSUnary(AssertElement('Sl.A is TJSUnary',TJSUnary,Sl.A));
   Asi:=TJSSimpleAssignStatement(AssertElement('Sl.A is TJSUnary',TJSSimpleAssignStatement,Uni.A));
   pex:=TJSPrimaryExpressionIdent(AssertElement('Asi.LHS is TJSPrimaryExpressionIdent',TJSPrimaryExpressionIdent,Asi.LHS));
-  AssertEquals('Correct name','myclass',pex.Name);
+  AssertEquals('Correct name','myclass',String(pex.Name));
   Call:=TJSCallExpression(AssertElement('Asi.Expr is TJSCallExpression',TJSCallExpression,Asi.Expr));
   if Call=nil then ;
 end;
@@ -1264,7 +1264,7 @@ end;
 Class procedure TTestConverter.AssertLiteral(Const Msg : String; Lit: TJSElement; AValue: TJSString);
 begin
   AssertLiteral(Msg,Lit,jstString);
-  AssertEquals(Msg+': Correct value',AValue,TJSLiteral(Lit).Value.AsString);
+  AssertEquals(Msg+': Correct value',String(AValue),String(TJSLiteral(Lit).Value.AsString));
 end;
 
 Class procedure TTestConverter.AssertLiteral(Const Msg : String; Lit: TJSElement; AValue: TJSNumber);
@@ -1278,12 +1278,12 @@ Class procedure TTestConverter.AssertIdentifier(Const Msg: String;
 begin
   AssertNotNull(Msg+': Have instance',Ident);
   AssertEquals(Msg+': Correct class',TJSPrimaryExpressionIdent,Ident.ClassType);
-  AssertEquals(Msg+': Correct name',AName,TJSPrimaryExpressionIdent(Ident).Name);
+  AssertEquals(Msg+': Correct name',AName,String(TJSPrimaryExpressionIdent(Ident).Name));
 end;
 
 Class Function TTestConverter.CreateLiteral(AValue: String): TPasExpr;
 begin
-  Result:=TPrimitiveExpr.Create(Nil,pekString,'me');
+  Result:=TPrimitiveExpr.Create(Nil,pekString,AValue);
 end;
 
 Class Function TTestConverter.CreateLiteral(AValue: Double): TPasExpr;
@@ -1293,7 +1293,7 @@ Var
 
 begin
   Str(AValue,S);
-  Result:=TPrimitiveExpr.Create(Nil,pekNumber,S);
+  Result:=TPrimitiveExpr.Create(Nil,pekNumber,Trim(S));
 end;
 
 Class Function TTestConverter.CreateIdent(AName: String): TPrimitiveExpr;