paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 02:29:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: custom ranges: char, enum, integer

Browse Source 
git-svn-id: trunk@37575 -
This commit is contained in:
Mattias Gaertner 2017-11-11 17:04:22 +00:00
parent a5f79ad390
commit 2e01415752
2 changed files with 170 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
packages/pastojs/src/fppas2js.pp
View File

@ -251,8 +251,17 @@ Works:
- use 0b for binary literals
- use 0o for octal literals
- dotted unit names, namespaces
- resourcestring
ToDos:
- enum range, int range, char range, set of enumrange, set of intrange, set of charrange
- custom ranges
- enum: low(), high(), pred(), succ(), ord(), rg(int), int(rg), enum:=rg,
rg:=rg, rg1:=rg2, rg:=enum, =, <>, in
array[rg], low(array), high(array)
- enumeration for..in..do
enum, set, char, intrange, enumrange, array
- typecast longint(highprecint) -> (value+0) & $ffffffff
- static arrays
- a[] of record
- RTTI
@ -263,8 +272,6 @@ ToDos:
- var absolute
- check memleaks
- make records more lightweight
- enumeration for..in..do
- resourcestring
- pointer of record
- nested types in class
- asm: pas() - useful for overloads and protect an identifier from optimization
@ -2016,13 +2023,60 @@ end;
procedure TPas2JSResolver.FinishSetType(El: TPasSetType);
var
TypeEl: TPasType;
C: TClass;
RangeValue: TResEvalValue;
bt: TResolverBaseType;
begin
inherited FinishSetType(El);
TypeEl:=ResolveAliasType(El.EnumType);
if TypeEl.ClassType=TPasEnumType then
// ok
else
RaiseMsg(20170415182320,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
C:=TypeEl.ClassType;
if C=TPasEnumType then
exit
else if C=TPasUnresolvedSymbolRef then
begin
if TypeEl.CustomData is TResElDataBaseType then
begin
bt:=TResElDataBaseType(TypeEl.CustomData).BaseType;
if bt in [btBoolean,btByte,btShortInt,btSmallInt,btWord,btChar,btWideChar] then
exit; // ok
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' TypeEl=',GetObjName(TypeEl),' ',bt);
{$ENDIF}
RaiseMsg(20171110150000,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
end;
end
else if C=TPasRangeType then
begin
RangeValue:=Eval(TPasRangeType(TypeEl).RangeExpr,[refConst]);
try
case RangeValue.Kind of
revkRangeInt:
begin
if TResEvalRangeInt(RangeValue).RangeEnd-TResEvalRangeInt(RangeValue).RangeStart>$ffff then
begin
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' Range='+RangeValue.AsDebugString,' ',bt);
{$ENDIF}
RaiseMsg(20171110150159,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
end;
exit;
end;
else
begin
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' Range='+RangeValue.AsDebugString);
{$ENDIF}
RaiseMsg(20171110145211,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
end;
end;
finally
ReleaseEvalValue(RangeValue);
end;
end;
{$IFDEF VerbosePas2JS}
writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' TypeEl=',GetObjName(TypeEl));
{$ENDIF}
RaiseMsg(20170415182320,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
end;
procedure TPas2JSResolver.FinishClassType(El: TPasClassType);
@ -10521,6 +10575,9 @@ begin
BinExp:=Nil;
if AContext.Access<>caRead then
RaiseInconsistency(20170213213740);
if not (El.LoopType in [ltNormal,ltDown]) then
RaiseNotSupported(El,AContext,20171110141937);
// get function context
FuncContext:=AContext;
while (FuncContext.Parent<>nil) and (not (FuncContext is TFunctionContext)) do
@ -10931,7 +10988,7 @@ var
bt: TResolverBaseType;
JSBaseType: TPas2jsBaseType;
C: TClass;
ResolvedEl: TPasResolverResult;
Value: TResEvalValue;
begin
T:=PasType;
if AContext.Resolver<>nil then
@ -10970,20 +11027,14 @@ begin
// a "set" without initial value
Result:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El))
else if (C=TPasRangeType) and (AContext.Resolver<>nil) then
// a custom range without initial value
// a custom range without initial value -> use first value
begin
AContext.Resolver.ComputeElement(PasType,ResolvedEl,[rcType]);
if ResolvedEl.BaseType in btAllInteger then
Result:=CreateLiteralNumber(El,0)
else if ResolvedEl.BaseType in btAllStringAndChars then
Result:=CreateLiteralJSString(El,'')
else
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateValInit ',GetResolverResultDbg(ResolvedEl));
{$ENDIF}
RaiseNotSupported(El,AContext,20170925203052);
end;
Value:=AContext.Resolver.Eval(TPasRangeType(T).RangeExpr.left,[refConst]);
try
Result:=ConvertConstValue(Value,AContext,El);
finally
ReleaseEvalValue(Value);
end;
end
else
begin
@ -11196,7 +11247,8 @@ begin
if AContext.Resolver<>nil then
begin
AContext.Resolver.ComputeElement(Expr,ExprResolved,[]);
if ExprResolved.BaseType in btAllJSStringAndChars then
if (ExprResolved.BaseType in btAllJSStringAndChars)
or ((ExprResolved.BaseType=btRange) and (ExprResolved.SubType in btAllJSChars)) then
begin
// aChar -> aChar.charCodeAt()
Call:=TJSCallExpression(CreateElement(TJSCallExpression,Expr));
@ -11277,7 +11329,7 @@ begin
end
else if ExprResolved.BaseType in btAllStringAndChars then
begin
US:=TJSString(AContext.Resolver.ComputeConstString(Expr,false,true));
US:=TJSString(UTF8Decode(AContext.Resolver.ComputeConstString(Expr,false,true)));
for i:=1 to length(US) do
ArrLit.Elements.AddElement.Expr:=CreateLiteralJSString(Expr,US[i]);
end

119
packages/pastojs/tests/tcmodules.pas
View File

@ -203,6 +203,7 @@ type
// numbers
Procedure TestDouble;
Procedure TestIntegerRange;
// strings
Procedure TestCharConst;
@ -220,6 +221,7 @@ type
Procedure TestBaseType_ShortStringFail;
Procedure TestBaseType_RawByteStringFail;
Procedure TestTypeShortstring_Fail;
Procedure TestCharSet_Custom;
// alias types
Procedure TestAliasTypeRef;
@ -271,8 +273,6 @@ type
Procedure TestSet_Property;
Procedure TestSet_EnumConst;
Procedure TestSet_AnonymousEnumType;
Procedure TestSet_CharFail;
Procedure TestSet_BooleanFail;
Procedure TestSet_ConstEnum;
Procedure TestSet_ConstChar;
Procedure TestSet_ConstInt;
@ -3657,26 +3657,6 @@ begin
'']));
end;
procedure TTestModule.TestSet_CharFail;
begin
StartProgram(false);
Add('type');
Add(' TChars = set of char;');
Add('begin');
SetExpectedPasResolverError('Not supported: set of Char',nNotSupportedX);
ConvertProgram;
end;
procedure TTestModule.TestSet_BooleanFail;
begin
StartProgram(false);
Add('type');
Add(' TBools = set of boolean;');
Add('begin');
SetExpectedPasResolverError('Not supported: set of Boolean',nNotSupportedX);
ConvertProgram;
end;
procedure TTestModule.TestSet_ConstEnum;
begin
StartProgram(false);
@ -4050,6 +4030,53 @@ begin
'']));
end;
procedure TTestModule.TestIntegerRange;
begin
StartProgram(false);
Add([
'const',
' MinInt = -1;',
' MaxInt = +1;',
'type',
' {#TMyInt}TMyInt = MinInt..MaxInt;',
' TInt2 = 1..3;',
'const',
' a = low(TMyInt)+High(TMyInt);',
' b = low(TInt2)+High(TInt2);',
' s1 = [1];',
' s2 = [1,2];',
' s3 = [1..3];',
' s4 = [low(shortint)..high(shortint)];',
' s5 = [succ(low(shortint))..pred(high(shortint))];',
' s6 = 1 in s2;',
'var',
' i: TMyInt;',
' i2: TInt2;',
'begin',
' i:=i2;',
' if i=i2 then ;']);
ConvertProgram;
CheckSource('TestIntegerRange',
LinesToStr([
'this.MinInt = -1;',
'this.MaxInt = +1;',
'this.a = -1 + 1;',
'this.b = 1 + 3;',
'this.s1 = rtl.createSet(1);',
'this.s2 = rtl.createSet(1, 2);',
'this.s3 = rtl.createSet(null, 1, 3);',
'this.s4 = rtl.createSet(null, -128, 127);',
'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
'this.s6 = 1 in $mod.s2;',
'this.i = -1;',
'this.i2 = 1;',
'']),
LinesToStr([
'$mod.i = $mod.i2;',
'if ($mod.i === $mod.i2) ;',
'']));
end;
procedure TTestModule.TestCharConst;
begin
StartProgram(false);
@ -4423,6 +4450,50 @@ begin
ConvertProgram;
end;
procedure TTestModule.TestCharSet_Custom;
begin
StartProgram(false);
Add([
'type',
' TCharRg = ''a''..''z'';',
' TSetOfCharRg = set of TCharRg;',
' TCharRg2 = ''m''..''p'';',
'const',
' crg: TCharRg = ''b'';',
'var',
' c: char;',
' crg2: TCharRg2;',
' s: TSetOfCharRg;',
'begin',
' c:=crg;',
' crg:=c;',
' crg2:=crg;',
' if c=crg then ;',
' if crg=c then ;',
' if crg=crg2 then ;',
' if c in s then ;',
' if crg2 in s then ;',
'']);
ConvertProgram;
CheckSource('TestCharSet_Custom',
LinesToStr([ // statements
'this.crg = "b";',
'this.c = "";',
'this.crg2 = "m";',
'this.s = {};',
'']),
LinesToStr([ // this.$main
'$mod.c = $mod.crg;',
'$mod.crg = $mod.c;',
'$mod.crg2 = $mod.crg;',
'if ($mod.c === $mod.crg) ;',
'if ($mod.crg === $mod.c) ;',
'if ($mod.crg === $mod.crg2) ;',
'if ($mod.c.charCodeAt() in $mod.s) ;',
'if ($mod.crg2.charCodeAt() in $mod.s) ;',
'']));
end;
procedure TTestModule.TestProcTwoArgs;
begin
StartProgram(false);
@ -5207,6 +5278,7 @@ begin
Add(' Arr2: TChars2;');
Add(' Arr3: array[2..4] of char = (''p'',''a'',''s'');');
Add(' Arr4: array[11..13] of char = ''pas'';');
Add(' Arr5: array[21..22] of char = ''äö'';');
Add(' c: char;');
Add(' b: boolean;');
Add('begin');
@ -5229,6 +5301,7 @@ begin
'this.Arr2 = rtl.arraySetLength(null, "", 26);',
'this.Arr3 = ["p", "a", "s"];',
'this.Arr4 = ["p", "a", "s"];',
'this.Arr5 = ["ä", "ö"];',
'this.c = "";',
'this.b = false;',
'']),
@ -13977,7 +14050,7 @@ begin
'this.h = 1;',
'rtl.createClass($mod, "TObject", null, function () {',
' this.$init = function () {',
' this.FV = 0;',
' this.FV = -1;',
' };',
' this.$final = function () {',
' };',