From 2e0141575259c328f3792fab31acbee644c7ea8e Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 11 Nov 2017 17:04:22 +0000 Subject: [PATCH] pastojs: custom ranges: char, enum, integer git-svn-id: trunk@37575 - --- packages/pastojs/src/fppas2js.pp | 96 ++++++++++++++++----- packages/pastojs/tests/tcmodules.pas | 119 +++++++++++++++++++++------ 2 files changed, 170 insertions(+), 45 deletions(-) diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 4761ceab9f..f55e9e24e3 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -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 diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 53c5f9cadd..12787db726 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -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 () {', ' };',