diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 3c93372feb..a1b71b7d7c 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -51,6 +51,7 @@ Works: - setlength(s,newlen) -> s.length == newlen - read and write char aString[] - allow only String, no ShortString, AnsiString, UnicodeString,... + - allow type casting string to external class name 'String' - for loop - if loopvar is used afterwards append if($loopend>i)i--; - repeat..until @@ -111,6 +112,8 @@ Works: - array of record - equal, unequal nil -> array.length == 0 - when passing nil to an array argument, pass [] + - allow type casting array to external class name 'Array' + - type cast array to array of same dimensions and compatible element type - static arrays - range: enumtype - init as arr = rtl.arrayNewMultiDim([dim1,dim2,...],value) @@ -194,7 +197,8 @@ Works: - enums: assign to jsvalue, typecast jsvalue to enum - class instance: assign to jsvalue, typecast jsvalue to a class - class of: assign to jsvalue, typecast jsvalue to a class-of - - array of jsvalue + - array of jsvalue, + allow to assign any array to an array of jsvalue - parameter, result type, assign from/to untyped - operators equal, not equal @@ -207,8 +211,6 @@ ToDos: - proc delete(var array,const start,count) - function concat(array1,array2,...): array - function splice(var array, const start,deletecount,item1,item2,...): arrayofdeletedelements; -- allow type casting array to external class 'Array' -- allow type casting string to external class 'String' - test param const R: TRect r.Left:=3 fails - FuncName:= (instead of Result:=) - ord(s[i]) -> s.charCodeAt(i) @@ -645,23 +647,24 @@ type function AddJSBaseType(const aName: string; Typ: TPas2jsBaseType): TResElDataPas2JSBaseType; function IsJSBaseType(TypeEl: TPasType; Typ: TPas2jsBaseType): boolean; function IsJSBaseType(const TypeResolved: TPasResolverResult; Typ: TPas2jsBaseType): boolean; - function CheckTypeCastCustomBaseType(const TypeResolved: TPasResolverResult; - Param: TPasExpr; const ParamResolved: TPasResolverResult): integer; - override; - function CheckAssignCompatibilityCustomBaseType(const LHS, + function CheckAssignCompatibilityCustom(const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; - RaiseOnIncompatible: boolean): integer; override; - function CheckTypeCastClassInstanceToClass(Param: TPasExpr; - const FromClassRes, ToClassRes: TPasResolverResult): integer; override; + RaiseOnIncompatible: boolean; var Handled: boolean): integer; override; + function CheckTypeCastClassInstanceToClass(const FromClassRes, + ToClassRes: TPasResolverResult; ErrorEl: TPasElement): integer; override; function CheckEqualCompatibilityCustomType(const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer; override; public constructor Create; destructor Destroy; override; + // base types procedure AddObjFPCBuiltInIdentifiers( const TheBaseTypes: TResolveBaseTypes=btAllStandardTypes; const TheBaseProcs: TResolverBuiltInProcs=bfAllStandardProcs); override; + function CheckTypeCastRes(const FromResolved, + ToResolved: TPasResolverResult; ErrorEl: TPasElement; + RaiseOnError: boolean): integer; override; // compute literals and constants Function ExtractPasStringLiteral(El: TPasElement; const S: String): TJSString; virtual; Function ComputeConst(Expr: TPasExpr; StoreCustomData: boolean): TJSValue; virtual; @@ -1742,74 +1745,13 @@ begin Result:=(TypeResolved.BaseType=btCustom) and IsJSBaseType(TypeResolved.TypeEl,Typ); end; -function TPas2JSResolver.CheckTypeCastCustomBaseType( - const TypeResolved: TPasResolverResult; Param: TPasExpr; - const ParamResolved: TPasResolverResult): integer; -// either TypeResolved or ParamResolved is btCustom -var - JSBaseType: TPas2jsBaseType; - C: TClass; -begin - Result:=cIncompatible; - {$IFDEF VerbosePas2JS} - writeln('TPas2JSResolver.CheckTypeCastCustomBaseType Type=',GetResolverResultDesc(TypeResolved),' Param=',GetObjName(Param),'=',GetResolverResultDesc(ParamResolved)); - {$ENDIF} - if Param=nil then exit; - if (TypeResolved.BaseType=btCustom) then - begin - if not (TypeResolved.TypeEl is TPasUnresolvedSymbolRef) then - RaiseInternalError(20170325142826); - if not (TypeResolved.TypeEl.CustomData is TResElDataPas2JSBaseType) then - exit; - // type cast to pas2js type, e.g. JSValue(V) - JSBaseType:=TResElDataPas2JSBaseType(TypeResolved.TypeEl.CustomData).JSBaseType; - if JSBaseType=pbtJSValue then - begin - if rrfReadable in ParamResolved.Flags then - begin - if (ParamResolved.BaseType in btAllJSValueSrcTypes) then - Result:=cExact+1 // type cast to JSValue - else if ParamResolved.BaseType=btCustom then - begin - if IsJSBaseType(ParamResolved,pbtJSValue) then - Result:=cExact; - end - else if ParamResolved.BaseType=btContext then - Result:=cExact+1; - end; - end; - end - else if ParamResolved.BaseType=btCustom then - begin - if not (ParamResolved.TypeEl is TPasUnresolvedSymbolRef) then - RaiseInternalError(20170325143016); - if not (ParamResolved.TypeEl.CustomData is TResElDataPas2JSBaseType) then - exit; - // type cast a pas2js value, e.g. T(jsvalue) - if not (rrfReadable in ParamResolved.Flags) then - exit; - JSBaseType:=TResElDataPas2JSBaseType(ParamResolved.TypeEl.CustomData).JSBaseType; - if JSBaseType=pbtJSValue then - begin - if (TypeResolved.BaseType in btAllJSValueTypeCastTo) then - Result:=cExact+1 // type cast JSValue to simple base type - else if TypeResolved.BaseType=btContext then - begin - C:=TypeResolved.TypeEl.ClassType; - if (C=TPasClassType) - or (C=TPasClassOfType) - or (C=TPasEnumType) then - Result:=cExact+1; - end; - end; - end; -end; - -function TPas2JSResolver.CheckAssignCompatibilityCustomBaseType(const LHS, - RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean - ): integer; +function TPas2JSResolver.CheckAssignCompatibilityCustom(const LHS, + RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean; + var Handled: boolean): integer; var LeftBaseType: TPas2jsBaseType; + LArray: TPasArrayType; + ElTypeResolved: TPasResolverResult; begin Result:=cIncompatible; if LHS.BaseType=btCustom then @@ -1823,6 +1765,7 @@ begin end; if not (LHS.TypeEl.CustomData is TResElDataPas2JSBaseType) then exit; + Handled:=true; LeftBaseType:=TResElDataPas2JSBaseType(LHS.TypeEl.CustomData).JSBaseType; if LeftBaseType=pbtJSValue then begin @@ -1850,18 +1793,32 @@ begin end; end; end; + end + else if (LHS.BaseType=btContext) and (LHS.TypeEl.ClassType=TPasArrayType) then + begin + LArray:=TPasArrayType(LHS.TypeEl); + if length(LArray.Ranges)>0 then + exit; + if (RHS.BaseType<>btContext) or (RHS.TypeEl.ClassType<>TPasArrayType) then + exit; + ComputeElement(LArray.ElType,ElTypeResolved,[rcType]); + if IsJSBaseType(ElTypeResolved,pbtJSValue) then + begin + // array of jsvalue := array + Handled:=true; + Result:=cExact+1; + end; end; if RaiseOnIncompatible then if ErrorEl=nil then ; end; -function TPas2JSResolver.CheckTypeCastClassInstanceToClass(Param: TPasExpr; - const FromClassRes, ToClassRes: TPasResolverResult): integer; +function TPas2JSResolver.CheckTypeCastClassInstanceToClass(const FromClassRes, + ToClassRes: TPasResolverResult; ErrorEl: TPasElement): integer; var ToClass: TPasClassType; ClassScope: TPasClassScope; begin - if Param=nil then ; if FromClassRes.BaseType=btNil then exit(cExact); ToClass:=(ToClassRes.TypeEl as TPasClassType); ClassScope:=ToClass.CustomData as TPasClassScope; @@ -1870,6 +1827,7 @@ begin Result:=cExact+1 else Result:=cIncompatible; + if ErrorEl=nil then ; end; function TPas2JSResolver.CheckEqualCompatibilityCustomType(const LHS, @@ -1957,6 +1915,91 @@ begin ,TheBaseProcs); end; +function TPas2JSResolver.CheckTypeCastRes(const FromResolved, + ToResolved: TPasResolverResult; ErrorEl: TPasElement; RaiseOnError: boolean + ): integer; +var + JSBaseType: TPas2jsBaseType; + C: TClass; + CurClass: TPasClassType; +begin + Result:=cIncompatible; + {$IFDEF VerbosePas2JS} + writeln('TPas2JSResolver.CheckTypeCastCustomBaseType To=',GetResolverResultDesc(ToResolved),' From=',GetResolverResultDesc(FromResolved)); + {$ENDIF} + if (ToResolved.BaseType=btCustom) then + begin + if not (ToResolved.TypeEl is TPasUnresolvedSymbolRef) then + RaiseInternalError(20170325142826); + if (ToResolved.TypeEl.CustomData is TResElDataPas2JSBaseType) then + begin + // type cast to pas2js type, e.g. JSValue(V) + JSBaseType:=TResElDataPas2JSBaseType(ToResolved.TypeEl.CustomData).JSBaseType; + if JSBaseType=pbtJSValue then + begin + if rrfReadable in FromResolved.Flags then + begin + if (FromResolved.BaseType in btAllJSValueSrcTypes) then + Result:=cExact+1 // type cast to JSValue + else if FromResolved.BaseType=btCustom then + begin + if IsJSBaseType(FromResolved,pbtJSValue) then + Result:=cExact; + end + else if FromResolved.BaseType=btContext then + Result:=cExact+1; + end; + end; + exit; + end; + end + else if FromResolved.BaseType=btCustom then + begin + if not (FromResolved.TypeEl is TPasUnresolvedSymbolRef) then + RaiseInternalError(20170325143016); + if (FromResolved.TypeEl.CustomData is TResElDataPas2JSBaseType) then + begin + // type cast a pas2js value, e.g. T(jsvalue) + if not (rrfReadable in FromResolved.Flags) then + exit; + JSBaseType:=TResElDataPas2JSBaseType(FromResolved.TypeEl.CustomData).JSBaseType; + if JSBaseType=pbtJSValue then + begin + if (ToResolved.BaseType in btAllJSValueTypeCastTo) then + Result:=cExact+1 // type cast JSValue to simple base type + else if ToResolved.BaseType=btContext then + begin + C:=ToResolved.TypeEl.ClassType; + if (C=TPasClassType) + or (C=TPasClassOfType) + or (C=TPasEnumType) then + Result:=cExact+1; + end; + end; + exit; + end; + end + else if ToResolved.BaseType=btContext then + begin + C:=ToResolved.TypeEl.ClassType; + if C=TPasClassType then + begin + CurClass:=TPasClassType(ToResolved.TypeEl); + if CurClass.IsExternal then + begin + if (CurClass.ExternalName='String') + and (FromResolved.BaseType in btAllStringAndChars) then + exit(cExact); + if (CurClass.ExternalName='Array') + and ((FromResolved.BaseType=btArray) + or (FromResolved.BaseType=btContext)) then + exit(cExact); + end; + end + end; + Result:=inherited CheckTypeCastRes(FromResolved,ToResolved,ErrorEl,RaiseOnError); +end; + function TPas2JSResolver.ExtractPasStringLiteral(El: TPasElement; const S: String): TJSString; { Extracts the value from a Pascal string literal @@ -4016,6 +4059,7 @@ var DeclResolved, ParamResolved: TPasResolverResult; Param: TPasExpr; JSBaseType: TPas2jsBaseType; + C: TClass; begin Result:=nil; if El.Kind<>pekFuncParams then @@ -4031,8 +4075,9 @@ begin if Decl is TPasType then Decl:=AContext.Resolver.ResolveAliasType(TPasType(Decl)); //writeln('TPasToJSConverter.ConvertFuncParams pekFuncParams TResolvedReference ',GetObjName(Ref.Declaration),' ',GetObjName(Ref.Declaration.CustomData)); + C:=Decl.ClassType; - if Decl.ClassType=TPasUnresolvedSymbolRef then + if C=TPasUnresolvedSymbolRef then begin if Decl.CustomData is TResElDataBuiltInProc then begin @@ -4088,18 +4133,18 @@ begin Result:=ConvertExternalConstructor(Left,Ref,El,AContext); exit; end - else if Decl is TPasProcedure then + else if C.InheritsFrom(TPasProcedure) then TargetProcType:=TPasProcedure(Decl).ProcType - else if (Decl.ClassType=TPasEnumType) - or (Decl.ClassType=TPasClassType) - or (Decl.ClassType=TPasClassOfType) then + else if (C=TPasClassType) + or (C=TPasClassOfType) + or (C=TPasEnumType) + or (C=TPasArrayType) then begin // typecast + // default is to simply replace "aType(value)" with "value" Param:=El.Params[0]; AContext.Resolver.ComputeElement(Param,ParamResolved,[]); - // EnumType(value) -> value - // ClassType(value) -> value - // ClassOfType(value) -> value + Result:=ConvertElement(Param,AContext); if (ParamResolved.BaseType=btCustom) and (ParamResolved.TypeEl.CustomData is TResElDataPas2JSBaseType) then @@ -4107,8 +4152,8 @@ begin JSBaseType:=TResElDataPas2JSBaseType(ParamResolved.TypeEl.CustomData).JSBaseType; if JSBaseType=pbtJSValue then begin - if (Decl.ClassType=TPasClassType) - or (Decl.ClassType=TPasClassOfType) then + if (C=TPasClassType) + or (C=TPasClassOfType) then begin // TObject(jsvalue) -> rtl.getObject(jsvalue) Call:=CreateCallExpression(El); @@ -4120,7 +4165,7 @@ begin end; exit; end - else if (Decl is TPasVariable) then + else if C.InheritsFrom(TPasVariable) then begin AContext.Resolver.ComputeElement(Decl,DeclResolved,[rcType]); if DeclResolved.TypeEl is TPasProcedureType then @@ -4128,7 +4173,7 @@ begin else RaiseNotSupported(El,AContext,20170217115244); end - else if (Decl.ClassType=TPasArgument) then + else if (C=TPasArgument) then begin AContext.Resolver.ComputeElement(Decl,DeclResolved,[rcType]); if DeclResolved.TypeEl is TPasProcedureType then @@ -4136,8 +4181,8 @@ begin else RaiseNotSupported(El,AContext,20170328224020); end - else if (Decl.ClassType=TPasProcedureType) - or (Decl.ClassType=TPasFunctionType) then + else if (C=TPasProcedureType) + or (C=TPasFunctionType) then begin TargetProcType:=TPasProcedureType(Decl); end @@ -5402,6 +5447,8 @@ function TPasToJSConverter.ConvertBuiltInCopyArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; begin Result:=nil; + if El=nil then ; + if AContext=nil then; end; function TPasToJSConverter.ConvertRecordValues(El: TRecordValues; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 36c0789624..70e2097704 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -274,6 +274,7 @@ type Procedure TestArray_SetLengthProperty; Procedure TestArray_OpenArrayOfString; Procedure TestArray_Concat; + Procedure TestExternalClass_TypeCastArrayToExternalArray; // ToDo: const array // ToDo: SetLength(array of static array) @@ -361,6 +362,7 @@ type Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail; Procedure TestExternalClass_NewInstance_SecondParamTyped_Fail; Procedure TestExternalClass_TypeCastToRootClass; + Procedure TestExternalClass_TypeCastStringToExternalString; // proc types Procedure TestProcType; @@ -4508,7 +4510,7 @@ begin Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue);'); Add(' arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);'); ConvertProgram; - CheckSource('TestRecord_Var', + CheckSource('TestArray_Concat', LinesToStr([ // statements 'this.TFlag = {', ' "0": "big",', @@ -4547,6 +4549,33 @@ begin ''])); end; +procedure TTestModule.TestExternalClass_TypeCastArrayToExternalArray; +begin + StartProgram(false); + Add('{$modeswitch externalclass}'); + Add('type'); + Add(' TJSArray = class external name ''Array'''); + Add(' class function isArray(Value: JSValue) : boolean;'); + Add(' function concat() : TJSArray; varargs;'); + Add(' end;'); + Add('var'); + Add(' aObj: TJSArray;'); + Add(' a: array of longint;'); + Add('begin'); + Add(' if TJSArray.isArray(65) then ;'); + Add(' aObj:=TJSArray(a).concat(a);'); + ConvertProgram; + CheckSource('TestExternalClass_TypeCastArrayToExternalArray', + LinesToStr([ // statements + 'this.aObj = null;', + 'this.a = [];', + '']), + LinesToStr([ // this.$main + 'if (Array.isArray(65)) ;', + 'this.aObj = this.a.concat(this.a);', + ''])); +end; + procedure TTestModule.TestRecord_Var; begin StartProgram(false); @@ -8232,6 +8261,33 @@ begin ''])); end; +procedure TTestModule.TestExternalClass_TypeCastStringToExternalString; +begin + StartProgram(false); + Add('{$modeswitch externalclass}'); + Add('type'); + Add(' TJSString = class external name ''String'''); + Add(' class function fromCharCode() : string; varargs;'); + Add(' function anchor(const aName : string) : string;'); + Add(' end;'); + Add('var'); + Add(' s: string;'); + Add('begin'); + Add(' s:=TJSString.fromCharCode(65,66);'); + Add(' s:=TJSString(s).anchor(s);'); + Add(' s:=TJSString(''foo'').anchor(s);'); + ConvertProgram; + CheckSource('TestExternalClass_TypeCastStringToExternalString', + LinesToStr([ // statements + 'this.s = "";', + '']), + LinesToStr([ // this.$main + 'this.s = String.fromCharCode(65, 66);', + 'this.s = this.s.anchor(this.s);', + 'this.s = "foo".anchor(this.s);', + ''])); +end; + procedure TTestModule.TestProcType; begin StartProgram(false); @@ -9319,20 +9375,24 @@ begin Add(' integer = longint;'); Add(' TArray = array of JSValue;'); Add(' TArrgh = tarray;'); + Add(' TArrInt = array of integer;'); Add('var'); Add(' v: jsvalue;'); - Add(' TheArray: TArray;'); - Add(' Arr: TArrgh;'); + Add(' TheArray: tarray;'); + Add(' Arr: tarrgh;'); Add(' i: integer;'); + Add(' ArrInt: tarrint;'); Add('begin'); - Add(' Arr:=TheArray;'); - Add(' TheArray:=Arr;'); - Add(' SetLength(Arr,2);'); - Add(' SetLength(TheArray,3);'); - Add(' Arr[4]:=v;'); - Add(' Arr[5]:=i;'); - Add(' Arr[6]:=nil;'); - Add(' Arr[7]:=TheArray[8];'); + Add(' arr:=thearray;'); + Add(' thearray:=arr;'); + Add(' setlength(arr,2);'); + Add(' setlength(thearray,3);'); + Add(' arr[4]:=v;'); + Add(' arr[5]:=i;'); + Add(' arr[6]:=nil;'); + Add(' arr[7]:=thearray[8];'); + Add(' arr:=arrint;'); + Add(' arrInt:=tarrint(arr);'); ConvertProgram; CheckSource('TestJSValue_ArrayOfJSValue', LinesToStr([ // statements @@ -9340,6 +9400,7 @@ begin 'this.TheArray = [];', 'this.Arr = [];', 'this.i = 0;', + 'this.ArrInt = [];', '']), LinesToStr([ // this.$main 'this.Arr = this.TheArray;', @@ -9350,6 +9411,8 @@ begin 'this.Arr[5] = this.i;', 'this.Arr[6] = null;', 'this.Arr[7] = this.TheArray[8];', + 'this.Arr = this.ArrInt;', + 'this.ArrInt = this.Arr;', ''])); end;