diff --git a/.gitattributes b/.gitattributes index 724fc7dab0..c91d6e1ea9 100644 --- a/.gitattributes +++ b/.gitattributes @@ -3898,6 +3898,7 @@ packages/fcl-passrc/tests/tcgenerics.pp svneol=native#text/plain packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain +packages/fcl-passrc/tests/tcpaswritestatements.pas svneol=native#text/plain packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain packages/fcl-passrc/tests/tcresolvegenerics.pas svneol=native#text/plain packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain @@ -18406,6 +18407,7 @@ tests/webtbs/tw3578.pp svneol=native#text/plain tests/webtbs/tw3579.pp svneol=native#text/plain tests/webtbs/tw35820.pp svneol=native#text/pascal tests/webtbs/tw3583.pp svneol=native#text/plain +tests/webtbs/tw35841.pp svneol=native#text/pascal tests/webtbs/tw35862.pp svneol=native#text/pascal tests/webtbs/tw35878.pp svneol=native#text/plain tests/webtbs/tw35878a.pp svneol=native#text/plain diff --git a/compiler/ncal.pas b/compiler/ncal.pas index ab9001d972..30d9d3cefb 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -5203,18 +5203,7 @@ implementation inlineinitstatement:=nil; inlinecleanupstatement:=nil; - { we cannot replace the whole block by a single assignment if the call - has an init/cleanup block - - we could though (not yet done), convert this into a bew block - consisting of the init code, the single assignment and the cleanup block - This might even enable new transformations } - if not(assigned(callinitblock)) and not(assigned(callcleanupblock)) then - { if all that's left of the inlined function is an constant assignment - to the result, replace the whole block with the constant only } - n:=optimize_funcret_assignment(inlineblock) - else - n:=nil; + n:=optimize_funcret_assignment(inlineblock); if assigned(n) then begin inlineblock.free; diff --git a/compiler/x86/aoptx86.pas b/compiler/x86/aoptx86.pas index 9b2d929686..975be47eb3 100644 --- a/compiler/x86/aoptx86.pas +++ b/compiler/x86/aoptx86.pas @@ -4166,7 +4166,7 @@ unit aoptx86; if MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^) and MatchOpType(taicpu(p),top_reg,top_reg) and GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and - MatchInstruction(taicpu(hp1),taicpu(p).opcode,[taicpu(p).opsize]) and + MatchInstruction(hp1,taicpu(p).opcode,[taicpu(p).opsize]) and MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[0]^) and MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^) then begin @@ -4174,7 +4174,37 @@ unit aoptx86; RemoveInstruction(hp1); Result:=true; Exit; - end; + end + { + replace + pxor reg1,reg1 + movapd/s reg1,reg2 + dealloc reg1 + + by + + pxor reg2,reg2 + } + else if GetNextInstruction(p,hp1) and + { we mix single and double opperations here because we assume that the compiler + generates vmovapd only after double operations and vmovaps only after single operations } + MatchInstruction(hp1,A_MOVAPD,A_MOVAPS,[S_NO]) and + MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^) and + MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and + (taicpu(p).oper[0]^.typ=top_reg) then + begin + TransferUsedRegs(TmpUsedRegs); + UpdateUsedRegs(TmpUsedRegs, tai(p.next)); + if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then + begin + taicpu(p).loadoper(0,taicpu(hp1).oper[1]^); + taicpu(p).loadoper(1,taicpu(hp1).oper[1]^); + DebugMsg(SPeepholeOptimization + 'PXorMovapd2PXor done',p); + RemoveInstruction(hp1); + result:=true; + end; + end; + end; @@ -4193,7 +4223,7 @@ unit aoptx86; if MatchOperand(taicpu(p).oper[0]^,taicpu(p).oper[1]^,taicpu(p).oper[2]^) and MatchOpType(taicpu(p),top_reg,top_reg,top_reg) and GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and - MatchInstruction(taicpu(hp1),taicpu(p).opcode,[taicpu(p).opsize]) and + MatchInstruction(hp1,taicpu(p).opcode,[taicpu(p).opsize]) and MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[0]^) and MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^,taicpu(hp1).oper[2]^) then begin @@ -4201,7 +4231,9 @@ unit aoptx86; RemoveInstruction(hp1); Result:=true; Exit; - end; + end + else + Result:=OptPass1VOP(p); end; function TX86AsmOptimizer.OptPass1Imul(var p: tai): boolean; @@ -6005,7 +6037,7 @@ unit aoptx86; function TX86AsmOptimizer.SkipSimpleInstructions(var hp1 : tai) : Boolean; begin { we can skip all instructions not messing with the stack pointer } - while assigned(hp1) and {MatchInstruction(taicpu(hp1),[A_LEA,A_MOV,A_MOVQ,A_MOVSQ,A_MOVSX,A_MOVSXD,A_MOVZX, + while assigned(hp1) and {MatchInstruction(hp1,[A_LEA,A_MOV,A_MOVQ,A_MOVSQ,A_MOVSX,A_MOVSXD,A_MOVZX, A_AND,A_OR,A_XOR,A_ADD,A_SHR,A_SHL,A_IMUL,A_SETcc,A_SAR,A_SUB,A_TEST,A_CMOVcc, A_MOVSS,A_MOVSD,A_MOVAPS,A_MOVUPD,A_MOVAPD,A_MOVUPS, A_VMOVSS,A_VMOVSD,A_VMOVAPS,A_VMOVUPD,A_VMOVAPD,A_VMOVUPS],[]) and} diff --git a/compiler/x86/nx86con.pas b/compiler/x86/nx86con.pas index f67195dc95..175bc35399 100644 --- a/compiler/x86/nx86con.pas +++ b/compiler/x86/nx86con.pas @@ -41,6 +41,7 @@ implementation symdef, defutil, cpubase, + aasmdata, cga,cgx86,cgobj,cgbase,cgutils; {***************************************************************************** @@ -68,14 +69,26 @@ implementation location.register:=NR_ST; tcgx86(cg).inc_fpu_stack; end - else if (value_real=0.0) and not(use_vectorfpu(resultdef)) then + else if value_real=0.0 then begin - emit_none(A_FLDZ,S_NO); - if (get_real_sign(value_real) < 0) then - emit_none(A_FCHS,S_NO); - location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef)); - location.register:=NR_ST; - tcgx86(cg).inc_fpu_stack; + if use_vectorfpu(resultdef) then + begin + location_reset(location,LOC_MMREGISTER,def_cgsize(resultdef)); + location.register:=cg.getmmregister(current_asmdata.CurrAsmList,def_cgsize(resultdef)); + if UseAVX then + emit_reg_reg_reg(A_VPXOR,S_NO,location.register,location.register,location.register) + else + emit_reg_reg(A_PXOR,S_NO,location.register,location.register); + end + else + begin + emit_none(A_FLDZ,S_NO); + if (get_real_sign(value_real) < 0) then + emit_none(A_FCHS,S_NO); + location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef)); + location.register:=NR_ST; + tcgx86(cg).inc_fpu_stack; + end; end else inherited pass_generate_code; diff --git a/compiler/x86_64/nx64flw.pas b/compiler/x86_64/nx64flw.pas index b205bf8987..20ac25cf57 100644 --- a/compiler/x86_64/nx64flw.pas +++ b/compiler/x86_64/nx64flw.pas @@ -321,6 +321,12 @@ procedure tx64tryfinallynode.pass_generate_code; cg.a_label(current_asmdata.CurrAsmList,endtrylabel); end; + { i32913 - if the try..finally block is also inside a try..finally or + try..except block, make a note of any Exit calls so all necessary labels + are generated. [Kit] } + if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then + Include(oldflowcontrol, fc_exit); + flowcontrol:=[fc_inflowcontrol]; { generate finally code as a separate procedure } if not implicitframe then @@ -431,6 +437,12 @@ procedure tx64tryexceptnode.pass_generate_code; current_procinfo.CurrBreakLabel:=breakexceptlabel; end; + { i32913 - if the try..finally block is also inside a try..finally or + try..except block, make a note of any Exit calls so all necessary labels + are generated. [Kit] } + if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then + Include(oldflowcontrol, fc_exit); + flowcontrol:=[fc_inflowcontrol]; { on statements } if assigned(right) then @@ -521,6 +533,12 @@ errorexit: { restore all saved labels } endexceptlabel:=oldendexceptlabel; + { i32913 - if the try..finally block is also inside a try..finally or + try..except block, make a note of any Exit calls so all necessary labels + are generated. [Kit] } + if (fc_exit in flowcontrol) and (fc_inflowcontrol in oldflowcontrol) then + Include(oldflowcontrol, fc_exit); + { restore the control flow labels } current_procinfo.CurrExitLabel:=oldCurrExitLabel; if assigned(oldBreakLabel) then diff --git a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp index 94cb28b9af..a3c63300b7 100644 --- a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp +++ b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp @@ -44,7 +44,6 @@ type TArrayStringArray = Array of TStringArray; PArrayStringArray = ^TArrayStringArray; - // VFS not supported at this time. // Do not change the order. See NativeFlags constant in GetSQLiteOpenFlags. TSQLiteOpenFlag = ( @@ -69,8 +68,10 @@ Type private fhandle: psqlite3; FOpenFlags: TSQLiteOpenFlags; + FVFS: String; function GetSQLiteOpenFlags: Integer; procedure SetOpenFlags(AValue: TSQLiteOpenFlags); + procedure SetVFS(const AValue: String); protected procedure DoInternalConnect; override; procedure DoInternalDisconnect; override; @@ -125,6 +126,7 @@ Type procedure LoadExtension(const LibraryFile: string); Published Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags; + Property VFS : String Read FVFS Write SetVFS; Property AlwaysUseBigint : Boolean Read GetAlwaysUseBigint Write SetAlwaysUseBigint; end; @@ -857,16 +859,28 @@ begin FOpenFlags:=AValue; end; +procedure TSQLite3Connection.SetVFS(const AValue: String); +begin + if FVFS=AValue then Exit; + CheckDisConnected; + FVFS:=AValue; +end; + procedure TSQLite3Connection.DoInternalConnect; var filename: ansistring; + pvfs: PChar; begin Inherited; if DatabaseName = '' then DatabaseError(SErrNoDatabaseName,self); InitializeSQLite; filename := DatabaseName; - checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,Nil)); + if FVFS <> '' then + pvfs := PAnsiChar(FVFS) + else + pvfs := Nil; + checkerror(sqlite3_open_v2(PAnsiChar(filename),@fhandle,GetSQLiteOpenFlags,pvfs)); if (Length(Password)>0) and assigned(sqlite3_key) then checkerror(sqlite3_key(fhandle,PChar(Password),StrLen(PChar(Password)))); if Params.IndexOfName('foreign_keys') <> -1 then diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 4a075ee73c..fdcb37fa05 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -9577,59 +9577,42 @@ type var ValueSet: TResEvalSet): boolean; var CaseExprType: TPasType; + bt: TResolverBaseType; + ElTypeResolved: TPasResolverResult; begin Result:=false; - if ResolvedEl.BaseType in btAllInteger then + bt:=ResolvedEl.BaseType; + if bt in btAllStrings then + exit(true) + else if bt=btRange then + bt:=ResolvedEl.SubType; + if bt in btAllInteger then begin ValueSet:=TResEvalSet.CreateEmpty(revskInt); Result:=true; end - else if ResolvedEl.BaseType in btAllBooleans then + else if bt in btAllBooleans then begin ValueSet:=TResEvalSet.CreateEmpty(revskBool); Result:=true; end - else if ResolvedEl.BaseType in btAllChars then + else if bt in btAllChars then begin ValueSet:=TResEvalSet.CreateEmpty(revskChar); Result:=true; end - else if ResolvedEl.BaseType in btAllStrings then - Result:=true - else if ResolvedEl.BaseType=btContext then + else if bt=btContext then begin CaseExprType:=ResolvedEl.LoTypeEl; if CaseExprType.ClassType=TPasEnumType then begin ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType); Result:=true; - end; - end - else if ResolvedEl.BaseType=btRange then - begin - if ResolvedEl.SubType in btAllInteger then - begin - ValueSet:=TResEvalSet.CreateEmpty(revskInt); - Result:=true; end - else if ResolvedEl.SubType in btAllBooleans then + else if CaseExprType.ClassType=TPasRangeType then begin - ValueSet:=TResEvalSet.CreateEmpty(revskBool); - Result:=true; - end - else if ResolvedEl.SubType in btAllChars then - begin - ValueSet:=TResEvalSet.CreateEmpty(revskChar); - Result:=true; - end - else if ResolvedEl.SubType=btContext then - begin - CaseExprType:=ResolvedEl.LoTypeEl; - if CaseExprType.ClassType=TPasEnumType then - begin - ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType); - Result:=true; - end; + ComputeElement(TPasRangeType(CaseExprType).RangeExpr.left,ElTypeResolved,[rcConstant]); + Result:=CreateValues(ElTypeResolved,ValueSet); end; end; end; @@ -18853,6 +18836,7 @@ var Param: TPasExpr; ParamResolved, IncrResolved: TPasResolverResult; TypeEl: TPasType; + bt: TResolverBaseType; begin if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then exit(cIncompatible); @@ -18872,18 +18856,23 @@ begin RaiseVarExpected(20170216152319,Expr,ParamResolved.IdentEl); exit; end; - if ParamResolved.BaseType in btAllInteger then + bt:=ParamResolved.BaseType; + if bt=btRange then + bt:=ParamResolved.SubType; + if bt in btAllInteger then Result:=cExact - else if ParamResolved.BaseType=btPointer then + else if bt=btPointer then begin if ElHasBoolSwitch(Expr,bsPointerMath) then Result:=cExact; end - else if ParamResolved.BaseType=btContext then + else if bt=btContext then begin TypeEl:=ParamResolved.LoTypeEl; if (TypeEl.ClassType=TPasPointerType) and ElHasBoolSwitch(Expr,bsPointerMath) then + Result:=cExact + else if TypeEl.ClassType=TPasRangeType then Result:=cExact; end; if Result=cIncompatible then @@ -19493,18 +19482,22 @@ function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr; end; var - TypeEl: TPasType; + bt: TResolverBaseType; + C: TClass; begin Result:=cIncompatible; - if ParamResolved.BaseType in (btAllInteger+btAllBooleans+btAllFloats) then + bt:=ParamResolved.BaseType; + if bt=btRange then + bt:=ParamResolved.SubType; + if bt in (btAllInteger+btAllBooleans+btAllFloats) then Result:=cExact - else if IsFunc and (ParamResolved.BaseType in btAllStringAndChars) then + else if IsFunc and (bt in btAllStringAndChars) then Result:=cExact - else if ParamResolved.BaseType=btContext then + else if bt=btContext then begin - TypeEl:=ParamResolved.LoTypeEl; - if TypeEl.ClassType=TPasEnumType then - Result:=cExact + C:=ParamResolved.LoTypeEl.ClassType; + if (C=TPasEnumType) or (C=TPasRangeType) then + Result:=cExact end; if Result=cIncompatible then exit(CheckRaiseTypeArgNo(20170319220517,ArgNo,Param,ParamResolved,'boolean, integer, enum value',RaiseOnError)); @@ -19673,6 +19666,8 @@ var Params: TParamsExpr; Param: TPasExpr; ParamResolved: TPasResolverResult; + bt: TResolverBaseType; + C: TClass; begin if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then exit(cIncompatible); @@ -19693,11 +19688,15 @@ begin Result:=cIncompatible; if ResolvedElCanBeVarParam(ParamResolved,Expr) then begin - if ParamResolved.BaseType in (btAllInteger+btAllBooleans+btAllFloats) then + bt:=ParamResolved.BaseType; + if bt=btRange then + bt:=ParamResolved.SubType; + if bt in (btAllInteger+btAllBooleans+btAllFloats) then Result:=cExact - else if ParamResolved.BaseType=btContext then + else if bt=btContext then begin - if ParamResolved.LoTypeEl is TPasEnumType then + C:=ParamResolved.LoTypeEl.ClassType; + if (C=TPasEnumType) or (C=TPasRangeType) then Result:=cExact; end; end; @@ -29730,8 +29729,8 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer; DestParams:=DestSpecializedFromItem.Params; for i:=0 to length(SrcParams)-1 do begin - SrcParam:=SrcParams[i]; - DestParam:=DestParams[i]; + SrcParam:=ResolveAliasType(SrcParams[i]); + DestParam:=ResolveAliasType(DestParams[i]); if (SrcParam is TPasGenericTemplateType) or (DestParam is TPasGenericTemplateType) or (SrcParam=DestParam) diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 9687ee07b2..4ec9758b36 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -5847,7 +5847,11 @@ begin begin If (Result<>'') then Result:=Result+', '; - Result:=Result+Params[I].GetDeclaration(Full); + Result:=Result+Params[I].GetDeclaration(Full); + if Assigned(Params[I].format1) then + Result:=Result+':'+Params[I].format1.GetDeclaration(false); + if Assigned(Params[I].format2) then + Result:=Result+':'+Params[I].format2.GetDeclaration(false); end; if Kind in [pekSet,pekArrayParams] then Result := '[' + Result + ']' diff --git a/packages/fcl-passrc/src/paswrite.pp b/packages/fcl-passrc/src/paswrite.pp index cf3da304f8..f93ad3e72a 100644 --- a/packages/fcl-passrc/src/paswrite.pp +++ b/packages/fcl-passrc/src/paswrite.pp @@ -122,6 +122,9 @@ type procedure WriteImplCommand(ACommand: TPasImplCommand);virtual; procedure WriteImplCommands(ACommands: TPasImplCommands); virtual; procedure WriteImplIfElse(AIfElse: TPasImplIfElse); virtual; + procedure WriteImplCaseOf(ACaseOf: TPasImplCaseOf); virtual; + procedure WriteImplCaseStatement(ACaseStatement: TPasImplCaseStatement; + AAutoInsertBeginEnd: boolean=true); virtual; procedure WriteImplForLoop(AForLoop: TPasImplForLoop); virtual; procedure WriteImplWhileDo(aWhileDo : TPasImplWhileDo); virtual; procedure WriteImplRepeatUntil(aRepeatUntil : TPasImplRepeatUntil); virtual; @@ -1196,6 +1199,8 @@ begin end else if AElement.ClassType = TPasImplIfElse then WriteImplIfElse(TPasImplIfElse(AElement)) + else if AElement.InheritsFrom(TPasImplCaseOf) then + WriteImplCaseOf(TPasImplCaseOf(aElement)) else if AElement.ClassType = TPasImplForLoop then WriteImplForLoop(TPasImplForLoop(AElement)) else if AElement.InheritsFrom(TPasImplWhileDo) then @@ -1295,6 +1300,72 @@ begin end; end; +procedure TPasWriter.WriteImplCaseStatement(ACaseStatement: TPasImplCaseStatement;AAutoInsertBeginEnd:boolean=true); +var + i: Integer; +begin + for i := 0 to ACaseStatement.Expressions.Count - 1 do + begin + if i>0 then add(', '); + add(GetExpr(TPasExpr(ACaseStatement.Expressions[i]))) + end; + add(': '); + IncIndent; + //JC: If no body is assigned, omit the whole block + if assigned(ACaseStatement.Body) then + begin + if AAutoInsertBeginEnd then + begin + addLn('begin'); + IncIndent; + end; + //JC: if the body already is a begin-end-Block, the begin of that block is omitted + if ACaseStatement.Body is TPasImplBeginBlock then + WriteImplBlock(TPasImplBeginBlock(ACaseStatement.Body)) + else + WriteImplElement(ACaseStatement.Body,false); + if AAutoInsertBeginEnd then + begin + DecIndent; + Add('end'); //JC: No semicolon or Linefeed here ! + // Otherwise there would be a problem with th else-statement. + end; + end; + DecIndent; +end; + +procedure TPasWriter.WriteImplCaseOf(ACaseOf: TPasImplCaseOf); +var + i: Integer; + +begin + Add('case %s of', [GetExpr(ACaseOf.CaseExpr)]); + IncIndent; + for i := 0 to ACaseOf.Elements.Count - 1 do + begin + if TPasElement(ACaseOf.Elements[i]) is TPasImplCaseStatement then + begin + if i >0 then + AddLn(';') + else + AddLn; + WriteImplCaseStatement(TPasImplCaseStatement(ACaseOf.Elements[i]),True); + end; + end; + if assigned(ACaseOf.ElseBranch) then + begin + AddLn; + AddLn('else'); + IncIndent; + WriteImplBlock(ACaseOf.ElseBranch); + DecIndent; + end + else + AddLn(';'); + DecIndent; + AddLn('end;'); +end; + procedure TPasWriter.WriteImplRepeatUntil(aRepeatUntil: TPasImplRepeatUntil); @@ -1337,9 +1408,14 @@ end; procedure TPasWriter.WriteImplRaise(aRaise: TPasImplRaise); begin - Add('raise %s',[GetExpr(aRaise.ExceptObject)]); - if aRaise.ExceptAddr<>Nil then - Add(' at %s',[GetExpr(aRaise.ExceptAddr)]); + if assigned(aRaise.ExceptObject) then + begin + Add('raise %s',[GetExpr(aRaise.ExceptObject)]); + if aRaise.ExceptAddr<>Nil then + Add(' at %s',[GetExpr(aRaise.ExceptAddr)]); + end + else + Add('raise'); Addln(';'); end; @@ -1391,15 +1467,21 @@ begin With aForLoop do begin If LoopType=ltIn then - AddLn('for %s in %s do',[GetExpr(VariableName),GetExpr(StartExpr)]) + Add('for %s in %s do',[GetExpr(VariableName),GetExpr(StartExpr)]) else - AddLn('for %s:=%s %s %s do',[GetExpr(VariableName),GetExpr(StartExpr), + Add('for %s:=%s %s %s do',[GetExpr(VariableName),GetExpr(StartExpr), ToNames[Down],GetExpr(EndExpr)]); - IncIndent; - WriteImplElement(Body, True); - DecIndent; - if (Body is TPasImplBlock) and - (Body is TPasImplCommands) then + if assigned(Body) then + begin + AddLn; + IncIndent; + WriteImplElement(Body, True); + DecIndent; + if (Body is TPasImplBlock) and + (Body is TPasImplCommands) then + AddLn(';'); + end + else AddLn(';'); end; end; @@ -1410,12 +1492,18 @@ procedure TPasWriter.WriteImplWhileDo(aWhileDo: TPasImplWhileDo); begin With aWhileDo do begin - AddLn('While %s do',[GetExpr(ConditionExpr)]); - IncIndent; - WriteImplElement(Body, True); - DecIndent; - if (Body.InheritsFrom(TPasImplBlock)) and - (Body.InheritsFrom(TPasImplCommands)) then + Add('While %s do',[GetExpr(ConditionExpr)]); + if assigned(Body) then + begin + AddLn; + IncIndent; + WriteImplElement(Body, True); + DecIndent; + if (Body.InheritsFrom(TPasImplBlock)) and + (Body.InheritsFrom(TPasImplCommands)) then + AddLn(';'); + end + else AddLn(';'); end; end; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index f28240efaa..c5bbf82569 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -451,7 +451,8 @@ type procedure ParseArgList(Parent: TPasElement; Args: TFPList; // list of TPasArgument EndToken: TToken); - procedure ParseProcedureOrFunction(Parent: TPasElement; Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean); + procedure ParseProcedureOrFunction(Parent: TPasElement; + Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean); procedure ParseProcedureBody(Parent: TPasElement); function ParseMethodResolution(Parent: TPasElement): TPasMethodResolution; // Properties for external access @@ -4998,7 +4999,7 @@ begin ptAnonymousProcedure,ptAnonymousFunction: case CurToken of tkIdentifier, // e.g. procedure assembler - tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction: + tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction,tkasm: UngetToken; tkColon: if ProcType=ptAnonymousFunction then @@ -5300,7 +5301,7 @@ begin ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); end; else - resultEl:=Nil; + ResultEl:=Nil; end; if OfObjectPossible then begin @@ -5312,7 +5313,7 @@ begin end else if (CurToken = tkIs) then begin - expectToken(tkIdentifier); + ExpectToken(tkIdentifier); if (lowerCase(CurTokenString)<>'nested') then ParseExc(nParserExpectedNested,SParserExpectedNested); Element.IsNested:=True; diff --git a/packages/fcl-passrc/tests/tcbaseparser.pas b/packages/fcl-passrc/tests/tcbaseparser.pas index 318fcaa216..6e2d027307 100644 --- a/packages/fcl-passrc/tests/tcbaseparser.pas +++ b/packages/fcl-passrc/tests/tcbaseparser.pas @@ -661,9 +661,11 @@ begin FFileName:=MainFilename; FResolver.AddStream(FFileName,TStringStream.Create(FSource.Text)); FScanner.OpenFile(FFileName); + {$ifndef NOCONSOLE} // JC: To get the tests to run with GUI Writeln('// Test : ',Self.TestName); for i:=0 to FSource.Count-1 do Writeln(Format('%:4d: ',[i+1]),FSource[i]); + {$EndIf} end; procedure TTestParser.ParseDeclarations; diff --git a/packages/fcl-passrc/tests/tcpaswritestatements.pas b/packages/fcl-passrc/tests/tcpaswritestatements.pas new file mode 100644 index 0000000000..2a6e6227d7 --- /dev/null +++ b/packages/fcl-passrc/tests/tcpaswritestatements.pas @@ -0,0 +1,3325 @@ +{ + Examples: + ./testpassrc --suite=TTestStatementParser.TestCallQualified2 +} +unit tcPasWriteStatements; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, PasTree, PScanner, PParser, PasWrite, + tcbaseparser, testregistry; + +type + { TTestStatementWriterBase } + + TTestStatementWriterBase = class(TTestParser) + private + FPasWriter: TPasWriter; + FStatement: TPasImplBlock; + FTestStream: TMemoryStream; + FVariables: TStrings; + procedure TestCallFormat(FN: string; AddPrecision: boolean; + AddSecondParam: boolean = False); + protected + procedure SetUp; override; + procedure TearDown; override; + procedure AddStatements(ASource: array of string); + function BuildString(ASource: array of string): string; + procedure DeclareVar(const AVarType: string; const AVarName: string = 'A'); + function TestStatement(ASource: string): TPasImplElement; + function TestStatement(ASource: array of string): TPasImplElement; + procedure ExpectParserError(const Msg: string); + procedure ExpectParserError(const Msg: string; ASource: array of string); + function AssertStatement(Msg: string; + AClass: TClass; AIndex: integer = 0): TPasImplBlock; + procedure AssertPasWriteOutput(Msg, ExpResult: string; aProgram: TPasElement); + property Statement: TPasImplBlock read FStatement; + published + end; + + { TTestStatementWriterEmpty } + + TTestStatementWriterEmpty = class(TTestStatementWriterBase) + published + procedure TestEmpty; + procedure TestEmptyStatement; + procedure TestEmptyStatements; + end; + + { TTestStatementWriterBlock } + + TTestStatementWriterBlock = class(TTestStatementWriterBase) + published + procedure TestBlock; + procedure TestBlockComment; + procedure TestBlock2Comments; + end; + + { TTestStatementWriterAssignment } + + TTestStatementWriterAssignment = class(TTestStatementWriterBase) + published + procedure TestAssignment; + procedure TestAssignmentAdd; + procedure TestAssignmentMinus; + procedure TestAssignmentMul; + procedure TestAssignmentDivision; + // Procedure TestAssignmentMissingSemicolonError; + + end; + + { TTestStatementWriterCall } + + TTestStatementWriterCall = class(TTestStatementWriterBase) + published + procedure TestCall; + procedure TestCallComment; + procedure TestCallQualified; + procedure TestCallQualified2; + procedure TestCallNoArgs; + procedure TestCallOneArg; + procedure TestCallWriteFormat1; + procedure TestCallWriteFormat2; + procedure TestCallWriteFormat3; + procedure TestCallWriteFormat4; + procedure TestCallWritelnFormat1; + procedure TestCallWritelnFormat2; + procedure TestCallStrFormat1; + procedure TestCallStrFormat2; + end; + + { TTestStatementWriterIf } + + TTestStatementWriterIf = class(TTestStatementWriterBase) + published + procedure TestIf; + procedure TestIfBlock; + procedure TestIfAssignment; + procedure TestIfElse; + procedure TestIfElseBlock; + procedure TestIfElseInBlock; + procedure TestIfforElseBlock; + procedure TestIfRaiseElseBlock; + procedure TestIfWithBlock; + procedure TestNestedIf; + procedure TestNestedIfElse; + procedure TestNestedIfElseElse; + procedure TestIfIfElseElseBlock; + end; + + { TTestStatementWriterLoops } + + TTestStatementWriterLoops = class(TTestStatementWriterBase) + published + procedure TestWhile; + procedure TestWhileBlock; + procedure TestWhileNested; + procedure TestRepeat; + procedure TestRepeatBlock; + procedure TestRepeatBlockNosemicolon; + procedure TestRepeatNested; + procedure TestFor; + procedure TestForIn; + procedure TestForExpr; + procedure TestForBlock; + procedure TestDowntoBlock; + procedure TestForNested; + end; + + { TTestStatementWriterWith } + + TTestStatementWriterWith = class(TTestStatementWriterBase) + published + procedure TestWith; + procedure TestWithMultiple; + end; + + { TTestStatementWriterCase } + + TTestStatementWriterCase = class(TTestStatementWriterBase) + published + //Procedure TestCaseEmpty; + procedure TestCaseOneInteger; + procedure TestCaseTwoIntegers; + procedure TestCaseRange; + procedure TestCaseRangeSeparate; + procedure TestCase2Cases; + procedure TestCaseBlock; + procedure TestCaseElseBlockEmpty; + procedure TestCaseOtherwiseBlockEmpty; + procedure TestCaseElseBlockAssignment; + procedure TestCaseElseBlock2Assignments; + procedure TestCaseIfCaseElse; + procedure TestCaseIfCaseElseElse; + procedure TestCaseIfElse; + procedure TestCaseElseNoSemicolon; + procedure TestCaseIfElseNoSemicolon; + procedure TestCaseIfOtherwiseNoSemicolon; + end; + + { TTestStatementWriterRaise } + + TTestStatementWriterRaise = class(TTestStatementWriterBase) + published + procedure TestRaise; + procedure TestRaiseEmpty; + procedure TestRaiseAt; + end; + + { TTestStatementWriterTry } + + TTestStatementWriterTry = class(TTestStatementWriterBase) + published + procedure TestTryFinally; + procedure TestTryFinallyEmpty; + procedure TestTryFinallyNested; + procedure TestTryExcept; + procedure TestTryExceptNested; + procedure TestTryExceptEmpty; + procedure TestTryExceptOn; + procedure TestTryExceptOn2; + procedure TestTryExceptOnElse; + procedure TestTryExceptOnIfElse; + procedure TestTryExceptOnElseNoSemicolo; + procedure TestTryExceptRaise; + end; + + { TTestStatementWriterAsm } + + TTestStatementWriterAsm = class(TTestStatementWriterBase) + published + procedure TestAsm; + procedure TestAsmBlock; + procedure TestAsmBlockWithEndLabel; + procedure TestAsmBlockInIfThen; + end; + + { TTestStatementWriterSpecials } + + TTestStatementWriterSpecials = class(TTestStatementWriterBase) + published + procedure TestGotoInIfThen; + procedure TestAssignToAddress; + procedure TestFinalizationNoSemicolon; + procedure TestMacroComment; + procedure TestPlatformIdentifier; + procedure TestPlatformIdentifier2; + procedure TestArgumentNameOn; + end; + + +implementation + +{ TTestStatementWriterBase } + +procedure TTestStatementWriterBase.SetUp; +begin + inherited SetUp; + FVariables := TStringList.Create; + FTestStream := TMemoryStream.Create; + FPasWriter := TPasWriter.Create(FTestStream); +end; + +procedure TTestStatementWriterBase.TearDown; +begin + FreeAndNil(FPasWriter); + FreeAndNil(FTestStream); + FreeAndNil(FVariables); + inherited TearDown; +end; + +procedure TTestStatementWriterBase.AddStatements(ASource: array of string); + +var + I: integer; +begin + StartProgram(ExtractFileUnitName(MainFilename)); + if FVariables.Count > 0 then + begin + Add('Var'); + for I := 0 to FVariables.Count - 1 do + Add(' ' + Fvariables[I]); + end; + Add('begin'); + for I := Low(ASource) to High(ASource) do + Add(' ' + ASource[i]); +end; + +function TTestStatementWriterBase.BuildString(ASource: array of string): string; +begin + Result := string.Join(LineEnding, ASource); +end; + +procedure TTestStatementWriterBase.DeclareVar(const AVarType: string; + const AVarName: string); +begin + FVariables.Add(AVarName + ' : ' + AVarType + ';'); +end; + +function TTestStatementWriterBase.TestStatement(ASource: string): TPasImplElement; +begin + Result := TestStatement([ASource]); +end; + +function TTestStatementWriterBase.TestStatement(ASource: array of string): +TPasImplElement; + +begin + Result := nil; + FStatement := nil; + AddStatements(ASource); + ParseModule; + AssertEquals('Have program', TPasProgram, Module.ClassType); + AssertNotNull('Have program section', PasProgram.ProgramSection); + AssertNotNull('Have initialization section', PasProgram.InitializationSection); + if (PasProgram.InitializationSection.Elements.Count > 0) then + if TObject(PasProgram.InitializationSection.Elements[0]) is TPasImplBlock then + FStatement := TPasImplBlock(PasProgram.InitializationSection.Elements[0]); + Result := FStatement; +end; + +procedure TTestStatementWriterBase.ExpectParserError(const Msg: string); +begin + AssertException(Msg, EParserError, @ParseModule); +end; + +procedure TTestStatementWriterBase.ExpectParserError(const Msg: string; + ASource: array of string); +begin + AddStatements(ASource); + ExpectParserError(Msg); +end; + +function TTestStatementWriterBase.AssertStatement(Msg: string; + AClass: TClass; AIndex: integer): TPasImplBlock; +begin + if not (AIndex < PasProgram.InitializationSection.Elements.Count) then + Fail(Msg + ': No such statement : ' + IntToStr(AIndex)); + AssertNotNull(Msg + ' Have statement', PasProgram.InitializationSection.Elements[AIndex]); + AssertEquals(Msg + ' statement class', AClass, TObject( + PasProgram.InitializationSection.Elements[AIndex]).ClassType); + Result := TObject(PasProgram.InitializationSection.Elements[AIndex]) as TPasImplBlock; +end; + +procedure TTestStatementWriterBase.AssertPasWriteOutput(Msg, ExpResult: string; + aProgram: TPasElement); +var + aString: string; +begin + FPasWriter.WriteElement(aProgram); + FTestStream.Seek(0, soBeginning); + setlength(aString, FTestStream.Size); + FTestStream.ReadBuffer(aString[1], FTestStream.Size); + AssertEquals(Testname + ': ' + Msg, ExpResult, aString); + AssertEquals(Testname + ': Streamsize', length(expResult), FTestStream.Size); +end; + +// Tests ----------------------------------------------------------------- + +procedure TTestStatementWriterEmpty.TestEmpty; +begin + //TestStatement(';'); + TestStatement(''); + AssertEquals('No statements', 0, PasProgram.InitializationSection.Elements.Count); + + AssertPasWriteOutput('output', 'program afile;'#13#10#13#10#13#10'begin'#13#10'end.'#13#10, PasProgram); +end; + +procedure TTestStatementWriterEmpty.TestEmptyStatement; +begin + TestStatement(';'); + AssertEquals('0 statement', 0, PasProgram.InitializationSection.Elements.Count); + AssertPasWriteOutput('output', 'program afile;'#13#10#13#10#13#10'begin'#13#10'end.'#13#10, PasProgram); +end; + +procedure TTestStatementWriterEmpty.TestEmptyStatements; +begin + TestStatement(';;'); + AssertEquals('0 statement', 0, PasProgram.InitializationSection.Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterBlock.TestBlock; + +var + B: TPasImplBeginBlock; +begin + TestStatement(['begin', 'end']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertNotNull('Statement assigned', PasProgram.InitializationSection.Elements[0]); + AssertEquals('Block statement', TPasImplBeginBlock, Statement.ClassType); + B := Statement as TPasImplBeginBlock; + AssertEquals('Empty block', 0, B.Elements.Count); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'begin', 'end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterBlock.TestBlockComment; +var + B: TPasImplBeginBlock; +begin + Engine.NeedComments := True; + TestStatement(['{ This is a comment }', 'begin', 'end']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertNotNull('Statement assigned', PasProgram.InitializationSection.Elements[0]); + AssertEquals('Block statement', TPasImplBeginBlock, Statement.ClassType); + B := Statement as TPasImplBeginBlock; + AssertEquals('Empty block', 0, B.Elements.Count); + AssertEquals('No DocComment', '', B.DocComment); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'begin', 'end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterBlock.TestBlock2Comments; +var + B: TPasImplBeginBlock; +begin + Engine.NeedComments := True; + TestStatement(['{ This is a comment }', '// Another comment', 'begin', 'end']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertNotNull('Statement assigned', PasProgram.InitializationSection.Elements[0]); + AssertEquals('Block statement', TPasImplBeginBlock, Statement.ClassType); + B := Statement as TPasImplBeginBlock; + AssertEquals('Empty block', 0, B.Elements.Count); + AssertEquals('No DocComment', '', B.DocComment); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'begin', 'end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterAssignment.TestAssignment; + +var + A: TPasImplAssign; +begin + DeclareVar('integer'); + TestStatement(['a:=1;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement', TPasImplAssign, Statement.ClassType); + A := Statement as TPasImplAssign; + AssertEquals('Normal assignment', akDefault, A.Kind); + AssertExpression('Right side is constant', A.Right, pekNumber, '1'); + AssertExpression('Left side is variable', A.Left, pekIdent, 'a'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' a := 1;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAssignment.TestAssignmentAdd; + +var + A: TPasImplAssign; +begin + Parser.Scanner.Options := [po_cassignments]; + DeclareVar('integer'); + TestStatement(['a+=1;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement', TPasImplAssign, Statement.ClassType); + A := Statement as TPasImplAssign; + AssertEquals('Add assignment', akAdd, A.Kind); + AssertExpression('Right side is constant', A.Right, pekNumber, '1'); + AssertExpression('Left side is variable', A.Left, pekIdent, 'a'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' a += 1;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAssignment.TestAssignmentMinus; +var + A: TPasImplAssign; +begin + Parser.Scanner.Options := [po_cassignments]; + DeclareVar('integer'); + TestStatement(['a-=1;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement', TPasImplAssign, Statement.ClassType); + A := Statement as TPasImplAssign; + AssertEquals('Minus assignment', akMinus, A.Kind); + AssertExpression('Right side is constant', A.Right, pekNumber, '1'); + AssertExpression('Left side is variable', A.Left, pekIdent, 'a'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' a -= 1;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAssignment.TestAssignmentMul; +var + A: TPasImplAssign; +begin + Parser.Scanner.Options := [po_cassignments]; + DeclareVar('integer'); + TestStatement(['a*=1;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement', TPasImplAssign, Statement.ClassType); + A := Statement as TPasImplAssign; + AssertEquals('Mul assignment', akMul, A.Kind); + AssertExpression('Right side is constant', A.Right, pekNumber, '1'); + AssertExpression('Left side is variable', A.Left, pekIdent, 'a'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' a *= 1;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAssignment.TestAssignmentDivision; +var + A: TPasImplAssign; +begin + Parser.Scanner.Options := [po_cassignments]; + DeclareVar('integer'); + TestStatement(['a/=1;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Assignment statement', TPasImplAssign, Statement.ClassType); + A := Statement as TPasImplAssign; + AssertEquals('Division assignment', akDivision, A.Kind); + AssertExpression('Right side is constant', A.Right, pekNumber, '1'); + AssertExpression('Left side is variable', A.Left, pekIdent, 'a'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' a /= 1;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCall; + +var + S: TPasImplSimple; +begin + TestStatement('Doit;'); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekIdent, 'Doit'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Doit;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallComment; + +var + S: TPasImplSimple; +begin + Engine.NeedComments := True; + TestStatement(['//comment line', 'Doit;']); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekIdent, 'Doit'); + AssertEquals('No DocComment', '', S.DocComment); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Doit;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallQualified; + +var + S: TPasImplSimple; + B: TBinaryExpr; +begin + TestStatement('Unita.Doit;'); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekBinary, TBinaryExpr); + B := S.Expr as TBinaryExpr; + TAssert.AssertSame('B.left.Parent=B', B, B.left.Parent); + TAssert.AssertSame('B.right.Parent=B', B, B.right.Parent); + AssertExpression('Unit name', B.Left, pekIdent, 'Unita'); + AssertExpression('Doit call', B.Right, pekIdent, 'Doit'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Unita.Doit;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallQualified2; +var + S: TPasImplSimple; + B: TBinaryExpr; +begin + TestStatement('Unita.ClassB.Doit;'); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekBinary, TBinaryExpr); + B := S.Expr as TBinaryExpr; + AssertExpression('Doit call', B.Right, pekIdent, 'Doit'); + AssertExpression('First two parts of unit name', B.left, pekBinary, TBinaryExpr); + B := B.left as TBinaryExpr; + AssertExpression('Unit name part 1', B.Left, pekIdent, 'Unita'); + AssertExpression('Unit name part 2', B.right, pekIdent, 'ClassB'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Unita.ClassB.Doit;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallNoArgs; + +var + S: TPasImplSimple; + P: TParamsExpr; +begin + TestStatement('Doit();'); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekFuncParams, TParamsExpr); + P := S.Expr as TParamsExpr; + AssertExpression('Correct function call name', P.Value, pekIdent, 'Doit'); + AssertEquals('No params', 0, Length(P.Params)); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Doit();', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallOneArg; + +var + S: TPasImplSimple; + P: TParamsExpr; +begin + TestStatement('Doit(1);'); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekFuncParams, TParamsExpr); + P := S.Expr as TParamsExpr; + AssertExpression('Correct function call name', P.Value, pekIdent, 'Doit'); + AssertEquals('One param', 1, Length(P.Params)); + AssertExpression('Parameter is constant', P.Params[0], pekNumber, '1'); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' Doit(1);', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterBase.TestCallFormat(FN: string; + AddPrecision: boolean; AddSecondParam: boolean); +var + P: TParamsExpr; + + procedure CheckParam(Index: integer; const aParamName: string); + begin + AssertExpression('Parameter[' + IntToStr(Index) + '] is identifier', + P.Params[Index], pekIdent, aParamName); + AssertExpression('Parameter[' + IntToStr(Index) + '] has formatting constant 1' + , P.Params[Index].format1, pekNumber, '3'); + if AddPrecision then + AssertExpression('Parameter[' + IntToStr(Index) + '] has formatting constant 2', + P.Params[Index].format2, pekNumber, '2'); + end; + +var + S: TPasImplSimple; + N: string; + ArgCnt: integer; +begin + N := fn + '(a:3'; + if AddPrecision then + N := N + ':2'; + ArgCnt := 1; + if AddSecondParam then + begin + ArgCnt := 2; + N := N + ',b:3'; + if AddPrecision then + N := N + ':2'; + end; + N := N + ');'; + TestStatement(N); + AssertEquals('1 statement', 1, PasProgram.InitializationSection.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, Statement.ClassType); + S := Statement as TPasImplSimple; + AssertExpression('Doit call', S.Expr, pekFuncParams, TParamsExpr); + P := S.Expr as TParamsExpr; + AssertExpression('Correct function call name', P.Value, pekIdent, FN); + AssertEquals(IntToStr(ArgCnt) + ' param', ArgCnt, Length(P.Params)); + CheckParam(0, 'a'); + if AddSecondParam then + CheckParam(1, 'b'); +end; + +procedure TTestStatementWriterCall.TestCallWriteFormat1; + +begin + TestCallFormat('write', False); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(a:3);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallWriteFormat2; + +begin + TestCallFormat('write', True); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(a:3:2);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallWriteFormat3; +begin + TestCallFormat('write', False, True); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(a:3, b:3);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallWriteFormat4; +begin + TestCallFormat('write', True, True); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(a:3:2, b:3:2);', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallWritelnFormat1; +begin + TestCallFormat('writeln', False); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' writeln(a:3);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallWritelnFormat2; +begin + TestCallFormat('writeln', True); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' writeln(a:3:2);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallStrFormat1; +begin + TestCallFormat('str', False); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' str(a:3);', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCall.TestCallStrFormat2; +begin + TestCallFormat('str', True); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' str(a:3:2);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterIf.TestIf; + +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ';']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNull('No else', i.ElseBranch); + AssertNull('No if branch', I.IfBranch); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfBlock; + +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' begin', ' end']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNull('No else', i.ElseBranch); + AssertNotNull('if branch', I.IfBranch); + AssertEquals('begin end block', TPasImplBeginBlock, I.ifBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' begin', ' end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfAssignment; + +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' a:=False;']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNull('No else', i.ElseBranch); + AssertNotNull('if branch', I.IfBranch); + AssertEquals('assignment statement', TPasImplAssign, I.ifBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' a := False;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfElse; + +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' begin', ' end', 'else', ';']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNull('No else', i.ElseBranch); + AssertNotNull('if branch', I.IfBranch); + AssertEquals('begin end block', TPasImplBeginBlock, I.ifBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' begin', ' end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfElseBlock; +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' begin', ' end', 'else', ' begin', ' end']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', I.IfBranch); + AssertEquals('begin end block', TPasImplBeginBlock, I.ifBranch.ClassType); + AssertNotNull('Else branch', i.ElseBranch); + AssertEquals('begin end block', TPasImplBeginBlock, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' begin', ' end else', ' begin', + ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfElseInBlock; +var + B: TPasImplBeginBlock; + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['begin', ' if a then', ' DoA', + ' else', 'end']); + + B := AssertStatement('begin block', TPasImplBeginBlock) as TPasImplBeginBlock; + AssertEquals('One Element', 1, B.Elements.Count); + AssertEquals('If statement', TPasImplIfElse, TObject(B.Elements[0]).ClassType); + I := TPasImplIfElse(B.Elements[0]); + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', I.IfBranch); + AssertEquals('i_br: simple command', TPasImplSimple, I.ifBranch.ClassType); + AssertExpression('Doit call', TPasImplSimple(I.ifBranch).Expr, pekIdent, 'DoA'); + AssertNull('Else branch', i.ElseBranch); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + 'begin', ' if a then', ' DoA;', 'end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfforElseBlock; + +var + I: TPasImplIfElse; + +begin + TestStatement(['if a then', 'for X := 1 downto 0 do Writeln(X)', 'else', + 'for X := 0 to 1 do Writeln(X)']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertEquals('For statement', TPasImplForLoop, I.ifBranch.ClassType); + AssertEquals('For statement', TPasImplForLoop, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' if a then', ' begin', + ' for X:=1 downto 0 do', ' Writeln(X);', ' end else', + ' for X:=0 to 1 do', ' Writeln(X);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfRaiseElseBlock; +// Error: to be searched for +var + I: TPasImplIfElse; +begin + TestStatement(['if a then', 'raise', 'else', 'for X := 0 to 1 do Writeln(X)']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertEquals('For statement', TPasImplRaise, I.ifBranch.ClassType); + AssertEquals('For statement', TPasImplForLoop, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', '', + '', 'begin', ' if a then', ' begin', ' raise;', ' end else', + ' for X:=0 to 1 do', ' Writeln(X);', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfWithBlock; +// Error: With not implemented +var + I: TPasImplIfElse; +begin + TestStatement(['if a then', 'with b do something', 'else', + 'for X := 0 to 1 do Writeln(X)']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertEquals('For statement', TPasImplWithDo, I.ifBranch.ClassType); + AssertEquals('For statement', TPasImplForLoop, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' with b do', ' something', + ' else', ' for X:=0 to 1 do', ' Writeln(X);', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestNestedIf; +var + I: TPasImplIfElse; +begin + DeclareVar('boolean'); + DeclareVar('boolean', 'b'); + TestStatement(['if a then', ' if b then', ' begin', ' end', + 'else', ' begin', ' end']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', I.IfBranch); + AssertNull('Else branch', i.ElseBranch); + AssertEquals('if in if branch', TPasImplIfElse, I.ifBranch.ClassType); + I := I.Ifbranch as TPasImplIfElse; + AssertEquals('begin end block', TPasImplBeginBlock, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', ' b: Boolean;', + '', 'begin', ' if a then', ' if b then', + ' begin', ' end else', ' begin', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestNestedIfElse; + +var + I: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' if b then', ' begin', ' end', + ' else', ' begin', ' end', 'else', ' begin', 'end']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', I.IfBranch); + AssertNotNull('Else branch', i.ElseBranch); + AssertEquals('begin end block', TPasImplBeginBlock, I.ElseBranch.ClassType); + AssertEquals('if in if branch', TPasImplIfElse, I.ifBranch.ClassType); + I := I.Ifbranch as TPasImplIfElse; + AssertEquals('begin end block', TPasImplBeginBlock, I.ElseBranch.ClassType); + + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' begin', ' if b then', ' begin', + ' end else', ' begin', ' end;', ' end else', + ' begin', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestNestedIfElseElse; + +// Bug ID 37760 + +var + I, I2: TPasImplIfElse; + +begin + DeclareVar('boolean'); + TestStatement(['if a then', ' if b then', + ' DoA ', ' else', ' else', + ' DoB']); + I := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', I.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', I.IfBranch); + AssertNotNull('Have else for outer if', I.ElseBranch); + AssertEquals('Have if in if branch', TPasImplIfElse, I.ifBranch.ClassType); + I2 := I.Ifbranch as TPasImplIfElse; + AssertExpression('IF condition', I2.ConditionExpr, pekIdent, 'b'); + AssertNotNull('Have then for inner if', I2.ifBranch); + AssertnotNull('Empty else for inner if', I2.ElseBranch); + AssertEquals('Have a commend for inner if else', TPasImplCommand, + I2.ElseBranch.ClassType); + AssertEquals('... an empty command', '', TPasImplCommand(I2.ElseBranch).Command); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' if a then', ' begin', ' if b then', ' begin', + ' DoA;', ' end else', ' end else', ' DoB;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterIf.TestIfIfElseElseBlock; + +var + OuterIf, InnerIf: TPasImplIfElse; +begin + DeclareVar('boolean'); + DeclareVar('boolean', 'B'); + TestStatement(['if a then', 'if b then', ' begin', ' end', 'else', + 'else', ' begin', ' end']); + OuterIf := AssertStatement('If statement', TPasImplIfElse) as TPasImplIfElse; + AssertExpression('IF condition', OuterIf.ConditionExpr, pekIdent, 'a'); + AssertNotNull('if branch', OuterIf.IfBranch); + AssertEquals('if else block', TPasImplIfElse, OuterIf.ifBranch.ClassType); + InnerIf := OuterIf.IfBranch as TPasImplIfElse; + AssertExpression('IF condition', InnerIf.ConditionExpr, pekIdent, 'b'); + AssertNotNull('if branch', InnerIf.IfBranch); + AssertEquals('begin end block', TPasImplBeginBlock, InnerIf.ifBranch.ClassType); + AssertNotNull('Else branch', InnerIf.ElseBranch); + AssertEquals('empty statement', TPasImplCommand, InnerIf.ElseBranch.ClassType); + AssertEquals('empty command', '', TPasImplCommand(InnerIf.ElseBranch).Command); + AssertNotNull('Else branch', OuterIf.ElseBranch); + AssertEquals('begin end block', TPasImplBeginBlock, OuterIf.ElseBranch.ClassType); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', ' B: Boolean;', + '', 'begin', ' if a then', ' begin', + ' if b then', ' begin', ' end else', + ' end else', ' begin', ' end;', 'end.', '']), PasProgram); +end; + + +procedure TTestStatementWriterLoops.TestWhile; + +var + W: TPasImplWhileDo; + +begin + DeclareVar('boolean'); + TestStatement(['While a do ;']); + W := AssertStatement('While statement', TPasImplWhileDo) as TPasImplWhileDo; + AssertExpression('While condition', W.ConditionExpr, pekIdent, 'a'); + AssertNull('Empty body', W.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' While a do;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestWhileBlock; +var + W: TPasImplWhileDo; + +begin + DeclareVar('boolean'); + TestStatement(['While a do', ' begin', ' end']); + W := AssertStatement('While statement', TPasImplWhileDo) as TPasImplWhileDo; + AssertExpression('While condition', W.ConditionExpr, pekIdent, 'a'); + AssertNotNull('Have while body', W.Body); + AssertEquals('begin end block', TPasImplBeginBlock, W.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(W.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' While a do', ' begin', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestWhileNested; + +var + W: TPasImplWhileDo; + +begin + DeclareVar('boolean'); + DeclareVar('boolean', 'b'); + TestStatement(['While a do', ' while b do', ' begin', ' end']); + W := AssertStatement('While statement', TPasImplWhileDo) as TPasImplWhileDo; + AssertExpression('While condition', W.ConditionExpr, pekIdent, 'a'); + AssertNotNull('Have while body', W.Body); + AssertEquals('Nested while', TPasImplWhileDo, W.Body.ClassType); + W := W.Body as TPasImplWhileDo; + AssertExpression('While condition', W.ConditionExpr, pekIdent, 'b'); + AssertNotNull('Have nested while body', W.Body); + AssertEquals('Nested begin end block', TPasImplBeginBlock, W.Body.ClassType); + AssertEquals('Empty nested block', 0, TPasImplBeginBlock(W.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', ' b: Boolean;', + '', 'begin', ' While a do', ' While b do', + ' begin', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestRepeat; + +var + R: TPasImplRepeatUntil; + +begin + DeclareVar('boolean'); + TestStatement(['Repeat', 'Until a;']); + R := AssertStatement('Repeat statement', TPasImplRepeatUntil) as TPasImplRepeatUntil; + AssertExpression('repeat condition', R.ConditionExpr, pekIdent, 'a'); + AssertEquals('Empty body', 0, R.Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' repeat', ' until a;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestRepeatBlock; + +var + R: TPasImplRepeatUntil; + +begin + DeclareVar('boolean'); + TestStatement(['Repeat', 'begin', 'end;', 'Until a;']); + R := AssertStatement('repeat statement', TPasImplRepeatUntil) as TPasImplRepeatUntil; + AssertExpression('repeat condition', R.ConditionExpr, pekIdent, 'a'); + AssertEquals('Have statement', 1, R.Elements.Count); + AssertEquals('begin end block', TPasImplBeginBlock, TObject(R.Elements[0]).ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(R.Elements[0]).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' repeat', ' begin', ' end;', ' until a;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestRepeatBlockNosemicolon; + +var + R: TPasImplRepeatUntil; + +begin + DeclareVar('boolean'); + TestStatement(['Repeat', 'begin', 'end', 'Until a;']); + R := AssertStatement('repeat statement', TPasImplRepeatUntil) as TPasImplRepeatUntil; + AssertExpression('repeat condition', R.ConditionExpr, pekIdent, 'a'); + AssertEquals('Have statement', 1, R.Elements.Count); + AssertEquals('begin end block', TPasImplBeginBlock, TObject(R.Elements[0]).ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(R.Elements[0]).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', '', 'begin', + ' repeat', ' begin', ' end;', ' until a;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestRepeatNested; + +var + R: TPasImplRepeatUntil; + +begin + DeclareVar('boolean'); + DeclareVar('boolean', 'b'); + TestStatement(['Repeat', 'repeat', 'begin', 'end', 'until b', 'Until a;']); + R := AssertStatement('repeat statement', TPasImplRepeatUntil) as TPasImplRepeatUntil; + AssertExpression('repeat condition', R.ConditionExpr, pekIdent, 'a'); + AssertEquals('Have statement', 1, R.Elements.Count); + AssertEquals('Nested repeat', TPasImplRepeatUntil, TObject(R.Elements[0]).ClassType); + R := TPasImplRepeatUntil(R.Elements[0]); + AssertExpression('repeat condition', R.ConditionExpr, pekIdent, 'b'); + AssertEquals('Have statement', 1, R.Elements.Count); + AssertEquals('begin end block', TPasImplBeginBlock, TObject(R.Elements[0]).ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(R.Elements[0]).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Boolean;', ' b: Boolean;', + '', 'begin', ' repeat', ' repeat', ' begin', + ' end;', ' until b;', ' until a;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterLoops.TestFor; + +var + F: TPasImplForLoop; + +begin + DeclareVar('integer'); + TestStatement(['For a:=1 to 10 do', ';']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Loop type', ltNormal, F.Looptype); + AssertEquals('Up loop', False, F.Down); + AssertExpression('Start value', F.StartExpr, pekNumber, '1'); + AssertExpression('End value', F.EndExpr, pekNumber, '10'); + AssertNull('Empty body', F.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' for a:=1 to 10 do;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestForIn; + +var + F: TPasImplForLoop; + +begin + DeclareVar('integer'); + TestStatement(['For a in SomeSet Do', ';']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Loop type', ltIn, F.Looptype); + AssertEquals('In loop', False, F.Down); + AssertExpression('Start value', F.StartExpr, pekIdent, 'SomeSet'); + AssertNull('Loop type', F.EndExpr); + AssertNull('Empty body', F.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' for a in SomeSet do;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestForExpr; +var + F: TPasImplForLoop; + B: TBinaryExpr; + +begin + DeclareVar('integer'); + TestStatement(['For a:=1+1 to 5+5 do', ';']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Up loop', False, F.Down); + AssertExpression('Start expression', F.StartExpr, pekBinary, TBinaryExpr); + B := F.StartExpr as TBinaryExpr; + AssertExpression('Start value left', B.left, pekNumber, '1'); + AssertExpression('Start value right', B.right, pekNumber, '1'); + AssertExpression('Start expression', F.StartExpr, pekBinary, TBinaryExpr); + B := F.EndExpr as TBinaryExpr; + AssertExpression('End value left', B.left, pekNumber, '5'); + AssertExpression('End value right', B.right, pekNumber, '5'); + AssertNull('Empty body', F.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' for a:=1 + 1 to 5 + 5 do;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestForBlock; + +var + F: TPasImplForLoop; + +begin + DeclareVar('integer'); + TestStatement(['For a:=1 to 10 do', 'begin', 'end']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Up loop', False, F.Down); + AssertExpression('Start value', F.StartExpr, pekNumber, '1'); + AssertExpression('End value', F.EndExpr, pekNumber, '10'); + AssertNotNull('Have for body', F.Body); + AssertEquals('begin end block', TPasImplBeginBlock, F.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(F.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' for a:=1 to 10 do', ' begin', ' end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterLoops.TestDowntoBlock; + +var + F: TPasImplForLoop; + +begin + DeclareVar('integer'); + TestStatement(['For a:=10 downto 1 do', 'begin', 'end']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Down loop', True, F.Down); + AssertExpression('Start value', F.StartExpr, pekNumber, '10'); + AssertExpression('End value', F.EndExpr, pekNumber, '1'); + AssertNotNull('Have for body', F.Body); + AssertEquals('begin end block', TPasImplBeginBlock, F.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(F.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', + ' for a:=10 downto 1 do', ' begin', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterLoops.TestForNested; +var + F: TPasImplForLoop; + +begin + DeclareVar('integer'); + DeclareVar('integer', 'b'); + TestStatement(['For a:=1 to 10 do', 'For b:=11 to 20 do', 'begin', 'end']); + F := AssertStatement('For statement', TPasImplForLoop) as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'a'); + AssertEquals('Up loop', False, F.Down); + AssertExpression('Start value', F.StartExpr, pekNumber, '1'); + AssertExpression('End value', F.EndExpr, pekNumber, '10'); + AssertNotNull('Have while body', F.Body); + AssertEquals('begin end block', TPasImplForLoop, F.Body.ClassType); + F := F.Body as TPasImplForLoop; + AssertExpression('Loop variable name', F.VariableName, pekIdent, 'b'); + AssertEquals('Up loop', False, F.Down); + AssertExpression('Start value', F.StartExpr, pekNumber, '11'); + AssertExpression('End value', F.EndExpr, pekNumber, '20'); + AssertNotNull('Have for body', F.Body); + AssertEquals('begin end block', TPasImplBeginBlock, F.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(F.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', ' b: Integer;', + '', 'begin', ' for a:=1 to 10 do', ' for b:=11 to 20 do', + ' begin', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterWith.TestWith; +// not implemented yet +var + W: TpasImplWithDo; + +begin + DeclareVar('record X,Y : Integer; end'); + TestStatement(['With a do', 'begin', 'end']); + W := AssertStatement('For statement', TpasImplWithDo) as TpasImplWithDo; + AssertEquals('1 expression', 1, W.Expressions.Count); + AssertExpression('With identifier', TPasExpr(W.Expressions[0]), pekIdent, 'a'); + AssertNotNull('Have with body', W.Body); + AssertEquals('begin end block', TPasImplBeginBlock, W.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(W.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: record', ' X,Y: Integer;', + ' end;', '', 'begin', ' with a do', ' begin', + ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterWith.TestWithMultiple; +// not implemented yet +var + W: TpasImplWithDo; + +begin + DeclareVar('record X,Y : Integer; end'); + DeclareVar('record W,Z : Integer; end', 'b'); + TestStatement(['With a,b do', 'begin', 'end']); + W := AssertStatement('For statement', TpasImplWithDo) as TpasImplWithDo; + AssertEquals('2 expressions', 2, W.Expressions.Count); + AssertExpression('With identifier 1', TPasExpr(W.Expressions[0]), pekIdent, 'a'); + AssertExpression('With identifier 2', TPasExpr(W.Expressions[1]), pekIdent, 'b'); + AssertNotNull('Have with body', W.Body); + AssertEquals('begin end block', TPasImplBeginBlock, W.Body.ClassType); + AssertEquals('Empty block', 0, TPasImplBeginBlock(W.Body).ELements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: record', ' X,Y: Integer;', + ' end;', ' b: record', ' W,Z: Integer;', + ' end;', '', 'begin', ' with a, b do', + ' begin', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseOneInteger; + +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : ;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('One case label', 1, C.Elements.Count); + AssertEquals('Correct case for case label', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('1 expression for case', 1, S.Expressions.Count); + AssertExpression('With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('Empty case label statement', 0, S.Elements.Count); + AssertNull('Empty case label statement', S.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1: ;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseTwoIntegers; + +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1,2 : ;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('One case label', 1, C.Elements.Count); + AssertEquals('Correct case for case label', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case', 2, S.Expressions.Count); + AssertExpression('With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertExpression('With identifier 2', TPasExpr(S.Expressions[1]), pekNumber, '2'); + AssertEquals('Empty case label statement', 0, S.Elements.Count); + AssertNull('Empty case label statement', S.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1, 2: ;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseRange; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1..3 : ;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('One case label', 1, C.Elements.Count); + AssertEquals('Correct case for case label', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('1 expression for case', 1, S.Expressions.Count); + AssertExpression('With identifier 1', TPasExpr(S.Expressions[0]), pekRange, TBinaryExpr); + AssertEquals('Empty case label statement', 0, S.Elements.Count); + AssertNull('Empty case label statement', S.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1..3: ;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseRangeSeparate; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1..3,5 : ;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('One case label', 1, C.Elements.Count); + AssertEquals('Correct case for case label', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case', 2, S.Expressions.Count); + AssertExpression('With identifier 1', TPasExpr(S.Expressions[0]), pekRange, TBinaryExpr); + AssertExpression('With identifier 2', TPasExpr(S.Expressions[1]), pekNumber, '5'); + AssertEquals('Empty case label statement', 0, S.Elements.Count); + AssertNull('Empty case label statement', S.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1..3, 5: ;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCase2Cases; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : ;', '2 : ;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case 1 With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('Empty case label statement 1', 0, S.Elements.Count); + AssertNull('Empty case label statement 1', S.Body); + // Two + AssertEquals('Correct case for case label 2', TPasImplCaseStatement, + TPasElement(C.Elements[1]).ClassType); + S := TPasImplCaseStatement(C.Elements[1]); + AssertEquals('2 expressions for case 2', 1, S.Expressions.Count); + AssertExpression('Case 2 With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '2'); + AssertEquals('Empty case label statement 2', 0, S.Elements.Count); + AssertNull('Empty case label statement 2', S.Body); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1: ;', ' 2: ;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseBlock; + +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + B: TPasImplbeginBlock; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : begin end;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertNull('No else branch', C.ElseBranch); + AssertEquals('Two case labels', 1, C.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplbeginBlock, + TPasElement(S.Elements[0]).ClassType); + B := TPasImplbeginBlock(S.Elements[0]); + AssertEquals('0 statements in block', 0, B.Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' A: Integer;', '', 'begin', ' case a of', + ' 1: begin', ' end;', ' end;', 'end.', '']), PasProgram); + +end; + +procedure TTestStatementWriterCase.TestCaseElseBlockEmpty; + +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + B: TPasImplbeginBlock; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : begin end;', 'else', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplbeginBlock, + TPasElement(S.Elements[0]).ClassType); + B := TPasImplbeginBlock(S.Elements[0]); + AssertEquals('0 statements in block', 0, B.Elements.Count); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('Zero statements ', 0, TPasImplCaseElse(C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' end', +' else', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseOtherwiseBlockEmpty; + +var + C: TPasImplCaseOf; +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : begin end;', 'otherwise', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('Zero statements ', 0, TPasImplCaseElse(C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' end', +' else', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseElseBlockAssignment; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + B: TPasImplbeginBlock; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : begin end;', 'else', 'a:=1', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplbeginBlock, + TPasElement(S.Elements[0]).ClassType); + B := TPasImplbeginBlock(S.Elements[0]); + AssertEquals('0 statements in block', 0, B.Elements.Count); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('1 statement in else branch ', 1, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' end', +' else', +' a := 1;', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseElseBlock2Assignments; + +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + B: TPasImplbeginBlock; + +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : begin end;', 'else', 'a:=1;', 'a:=32;', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplCaseStatement, + TPasElement(C.Elements[0]).ClassType); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('Correct case for case label 1', TPasImplbeginBlock, + TPasElement(S.Elements[0]).ClassType); + B := TPasImplbeginBlock(S.Elements[0]); + AssertEquals('0 statements in block', 0, B.Elements.Count); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('2 statements in else branch ', 2, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' end', +' else', +' a := 1;', +' a := 32;', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseIfCaseElse; + +var + C: TPasImplCaseOf; + +begin + DeclareVar('integer'); + DeclareVar('boolean', 'b'); + TestStatement(['case a of', '1 : if b then', ' begin end;', 'else', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('0 statement in else branch ', 0, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +' b: Boolean;', +'', +'begin', +' case a of', +' 1: begin', +' if b then', +' end', +' else', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseIfElse; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + DeclareVar('boolean', 'b'); + TestStatement(['case a of', '1 : if b then', ' begin end', 'else', 'begin', 'end', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('One case label', 1, C.Elements.Count); + AssertNull('Have no else branch', C.ElseBranch); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('If statement in case label 1', TPasImplIfElse, TPasElement( + S.Elements[0]).ClassType); + AssertNotNull('If statement has else block', TPasImplIfElse(S.Elements[0]).ElseBranch); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +' b: Boolean;', +'', +'begin', +' case a of', +' 1: begin', +' if b then', +' begin', +' end else', +' begin', +' end;', +' end;', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseIfCaseElseElse; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; + +begin + DeclareVar('integer'); + DeclareVar('boolean', 'b'); + TestStatement(['case a of', '1 : if b then', ' begin end', 'else', + 'else', 'DoElse', ' end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('Two case labels', 2, C.Elements.Count); + AssertNotNull('Have an else branch', C.ElseBranch); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('2 expressions for case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + AssertEquals('1 case label statement', 1, S.Elements.Count); + AssertEquals('If statement in case label 1', TPasImplIfElse, TPasElement( + S.Elements[0]).ClassType); + AssertNotNull('If statement has else block', TPasImplIfElse(S.Elements[0]).ElseBranch); + AssertEquals('If statement has a commend as else block', TPasImplCommand, + TPasImplIfElse(S.Elements[0]).ElseBranch.ClassType); + AssertEquals('But ... an empty command', '', TPasImplCommand( + TPasImplIfElse(S.Elements[0]).ElseBranch).Command); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +' b: Boolean;', +'', +'begin', +' case a of', +' 1: begin', +' if b then', +' begin', +' end else', +' end', +' else', +' DoElse;', +' end;', +'end.','']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseElseNoSemicolon; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : dosomething;', '2 : dosomethingmore', + 'else', 'a:=1;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('case label count', 3, C.Elements.Count); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + S := TPasImplCaseStatement(C.Elements[1]); + AssertEquals('case 2', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '2'); + AssertEquals('third is else', TPasImplCaseElse, TObject(C.Elements[2]).ClassType); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('1 statements in else branch ', 1, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' dosomething;', +' end;', +' 2: begin', +' dosomethingmore;', +' end', +' else', +' a := 1;', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseIfElseNoSemicolon; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : dosomething;', '2: if b then', + ' dosomething', 'else dosomethingmore', 'else', 'a:=1;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('case label count', 3, C.Elements.Count); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + S := TPasImplCaseStatement(C.Elements[1]); + AssertEquals('case 2', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '2'); + AssertEquals('third is else', TPasImplCaseElse, TObject(C.Elements[2]).ClassType); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('1 statements in else branch ', 1, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' dosomething;', +' end;', +' 2: begin', +' if b then', +' begin', +' dosomething;', +' end else', +' dosomethingmore;', +' end', +' else', +' a := 1;', +' end;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterCase.TestCaseIfOtherwiseNoSemicolon; +var + C: TPasImplCaseOf; + S: TPasImplCaseStatement; +begin + DeclareVar('integer'); + TestStatement(['case a of', '1 : dosomething;', '2: if b then', + ' dosomething', 'else dosomethingmore', 'otherwise', 'a:=1;', 'end;']); + C := AssertStatement('Case statement', TpasImplCaseOf) as TpasImplCaseOf; + AssertNotNull('Have case expression', C.CaseExpr); + AssertExpression('Case expression', C.CaseExpr, pekIdent, 'a'); + AssertEquals('case label count', 3, C.Elements.Count); + S := TPasImplCaseStatement(C.Elements[0]); + AssertEquals('case 1', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '1'); + S := TPasImplCaseStatement(C.Elements[1]); + AssertEquals('case 2', 1, S.Expressions.Count); + AssertExpression('Case With identifier 1', TPasExpr(S.Expressions[0]), pekNumber, '2'); + AssertEquals('third is else', TPasImplCaseElse, TObject(C.Elements[2]).ClassType); + AssertNotNull('Have else branch', C.ElseBranch); + AssertEquals('Correct else branch class', TPasImplCaseElse, C.ElseBranch.ClassType); + AssertEquals('1 statements in else branch ', 1, TPasImplCaseElse( + C.ElseBranch).Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Integer;', +'', +'begin', +' case a of', +' 1: begin', +' dosomething;', +' end;', +' 2: begin', +' if b then', +' begin', +' dosomething;', +' end else', +' dosomethingmore;', +' end', +' else', +' a := 1;', +' end;', +'end.', '']), PasProgram); +end; + + + +procedure TTestStatementWriterRaise.TestRaise; + +var + R: TPasImplRaise; + +begin + DeclareVar('Exception'); + TestStatement('Raise A;'); + R := AssertStatement('Raise statement', TPasImplRaise) as TPasImplRaise; + AssertEquals(0, R.Elements.Count); + AssertNotNull(R.ExceptObject); + AssertNull(R.ExceptAddr); + AssertExpression('Expression object', R.ExceptObject, pekIdent, 'A'); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Exception;', +'', +'begin', +' raise A;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterRaise.TestRaiseEmpty; +var + R: TPasImplRaise; + +begin + TestStatement('Raise;'); + R := AssertStatement('Raise statement', TPasImplRaise) as TPasImplRaise; + AssertEquals(0, R.Elements.Count); + AssertNull(R.ExceptObject); + AssertNull(R.ExceptAddr); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'', +'begin', +' raise;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterRaise.TestRaiseAt; + +var + R: TPasImplRaise; + +begin + DeclareVar('Exception'); + DeclareVar('Pointer', 'B'); + TestStatement('Raise A at B;'); + R := AssertStatement('Raise statement', TPasImplRaise) as TPasImplRaise; + AssertEquals(0, R.Elements.Count); + AssertNotNull(R.ExceptObject); + AssertNotNull(R.ExceptAddr); + AssertExpression('Expression object', R.ExceptAddr, pekIdent, 'B'); + AssertPasWriteOutput('output', BuildString(['program afile;', +'', +'var', +' A: Exception;', +' B: Pointer;', +'', +'begin', +' raise A at B;', +'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryFinally; + +var + T: TPasImplTry; + S: TPasImplSimple; + F: TPasImplTryFinally; + +begin + TestStatement(['Try', ' DoSomething;', 'finally', ' DoSomethingElse', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Finally statement', TPasImplTryFinally, T.FinallyExcept.ClassType); + F := TPasImplTryFinally(T.FinallyExcept); + AssertEquals(1, F.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(F.Elements[0]).ClassType); + S := TPasImplSimple(F.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' DoSomething;', + ' finally', ' DoSomethingElse;', ' end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryFinallyEmpty; +var + T: TPasImplTry; + F: TPasImplTryFinally; + +begin + TestStatement(['Try', 'finally', 'end;']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(0, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertEquals('Finally statement', TPasImplTryFinally, T.FinallyExcept.ClassType); + F := TPasImplTryFinally(T.FinallyExcept); + AssertEquals(0, F.Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' finally', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryFinallyNested; +var + T: TPasImplTry; + S: TPasImplSimple; + F: TPasImplTryFinally; + +begin + TestStatement(['Try', ' DoSomething1;', ' Try', ' DoSomething2;', + ' finally', ' DoSomethingElse2', ' end;', 'Finally', ' DoSomethingElse1', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(2, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething1'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Finally statement', TPasImplTryFinally, T.FinallyExcept.ClassType); + F := TPasImplTryFinally(T.FinallyExcept); + AssertEquals(1, F.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(F.Elements[0]).ClassType); + S := TPasImplSimple(F.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse1'); + // inner statement + AssertNotNull(T.Elements[1]); + AssertEquals('Nested try statement', TPasImplTry, TPasElement(T.Elements[1]).ClassType); + T := TPasImplTry(T.Elements[1]); + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething2'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Finally statement', TPasImplTryFinally, T.FinallyExcept.ClassType); + F := TPasImplTryFinally(T.FinallyExcept); + AssertEquals(1, F.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(F.Elements[0]).ClassType); + S := TPasImplSimple(F.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse2'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' DoSomething1;', + ' try', ' DoSomething2;', ' finally', + ' DoSomethingElse2;', ' end;', ' finally', + ' DoSomethingElse1;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExcept; + +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + +begin + TestStatement(['Try', ' DoSomething;', 'except', ' DoSomethingElse', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(E.Elements[0]).ClassType); + S := TPasImplSimple(E.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' DoSomething;', + ' except', ' DoSomethingElse;', ' end;', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptNested; +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + +begin + TestStatement(['Try', ' DoSomething1;', ' try', ' DoSomething2;', + ' except', ' DoSomethingElse2', ' end', 'except', ' DoSomethingElse1', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(2, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething1'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(E.Elements[0]).ClassType); + S := TPasImplSimple(E.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse1'); + AssertNotNull(T.Elements[1]); + AssertEquals('Simple statement', TPasImplTry, TPasElement(T.Elements[1]).ClassType); + T := TPasImplTry(T.Elements[1]); + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement 2', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething2 call ', S.Expr, pekIdent, 'DoSomething2'); + AssertEquals('Simple statement2', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement2', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Simple statement2', TPasImplSimple, TPasElement(E.Elements[0]).ClassType); + S := TPasImplSimple(E.Elements[0]); + AssertExpression('DoSomethingElse2 call', S.Expr, pekIdent, 'DoSomethingElse2'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' DoSomething1;', + ' try', ' DoSomething2;', ' except', + ' DoSomethingElse2;', ' end;', ' except', + ' DoSomethingElse1;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptEmpty; + +var + T: TPasImplTry; + E: TPasImplTryExcept; + +begin + TestStatement(['Try', 'except', 'end;']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(0, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(0, E.Elements.Count); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' except', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptOn; + +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + O: TPasImplExceptOn; + +begin + TestStatement(['Try', ' DoSomething;', 'except', 'On E : Exception do', + 'DoSomethingElse;', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[0]).ClassType); + O := TPasImplExceptOn(E.Elements[0]); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(O.Elements[0]).ClassType); + AssertEquals('Exception Variable name', 'E', O.VariableName); + AssertEquals('Exception Type name', 'Exception', O.TypeName); + S := TPasImplSimple(O.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + // AssertEquals('Variable name', + + AssertPasWriteOutput('output', BuildString(['program afile;', '', + '', 'begin', ' try', ' DoSomething;', ' except', + ' On E : Exception do', ' DoSomethingElse;', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptOn2; + +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + O: TPasImplExceptOn; + +begin + TestStatement(['Try', ' DoSomething;', 'except', + 'On E : Exception do', 'DoSomethingElse;', + 'On Y : Exception2 do', 'DoSomethingElse2;', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(2, E.Elements.Count); + // Exception handler 1 + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[0]).ClassType); + O := TPasImplExceptOn(E.Elements[0]); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(O.Elements[0]).ClassType); + AssertEquals('Exception Variable name', 'E', O.VariableName); + AssertEquals('Exception Type name', 'Exception', O.TypeName); + S := TPasImplSimple(O.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + // Exception handler 2 + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[1]).ClassType); + O := TPasImplExceptOn(E.Elements[1]); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(O.Elements[0]).ClassType); + AssertEquals('Exception Variable name', 'Y', O.VariableName); + AssertEquals('Exception Type name', 'Exception2', O.TypeName); + S := TPasImplSimple(O.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse2'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' try', ' DoSomething;', + ' except', ' On E : Exception do', ' DoSomethingElse;', + ' On Y : Exception2 do', ' DoSomethingElse2;', ' end;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptOnElse; +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + O: TPasImplExceptOn; + EE: TPasImplTryExceptElse; + I: TPasImplIfElse; + +begin + DeclareVar('Boolean', 'b'); + // Check that Else belongs to Except, not to IF + + TestStatement(['Try', ' DoSomething;', 'except', 'On E : Exception do', + 'if b then', 'DoSomethingElse;', 'else', 'DoSomethingMore;', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNotNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[0]).ClassType); + O := TPasImplExceptOn(E.Elements[0]); + AssertEquals('Exception Variable name', 'E', O.VariableName); + AssertEquals('Exception Type name', 'Exception', O.TypeName); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplIfElse, TPasElement(O.Elements[0]).ClassType); + I := TPasImplIfElse(O.Elements[0]); + AssertEquals(1, I.Elements.Count); + AssertNull('No else barcnh for if', I.ElseBranch); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(I.Elements[0]).ClassType); + S := TPasImplSimple(I.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + AssertEquals('Except Else statement', TPasImplTryExceptElse, T.ElseBranch.ClassType); + EE := TPasImplTryExceptElse(T.ElseBranch); + AssertEquals(1, EE.Elements.Count); + AssertNotNull(EE.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(EE.Elements[0]).ClassType); + S := TPasImplSimple(EE.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomethingMore'); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'var', ' b: Boolean;', '', 'begin', + ' try', ' DoSomething;', ' except', ' On E : Exception do', + ' if b then', ' DoSomethingElse;', ' else', + ' DoSomethingMore;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptOnIfElse; +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + O: TPasImplExceptOn; + EE: TPasImplTryExceptElse; + +begin + TestStatement(['Try', ' DoSomething;', 'except', 'On E : Exception do', + 'DoSomethingElse;', 'else', 'DoSomethingMore;', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNotNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[0]).ClassType); + O := TPasImplExceptOn(E.Elements[0]); + AssertEquals('Exception Variable name', 'E', O.VariableName); + AssertEquals('Exception Type name', 'Exception', O.TypeName); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(O.Elements[0]).ClassType); + S := TPasImplSimple(O.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + AssertEquals('Except Else statement', TPasImplTryExceptElse, T.ElseBranch.ClassType); + EE := TPasImplTryExceptElse(T.ElseBranch); + AssertEquals(1, EE.Elements.Count); + AssertNotNull(EE.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(EE.Elements[0]).ClassType); + S := TPasImplSimple(EE.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomethingMore'); + AssertPasWriteOutput('output', BuildString( + ['program afile;', '', '', 'begin', ' try', ' DoSomething;', + ' except', ' On E : Exception do', ' DoSomethingElse;', ' else', + ' DoSomethingMore;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptOnElseNoSemicolo; +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + O: TPasImplExceptOn; + EE: TPasImplTryExceptElse; +begin + TestStatement(['Try', ' DoSomething;', 'except', 'On E : Exception do', + 'DoSomethingElse', 'else', 'DoSomethingMore', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNotNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Except on handler', TPasImplExceptOn, TPasElement( + E.Elements[0]).ClassType); + O := TPasImplExceptOn(E.Elements[0]); + AssertEquals('Exception Variable name', 'E', O.VariableName); + AssertEquals('Exception Type name', 'Exception', O.TypeName); + AssertEquals(1, O.Elements.Count); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(O.Elements[0]).ClassType); + S := TPasImplSimple(O.Elements[0]); + AssertExpression('DoSomethingElse call', S.Expr, pekIdent, 'DoSomethingElse'); + AssertEquals('Except Else statement', TPasImplTryExceptElse, T.ElseBranch.ClassType); + EE := TPasImplTryExceptElse(T.ElseBranch); + AssertEquals(1, EE.Elements.Count); + AssertNotNull(EE.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(EE.Elements[0]).ClassType); + S := TPasImplSimple(EE.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomethingMore'); + AssertPasWriteOutput('output', BuildString( + ['program afile;', '', '', 'begin', ' try', ' DoSomething;', + ' except', ' On E : Exception do', ' DoSomethingElse;', ' else', + ' DoSomethingMore;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterTry.TestTryExceptRaise; +var + T: TPasImplTry; + S: TPasImplSimple; + E: TPasImplTryExcept; + +begin + TestStatement(['Try', ' DoSomething;', 'except', ' raise', 'end']); + T := AssertStatement('Try statement', TPasImplTry) as TPasImplTry; + AssertEquals(1, T.Elements.Count); + AssertNotNull(T.FinallyExcept); + AssertNull(T.ElseBranch); + AssertNotNull(T.Elements[0]); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + S := TPasImplSimple(T.Elements[0]); + AssertExpression('DoSomething call', S.Expr, pekIdent, 'DoSomething'); + AssertEquals('Simple statement', TPasImplSimple, TPasElement(T.Elements[0]).ClassType); + AssertEquals('Except statement', TPasImplTryExcept, T.FinallyExcept.ClassType); + E := TPasImplTryExcept(T.FinallyExcept); + AssertEquals(1, E.Elements.Count); + AssertEquals('Raise statement', TPasImplRaise, TPasElement(E.Elements[0]).ClassType); + AssertPasWriteOutput('output', BuildString( + ['program afile;', '', '', 'begin', ' try', ' DoSomething;', + ' except', ' raise;', ' end;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAsm.TestAsm; + +var + T: TPasImplAsmStatement; + +begin + TestStatement(['asm', ' mov eax,1', 'end;']); + T := AssertStatement('Asm statement', TPasImplAsmStatement) as TPasImplAsmStatement; + AssertEquals('Asm tokens', 4, T.Tokens.Count); + AssertEquals('token 1 ', 'mov', T.Tokens[0]); + AssertEquals('token 2 ', 'eax', T.Tokens[1]); + AssertEquals('token 3 ', ',', T.Tokens[2]); + AssertEquals('token 4 ', '1', T.Tokens[3]); + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAsm.TestAsmBlock; +begin + Source.Add('{$MODE DELPHI}'); + Source.Add('function BitsHighest(X: Cardinal): Integer;'); + Source.Add('asm'); + Source.Add('end;'); + Source.Add('begin'); + Source.Add('end.'); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'function BitsHighest(X: Cardinal): Integer;', 'begin', + 'end;', '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAsm.TestAsmBlockWithEndLabel; +begin + Source.Add('{$MODE DELPHI}'); + Source.Add('function BitsHighest(X: Cardinal): Integer;'); + Source.Add('asm'); + Source.Add(' MOV ECX, EAX'); + Source.Add(' MOV EAX, -1'); + Source.Add(' BSR EAX, ECX'); + Source.Add(' JNZ @@End'); + Source.Add(' MOV EAX, -1'); + Source.Add('@@End:'); + Source.Add('end;'); + Source.Add('begin'); + Source.Add('end.'); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'function BitsHighest(X: Cardinal): Integer;', 'begin', + 'end;', '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterAsm.TestAsmBlockInIfThen; +begin + Source.Add('{$MODE DELPHI}'); + Source.Add('function Get8087StatusWord(ClearExceptions: Boolean): Word;'); + Source.Add(' begin'); + Source.Add(' if ClearExceptions then'); + Source.Add(' asm'); + Source.Add(' end'); + Source.Add(' else'); + Source.Add(' asm'); + Source.Add(' end;'); + Source.Add(' end;'); + Source.Add(' begin'); + Source.Add(' end.'); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestAssignToAddress; + +begin + AddStatements(['@Proc:=Nil']); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' @Proc:=Nil;', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestFinalizationNoSemicolon; +begin + Source.Add('unit afile;'); + Source.Add('{$mode objfpc}'); + Source.Add('interface'); + Source.Add('implementation'); + Source.Add('initialization'); + Source.Add(' writeln(''qqq'')'); + Source.Add('finalization'); + Source.Add(' write(''rrr'')'); + ParseModule; + AssertPasWriteOutput('output', BuildString(['unit afile;', +'', +'interface', +'', +'', +'', +'implementation', +'', +'', +'initialization', +' writeln(''qqq'');', +'finalization', +' write(''rrr'');', +'end.','']), Module); +end; + +procedure TTestStatementWriterSpecials.TestMacroComment; +begin + AddStatements(['{$MACRO ON}', '{$DEFINE func := //}', ' calltest;', + ' func (''1'',''2'',''3'');', 'CallTest2;']); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' calltest;', ' CallTest2;', + 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestPlatformIdentifier; +begin + AddStatements(['write(platform);']); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(platform);', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestPlatformIdentifier2; +begin + AddStatements(['write(libs+platform);']); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' write(libs + platform);', 'end.', '']), + PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestArgumentNameOn; +begin + Source.Add('function TryOn(const on: boolean): boolean;'); + Source.Add(' begin'); + Source.Add(' end;'); + Source.Add(' begin'); + Source.Add(' end.'); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', 'function TryOn(const on: Boolean): Boolean;', 'begin', + 'end;', '', '', 'begin', 'end.', '']), PasProgram); +end; + +procedure TTestStatementWriterSpecials.TestGotoInIfThen; + +begin + AddStatements(['{$goto on}', 'if expr then', ' dosomething', + ' else if expr2 then', ' goto try_qword', ' else', + ' dosomething;', ' try_qword:', ' dosomething;']); + ParseModule; + AssertPasWriteOutput('output', BuildString(['program afile;', + '', '', 'begin', ' if expr then', ' dosomething', + ' else if expr2 then', ' goto try_qword', ' else', + ' dosomething;', ' try_qword:', ' dosomething;', + 'end.', '']), PasProgram); +end; + +initialization + RegisterTests('TestPassWriter', + [TTestStatementWriterEmpty, TTestStatementWriterBlock, TTestStatementWriterAssignment, + TTestStatementWriterCall, TTestStatementWriterIf, TTestStatementWriterCase, + TTestStatementWriterWith, TTestStatementWriterLoops, TTestStatementWriterRaise, + TTestStatementWriterTry, TTestStatementWriterAsm, TTestStatementWriterSpecials]); + +end. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 13e4b33328..cd881212a0 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -4281,6 +4281,15 @@ begin ' i:=longint(er);', ' if b in sr then ;', ' if er in sr then ;', + ' er:=low(TEnumRg);', + ' er:=high(TEnumRg);', + ' er:=succ(er);', + ' er:=pred(er);', + ' inc(er);', + ' dec(er);', + ' case er of', + ' c: ;', + ' end;', '']); ParseProgram; CheckResolverUnexpectedHints; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 23397538f3..9d2b1a86bb 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -5524,15 +5524,21 @@ var Params: TParamsExpr; Param: TPasExpr; ParamResolved: TPasResolverResult; + bt: TResolverBaseType; + C: TClass; begin Result:=inherited; Params:=TParamsExpr(Expr); Param:=Params.Params[1]; ComputeElement(Param,ParamResolved,[]); Result:=cIncompatible; - if ParamResolved.BaseType=btContext then + bt:=ParamResolved.BaseType; + if bt=btRange then + bt:=ParamResolved.SubType; + if bt=btContext then begin - if ParamResolved.LoTypeEl is TPasEnumType then + C:=ParamResolved.LoTypeEl.ClassType; + if (C=TPasEnumType) or (C=TPasRangeType) then Result:=cExact end; if Result=cIncompatible then @@ -11831,6 +11837,9 @@ var AddExpr: TJSAdditiveExpressionPlus; Int: TMaxPrecInt; aResolver: TPas2JSResolver; + from_bt: TResolverBaseType; + FromTypeEl: TPasType; + ElTypeResolved: TPasResolverResult; begin Result:=nil; Param:=El.Params[0]; @@ -11839,8 +11848,16 @@ begin JSBaseTypeData:=nil; JSBaseType:=pbtNone; + from_bt:=ParamResolved.BaseType; + FromTypeEl:=ParamResolved.LoTypeEl; + if from_bt=btRange then + begin + from_bt:=ParamResolved.SubType; + aResolver.ComputeElement(TPasRangeType(FromTypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]); + FromTypeEl:=ElTypeResolved.LoTypeEl; + end; to_bt:=ToBaseTypeData.BaseType; - if to_bt=ParamResolved.BaseType then + if from_bt=to_bt then begin Result:=ConvertExpression(Param,AContext); exit; @@ -11848,14 +11865,14 @@ begin if to_bt in btAllJSInteger then begin - if ParamResolved.BaseType in btAllJSInteger then + if from_bt in btAllJSInteger then begin // integer to integer -> value Result:=ConvertExpression(Param,AContext); - Result:=ConvertIntToInt(Result,ParamResolved.BaseType,to_bt,El,AContext); + Result:=ConvertIntToInt(Result,from_bt,to_bt,El,AContext); exit; end - else if ParamResolved.BaseType in btAllJSBooleans then + else if from_bt in btAllJSBooleans then begin // boolean to integer -> value?1:0 Result:=ConvertExpression(Param,AContext); @@ -11870,7 +11887,7 @@ begin Result:=CondExpr; exit; end - else if ParamResolved.BaseType in btAllJSChars then + else if from_bt in btAllJSChars then begin // char to integer Result:=ConvertExpression(Param,AContext); @@ -11878,9 +11895,9 @@ begin Result:=ConvertIntToInt(Result,btWord,to_bt,El,AContext); exit; end - else if ParamResolved.BaseType=btContext then + else if from_bt=btContext then begin - if ParamResolved.LoTypeEl.ClassType=TPasEnumType then + if FromTypeEl.ClassType=TPasEnumType then begin // e.g. longint(TEnum) -> value Result:=ConvertExpression(Param,AContext); @@ -11904,7 +11921,7 @@ begin exit; end; end - else if (to_bt=btCurrency) and (ParamResolved.BaseType in btAllJSFloats) then + else if (to_bt=btCurrency) and (from_bt in btAllJSFloats) then begin // currency(double) -> double*10000 Result:=ConvertExpression(Param,AContext); @@ -11914,13 +11931,13 @@ begin end else if to_bt in btAllJSBooleans then begin - if ParamResolved.BaseType in btAllJSBooleans then + if from_bt in btAllJSBooleans then begin // boolean to boolean -> value Result:=ConvertExpression(Param,AContext); exit; end - else if ParamResolved.BaseType in btAllJSInteger then + else if from_bt in btAllJSInteger then begin // integer to boolean -> value!=0 Result:=ConvertExpression(Param,AContext); @@ -11949,7 +11966,7 @@ begin end else if to_bt in btAllJSFloats then begin - if ParamResolved.BaseType in (btAllJSFloats+btAllJSInteger) then + if from_bt in (btAllJSFloats+btAllJSInteger) then begin // int to double -> value Result:=ConvertExpression(Param,AContext); @@ -11975,13 +11992,13 @@ begin end else if to_bt in btAllJSStrings then begin - if ParamResolved.BaseType in btAllJSStringAndChars then + if from_bt in btAllJSStringAndChars then begin // string or char to string -> value Result:=ConvertExpression(Param,AContext); exit; end - else if ParamResolved.BaseType=btPointer then + else if from_bt=btPointer then begin // string(aPointer) -> value Result:=ConvertExpression(Param,AContext); @@ -12004,15 +12021,15 @@ begin end else if to_bt=btChar then begin - if ParamResolved.BaseType=btChar then + if from_bt=btChar then begin // char to char Result:=ConvertExpression(Param,AContext); exit; end - else if (ParamResolved.BaseType in btAllJSInteger) - or ((ParamResolved.BaseType=btContext) - and (aResolver.ResolveAliasType(ParamResolved.LoTypeEl).ClassType=TPasEnumType)) + else if (from_bt in btAllJSInteger) + or ((from_bt=btContext) + and (FromTypeEl.ClassType=TPasEnumType)) then begin // Note: convert value first in case it raises an exception @@ -12030,7 +12047,7 @@ begin end; exit; end - else if (ParamResolved.BaseType in (btArrayRangeTypes+[btRange])) + else if (from_bt in (btArrayRangeTypes+[btRange])) or (IsParamPas2JSBaseType and (JSBaseType=pbtJSValue)) then begin // convert value to char -> rtl.getChar(value) @@ -12071,13 +12088,13 @@ begin exit; end; end - else if ParamResolved.BaseType in btAllJSStrings then + else if from_bt in btAllJSStrings then begin // pointer(aString) -> value Result:=ConvertExpression(Param,AContext); exit; end - else if ParamResolved.BaseType=btContext then + else if from_bt=btContext then begin // convert user type/value to pointer -> value Result:=ConvertExpression(Param,AContext); @@ -12753,6 +12770,8 @@ var Minus: TJSAdditiveExpressionMinus; Add: TJSAdditiveExpressionPlus; aResolver: TPas2JSResolver; + bt: TResolverBaseType; + C: TClass; begin Result:=nil; aResolver:=AContext.Resolver; @@ -12760,7 +12779,10 @@ begin RaiseInconsistency(20170210105235,El); Param:=El.Params[0]; aResolver.ComputeElement(Param,ParamResolved,[]); - if ParamResolved.BaseType=btChar then + bt:=ParamResolved.BaseType; + if bt=btRange then + bt:=ParamResolved.SubType; + if bt=btChar then begin if Param is TParamsExpr then begin @@ -12805,7 +12827,7 @@ begin Result:=CreateCallCharCodeAt(Result,0,El); exit; end - else if ParamResolved.BaseType in btAllJSBooleans then + else if bt in btAllJSBooleans then begin // ord(bool) Result:=CheckOrdConstant(aResolver,Param); @@ -12819,9 +12841,10 @@ begin Result:=Add; exit; end - else if ParamResolved.BaseType=btContext then + else if bt=btContext then begin - if ParamResolved.LoTypeEl.ClassType=TPasEnumType then + C:=ParamResolved.LoTypeEl.ClassType; + if (C=TPasEnumType) or (C=TPasRangeType) then begin // ord(enum) -> enum Result:=ConvertExpression(Param,AContext); @@ -12856,25 +12879,39 @@ function TPasToJSConverter.ConvertBuiltIn_LowHigh(El: TParamsExpr; end; var - ResolvedEl: TPasResolverResult; Param: TPasExpr; + aResolver: TPas2JSResolver; + ResolvedEl: TPasResolverResult; TypeEl: TPasType; Ranges: TPasExprArray; Value: TResEvalValue; Call: TJSCallExpression; MinusExpr: TJSAdditiveExpressionMinus; MinVal, MaxVal: TMaxPrecInt; + bt: TResolverBaseType; begin Result:=nil; if AContext.Resolver=nil then RaiseInconsistency(20170210120659,El); Param:=El.Params[0]; - AContext.Resolver.ComputeElement(Param,ResolvedEl,[]); - case ResolvedEl.BaseType of + aResolver:=AContext.Resolver; + aResolver.ComputeElement(Param,ResolvedEl,[]); + bt:=ResolvedEl.BaseType; + if bt=btRange then + bt:=ResolvedEl.SubType; + case bt of btContext: begin TypeEl:=ResolvedEl.LoTypeEl; - if TypeEl.ClassType=TPasEnumType then + if TypeEl.ClassType=TPasRangeType then + begin + if IsLow then + Result:=ConvertElement(TPasRangeType(TypeEl).RangeExpr.left,AContext) + else + Result:=ConvertElement(TPasRangeType(TypeEl).RangeExpr.right,AContext); + exit; + end + else if TypeEl.ClassType=TPasEnumType then begin CreateEnumValue(TPasEnumType(TypeEl)); exit; @@ -13261,25 +13298,32 @@ var end; var - ResolvedEl: TPasResolverResult; + aResolver: TPas2JSResolver; + ResolvedEl, ElTypeResolved: TPasResolverResult; NeedStrLit: Boolean; Call: TJSCallExpression; Bracket: TJSBracketMemberExpression; Arg: TJSElement; + bt: TResolverBaseType; + TypeEl: TPasType; begin Result:=nil; - AContext.Resolver.ComputeElement(El,ResolvedEl,[]); + aResolver:=AContext.Resolver; + aResolver.ComputeElement(El,ResolvedEl,[]); Add:=nil; Call:=nil; Bracket:=nil; try NeedStrLit:=false; - if ResolvedEl.BaseType in (btAllJSBooleans+btAllJSInteger-[btCurrency]) then + bt:=ResolvedEl.BaseType; + if bt=btRange then + bt:=ResolvedEl.SubType; + if bt in (btAllJSBooleans+btAllJSInteger-[btCurrency]) then begin NeedStrLit:=true; Add:=ConvertExpression(El,AContext); end - else if ResolvedEl.BaseType in (btAllJSFloats+[btCurrency]) then + else if bt in (btAllJSFloats+[btCurrency]) then begin // convert to rtl.floatToStr(El,width,precision) Call:=CreateCallExpression(El); @@ -13296,15 +13340,21 @@ begin Call:=nil; exit; end - else if IsStrFunc and (ResolvedEl.BaseType in btAllJSStringAndChars) then + else if IsStrFunc and (bt in btAllJSStringAndChars) then Add:=ConvertExpression(El,AContext) - else if ResolvedEl.BaseType=btContext then + else if bt=btContext then begin - if ResolvedEl.LoTypeEl.ClassType=TPasEnumType then + TypeEl:=ResolvedEl.LoTypeEl; + if TypeEl.ClassType=TPasRangeType then + begin + aResolver.ComputeElement(TPasRangeType(TypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]); + TypeEl:=ElTypeResolved.LoTypeEl; + end; + if TypeEl.ClassType=TPasEnumType then begin // create enumtype[enumvalue] Bracket:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El)); - Bracket.MExpr:=CreateReferencePathExpr(TPasEnumType(ResolvedEl.LoTypeEl),AContext); + Bracket.MExpr:=CreateReferencePathExpr(TPasEnumType(TypeEl),AContext); Bracket.Name:=ConvertExpression(El,AContext); Add:=Bracket; Bracket:=nil; @@ -13389,28 +13439,32 @@ function TPasToJSConverter.ConvertBuiltIn_Val(El: TParamsExpr; AContext: TConvertContext): TJSElement; // val(const s: string; out value: valuetype; out Code: integertype) // for enum it is converted to -// value = rtl.valEnum(s,enumTupe,function(c){ Code=c; }) +// value = rtl.valEnum(s,enumType,function(c){ Code=c; }) var + aResolver: TPas2JSResolver; AssignContext: TAssignContext; ValueExpr, CodeExpr: TPasExpr; Call: TJSCallExpression; Params: TPasExprArray; EnumType: TPasEnumType; Fun: TJSFunctionDeclarationStatement; - ExprResolved: TPasResolverResult; + ExprResolved, ElTypeResolved: TPasResolverResult; ExprArg: TPasArgument; AssignSt: TJSSimpleAssignStatement; SetterArgName: String; ArgJS, SetExpr: TJSElement; + bt: TResolverBaseType; + LoTypeEl: TPasType; begin Result:=nil; + aResolver:=AContext.Resolver; Params:=El.Params; Call:=nil; AssignContext:=TAssignContext.Create(El,nil,AContext); try // ValueExpr:=Params[1]; - AContext.Resolver.ComputeElement(ValueExpr,AssignContext.LeftResolved,[rcNoImplicitProc]); + aResolver.ComputeElement(ValueExpr,AssignContext.LeftResolved,[rcNoImplicitProc]); // rtl.valEnum() Call:=CreateCallExpression(El); @@ -13419,11 +13473,20 @@ begin // add arg string Call.AddArg(ConvertExpression(Params[0],AContext)); // add arg enumtype - if AssignContext.LeftResolved.BaseType=btContext then + bt:=AssignContext.LeftResolved.BaseType; + if bt=btRange then + bt:=AssignContext.LeftResolved.SubType; + if bt=btContext then begin - if AssignContext.LeftResolved.LoTypeEl is TPasEnumType then + LoTypeEl:=AssignContext.LeftResolved.LoTypeEl; + if LoTypeEl.ClassType=TPasRangeType then begin - EnumType:=TPasEnumType(AssignContext.LeftResolved.LoTypeEl); + aResolver.ComputeElement(TPasRangeType(LoTypeEl).RangeExpr.left,ElTypeResolved,[rcConstant]); + LoTypeEl:=ElTypeResolved.LoTypeEl; + end; + if LoTypeEl.ClassType=TPasEnumType then + begin + EnumType:=TPasEnumType(LoTypeEl); Call.AddArg(CreateReferencePathExpr(EnumType,AContext)); end else RaiseNotSupported(Params[1],AContext,20181214145226,GetResolverResultDbg(AssignContext.LeftResolved)); @@ -23321,6 +23384,8 @@ var Call: TJSCallExpression; DotExpr: TJSDotMemberExpression; aResolver: TPas2JSResolver; + bt: TResolverBaseType; + C: TClass; begin Result:=ConvertExpression(Expr,AContext); if Result=nil then @@ -23374,19 +23439,22 @@ begin if aResolver<>nil then begin aResolver.ComputeElement(Expr,ExprResolved,[]); - if (ExprResolved.BaseType in btAllJSStringAndChars) - or ((ExprResolved.BaseType=btRange) and (ExprResolved.SubType in btAllJSChars)) then + bt:=ExprResolved.BaseType; + if bt=btRange then + bt:=ExprResolved.SubType; + if bt in btAllJSStringAndChars then begin // aChar -> aChar.charCodeAt() Result:=CreateCallCharCodeAt(Result,0,Expr); end - else if ExprResolved.BaseType in btAllJSInteger then + else if bt in btAllJSInteger then begin // ok end - else if ExprResolved.BaseType=btContext then + else if bt=btContext then begin - if ExprResolved.LoTypeEl.ClassType=TPasEnumType then + C:=ExprResolved.LoTypeEl.ClassType; + if (C=TPasEnumType) or (C=TPasRangeType) then // ok else RaiseNotSupported(Expr,AContext,20170415191933); diff --git a/packages/pastojs/src/pas2jslibcompiler.pp b/packages/pastojs/src/pas2jslibcompiler.pp index 80f66f8756..6f3b377a25 100644 --- a/packages/pastojs/src/pas2jslibcompiler.pp +++ b/packages/pastojs/src/pas2jslibcompiler.pp @@ -67,6 +67,8 @@ Type FOnWriteJSCallBack: TWriteJSCallBack; FOnWriteJSData: Pointer; FReadBufferLen: Cardinal; + function GetLogEncoding: String; + procedure SetLogEncoding(AValue: String); Protected Function DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean; override; Procedure GetLastError(AError : PAnsiChar; Var AErrorLength : Longint; @@ -80,6 +82,7 @@ Type Function LibraryRun(ACompilerExe, AWorkingDir : PAnsiChar; CommandLine : PPAnsiChar; DoReset : Boolean) :Boolean; {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; Property LastError : String Read FLastError Write FLastError; Property LastErrorClass : String Read FLastErrorClass Write FLastErrorClass; + property LogEncoding: String read GetLogEncoding write SetLogEncoding; Property OnLibLogCallBack : TLibLogCallBack Read FOnLibLogCallBack Write FOnLibLogCallBack; Property OnLibLogData : Pointer Read FOnLibLogData Write FOnLibLogData; Property OnWriteJSCallBack : TWriteJSCallBack Read FOnWriteJSCallBack Write FOnWriteJSCallBack; @@ -107,6 +110,7 @@ Function RunPas2JSCompiler(P : PPas2JSCompiler; ACompilerExe, AWorkingDir : PAns Procedure FreePas2JSCompiler(P : PPas2JSCompiler); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; Function GetPas2JSCompiler : PPas2JSCompiler; {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; Procedure GetPas2JSCompilerLastError(P : PPas2JSCompiler; AError : PAnsiChar; Var AErrorLength : Longint; AErrorClass : PAnsiChar; Var AErrorClassLength : Longint); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; +procedure SetPas2JSLogEncoding(P : PPas2JSCompiler; Enconding: PAnsiChar); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; implementation @@ -120,6 +124,16 @@ begin Result:=OnReadDir(FOnReadDirData,Dir,PAnsiChar(Dir.Path)); end; +function TLibraryPas2JSCompiler.GetLogEncoding: String; +begin + Result := Log.Encoding; +end; + +procedure TLibraryPas2JSCompiler.SetLogEncoding(AValue: String); +begin + Log.Encoding := AValue; +end; + function TLibraryPas2JSCompiler.DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean; Var @@ -344,5 +358,10 @@ begin TLibraryPas2JSCompiler(P).GetLastError(AError,AErrorLength,AErrorClass,AErrorClassLength); end; +procedure SetPas2JSLogEncoding(P : PPas2JSCompiler; Enconding: PAnsiChar); {$IFDEF UseCDecl}cdecl{$ELSE}stdcall{$ENDIF}; +begin + TLibraryPas2JSCompiler(P).LogEncoding := Enconding; +end; + end. diff --git a/packages/pastojs/tests/tcfiler.pas b/packages/pastojs/tests/tcfiler.pas index 7b347f96ca..9f6f8fbeeb 100644 --- a/packages/pastojs/tests/tcfiler.pas +++ b/packages/pastojs/tests/tcfiler.pas @@ -2730,7 +2730,7 @@ begin 'implementation', 'generic function Run(a: T): T;', 'var b: T;', - ' var i: word;', + ' i: word;', 'begin', ' b:=a;', ' Result:=b;', diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index ee8d14c966..63d06c0eb7 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -358,12 +358,14 @@ type Procedure TestAnonymousProc_NestedAssignResult; Procedure TestAnonymousProc_Class; Procedure TestAnonymousProc_ForLoop; + Procedure TestAnonymousProc_AsmDelphi; // enums, sets Procedure TestEnum_Name; Procedure TestEnum_Number; Procedure TestEnum_ConstFail; Procedure TestEnum_Functions; + Procedure TestEnumRg_Functions; Procedure TestEnum_AsParams; Procedure TestEnumRange_Array; Procedure TestEnum_ForIn; @@ -5256,6 +5258,51 @@ begin ])); end; +procedure TTestModule.TestAnonymousProc_AsmDelphi; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + 'type', + ' TProc = reference to procedure;', + ' TFunc = reference to function(x: word): word;', + 'procedure Run;', + 'asm', + 'end;', + 'procedure Walk(p: TProc; f: TFunc);', + 'begin', + ' Walk(procedure asm end, function(b:word): word asm return 1+b; end);', + 'end;', + 'begin', + ' Walk(procedure', + ' asm', + ' console.log("a");', + ' end,', + ' function(x: word): word asm', + ' console.log("c");', + ' end);', + '']); + ConvertProgram; + CheckSource('TestAnonymousProc_AsmDelphi', + LinesToStr([ // statements + 'this.Run = function () {', + '};', + 'this.Walk = function (p, f) {', + ' $mod.Walk(function () {', + ' }, function (b) {', + ' return 1+b;', + ' });', + '};', + '']), + LinesToStr([ + '$mod.Walk(function () {', + ' console.log("a");', + '}, function (x) {', + ' console.log("c");', + '});', + ''])); +end; + procedure TTestModule.TestEnum_Name; begin StartProgram(false); @@ -5373,7 +5420,6 @@ begin ' s:=str(e:3);', ' writestr(s,e:3,red);', ' val(s,e,i);', - ' e:=TMyEnum(i);', ' i:=longint(e);']); ConvertProgram; CheckSource('TestEnum_Functions', @@ -5424,7 +5470,93 @@ begin '$mod.e = rtl.valEnum($mod.s, $mod.TMyEnum, function (v) {', ' $mod.i = v;', '});', + '$mod.i=$mod.e;', + ''])); +end; + +procedure TTestModule.TestEnumRg_Functions; +begin + StartProgram(false); + Add([ + 'type', + ' TEnum = (Red, Green, Blue);', + ' TEnumRg = Green..Blue;', + 'procedure DoIt(var e: TEnumRg; var i: word);', + 'var', + ' v: longint;', + ' s: string;', + 'begin', + ' val(s,e,v);', + ' val(s,e,i);', + 'end;', + 'var', + ' e: TEnumRg;', + ' i: longint;', + ' s: string;', + 'begin', + ' i:=ord(green);', + ' i:=ord(e);', + ' e:=low(tenumrg);', + ' e:=low(e);', + ' e:=high(tenumrg);', + ' e:=high(e);', + ' e:=pred(blue);', + ' e:=pred(e);', + ' e:=succ(green);', + ' e:=succ(e);', + ' e:=tenumrg(1);', + ' e:=tenumrg(i);', + ' s:=str(e);', + ' str(e,s);', + ' str(red,s);', + ' s:=str(e:3);', + ' writestr(s,e:3,blue);', + ' val(s,e,i);', + ' i:=longint(e);']); + ConvertProgram; + CheckSource('TestEnumRg_Functions', + LinesToStr([ // statements + 'this.TEnum = {', + ' "0":"Red",', + ' Red:0,', + ' "1":"Green",', + ' Green:1,', + ' "2":"Blue",', + ' Blue:2', + ' };', + 'this.DoIt = function (e, i) {', + ' var v = 0;', + ' var s = "";', + ' e.set(rtl.valEnum(s, $mod.TEnum, function (w) {', + ' v = w;', + ' }));', + ' e.set(rtl.valEnum(s, $mod.TEnum, i.set));', + '};', + 'this.e = this.TEnum.Green;', + 'this.i = 0;', + 'this.s = "";', + '']), + LinesToStr([ + '$mod.i=$mod.TEnum.Green;', + '$mod.i=$mod.e;', + '$mod.e=$mod.TEnum.Green;', + '$mod.e=$mod.TEnum.Green;', + '$mod.e=$mod.TEnum.Blue;', + '$mod.e=$mod.TEnum.Blue;', + '$mod.e=$mod.TEnum.Blue-1;', + '$mod.e=$mod.e-1;', + '$mod.e=$mod.TEnum.Green+1;', + '$mod.e=$mod.e+1;', + '$mod.e=1;', '$mod.e=$mod.i;', + '$mod.s = $mod.TEnum[$mod.e];', + '$mod.s = $mod.TEnum[$mod.e];', + '$mod.s = $mod.TEnum[$mod.TEnum.Red];', + '$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3);', + '$mod.s = rtl.spaceLeft($mod.TEnum[$mod.e], 3)+$mod.TEnum[$mod.TEnum.Blue];', + '$mod.e = rtl.valEnum($mod.s, $mod.TEnum, function (v) {', + ' $mod.i = v;', + '});', '$mod.i=$mod.e;', ''])); end; @@ -5824,23 +5956,28 @@ end; procedure TTestModule.TestSet_Operator_In; begin StartProgram(false); - Add('type'); - Add(' TColor = (Red, Green, Blue);'); - Add(' TColors = set of tcolor;'); - Add('var'); - Add(' vC: tcolor;'); - Add(' vT: tcolors;'); - Add(' B: boolean;'); - Add('begin'); - Add(' b:=red in vt;'); - Add(' b:=vc in vt;'); - Add(' b:=green in [red..blue];'); - Add(' b:=vc in [red..blue];'); - Add(' '); - Add(' if red in vt then ;'); - Add(' while vC in vt do ;'); - Add(' repeat'); - Add(' until vC in vt;'); + Add([ + 'type', + ' TColor = (Red, Green, Blue);', + ' TColors = set of tcolor;', + ' TColorRg = green..blue;', + 'var', + ' vC: tcolor;', + ' vT: tcolors;', + ' B: boolean;', + ' rg: TColorRg;', + 'begin', + ' b:=red in vt;', + ' b:=vc in vt;', + ' b:=green in [red..blue];', + ' b:=vc in [red..blue];', + ' ', + ' if red in vt then ;', + ' while vC in vt do ;', + ' repeat', + ' until vC in vt;', + ' if rg in [green..blue] then ;', + '']); ConvertProgram; CheckSource('TestSet_Operator_In', LinesToStr([ // statements @@ -5854,8 +5991,9 @@ begin ' };', 'this.vC = 0;', 'this.vT = {};', - 'this.B = false;' - ]), + 'this.B = false;', + 'this.rg = this.TColor.Green;', + '']), LinesToStr([ '$mod.B = $mod.TColor.Red in $mod.vT;', '$mod.B = $mod.vC in $mod.vT;', @@ -5866,6 +6004,7 @@ begin '};', 'do {', '} while (!($mod.vC in $mod.vT));', + 'if ($mod.rg in rtl.createSet(null, $mod.TColor.Green, $mod.TColor.Blue)) ;', ''])); end; diff --git a/rtl/inc/except.inc b/rtl/inc/except.inc index b3a1e7e96e..e224f7b34d 100644 --- a/rtl/inc/except.inc +++ b/rtl/inc/except.inc @@ -101,40 +101,43 @@ begin writeln ('In PushExceptObject'); {$endif} _ExceptObjectStack:=@ExceptObjectStack; - New(NewObj); + NewObj:=AllocMem(sizeof(TExceptObject)); NewObj^.Next:=_ExceptObjectStack^; _ExceptObjectStack^:=NewObj; NewObj^.FObject:=Obj; NewObj^.Addr:=AnAddr; - NewObj^.refcount:=0; + if assigned(get_frame) then + begin + NewObj^.refcount:=0; - { Backtrace } - curr_frame:=AFrame; - curr_addr:=AnAddr; - frames:=nil; - framecount:=0; - framebufsize:=0; - { The frame pointer of this procedure is used as initial stack bottom value. } - prev_frame:=get_frame; - while (framecount prev_frame) and - (curr_frame=framebufsize) then - begin - inc(framebufsize,16); - reallocmem(frames,framebufsize*sizeof(codepointer)); - end; - frames[framecount]:=curr_addr; - inc(framecount); - End; - NewObj^.framecount:=framecount; - NewObj^.frames:=frames; + { Backtrace } + curr_frame:=AFrame; + curr_addr:=AnAddr; + frames:=nil; + framecount:=0; + framebufsize:=0; + { The frame pointer of this procedure is used as initial stack bottom value. } + prev_frame:=get_frame; + while (framecount prev_frame) and + (curr_frame=framebufsize) then + begin + inc(framebufsize,16); + reallocmem(frames,framebufsize*sizeof(codepointer)); + end; + frames[framecount]:=curr_addr; + inc(framecount); + End; + NewObj^.framecount:=framecount; + NewObj^.frames:=frames; + end; Result:=NewObj; end; diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 6a0dc0b3c7..9b1f7932e1 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -1399,7 +1399,7 @@ end; Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer); var - i : Longint; + i : ObjpasInt; prevfp : Pointer; is_dev : boolean; Begin @@ -1435,7 +1435,7 @@ End; procedure dump_stack(var f: text; skipframes: longint); var - i,count: longint; + i,count: ObjpasInt; frames: array [0..255] of codepointer; begin if do_isdevice(textrec(f).handle) then @@ -1459,7 +1459,7 @@ end; procedure DumpExceptionBackTrace(var f:text); var FrameNumber, - FrameCount : longint; + FrameCount : ObjpasInt; Frames : PCodePointer; begin if RaiseList=nil then @@ -1525,7 +1525,7 @@ end; // if "s" goes out of scope in the parent procedure, the pointer is dangling. var p : ppchar; - i : LongInt; + i : ObjpasInt; begin if High(s)Count then NewLen:=Count; Result:=FEncoding.GetAnsiString(FBytes,FPosition,NewLen); + Inc(FPosition,NewLen); end; procedure TStringStream.WriteAnsiString(const AString: AnsiString); @@ -1704,6 +1705,7 @@ begin begin SetLength(Result, NewLen); Move(FBytes[FPosition],Result[1],NewLen); + inc(FPosition,Newlen); end; end; diff --git a/rtl/objpas/sysconst.pp b/rtl/objpas/sysconst.pp index 2aa466adf6..39b844dfa2 100644 --- a/rtl/objpas/sysconst.pp +++ b/rtl/objpas/sysconst.pp @@ -100,6 +100,7 @@ const SSafecallException = 'Exception in safecall method'; SiconvError = 'iconv error'; SThreadError = 'Thread error'; + SSeekFailed = 'Seek operation failed'; STooManyOpenFiles = 'Too many open files'; SUnKnownRunTimeError = 'Unknown Run-Time error : %3.3d'; diff --git a/rtl/objpas/sysutils/filutil.inc b/rtl/objpas/sysutils/filutil.inc index 29e33f915f..e61a344386 100644 --- a/rtl/objpas/sysutils/filutil.inc +++ b/rtl/objpas/sysutils/filutil.inc @@ -670,3 +670,80 @@ begin Result:= False; end; {$endif} + +Function GetFileContents(Const aFileName : RawByteString) : TBytes; + +Var + H : Thandle; + +begin + H:=FileOpen(aFileName,fmOpenRead or fmShareDenyWrite); + if H<0 then + Raise EFileNotFoundException.Create(SFileNotFound); + try + Result:=GetFileContents(H); + finally + FileClose(H); + end; +end; + +Function GetFileContents(Const aFileName : UnicodeString) : TBytes; + +Var + H : Thandle; + +begin + H:=FileOpen(aFileName,fmOpenRead or fmShareDenyWrite); + if H<0 then + Raise EFileNotFoundException.Create(SFileNotFound); + try + Result:=GetFileContents(H); + finally + FileClose(H); + end; +end; + +Function GetFileContents(Const aHandle : THandle) : TBytes; + +Var + aLen,aOffset,aRead : Int64; + aBuf : PByte; + +begin + aLen:=FileSeek(aHandle,0,fsFromEnd); + if aLen<0 then + Raise EInOutError.Create(SSeekFailed); + if FileSeek(aHandle,0,fsFromBeginning)<0 then + Raise EInOutError.Create(SSeekFailed); + SetLength(Result,aLen); + aOffset:=0; + Repeat + aBuf:=@Result[aOffset]; + aRead:=FileRead(aHandle,aBuf^,aLen-aOffset); + aOffset:=aOffset+aRead; + Until (aOffset>=aLen) or (aRead<=0); + if aRead<0 then + RaiseLastOSError; +end; + +Function GetFileAsString(Const aFileName : RawByteString; aEncoding : TEncoding) : RawByteString; + +begin + Result:=aEncoding.GetAnsiString(GetFileContents(aFileName)); +end; + +Function GetFileAsString(Const aFileName : RawByteString) : RawByteString; + +begin + Result:=GetFileAsString(aFileName,TEncoding.SystemEncoding); +end; + +Function GetFileAsString(Const aFileName : UnicodeString) : UnicodeString; +begin + Result:=GetFileAsString(aFileName, TEncoding.Unicode); +end; + +Function GetFileAsString(Const aFileName : UnicodeString; aEncoding : TEncoding) : UnicodeString; +begin + Result:=aEncoding.GetString(GetFileContents(aFileName)) +end; diff --git a/rtl/objpas/sysutils/filutilh.inc b/rtl/objpas/sysutils/filutilh.inc index b827340e09..651deb9a34 100644 --- a/rtl/objpas/sysutils/filutilh.inc +++ b/rtl/objpas/sysutils/filutilh.inc @@ -229,3 +229,12 @@ Function FileGetDate (Handle : THandle) : Int64; Function FileSetDate (Handle : THandle;Age : Int64) : Longint; Function GetFileHandle(var f : File):THandle; Function GetFileHandle(var f : Text):THandle; + +Function GetFileContents(Const aFileName : RawByteString) : TBytes; +Function GetFileContents(Const aFileName : UnicodeString) : TBytes; +Function GetFileContents(Const aHandle : THandle) : TBytes; +Function GetFileAsString(Const aFileName : RawByteString) : RawByteString; +Function GetFileAsString(Const aFileName : RawByteString; aEncoding : TEncoding) : RawByteString; +Function GetFileAsString(Const aFileName : UnicodeString) : UnicodeString; +Function GetFileAsString(Const aFileName : UnicodeString; aEncoding : TEncoding) : UnicodeString; + diff --git a/rtl/unix/bunxovl.inc b/rtl/unix/bunxovl.inc index 12025aad32..c5774ea3a3 100644 --- a/rtl/unix/bunxovl.inc +++ b/rtl/unix/bunxovl.inc @@ -248,10 +248,16 @@ begin end; {$endif} +const + { read/write permission for everyone } + MODE_FPOPEN = S_IWUSR OR S_IRUSR OR + S_IWGRP OR S_IRGRP OR + S_IWOTH OR S_IROTH; + Function FpOpen (path : pChar; flags : cInt):cInt; {$ifdef VER2_0}inline;{$endif} begin - FpOpen:=FpOpen(path,flags,438); + FpOpen:=FpOpen(path,flags,MODE_FPOPEN); end; Function FpOpen (const path : RawByteString; flags : cInt):cInt; {$ifdef VER2_0}inline;{$endif} @@ -259,14 +265,14 @@ var SystemPath: RawByteString; Begin SystemPath:=ToSingleByteFileSystemEncodedFileName(path); - FpOpen:=FpOpen(pchar(SystemPath),flags,438); + FpOpen:=FpOpen(pchar(SystemPath),flags,MODE_FPOPEN); end; Function FpOpen (path : String; flags : cInt):cInt; begin path:=path+#0; - FpOpen:=FpOpen(@path[1],flags,438); + FpOpen:=FpOpen(@path[1],flags,MODE_FPOPEN); end; Function FpOpen (path : String; flags : cInt; Mode: TMode):cInt; diff --git a/tests/webtbs/tw35841.pp b/tests/webtbs/tw35841.pp new file mode 100644 index 0000000000..997a1bba70 --- /dev/null +++ b/tests/webtbs/tw35841.pp @@ -0,0 +1,18 @@ +{ %norun } +{$mode objfpc} +procedure p; + begin + try + writeln + except + try + writeln; + Exit; + finally + writeln; + end; + end; + end; + +begin +end. diff --git a/utils/pas2js/pas2jslib.pp b/utils/pas2js/pas2jslib.pp index f0376e38dd..0657b571db 100644 --- a/utils/pas2js/pas2jslib.pp +++ b/utils/pas2js/pas2jslib.pp @@ -17,7 +17,8 @@ exports AddPas2JSDirectoryEntry, SetPas2JSUnitAliasCallBack, SetPas2JSCompilerLogCallBack, - GetPas2JSCompilerLastError; + GetPas2JSCompilerLastError, + SetPas2JSLogEncoding; end.