diff options
Diffstat (limited to 'avx512-0037785/packages/fcl-passrc')
22 files changed, 5832 insertions, 715 deletions
diff --git a/avx512-0037785/packages/fcl-passrc/Makefile b/avx512-0037785/packages/fcl-passrc/Makefile index ff1044537e..484cb79715 100644 --- a/avx512-0037785/packages/fcl-passrc/Makefile +++ b/avx512-0037785/packages/fcl-passrc/Makefile @@ -2,7 +2,7 @@ # Don't edit, this file is generated by FPCMake Version 2.0.0 # default: all -MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-freertos arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android mips64el-linux jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-darwin aarch64-win64 aarch64-android aarch64-ios wasm-wasm sparc64-linux riscv32-linux riscv32-embedded riscv64-linux riscv64-embedded xtensa-linux xtensa-embedded xtensa-freertos z80-embedded z80-zxspectrum z80-msxdos +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded m68k-sinclairql powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-freertos arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android mips64el-linux jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-darwin aarch64-win64 aarch64-android aarch64-ios wasm-wasm sparc64-linux riscv32-linux riscv32-embedded riscv64-linux riscv64-embedded xtensa-linux xtensa-embedded xtensa-freertos z80-embedded z80-zxspectrum z80-msxdos z80-amstradcpc BSDs = freebsd netbsd openbsd darwin dragonfly UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom msdos win16 atari @@ -584,15 +584,34 @@ ifneq ($(findstring sparc64,$(shell uname -a)),) ifeq ($(BINUTILSPREFIX),) GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`) else +ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),) +CROSSGCCOPT=-mabi=32 +else CROSSGCCOPT=-m32 endif endif endif endif +endif ifdef FPCFPMAKE FPCFPMAKE_CPU_TARGET=$(shell $(FPCFPMAKE) -iTP) ifeq ($(CPU_TARGET),$(FPCFPMAKE_CPU_TARGET)) FPCMAKEGCCLIBDIR:=$(GCCLIBDIR) +else +ifneq ($(findstring $(FPCFPMAKE_CPU_TARGET),aarch64 powerpc64 riscv64 sparc64 x86_64),) +FPCMAKE_CROSSGCCOPT=-m64 +else +ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips64 mips64el),) +FPCMAKE_CROSSGCCOPT=-mabi=64 +else +ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),) +FPCMAKE_CROSSGCCOPT=-mabi=32 +else +FPCMAKE_CROSSGCCOPT=-m32 +endif +endif +endif +FPCMAKEGCCLIBDIR:=$(shell dirname `gcc $(FPCMAKE_CROSSGCCOPT) -print-libgcc-file-name`) endif endif ifndef FPCMAKEGCCLIBDIR @@ -1333,6 +1352,14 @@ REQUIRE_PACKAGES_HASH=1 REQUIRE_PACKAGES_LIBTAR=1 REQUIRE_PACKAGES_FPMKUNIT=1 endif +ifeq ($(FULL_TARGET),m68k-sinclairql) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_LIBTAR=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +endif ifeq ($(FULL_TARGET),powerpc-linux) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_PASZLIB=1 @@ -1909,6 +1936,14 @@ REQUIRE_PACKAGES_HASH=1 REQUIRE_PACKAGES_LIBTAR=1 REQUIRE_PACKAGES_FPMKUNIT=1 endif +ifeq ($(FULL_TARGET),z80-amstradcpc) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_LIBTAR=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +endif ifdef REQUIRE_PACKAGES_RTL PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR)))))) ifneq ($(PACKAGEDIR_RTL),) @@ -2154,11 +2189,11 @@ endif ifndef CROSSBOOTSTRAP ifneq ($(BINUTILSPREFIX),) override FPCOPT+=-XP$(BINUTILSPREFIX) -endif -ifneq ($(BINUTILSPREFIX),) +ifneq ($(RLINKPATH),) override FPCOPT+=-Xr$(RLINKPATH) endif endif +endif ifndef CROSSCOMPILE ifneq ($(BINUTILSPREFIX),) override FPCMAKEOPT+=-XP$(BINUTILSPREFIX) diff --git a/avx512-0037785/packages/fcl-passrc/fpmake.pp b/avx512-0037785/packages/fcl-passrc/fpmake.pp index f0936de865..4bdbda94cf 100644 --- a/avx512-0037785/packages/fcl-passrc/fpmake.pp +++ b/avx512-0037785/packages/fcl-passrc/fpmake.pp @@ -25,7 +25,7 @@ begin P.Email := ''; P.Description := 'Pascal parsing parts of Free Component Libraries (FCL), FPC''s OOP library.'; P.NeedLibC:= false; - P.OSes:=AllOSes-[embedded,msdos,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc]; + P.OSes:=AllOSes-[embedded,msdos,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc,sinclairql]; if Defaults.CPU=jvm then P.OSes := P.OSes - [java,android]; diff --git a/avx512-0037785/packages/fcl-passrc/src/pasresolveeval.pas b/avx512-0037785/packages/fcl-passrc/src/pasresolveeval.pas index 85995de067..c570595277 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pasresolveeval.pas +++ b/avx512-0037785/packages/fcl-passrc/src/pasresolveeval.pas @@ -207,6 +207,8 @@ const nParamOfThisTypeCannotHaveDefVal = 3141; nClassTypesAreNotRelatedXY = 3142; nDirectiveXNotAllowedHere = 3143; + nAwaitWithoutPromise = 3144; + nSymbolCannotExportedFromALibrary = 3145; // using same IDs as FPC nVirtualMethodXHasLowerVisibility = 3250; // was 3050 @@ -361,6 +363,8 @@ resourcestring sParamOfThisTypeCannotHaveDefVal = 'Parameters of this type cannot have default values'; sClassTypesAreNotRelatedXY = 'Class types "%s" and "%s" are not related'; sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here'; + sAwaitWithoutPromise = 'Await without promise'; + sSymbolCannotExportedFromALibrary = 'The symbol cannot be exported from a library'; type { TResolveData - base class for data stored in TPasElement.CustomData } @@ -433,6 +437,7 @@ type revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3] revkExternal // TResEvalExternal: an external const ); + TREVKinds = set of TREVKind; const revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString]; type @@ -445,6 +450,7 @@ type function Clone: TResEvalValue; virtual; function AsDebugString: string; virtual; function AsString: string; virtual; + function TypeAsString: string; virtual; end; TResEvalValueClass = class of TResEvalValue; @@ -457,6 +463,7 @@ type constructor CreateValue(const aValue: boolean); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; TResEvalTypedInt = ( @@ -518,6 +525,7 @@ type function Clone: TResEvalValue; override; function AsString: string; override; function AsDebugString: string; override; + function TypeAsString: string; override; end; { TResEvalUInt } @@ -529,6 +537,7 @@ type constructor CreateValue(const aValue: TMaxPrecUInt); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalFloat } @@ -541,6 +550,7 @@ type function Clone: TResEvalValue; override; function AsString: string; override; function IsInt(out Int: TMaxPrecInt): boolean; + function TypeAsString: string; override; end; { TResEvalCurrency } @@ -554,6 +564,7 @@ type function AsString: string; override; function IsInt(out Int: TMaxPrecInt): boolean; function AsInt: TMaxPrecInt; // value * 10.000 + function TypeAsString: string; override; end; {$ifdef FPC_HAS_CPSTRING} @@ -562,10 +573,12 @@ type TResEvalString = class(TResEvalValue) public S: RawByteString; + OnlyASCII: boolean; constructor Create; override; constructor CreateValue(const aValue: RawByteString); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; {$endif} @@ -578,6 +591,7 @@ type constructor CreateValue(const aValue: UnicodeString); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalEnum - Kind=revkEnum, Value.Int } @@ -593,6 +607,7 @@ type function Clone: TResEvalValue; override; function AsDebugString: string; override; function AsString: string; override; + function TypeAsString: string; override; end; TRESetElKind = ( @@ -617,6 +632,7 @@ type function AsString: string; override; function AsDebugString: string; override; function ElementAsString(El: TMaxPrecInt): string; virtual; + function TypeAsString: string; override; end; { TResEvalRangeUInt } @@ -628,6 +644,7 @@ type constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt); function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; { TResEvalSet - Kind=revkSetOfInt } @@ -649,6 +666,7 @@ type const aRangeStart, aRangeEnd: TMaxPrecInt); override; function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer; function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range @@ -662,6 +680,7 @@ type constructor Create; override; function Clone: TResEvalValue; override; function AsString: string; override; + function TypeAsString: string; override; end; TResEvalFlag = ( @@ -690,7 +709,8 @@ type private FAllowedInts: TResEvalTypedInts; {$ifdef FPC_HAS_CPSTRING} - FDefaultEncoding: TSystemCodePage; + FDefaultSourceEncoding: TSystemCodePage; + FDefaultStringEncoding: TSystemCodePage; {$endif} FOnEvalIdentifier: TPasResEvalIdentHandler; FOnEvalParams: TPasResEvalParamsHandler; @@ -777,6 +797,8 @@ type function GetUTF8Str(const s: RawByteString; ErrorEl: TPasElement): String; function GetUnicodeStr(const s: RawByteString; ErrorEl: TPasElement): UnicodeString; function GetWideChar(const s: RawByteString; out w: WideChar): boolean; + function GetExprStringTargetCP(Expr: TPasExpr): TSystemCodePage; virtual; // e.g. var s: String(1234) = 'ä' return 1234 + function GetExprStringSourceCP(Expr: TPasExpr): TSystemCodePage; virtual; // e.g. {$codepage 123}var s: String = 'ä' return 123 {$endif} property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog; property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier; @@ -784,7 +806,8 @@ type property OnRangeCheckEl: TPasResEvalRangeCheckElHandler read FOnRangeCheckEl write FOnRangeCheckEl; property AllowedInts: TResEvalTypedInts read FAllowedInts write FAllowedInts; {$ifdef FPC_HAS_CPSTRING} - property DefaultStringCodePage: TSystemCodePage read FDefaultEncoding write FDefaultEncoding; + property DefaultSourceCodePage: TSystemCodePage read FDefaultSourceEncoding write FDefaultSourceEncoding; + property DefaultStringCodePage: TSystemCodePage read FDefaultStringEncoding write FDefaultStringEncoding; {$endif} end; TResExprEvaluatorClass = class of TResExprEvaluator; @@ -921,6 +944,7 @@ end; function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer ): Unicodestring; +// encode a string as a Pascal string literal using '' and # var InLit: boolean; Len: integer; @@ -1067,7 +1091,8 @@ begin begin GenType:=TPasGenericType(El); if (GenType.GenericTemplateTypes<>nil) - and (GenType.GenericTemplateTypes.Count>0) then + and (GenType.GenericTemplateTypes.Count>0) + and (Pos('<',El.Name)<1) then Result:=GetGenericParamCommas(GenType.GenericTemplateTypes.Count)+Result; end; if El.Name<>'' then @@ -1179,6 +1204,11 @@ begin Result:=inherited AsString; end; +function TResEvalExternal.TypeAsString: string; +begin + Result:='external value'; +end; + { TResEvalCurrency } constructor TResEvalCurrency.Create; @@ -1222,6 +1252,11 @@ begin {$endif}; end; +function TResEvalCurrency.TypeAsString: string; +begin + Result:='currency'; +end; + { TResEvalBool } constructor TResEvalBool.Create; @@ -1250,6 +1285,11 @@ begin Result:='false'; end; +function TResEvalBool.TypeAsString: string; +begin + Result:='boolean'; +end; + { TResEvalRangeUInt } constructor TResEvalRangeUInt.Create; @@ -1278,6 +1318,11 @@ begin Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd); end; +function TResEvalRangeUInt.TypeAsString: string; +begin + Result:='unsigned integer range'; +end; + { TResExprEvaluator } procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; @@ -4122,63 +4167,265 @@ end; function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr ): TResEvalValue; -{ Extracts the value from a Pascal string literal - - S is a Pascal string literal e.g. 'Line'#10 - '' empty string - '''' => "'" - #decimal - #$hex - ^l l is a letter a-z -} + //Extracts the value from a Pascal string literal + // + // S is a Pascal string literal e.g. 'Line'#10 + // '' empty string + // '''' => "'" + // #decimal + // #$hex + // ^l l is a letter a-z + // + // Codepage: + // For example {$codepage utf8}var s: AnsiString(CP_1251) = 'a'; + // Source codepage is CP_UTF8, target codepage is CP_1251 + // + // Source codepage is needed for reading non ASCII string literals 'ä'. + // Target codepage is needed for reading non ASCII # literals. + // Target codepage costs time to compute. +var + Value: TResEvalValue; procedure RangeError(id: TMaxPrecInt); begin - Result.Free; + Value.Free; RaiseRangeCheck(id,Expr); end; - procedure Add(h: String); +{$IFDEF FPC_HAS_CPSTRING} +var + TargetCPValid: boolean; + TargetCP: word; + SourceCPValid: boolean; + SourceCP: word; + + procedure FetchSourceCP; begin - {$ifdef FPC_HAS_CPSTRING} - if Result.Kind=revkString then - TResEvalString(Result).S:=TResEvalString(Result).S+h - else - TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+GetUnicodeStr(h,Expr); - {$else} - TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+h; - {$endif} + if SourceCPValid then exit; + SourceCP:=GetExprStringSourceCP(Expr); + if SourceCP=DefaultSystemCodePage then + SourceCP:=CP_ACP; + SourceCPValid:=true; end; - procedure AddHash(u: longword; ForceUTF16: boolean); - {$ifdef FPC_HAS_CPSTRING} + procedure FetchTargetCP; + begin + if TargetCPValid then exit; + TargetCP:=GetExprStringTargetCP(Expr); + if TargetCP=DefaultSystemCodePage then + TargetCP:=CP_ACP; + TargetCPValid:=true; + end; + + procedure ForceUTF16; var h: RawByteString; begin - if ((u>255) or (ForceUTF16)) and (Result.Kind=revkString) then + if Value.Kind=revkString then begin // switch to unicodestring - h:=TResEvalString(Result).S; - Result.Free; - Result:=nil; // in case of exception in GetUnicodeStr - Result:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr)); + h:=TResEvalString(Value).S; + Value.Free; + Value:=nil; // in case of exception in GetUnicodeStr + Value:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr)); end; - if Result.Kind=revkString then - TResEvalString(Result).S:=TResEvalString(Result).S+Chr(u) + end; +{$ENDIF} + + procedure AddSrc(h: String); + {$ifdef FPC_HAS_CPSTRING} + var + ValueAnsi: TResEvalString; + OnlyASCII: Boolean; + i: Integer; + {$ENDIF} + begin + if h='' then exit; + //writeln('AddSrc ',length(h),' ',ord(h[1]),' ',stringcodepage(h),' ',defaultsystemcodepage); + {$ifdef FPC_HAS_CPSTRING} + OnlyASCII:=true; + for i:=1 to length(h) do + if ord(h[i])>127 then + begin + // append non ASCII -> needs codepage + OnlyASCII:=false; + FetchSourceCP; + SetCodePage(rawbytestring(h),SourceCP,false); + break; + end; + + if Value.Kind=revkString then + begin + ValueAnsi:=TResEvalString(Value); + if OnlyASCII and ValueAnsi.OnlyASCII then + begin + // concatenate ascii strings + ValueAnsi.S:=ValueAnsi.S+h; + exit; + end; + + // concatenate non ascii strings + FetchTargetCP; + case TargetCP of + CP_UTF16: + begin + ForceUTF16; + TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr); + //writeln('AddSrc len(h)=',length(h),' StringCodePage=',StringCodePage(h),' GetCodePage=',GetCodePage(h),' S=',length(TResEvalUTF16(Value).S)); + end; + CP_UTF16BE: + RaiseNotYetImplemented(20201220222608,Expr); + else + begin + if ValueAnsi.S<>'' then + begin + if ValueAnsi.OnlyASCII then + SetCodePage(ValueAnsi.S,TargetCP,false); + ValueAnsi.S:=ValueAnsi.S+h; + end else begin + ValueAnsi.S:=h; + end; + end; + end; + + end else - TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u); + TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+GetUnicodeStr(h,Expr); + {$else} + TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+h; + {$endif} + end; + + procedure AddHash(u: longword); + {$ifdef FPC_HAS_CPSTRING} + begin + if Value.Kind=revkString then + TResEvalString(Value).s:=TResEvalString(Value).S+Chr(u) + else + TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u); end; {$else} begin - TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u); - if ForceUTF16 then ; + TResEvalUTF16(Value).S:=TResEvalUTF16(Value).S+WideChar(u); end; {$endif} + function ReadHash(const S: string; p, l: integer): integer; + var + StartP: Integer; + u: longword; + c: Char; + {$ifdef FPC_HAS_CPSTRING} + ValueAnsi: TResEvalString; + ValueUTF16: TResEvalUTF16; + OldCP: TSystemCodePage; + {$ENDIF} + begin + //writeln('ReadHash S="',S,'" p=',p,' l=',l,' ',StringCodePage(S)); + Result:=p; + inc(Result); + if Result>l then + RaiseInternalError(20181016121354); // error in scanner + if S[Result]='$' then + begin + // #$hexnumber + inc(Result); + StartP:=Result; + u:=0; + while Result<=l do + begin + c:=S[Result]; + case c of + '0'..'9': u:=u*16+longword(ord(c)-ord('0')); + 'a'..'f': u:=u*16+longword(ord(c)-ord('a'))+10; + 'A'..'F': u:=u*16+longword(ord(c)-ord('A'))+10; + else break; + end; + if u>$10FFFF then + RangeError(20170523115712); + inc(Result); + end; + end + else + begin + // #decimalnumber + StartP:=Result; + u:=0; + while Result<=l do + begin + c:=S[Result]; + case c of + '0'..'9': u:=u*10+longword(ord(c)-ord('0')); + else break; + end; + if u>$ffff then + RangeError(20170523123137); + inc(Result); + end; + end; + if Result=StartP then + RaiseInternalError(20170523123806); + {$IFDEF FPC_HAS_CPSTRING} + if u<128 then + begin + // ASCII + AddHash(u); + exit; + end; + // non ASCII + FetchTargetCP; + if (TargetCP=CP_UTF16) or (TargetCP=CP_UTF16BE) or (u>255) then + begin + ForceUTF16; + ValueUTF16:=TResEvalUTF16(Value); + if u>$ffff then + begin + // split into two + dec(u,$10000); + ValueUTF16.S:=ValueUTF16.S + +WideChar($D800+(u shr 10))+WideChar($DC00+(u and $3ff)); + end + else + ValueUTF16.S:=ValueUTF16.S+WideChar(u); + if TargetCP=CP_UTF16BE then + RaiseNotYetImplemented(20201220212206,Expr); + end + else + begin + // byte encoding + ValueAnsi:=TResEvalString(Value); + if ValueAnsi.S<>'' then + begin + // append + OldCP:=StringCodePage(ValueAnsi.S); + if OldCP<>TargetCP then + SetCodePage(ValueAnsi.S,TargetCP,false); + ValueAnsi.S:=ValueAnsi.S+Chr(u); + end + else + begin + // start + ValueAnsi.S:=Chr(u); + SetCodePage(ValueAnsi.S,TargetCP,false); + end; + ValueAnsi.OnlyASCII:=false; + end; + {$ELSE} + if u>$ffff then + begin + // split into two + dec(u,$10000); + AddHash($D800+(u shr 10)); + AddHash($DC00+(u and $3ff)); + end + else + AddHash(u); + {$ENDIF} + end; + var p, StartP, l: integer; c: Char; - u: longword; S: String; begin Result:=nil; @@ -4190,11 +4437,16 @@ begin if l=0 then RaiseInternalError(20170523113809); {$ifdef FPC_HAS_CPSTRING} - Result:=TResEvalString.Create; + TargetCPValid:=false; + TargetCP:=CP_ACP; + SourceCPValid:=false; + SourceCP:=CP_ACP; + Value:=TResEvalString.Create; {$else} - Result:=TResEvalUTF16.Create; + Value:=TResEvalUTF16.Create; {$endif} p:=1; + //writeln('TResExprEvaluator.EvalPrimitiveExprString ',GetObjPath(Expr),' ',Expr.SourceFilename,' ',Expr.SourceLinenumber div 2048,' S=[',S,']'); while p<=l do case S[p] of {$ifdef UsePChar} @@ -4212,12 +4464,12 @@ begin '''': begin if p>StartP then - Add(copy(S,StartP,p-StartP)); + AddSrc(copy(S,StartP,p-StartP)); inc(p); StartP:=p; if (p>l) or (S[p]<>'''') then break; - Add(''''); + AddSrc(''''); inc(p); StartP:=p; end; @@ -4226,65 +4478,10 @@ begin end; until false; if p>StartP then - Add(copy(S,StartP,p-StartP)); + AddSrc(copy(S,StartP,p-StartP)); end; '#': - begin - inc(p); - if p>l then - RaiseInternalError(20181016121354); - if S[p]='$' then - begin - // #$hexnumber - inc(p); - StartP:=p; - u:=0; - while p<=l do - begin - c:=S[p]; - case c of - '0'..'9': u:=u*16+longword(ord(c)-ord('0')); - 'a'..'f': u:=u*16+longword(ord(c)-ord('a'))+10; - 'A'..'F': u:=u*16+longword(ord(c)-ord('A'))+10; - else break; - end; - if u>$10FFFF then - RangeError(20170523115712); - inc(p); - end; - if p=StartP then - RaiseInternalError(20170207164956); - if u>$ffff then - begin - // split into two - dec(u,$10000); - AddHash($D800+(u shr 10),true); - AddHash($DC00+(u and $3ff),true); - end - else - AddHash(u,p-StartP>2); - end - else - begin - // #decimalnumber - StartP:=p; - u:=0; - while p<=l do - begin - c:=S[p]; - case c of - '0'..'9': u:=u*10+longword(ord(c)-ord('0')); - else break; - end; - if u>$ffff then - RangeError(20170523123137); - inc(p); - end; - if p=StartP then - RaiseInternalError(20170523123806); - AddHash(u,false); - end; - end; + p:=ReadHash(S,p,l); '^': begin // ^A is #1 @@ -4293,8 +4490,8 @@ begin RaiseInternalError(20181016121520); c:=S[p]; case c of - 'a'..'z': AddHash(ord(c)-ord('a')+1,false); - 'A'..'Z': AddHash(ord(c)-ord('A')+1,false); + 'a'..'z': AddHash(ord(c)-ord('a')+1); + 'A'..'Z': AddHash(ord(c)-ord('A')+1); else RaiseInternalError(20170523123809); end; inc(p); @@ -4302,6 +4499,7 @@ begin else RaiseNotYetImplemented(20170523123815,Expr,'ord='+IntToStr(ord(S[p]))); end; + Result:=Value; {$IFDEF VerbosePasResEval} //writeln('TResExprEvaluator.EvalPrimitiveExprString Result=',Result.AsString); {$ENDIF} @@ -4320,7 +4518,8 @@ begin inherited Create; FAllowedInts:=ReitDefaults; {$ifdef FPC_HAS_CPSTRING} - FDefaultEncoding:=CP_ACP; + FDefaultSourceEncoding:=system.DefaultSystemCodePage; + FDefaultStringEncoding:=CP_ACP; {$endif} end; @@ -5112,11 +5311,11 @@ end; function TResExprEvaluator.GetCodePage(const s: RawByteString): TSystemCodePage; begin - if s='' then exit(DefaultStringCodePage); + if s='' then exit(DefaultSourceCodePage); Result:=StringCodePage(s); if (Result=CP_ACP) or (Result=CP_NONE) then begin - Result:=DefaultStringCodePage; + Result:=DefaultSourceCodePage; if (Result=CP_ACP) or (Result=CP_NONE) then begin Result:=System.DefaultSystemCodePage; @@ -5178,7 +5377,7 @@ var begin if s='' then exit(''); CP:=GetCodePage(s); - if CP=CP_UTF8 then + if (CP=CP_UTF8) or ((CP=CP_ACP) and (DefaultSystemCodePage=CP_UTF8)) then begin if ErrorEl<>nil then CheckValidUTF8(s,ErrorEl); @@ -5213,6 +5412,20 @@ begin Result:=true; end; end; + +function TResExprEvaluator.GetExprStringTargetCP(Expr: TPasExpr + ): TSystemCodePage; +begin + Result:=DefaultStringCodePage; + if Expr=nil then ; +end; + +function TResExprEvaluator.GetExprStringSourceCP(Expr: TPasExpr + ): TSystemCodePage; +begin + Result:=DefaultSourceCodePage; + if Expr=nil then ; +end; {$endif} procedure TResExprEvaluator.PredBool(Value: TResEvalBool; ErrorEl: TPasElement); @@ -5438,6 +5651,15 @@ begin end; end; +function TResEvalValue.TypeAsString: string; +begin + case Kind of + revkNil: Result:='nil'; + else + Result:=''; + end; +end; + { TResEvalUInt } constructor TResEvalUInt.Create; @@ -5463,6 +5685,11 @@ begin Result:=IntToStr(UInt); end; +function TResEvalUInt.TypeAsString: string; +begin + Result:='unsigned int'; +end; + { TResEvalInt } constructor TResEvalInt.Create; @@ -5520,6 +5747,24 @@ begin end; end; +function TResEvalInt.TypeAsString: string; +begin + case Typed of + reitByte: Result:='byte'; + reitShortInt: Result:='shortint'; + reitWord: Result:='word'; + reitSmallInt: Result:='smallint'; + reitUIntSingle: Result:='unsinged int single'; + reitIntSingle: Result:='int single'; + reitLongWord: Result:='longword'; + reitLongInt: Result:='longint'; + reitUIntDouble: Result:='unsigned int double'; + reitIntDouble: Result:='int double'; + else + Result:='int'; + end; +end; + { TResEvalFloat } constructor TResEvalFloat.Create; @@ -5555,12 +5800,18 @@ begin Result:=true; end; +function TResEvalFloat.TypeAsString: string; +begin + Result:='float'; +end; + {$ifdef FPC_HAS_CPSTRING} { TResEvalString } constructor TResEvalString.Create; begin inherited Create; + OnlyASCII:=true; Kind:=revkString; end; @@ -5574,12 +5825,22 @@ function TResEvalString.Clone: TResEvalValue; begin Result:=inherited Clone; TResEvalString(Result).S:=S; + TResEvalString(Result).OnlyASCII:=OnlyASCII; end; function TResEvalString.AsString: string; begin Result:=RawStrToCaption(S,60); end; + +function TResEvalString.TypeAsString: string; +begin + if OnlyASCII then + Result:='string' + else + Result:='ansistring'; +end; + {$endif} { TResEvalUTF16 } @@ -5607,6 +5868,11 @@ begin Result:=String(UnicodeStrToCaption(S,60)); end; +function TResEvalUTF16.TypeAsString: string; +begin + Result:='unicodestring'; +end; + { TResEvalEnum } constructor TResEvalEnum.Create; @@ -5670,6 +5936,13 @@ begin Result:=ElType.Name+'('+IntToStr(Index)+')'; end; +function TResEvalEnum.TypeAsString: string; +begin + Result:=ElType.Name; + if Result='' then + Result:='enum'; +end; + { TResEvalRangeInt } constructor TResEvalRangeInt.Create; @@ -5741,6 +6014,18 @@ begin end; end; +function TResEvalRangeInt.TypeAsString: string; +begin + case ElKind of + revskEnum: Result:='enum range'; + revskInt: Result:='integer range'; + revskChar: Result:='char range'; + revskBool: Result:='boolean range'; + else + Result:='integer range'; + end; +end; + { TResEvalSet } constructor TResEvalSet.Create; @@ -5801,6 +6086,11 @@ begin Result:=Result+']'; end; +function TResEvalSet.TypeAsString: string; +begin + Result:='set'; +end; + function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; {$IF FPC_FULLVERSION<30101} diff --git a/avx512-0037785/packages/fcl-passrc/src/pasresolver.pp b/avx512-0037785/packages/fcl-passrc/src/pasresolver.pp index fed51e44a3..9fe78b10ff 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pasresolver.pp +++ b/avx512-0037785/packages/fcl-passrc/src/pasresolver.pp @@ -872,6 +872,7 @@ type public constructor Create; override; destructor Destroy; override; + procedure ClearIdentifiers(FreeItems: boolean); function FindLocalIdentifier(const Identifier: String): TPasIdentifier; inline; function FindIdentifier(const Identifier: String): TPasIdentifier; virtual; function RemoveLocalIdentifier(El: TPasElement): boolean; virtual; @@ -1092,7 +1093,7 @@ type procedure WriteIdentifiers(Prefix: string); override; destructor Destroy; override; public - References: TPasScopeReferences; // created by TPasAnalyzer in DeclrationProc + References: TPasScopeReferences; // created by TPasAnalyzer in DeclarationProc function AddReference(El: TPasElement; Access: TPSRefAccess): TPasScopeReference; function GetReferences: TFPList; end; @@ -1611,6 +1612,7 @@ type procedure AddClassType(El: TPasClassType; TypeParams: TFPList); virtual; procedure AddVariable(El: TPasVariable); virtual; procedure AddResourceString(El: TPasResString); virtual; + procedure AddExportSymbol(El: TPasExportSymbol); virtual; procedure AddEnumType(El: TPasEnumType); virtual; procedure AddEnumValue(El: TPasEnumValue); virtual; procedure AddProperty(El: TPasProperty); virtual; @@ -1697,6 +1699,7 @@ type procedure FinishAncestors(aClass: TPasClassType); virtual; procedure FinishMethodResolution(El: TPasMethodResolution); virtual; procedure FinishAttributes(El: TPasAttributes); virtual; + procedure FinishExportSymbol(El: TPasExportSymbol); virtual; procedure FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); virtual; procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty); virtual; @@ -1709,8 +1712,8 @@ type function CreateClassIntfMap(El: TPasClassType; Index: integer): TPasClassIntfMap; procedure CheckConditionExpr(El: TPasExpr; const ResolvedEl: TPasResolverResult); virtual; procedure CheckProcSignatureMatch(DeclProc, ImplProc: TPasProcedure; - IsOverride: boolean); - procedure CheckPendingForwardProcs(El: TPasElement); + IsOverride: boolean // override or class intf implementation + ); procedure CheckPointerCycle(El: TPasPointerType); procedure CheckGenericTemplateTypes(El: TPasGenericType); virtual; procedure ComputeUnaryNot(El: TUnaryExpr; var ResolvedEl: TPasResolverResult; @@ -1871,7 +1874,7 @@ type procedure SpecializeElArray(GenEl, SpecEl: TPasElement; GenList: TPasElementArray; var SpecList: TPasElementArray; AllowReferences: boolean {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF}); - procedure SpecializeProcedure(GenEl, SpecEl: TPasProcedure; SpecializedItem: TPRSpecializedItem); + procedure SpecializeProcedure(GenEl, SpecEl: TPasProcedure; SpecializedItem: TPRSpecializedItem); virtual; procedure SpecializeOperator(GenEl, SpecEl: TPasOperator); procedure SpecializeProcedureType(GenEl, SpecEl: TPasProcedureType; SpecializedItem: TPRSpecializedItem); procedure SpecializeProcedureBody(GenEl, SpecEl: TProcedureBody); @@ -2341,8 +2344,9 @@ type function IsClassMethod(El: TPasElement): boolean; function IsClassField(El: TPasElement): boolean; function GetFunctionType(El: TPasElement): TPasFunctionType; - function MethodIsStatic(El: TPasProcedure): boolean; + function MethodIsStatic(El: TPasProcedure): boolean; // does not check if El is a method function IsMethod(El: TPasProcedure): boolean; + function IsMethod_SelfIsClass(El: TPasElement): boolean; function IsHelperMethod(El: TPasElement): boolean; virtual; function IsHelper(El: TPasElement): boolean; function IsExternalClass_Name(aClass: TPasClassType; const ExtName: string): boolean; @@ -2357,8 +2361,9 @@ type function GetGenericConstraintErrorEl(ConstraintEl, TemplType: TPasElement): TPasElement; function GetSpecializedEl(El: TPasElement; GenericEl: TPasElement; Params: TFPList): TPasElement; virtual; - procedure FinishSpecializedClassOrRecIntf(Scope: TPasGenericScope); virtual; + procedure FinishGenericClassOrRecIntf(Scope: TPasGenericScope); virtual; procedure FinishSpecializations(Scope: TPasGenericScope); virtual; + procedure CheckPendingForwardProcs(El: TPasElement); virtual; function IsSpecialized(El: TPasGenericType): boolean; overload; function IsFullySpecialized(El: TPasGenericType): boolean; overload; function IsFullySpecialized(Proc: TPasProcedure): boolean; overload; @@ -2372,6 +2377,8 @@ type function GetAttributeCallsEl(El: TPasElement): TPasExprArray; virtual; function GetAttributeCalls(Members: TFPList; Index: integer): TPasExprArray; virtual; function ProcNeedsParams(El: TPasProcedureType): boolean; + function ProcHasSelf(El: TPasProcedure): boolean; // returns false for local procs + procedure CreateProcSelfArg(Proc: TPasProcedure); virtual; function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean; function GetTopLvlProc(El: TPasElement): TPasProcedure; function GetParentProc(El: TPasElement; GetDeclProc: boolean): TPasProcedure; @@ -4410,19 +4417,34 @@ end; destructor TPasIdentifierScope.Destroy; begin + ClearIdentifiers(true); + inherited Destroy; + {$IFDEF VerbosePasResolverMem} + writeln('TPasIdentifierScope.Destroy END ',ClassName); + {$ENDIF} +end; + +procedure TPasIdentifierScope.ClearIdentifiers(FreeItems: boolean); +begin {$IFDEF VerbosePasResolverMem} - writeln('TPasIdentifierScope.Destroy START ',ClassName); + writeln('TPasIdentifierScope.Clear START ',ClassName); {$ENDIF} + FItems.ForEachCall(@OnClearItem,nil); + {$ifdef pas2js} - FItems:=nil; + if FreeItems then + FItems:=nil + else + FItems.Clear; {$else} FItems.Clear; - FreeAndNil(FItems); + if FreeItems then + FreeAndNil(FItems); {$endif} - inherited Destroy; + {$IFDEF VerbosePasResolverMem} - writeln('TPasIdentifierScope.Destroy END ',ClassName); + writeln('TPasIdentifierScope.Clear END ',ClassName); {$ENDIF} end; @@ -4714,7 +4736,7 @@ end; procedure TPasResolver.GetParamsOfNameExpr(El: TPasExpr; out ParentParams: TPRParentParams); -// Checks is El is the name expression of a call or array access +// Checks if El is the name expression of a call or array access // For example: a.b.El() a.El[] // Note: TPasParser guarantees that there is at most one TBinaryExpr // and one TInlineSpecializeExpr between El and TParamsExpr @@ -4729,14 +4751,6 @@ begin if not IsNameExpr(El) then exit; Parent:=El.Parent; if Parent=nil then exit; - if Parent.ClassType=TBinaryExpr then - begin - Bin:=TBinaryExpr(Parent); - if (Bin.OpCode<>eopSubIdent) or (Bin.right<>El) then - exit; - El:=Bin; - Parent:=El.Parent; - end; if Parent.ClassType=TInlineSpecializeExpr then begin InlineSpec:=TInlineSpecializeExpr(Parent); @@ -4746,6 +4760,14 @@ begin Parent:=El.Parent; if Parent=nil then exit; end; + if Parent.ClassType=TBinaryExpr then + begin + Bin:=TBinaryExpr(Parent); + if (Bin.OpCode<>eopSubIdent) or (Bin.right<>El) then + exit; + El:=Bin; + Parent:=El.Parent; + end; if Parent.ClassType<>TParamsExpr then exit; Params:=TParamsExpr(Parent); if Params.Value<>El then exit; @@ -4847,7 +4869,9 @@ begin begin Bin:=TBinaryExpr(El); if Bin.OpCode=eopSubIdent then - El:=Bin.right; + El:=Bin.right + else + exit(nil); end; if (El is TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent) then Result:=El; @@ -5804,12 +5828,14 @@ begin FinishSection(TPasLibrary(CurModule).LibrarySection); // resolve begin..end block ResolveImplBlock(CurModule.InitializationSection); + ResolveImplBlock(CurModule.FinalizationSection); end else if (CurModuleClass=TPasModule) then begin // unit FinishSection(CurModule.InterfaceSection); - FinishSection(CurModule.ImplementationSection); + if CurModule.ImplementationSection<>nil then + FinishSection(CurModule.ImplementationSection); if CurModule.FinalizationSection<>nil then // finalization section finished -> resolve ResolveImplBlock(CurModule.FinalizationSection); @@ -6276,7 +6302,7 @@ begin PopScope; Scope:=El.CustomData as TPasRecordScope; - FinishSpecializedClassOrRecIntf(Scope); + FinishGenericClassOrRecIntf(Scope); end; procedure TPasResolver.FinishClassType(El: TPasClassType); @@ -6431,6 +6457,10 @@ begin RaiseMsg(20180322143202,nNoMatchingImplForIntfMethodXFound, sNoMatchingImplForIntfMethodXFound, [GetProcTypeDescription(IntfProc.ProcType,[prptdUseName,prptdAddPaths,prptdResolveSimpleAlias])],El); // ToDo: jump to interface list + // check calling conventions + //writeln('TPasResolver.FinishClassType Intf=',GetObjPath(IntfProc),' Found=',GetObjPath(FindData.Found)); + CheckProcSignatureMatch(IntfProc,TPasProcedure(FindData.Found),true); + Map.Procs[j]:=FindData.Found; end; Map:=Map.AncestorMap; @@ -6470,7 +6500,7 @@ begin PopGenericParamScope(El); if not El.IsForward then - FinishSpecializedClassOrRecIntf(ClassScope); + FinishGenericClassOrRecIntf(ClassScope); end; procedure TPasResolver.FinishClassOfType(El: TPasClassOfType); @@ -6895,6 +6925,7 @@ var Arg: TPasArgument; ProcTypeScope: TPasProcTypeScope; C: TClass; + FuncType: TPasFunctionType; begin if TopScope.Element=El then begin @@ -6935,7 +6966,11 @@ begin end; if El is TPasFunctionType then - CheckUseAsType(TPasFunctionType(El).ResultEl.ResultType,20190123095743,TPasFunctionType(El).ResultEl); + begin + FuncType:=TPasFunctionType(El); + if FuncType.ResultEl<>nil then + CheckUseAsType(FuncType.ResultEl.ResultType,20190123095743,FuncType.ResultEl); + end; if (proProcTypeWithoutIsNested in Options) and El.IsNested then RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El); @@ -7293,6 +7328,7 @@ var i: Integer; ParentScope: TPasScope; TemplTypes: TFPList; + ClassRecType: TPasMembersType; begin if not (ptmStatic in Proc.ProcType.Modifiers) then Proc.ProcType.IsOfObject:=true; @@ -7300,7 +7336,8 @@ begin ParentScope:=Scopes[ScopeCount-2]; // ToDo: store the scanner flags *before* it has parsed the token after the proc StoreScannerFlagsInProc(ProcScope); - ClassOrRecScope:=Proc.Parent.CustomData as TPasClassOrRecordScope; + ClassRecType:=TPasMembersType(Proc.Parent); + ClassOrRecScope:=ClassRecType.CustomData as TPasClassOrRecordScope; ProcScope.ClassRecScope:=ClassOrRecScope; TemplTypes:=GetProcTemplateTypes(Proc); @@ -7376,17 +7413,17 @@ begin if Proc.IsAbstract and (ClassOrRecScope is TPasClassScope) then Insert(Proc,TPasClassScope(ClassOrRecScope).AbstractProcs, length(TPasClassScope(ClassOrRecScope).AbstractProcs)); + + CreateProcSelfArg(Proc); end; procedure TPasResolver.FinishMethodImplHeader(ImplProc: TPasProcedure); var ProcName: String; - ClassRecType: TPasMembersType; ImplProcScope, DeclProcScope: TPasProcedureScope; DeclProc: TPasProcedure; ClassOrRecScope: TPasClassOrRecordScope; SelfArg: TPasArgument; - SelfType, LoSelfType: TPasType; LastNamePart: TProcedureNamePart; begin if ImplProc.IsExternal then @@ -7400,7 +7437,6 @@ begin ClassOrRecScope:=ImplProcScope.ClassRecScope; if ClassOrRecScope=nil then RaiseInternalError(20161013172346); - ClassRecType:=NoNil(ClassOrRecScope.Element) as TPasMembersType; if ImplProcScope.GroupScope=nil then RaiseInternalError(20190120135017); @@ -7415,6 +7451,8 @@ begin ProcName:=LastDottedIdentifier(ProcName); end; + DeclProc:=nil; + DeclProcScope:=nil; if ImplProcScope.DeclarationProc=nil then begin {$IFDEF VerbosePasResolver} @@ -7469,54 +7507,14 @@ begin else RaiseNotYetImplemented(20190804181222,ImplProc); - if not DeclProc.IsStatic then + SelfArg:=DeclProcScope.SelfArg; + if SelfArg<>nil then begin // add 'Self' - if (DeclProc.ClassType=TPasClassConstructor) - or (DeclProc.ClassType=TPasClassDestructor) then - // actually class constructor/destructor are static - else if (DeclProc.ClassType=TPasClassProcedure) - or (DeclProc.ClassType=TPasClassFunction) then - begin - if (ClassOrRecScope is TPasClassScope) - and (TPasClassScope(ClassOrRecScope).CanonicalClassOf<>nil) then - begin - // 'Self' in a class method is the hidden classtype argument - // Note: this is true in classes, adv records and helpers - SelfArg:=TPasArgument.Create('Self',DeclProc); - ImplProcScope.SelfArg:=SelfArg; - {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} - SelfArg.Access:=argConst; - SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf; - SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; - AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); - end - else - RaiseInternalError(20190106121745); - end - else - begin - // 'Self' in a method is the hidden instance argument - SelfArg:=TPasArgument.Create('Self',DeclProc); - ImplProcScope.SelfArg:=SelfArg; - {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} - SelfType:=ClassRecType; - if (SelfType.ClassType=TPasClassType) - and (TPasClassType(SelfType).HelperForType<>nil) then - begin - // in a helper Self is a var argument of the helped variable - SelfType:=TPasClassType(SelfType).HelperForType; - end; - LoSelfType:=ResolveAliasType(SelfType); - if (LoSelfType is TPasClassType) - and (TPasClassType(LoSelfType).ObjKind=okClass) then - SelfArg.Access:=argConst - else - SelfArg.Access:=argVar; - SelfArg.ArgType:=SelfType; - SelfType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; - AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); - end; + ImplProcScope.SelfArg:=SelfArg; + SelfArg.AddRef{$IFDEF CheckPasTreeRefCount}('TPasProcedureScope.SelfArg'){$ENDIF}; + {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} + AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); end; {$IFDEF VerbosePasResolver} @@ -7781,6 +7779,8 @@ begin FinishMethodResolution(TPasMethodResolution(El)) else if C=TPasAttributes then FinishAttributes(TPasAttributes(El)) + else if C=TPasExportSymbol then + FinishExportSymbol(TPasExportSymbol(El)) else begin {$IFDEF VerbosePasResolver} @@ -9138,6 +9138,62 @@ begin end; end; +procedure TPasResolver.FinishExportSymbol(El: TPasExportSymbol); + + procedure CheckConstExpr(Expr: TPasExpr; Kinds: TREVKinds; const Expected: string); + var + Value: TResEvalValue; + ResolvedEl: TPasResolverResult; + begin + if Expr=nil then exit; + ResolveExpr(Expr,rraRead); + Value:=Eval(Expr,[refConst]); + if (Value<>nil) and (Value.Kind in Kinds) then + begin + ReleaseEvalValue(Value); + exit; + end; + ReleaseEvalValue(Value); + ComputeElement(Expr,ResolvedEl,[rcConstant]); + RaiseXExpectedButYFound(20210101194628,Expected,GetTypeDescription(ResolvedEl),Expr); + end; + +var + Expr: TPasExpr; + DeclEl: TPasElement; + FindData: TPRFindData; + Ref: TResolvedReference; + ResolvedEl: TPasResolverResult; +begin + Expr:=El.NameExpr; + if Expr<>nil then + begin + ResolveExpr(Expr,rraRead); + //ResolveGlobalSymbol(Expr); + ComputeElement(Expr,ResolvedEl,[rcConstant]); + DeclEl:=ResolvedEl.IdentEl; + if DeclEl=nil then + RaiseMsg(20210103012907,nXExpectedButYFound,sXExpectedButYFound,['symbol',GetTypeDescription(ResolvedEl)],Expr); + if not (DeclEl.Parent is TPasSection) then + RaiseMsg(20210103012908,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetElementTypeName(DeclEl)],Expr); + end + else + begin + FindFirstEl(El.Name,FindData,El); + DeclEl:=FindData.Found; + if DeclEl=nil then + RaiseMsg(20210103002747,nIdentifierNotFound,sIdentifierNotFound,[El.Name],El); + if not (DeclEl.Parent is TPasSection) then + RaiseMsg(20210103003244,nXExpectedButYFound,sXExpectedButYFound,['global symbol',GetObjPath(DeclEl)],El); + Ref:=CreateReference(DeclEl,El,rraRead,@FindData); + CheckFoundElement(FindData,Ref); + end; + + // check index and name + CheckConstExpr(El.ExportIndex,[revkInt,revkUInt],'integer'); + CheckConstExpr(El.ExportName,[revkString,revkUnicodeString],'string'); +end; + procedure TPasResolver.FinishProcParamAccess(ProcType: TPasProcedureType; Params: TParamsExpr); var @@ -9268,6 +9324,7 @@ var ImplNameParts: TProcedureNameParts; ImplNamePart: TProcedureNamePart; ImplTemplType, DeclTemplType: TPasGenericTemplateType; + FuncType: TPasFunctionType; begin ImplProc:=ImplProcScope.Element as TPasProcedure; DeclProc:=ImplProcScope.DeclarationProc; @@ -9331,14 +9388,26 @@ begin Identifier.Identifier:=DeclArg.Name; end else - RaiseNotYetImplemented(20170203161826,ImplProc); + begin + // e.g. when Delphi mode omits ImplProc signature + AddIdentifier(ImplProcScope,DeclArg.Name,DeclArg,pikSimple); + end; end; if DeclProc.ProcType is TPasFunctionType then begin // redirect implementation 'Result' to declaration FuncType.ResultEl - Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar); - if Identifier.Element is TPasResultElement then - Identifier.Element:=TPasFunctionType(DeclProc.ProcType).ResultEl; + FuncType:=TPasFunctionType(DeclProc.ProcType); + if FuncType.ResultEl<>nil then + begin + Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar); + if Identifier=nil then + begin + // e.g. when Delphi mode omits ImplProc signature + AddIdentifier(ImplProcScope,ResolverResultVar,FuncType.ResultEl,pikSimple); + end + else if Identifier.Element is TPasResultElement then + Identifier.Element:=FuncType.ResultEl; + end; end; end; @@ -9393,7 +9462,7 @@ var DeclName, ImplName: String; ImplResult, DeclResult: TPasType; ImplTemplType, DeclTemplType: TPasGenericTemplateType; - NewImplPTMods: TProcTypeModifiers; + NewImplPTMods, DeclPTMods, ImplPTMods: TProcTypeModifiers; ptm: TProcTypeModifier; NewImplProcMods: TProcedureModifiers; pm: TProcedureModifier; @@ -9406,6 +9475,9 @@ begin if DeclArgs.Count<>ImplArgs.Count then RaiseNotYetImplemented(20190912110642,ImplProc); + DeclPTMods:=DeclProc.ProcType.Modifiers; + ImplPTMods:=ImplProc.ProcType.Modifiers; + DeclTemplates:=GetProcTemplateTypes(DeclProc); ImplTemplates:=GetProcTemplateTypes(ImplProc); if DeclTemplates<>nil then @@ -9462,33 +9534,36 @@ begin if CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple)>cGenericExact then RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound, [],DeclResult,ImplResult,ImplProc); - - if ImplProc.IsAsync<>DeclProc.IsAsync then - RaiseMsg(20200524111856,nXModifierMismatchY,sXModifierMismatchY,['procedure type','async'],ImplProc); end; // calling convention if ImplProc.CallingConvention<>DeclProc.CallingConvention then RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc); - // proc modifiers - NewImplProcMods:=ImplProc.Modifiers-DeclProc.Modifiers-[pmAssembler]; - if not IsOverride then + // modifiers + if IsOverride then + begin + // override/class-intf-impl: calling conventions must match + NewImplPTMods:=ImplPTMods><DeclPTMods; + for ptm in NewImplPTMods do + RaiseMsg(20201227213020,nXModifierMismatchY,sXModifierMismatchY, + ['procedure type',ProcTypeModifiers[ptm]],ImplProc.ProcType); + end + else begin // implementation proc must not add modifiers, except "assembler" + NewImplProcMods:=ImplProc.Modifiers-DeclProc.Modifiers-[pmAssembler]; if NewImplProcMods<>[] then for pm in NewImplProcMods do RaiseMsg(20200518182445,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, [ModifierNames[pm]],ImplProc.ProcType); + // implementation proc must not add modifiers + NewImplPTMods:=ImplPTMods-DeclPTMods; + if NewImplPTMods<>[] then + for ptm in NewImplPTMods do + RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, + [ProcTypeModifiers[ptm]],ImplProc.ProcType); end; - - // proc type modifiers - NewImplPTMods:=ImplProc.ProcType.Modifiers-DeclProc.ProcType.Modifiers; - // implementation proc must not add modifiers - if NewImplPTMods<>[] then - for ptm in NewImplPTMods do - RaiseMsg(20200425154821,nDirectiveXNotAllowedHere,sDirectiveXNotAllowedHere, - [ProcTypeModifiers[ptm]],ImplProc.ProcType); end; procedure TPasResolver.ResolveImplBlock(Block: TPasImplBlock); @@ -9577,59 +9652,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 - begin - ValueSet:=TResEvalSet.CreateEmpty(revskBool); - Result:=true; end - else if ResolvedEl.SubType in btAllChars then + else if CaseExprType.ClassType=TPasRangeType 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; @@ -10179,7 +10237,6 @@ begin if ParentParams.InlineSpec<>nil then begin TypeCnt:=InlParams.Count; - // ToDo: generic functions without params DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El); if DeclEl<>nil then begin @@ -10210,9 +10267,19 @@ begin begin TemplTypes:=GetProcTemplateTypes(Proc); if (TemplTypes<>nil) then + begin // implicit function specialization without bracket + {$IFDEF VerbosePasResolver} + DeclEl:=El; + while DeclEl.Parent is TPasExpr do + DeclEl:=DeclEl.Parent; + {AllowWriteln} + writeln('TPasResolver.ResolveNameExpr ',WritePasElTree(TPasExpr(DeclEl),' ')); + {AllowWriteln-} + {$ENDIF} RaiseMsg(20191007222004,nCouldNotInferTypeArgXForMethodY, sCouldNotInferTypeArgXForMethodY,[TPasGenericTemplateType(TemplTypes[0]).Name,Proc.Name],El); + end; end; if El.Parent.ClassType=TPasProperty then @@ -10241,7 +10308,7 @@ begin if ProcNeedsParams(Proc.ProcType) and not ExprIsAddrTarget(El) then begin {$IFDEF VerbosePasResolver} - writeln('TPasResolver.ResolveNameExpr ',GetObjName(El)); + writeln('TPasResolver.ResolveNameExpr ',GetObjPath(El)); {$ENDIF} RaiseMsg(20170216152138,nWrongNumberOfParametersForCallTo, sWrongNumberOfParametersForCallTo,[Proc.Name],El); @@ -10760,7 +10827,7 @@ begin else if Value.ClassType=TInlineSpecializeExpr then begin // e.g. Name<>() - ResolveInlineSpecializeExpr(TInlineSpecializeExpr(Value),rraRead); + ResolveInlineSpecializeExpr(TInlineSpecializeExpr(Value),Access); end else if Value.ClassType=TParamsExpr then begin @@ -10853,6 +10920,30 @@ procedure TPasResolver.ResolveFuncParamsExprName(NameExpr: TPasExpr; end; end; + procedure CheckIncompatibleProc(const CallName: string; + FoundProcType: TPasProcedureType; TemplParamsCnt: integer); + var + FoundTemplCnt: Integer; + aName: String; + begin + CheckCallProcCompatibility(FoundProcType,Params,true); + if FoundProcType.GenericTemplateTypes<>nil then + FoundTemplCnt:=FoundProcType.GenericTemplateTypes.Count + else + FoundTemplCnt:=0; + if TemplParamsCnt<>FoundTemplCnt then + begin + if FoundProcType.Parent is TPasProcedure then + aName:=FoundProcType.Parent.Name + else + aName:=FoundProcType.Name; + if aName='' then + aName:=GetObjPath(FoundProcType); + RaiseMsg(20201101205447,nXExpectedButYFound,sXExpectedButYFound, + [aName,CallName+GetGenericParamCommas(TemplParamsCnt)],Params); + end; + end; + var FindCallData: TFindCallElData; Abort: boolean; @@ -10897,7 +10988,7 @@ begin WriteScopes; {$ENDIF} if FoundEl is TPasProcedure then - CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true) + CheckIncompatibleProc(CallName,TPasProcedure(FoundEl).ProcType,TemplParamsCnt) else if FoundEl is TPasProcedureType then CheckTypeCast(TPasProcedureType(FoundEl),Params,true) else if FoundEl.ClassType=TPasUnresolvedSymbolRef then @@ -10920,7 +11011,7 @@ begin begin TypeEl:=ResolveAliasType(TPasVariable(FoundEl).VarType); if TypeEl is TPasProcedureType then - CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true) + CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt) else RaiseMsg(20170405003522,nIllegalQualifierAfter,sIllegalQualifierAfter, ['(',TypeEl.ElementTypeName],Params); @@ -10929,7 +11020,7 @@ begin begin TypeEl:=ResolveAliasType(TPasArgument(FoundEl).ArgType); if TypeEl is TPasProcedureType then - CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true) + CheckIncompatibleProc(CallName,TPasProcedureType(TypeEl),TemplParamsCnt) else RaiseMsg(20180228145412,nIllegalQualifierAfter,sIllegalQualifierAfter, ['(',TypeEl.ElementTypeName],Params); @@ -10972,7 +11063,7 @@ begin FoundEl:=GetSpecializedEl(NameExpr,FoundEl,TemplParams); if FoundEl is TPasProcedure then begin - // check if params fit the implicit specialized function + // check if params fit the explicit specialized function, e.g. Run<Word>() CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true); end; end @@ -10986,7 +11077,7 @@ begin try CheckTemplParams(GenTemplates,InferenceParams); FoundEl:=GetSpecializedEl(NameExpr,FoundEl,InferenceParams); - // check if params fit the implicit specialized function + // check if params fit the implicit specialized function, e.g. Run() CheckCallProcCompatibility(TPasProcedure(FoundEl).ProcType,Params,true); finally ReleaseElementList(InferenceParams{$IFDEF CheckPasTreeRefCount},RefIdInferenceParamsExpr{$ENDIF}); @@ -11013,13 +11104,12 @@ begin else begin // typecast to user type - CheckTypeCast(TypeEl,Params,true); // emit warnings + CheckTypeCast(TypeEl,Params,true); // emit warnings, and errors for specializations end; end; // FoundEl compatible element -> create reference Ref:=CreateReference(FoundEl,NameExpr,rraRead); - if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope); FindData:=Default(TPRFindData); @@ -11808,71 +11898,6 @@ begin Traverse(Expr,ArrType,0); end; -procedure TPasResolver.CheckPendingForwardProcs(El: TPasElement); -var - i: Integer; - DeclEl: TPasElement; - Proc: TPasProcedure; - aClassOrRec: TPasMembersType; - ClassOrRecScope: TPasClassOrRecordScope; -begin - if IsElementSkipped(El) then exit; - if El is TPasDeclarations then - begin - for i:=0 to TPasDeclarations(El).Declarations.Count-1 do - begin - DeclEl:=TPasElement(TPasDeclarations(El).Declarations[i]); - if DeclEl is TPasProcedure then - begin - Proc:=TPasProcedure(DeclEl); - if ProcNeedsImplProc(Proc) - and (TPasProcedureScope(Proc.CustomData).ImplProc=nil) then - RaiseMsg(20170216152219,nForwardProcNotResolved,sForwardProcNotResolved, - [GetElementTypeName(Proc),Proc.Name],Proc); - end; - end; - end - else if El is TPasMembersType then - begin - aClassOrRec:=TPasMembersType(El); - if (aClassOrRec is TPasClassType) then - begin - if (TPasClassType(aClassOrRec).ObjKind in [okInterface,okDispInterface]) then - exit; - if TPasClassType(aClassOrRec).IsForward then - exit; - if TPasClassType(aClassOrRec).IsExternal then - exit; - end; - ClassOrRecScope:=aClassOrRec.CustomData as TPasClassOrRecordScope; - if ClassOrRecScope.SpecializedFromItem<>nil then - exit; - // finish implementation of (generic) class/record - if ClassOrRecScope.GenericStep<>psgsInterfaceParsed then - RaiseNotYetImplemented(20190804115324,El); - for i:=0 to aClassOrRec.Members.Count-1 do - begin - DeclEl:=TPasElement(aClassOrRec.Members[i]); - if DeclEl is TPasProcedure then - begin - Proc:=TPasProcedure(DeclEl); - if Proc.IsAbstract or Proc.IsExternal then continue; - if TPasProcedureScope(Proc.CustomData).ImplProc=nil then - begin - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.CheckPendingForwardProcs Proc.ParentPath=',Proc.PathName); - {$ENDIF} - RaiseMsg(20170216152221,nForwardProcNotResolved,sForwardProcNotResolved, - [GetElementTypeName(Proc),Proc.Name],Proc); - end; - end; - end; - ClassOrRecScope.GenericStep:=psgsImplementationParsed; - if ClassOrRecScope.SpecializedItems<>nil then - FinishSpecializations(ClassOrRecScope); - end; -end; - procedure TPasResolver.CheckPointerCycle(El: TPasPointerType); var C: TClass; @@ -11902,7 +11927,7 @@ var begin GenTemplates:=El.GenericTemplateTypes; if (GenTemplates=nil) or (GenTemplates.Count=0) then - RaiseNotYetImplemented(20190726184902,El,'emty generic template list'); + RaiseNotYetImplemented(20190726184902,El,'empty generic template list'); // template names must differ from generic type name for i:=0 to GenTemplates.Count-1 do @@ -12212,6 +12237,14 @@ begin AddIdentifier(TPasIdentifierScope(TopScope),El.Name,El,pikSimple); end; +procedure TPasResolver.AddExportSymbol(El: TPasExportSymbol); +begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AddExportSymbol ',GetObjName(El)); + {$ENDIF} + // Note: export symbol is not added to scope +end; + procedure TPasResolver.AddEnumType(El: TPasEnumType); var CanonicalSet: TPasSetType; @@ -13974,7 +14007,7 @@ begin begin // type cast Param0:=Params.Params[0]; - ComputeElement(Param0,ParamResolved,[]); + ComputeElement(Param0,ParamResolved,Flags); ComputeTypeCast(ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,Param0, ParamResolved,ResolvedEl,Flags); end @@ -15759,7 +15792,7 @@ begin end; {$endif} revkUnicodeString: - if length(TResEvalUTF16(Value).S)=1 then + if (length(TResEvalUTF16(Value).S)=1) and (bt in btAllChars) then begin w:=TResEvalUTF16(Value).S[1]; {$ifdef FPC_HAS_CPSTRING} @@ -16707,8 +16740,28 @@ end; function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): string; + function Get_ProcName(aProc: TPasProcedure): string; forward; function GetTypeName(aType: TPasType): string; forward; + function GetParentName(El: TPasElement): string; + begin + if El.Parent is TPasType then + Result:=GetTypeName(TPasType(El.Parent)) + else if El is TPasUnresolvedSymbolRef then + Result:='System' + else if El.Parent is TPasProcedure then + Result:=Get_ProcName(TPasProcedure(El.Parent)) + else + Result:=El.GetModule.Name; + end; + + function Get_ProcName(aProc: TPasProcedure): string; + begin + Result:=GetParentName(aProc); + if aProc.Name<>'' then + Result:=Result+'.'+aProc.Name; + end; + function GetSpecParams(Item: TPRSpecializedItem): string; var i: Integer; @@ -16747,14 +16800,8 @@ function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): strin end else begin - if aType.Parent is TPasType then - Result:=GetTypeName(TPasType(aType.Parent)) - else if aType is TPasUnresolvedSymbolRef then - Result:='System' - else - Result:=aType.GetModule.Name; - Result:=Result+'.'+aType.Name; - if aType.CustomData is TPasGenericScope then + Result:=GetParentName(aType)+'.'+aType.Name; + if (aType.CustomData is TPasGenericScope) and (Pos('<',aType.Name)<1) then begin ChildItem:=TPasGenericScope(aType.CustomData).SpecializedFromItem; if ChildItem<>nil then @@ -16764,7 +16811,13 @@ function TPasResolver.CreateSpecializedTypeName(Item: TPRSpecializedItem): strin end; begin + if Pos('<',Item.GenericEl.Name)>0 then + RaiseNotYetImplemented(20201203140102,Item.SpecializedEl,Item.GenericEl.Name); + Result:=Item.GenericEl.Name+GetSpecParams(Item); + + if Pos('><',Result)>0 then + RaiseNotYetImplemented(20201203140223,Item.SpecializedEl,Result); end; procedure TPasResolver.InitSpecializeScopes(El: TPasElement; out @@ -17238,8 +17291,6 @@ begin SpecImplProcScope.BoolSwitches:=GenImplProcScope.BoolSwitches; SpecImplProcScope.VisibilityContext:=SpecClassOrRec; SpecImplProcScope.ClassRecScope:=SpecClassOrRecScope; - if GenDeclProcScope.SelfArg<>nil then - RaiseNotYetImplemented(20190922154603,GenImplProc); if SpecializedProcItem<>nil then begin @@ -17441,6 +17492,8 @@ begin AddProcedureType(TPasProcedureType(SpecEl),nil); SpecializeProcedureType(TPasProcedureType(GenEl),TPasProcedureType(SpecEl),nil); end + else if C=TPasExportSymbol then + RaiseMsg(20210101234958,nSymbolCannotExportedFromALibrary,sSymbolCannotExportedFromALibrary,[],GenEl) else RaiseNotYetImplemented(20190728151215,GenEl); end; @@ -17682,8 +17735,6 @@ begin if GenProcScope.OverriddenProc<>nil then RaiseNotYetImplemented(20190920203536,SpecEl); SpecProcScope.ClassRecScope:=GenProcScope.ClassRecScope; - if GenProcScope.SelfArg<>nil then - RaiseNotYetImplemented(20190920203626,SpecEl); // SpecProcScope.Flags SpecProcScope.ModeSwitches:=GenProcScope.ModeSwitches; SpecProcScope.BoolSwitches:=GenProcScope.BoolSwitches; @@ -17746,7 +17797,12 @@ begin begin GenProcType:=GenEl.ProcType; if GenProcType.Parent<>GenEl then - RaiseNotYetImplemented(20190803212426,GenEl,GetObjName(GenProcType.Parent)); + begin + {$IFDEF defined(VerbosePCUFiler) or defined(VerbosePJUFiler)} + writeln('TPasResolver.SpecializeProcedure GenEl=',GetObjPath(GenEl),' GenProcType.Parent=',GetObjPath(GenProcType.Parent)); + {$ENDIF} + RaiseNotYetImplemented(20190803212426,GenEl,GetObjPath(GenProcType.Parent)); + end; NewClass:=TPTreeElement(GenProcType.ClassType); SpecEl.ProcType:=TPasProcedureType(NewClass.Create(GenProcType.Name,SpecEl)); SpecializeElement(GenProcType,SpecEl.ProcType); @@ -17828,13 +17884,16 @@ begin if SpecEl is TPasFunctionType then begin GenResultEl:=TPasFunctionType(GenEl).ResultEl; - if GenResultEl.Parent<>GenEl then - RaiseNotYetImplemented(20190803212935,GenEl,GetObjName(GenResultEl.Parent)); - NewClass:=TPTreeElement(GenResultEl.ClassType); - NewResultEl:=TPasResultElement(NewClass.Create(GenResultEl.Name,SpecEl)); - TPasFunctionType(SpecEl).ResultEl:=NewResultEl; - AddFunctionResult(NewResultEl); - SpecializeElType(GenResultEl,NewResultEl,GenResultEl.ResultType,NewResultEl.ResultType); + if GenResultEl<>nil then + begin + if GenResultEl.Parent<>GenEl then + RaiseNotYetImplemented(20190803212935,GenEl,GetObjName(GenResultEl.Parent)); + NewClass:=TPTreeElement(GenResultEl.ClassType); + NewResultEl:=TPasResultElement(NewClass.Create(GenResultEl.Name,SpecEl)); + TPasFunctionType(SpecEl).ResultEl:=NewResultEl; + AddFunctionResult(NewResultEl); + SpecializeElType(GenResultEl,NewResultEl,GenResultEl.ResultType,NewResultEl.ResultType); + end; end; FinishProcedureType(SpecEl); @@ -18804,7 +18863,10 @@ begin begin // inside procedure: first param is function result ProcScope:=TPasProcedureScope(Scopes[i]); - CtxProc:=TPasProcedure(ProcScope.Element); + if ProcScope.DeclarationProc<>nil then + CtxProc:=ProcScope.DeclarationProc + else + CtxProc:=TPasProcedure(ProcScope.Element); if not (CtxProc.ProcType is TPasFunctionType) then begin if RaiseOnError then @@ -18853,6 +18915,7 @@ var Param: TPasExpr; ParamResolved, IncrResolved: TPasResolverResult; TypeEl: TPasType; + bt: TResolverBaseType; begin if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then exit(cIncompatible); @@ -18872,18 +18935,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 +19561,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 +19745,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 +19767,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; @@ -20829,6 +20907,8 @@ begin else if AClass.InheritsFrom(TPasImplBlock) then // resolved when finished else if AClass=TPasAttributes then + else if AClass=TPasExportSymbol then + AddExportSymbol(TPasExportSymbol(El)) else if AClass=TPasUnresolvedUnitRef then RaiseMsg(20171018121900,nCantFindUnitX,sCantFindUnitX,[AName],El) else @@ -20878,10 +20958,26 @@ function TPasResolver.FindElementFor(const aName: String; AParent: TPasElement; TypeParamCount: integer): TPasElement; // called by TPasParser for direct types, e.g. type t = ns1.unit1.tobj.tsub var + ErrorEl: TPasElement; + + procedure CheckGenericRefWithoutParams(GenEl: TPasGenericType); + // called when TypeParamCount=0 check if reference to a generic type is allowed with + begin + if (GenEl.GenericTemplateTypes=nil) or (GenEl.GenericTemplateTypes.Count=0) then + exit; + // referrring to a generic type without params + if not (msDelphi in CurrentParser.CurrentModeswitches) + and (AParent<>nil) + and AParent.HasParent(GenEl) then + exit; // mode objfpc: inside the generic type it can be referred without params + RaiseMsg(20201129005025,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,['variable'],ErrorEl); + end; + +var p: SizeInt; RightPath, CurName, LeftPath: String; NeedPop: Boolean; - CurScopeEl, NextEl, ErrorEl, BestEl: TPasElement; + CurScopeEl, NextEl, BestEl: TPasElement; CurSection: TPasSection; i: Integer; UsesUnit: TPasUsesUnit; @@ -20953,11 +21049,17 @@ begin RaiseInternalError(20190801104033); // caller forgot to handle "With" end else + begin NextEl:=FindElementWithoutParams(CurName,ErrorEl,true,true); + if (NextEl is TPasGenericType) and (RightPath='') then + CheckGenericRefWithoutParams(TPasGenericType(NextEl)); + end; {$IFDEF VerbosePasResolver} //if RightPath<>'' then // writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ... NextEl=',GetObjName(NextEl)); {$ENDIF} + if NextEl=nil then + RaiseIdentifierNotFound(20201129004745,CurName,ErrorEl); if NextEl is TPasModule then begin if CurScopeEl is TPasModule then @@ -21011,10 +21113,8 @@ begin else CurScopeEl:=BestEl; end - else if NextEl<>nil then - CurScopeEl:=NextEl else - RaiseIdentifierNotFound(20170328001941,CurName,ErrorEl); + CurScopeEl:=NextEl; // restore scope if NeedPop then @@ -21029,6 +21129,7 @@ end; function TPasResolver.FindElementWithoutParams(const AName: String; ErrorPosEl: TPasElement; NoProcsWithArgs, NoGenerics: boolean): TPasElement; +// ErrorPosEl=nil means to use scanner position as error position var Data: TPRFindData; begin @@ -21043,6 +21144,7 @@ end; function TPasResolver.FindElementWithoutParams(const AName: String; out Data: TPRFindData; ErrorPosEl: TPasElement; NoProcsWithArgs, NoGenerics: boolean): TPasElement; +// ErrorPosEl=nil means to use scanner position as error position var Abort: boolean; begin @@ -25804,7 +25906,7 @@ begin end; if (Param.ArgType=nil) then exit(cExact); // untyped argument - if (ParamResolved.BaseType=ExprResolved.BaseType) then + if GetActualBaseType(ParamResolved.BaseType)=GetActualBaseType(ExprResolved.BaseType) then begin if msDelphi in CurrentParser.CurrentModeswitches then begin @@ -26742,7 +26844,7 @@ function TPasResolver.CheckTypeCastRes(const FromResolved, end; var - ToTypeEl, ToType, FromType, FromTypeEl: TPasType; + ToTypeEl, FromTypeEl: TPasType; ToTypeBaseType: TResolverBaseType; C: TClass; ToProcType, FromProcType: TPasProcedureType; @@ -26767,9 +26869,12 @@ begin begin if ToTypeEl.CustomData is TResElDataBaseType then begin - // base type cast, e.g. double(aninteger) + // type cast to base type, e.g. double(aninteger) if ToTypeEl=FromResolved.LoTypeEl then exit(cExact); + if (FromResolved.BaseType=btContext) + and (FromResolved.LoTypeEl.ClassType=TPasGenericTemplateType) then + exit(cExact); // e.g. double(T) -> will be checked when specialized ToTypeBaseType:=(ToTypeEl.CustomData as TResElDataBaseType).BaseType; if ToTypeBaseType=FromResolved.BaseType then Result:=cExact @@ -26954,6 +27059,9 @@ begin // e.g. T(var) TemplType:=TPasGenericTemplateType(ToTypeEl); FromTypeEl:=FromResolved.LoTypeEl; + if (FromTypeEl<>nil) + and (FromTypeEl.ClassType=TPasGenericTemplateType) then + exit(cExact); // e.g. T(S) -> will be checked when specialized for i:=0 to length(TemplType.Constraints)-1 do begin ConEl:=TemplType.Constraints[i]; @@ -26988,9 +27096,9 @@ begin if (FromResolved.IdentEl is TPasType) then RaiseMsg(20170404162604,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl); // type cast classof(classof-var) upwards or downwards - ToType:=TPasClassOfType(ToTypeEl).DestType; - FromType:=TPasClassOfType(FromResolved.LoTypeEl).DestType; - Result:=CheckClassesAreRelated(ToType,FromType); + ToTypeEl:=TPasClassOfType(ToTypeEl).DestType; + FromTypeEl:=TPasClassOfType(FromResolved.LoTypeEl).DestType; + Result:=CheckClassesAreRelated(ToTypeEl,FromTypeEl); end; end else if FromResolved.BaseType=btPointer then @@ -27175,9 +27283,8 @@ begin and (ToTypeEl=ToResolved.IdentEl) then begin // for example class-of(Self) in a class function - ToType:=TPasClassOfType(ToTypeEl).DestType; - FromType:=TPasClassType(FromTypeEl); - Result:=CheckClassesAreRelated(ToType,FromType); + ToTypeEl:=TPasClassOfType(ToTypeEl).DestType; + Result:=CheckClassesAreRelated(ToTypeEl,FromTypeEl); end; end; end; @@ -27229,6 +27336,11 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDescription(FromType),' ToType=',GetTypeDescription(ToType)); {$ENDIF} + if not RaiseOnError then + begin + if (ToType.GenericTemplateTypes<>nil) and (ToType.GenericTemplateTypes.Count>0) then + exit(cCompatible); // is later checked when specialized + end; StartFromType:=FromType; StartToType:=ToType; Result:=cIncompatible; @@ -27258,10 +27370,11 @@ begin break; // ToType has more dimensions end; // have same dimension -> check ElType + Include(FromElTypeRes.Flags,rrfReadable); + FromElTypeRes.IdentEl:=nil; {$IFDEF VerbosePasResolver} writeln('TPasResolver.CheckTypeCastArray check ElType From=',GetResolverResultDbg(FromElTypeRes),' To=',GetResolverResultDbg(ToElTypeRes)); {$ENDIF} - Include(FromElTypeRes.Flags,rrfReadable); Result:=CheckTypeCastRes(FromElTypeRes,ToElTypeRes,ErrorEl,false); break; end @@ -27339,7 +27452,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out end else if ParentNeedsExprResult(Expr) then begin - // a procedure + // a procedure address exit; end; if rcSetReferenceFlags in Flags then @@ -27896,6 +28009,8 @@ end; function TPasResolver.IsSameType(TypeA, TypeB: TPasType; ResolveAlias: TPRResolveAlias): boolean; +var + btA, btB: TResolverBaseType; begin if (TypeA=nil) or (TypeB=nil) then exit(false); case ResolveAlias of @@ -27914,7 +28029,11 @@ begin if (TypeA.ClassType=TPasUnresolvedSymbolRef) and (TypeB.ClassType=TPasUnresolvedSymbolRef) then begin - Result:=CompareText(TypeA.Name,TypeB.Name)=0; + if CompareText(TypeA.Name,TypeB.Name)=0 then + exit(true); + btA:=TResElDataBaseType(TypeA.CustomData).BaseType; + btB:=TResElDataBaseType(TypeB.CustomData).BaseType; + Result:=GetActualBaseType(btA)=GetActualBaseType(btB); exit; end; Result:=false; @@ -28133,10 +28252,12 @@ function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean; e.g. '@p().o[].El' or '@El[]' b) mode delphi: the last element of a right side of an assignment c) an accessor function, e.g. property P read El; + d) an export } var Parent: TPasElement; Prop: TPasProperty; + C: TClass; begin Result:=false; if El=nil then exit; @@ -28145,31 +28266,34 @@ begin repeat Parent:=El.Parent; //writeln('TPasResolver.ExprIsAddrTarget El=',GetObjName(El),' Parent=',GetObjName(Parent)); - if Parent.ClassType=TUnaryExpr then + C:=Parent.ClassType; + if C=TUnaryExpr then begin if TUnaryExpr(Parent).OpCode=eopAddress then exit(true); end - else if Parent.ClassType=TBinaryExpr then + else if C=TBinaryExpr then begin if TBinaryExpr(Parent).right<>El then exit; if TBinaryExpr(Parent).OpCode<>eopSubIdent then exit; end - else if Parent.ClassType=TParamsExpr then + else if C=TParamsExpr then begin if TParamsExpr(Parent).Value<>El then exit; end - else if Parent.ClassType=TPasProperty then + else if C=TPasProperty then begin Prop:=TPasProperty(Parent); Result:=(Prop.ReadAccessor=El) or (Prop.WriteAccessor=El) or (Prop.StoredAccessor=El); exit; end - else if Parent.ClassType=TPasImplAssign then + else if C=TPasImplAssign then begin if TPasImplAssign(Parent).right<>El then exit; if (msDelphi in CurrentParser.CurrentModeswitches) then exit(true); exit; end + else if C=TPasExportSymbol then + exit(true) else exit; El:=TPasExpr(Parent); @@ -28198,6 +28322,8 @@ begin else Result:=true; end + else if C=TInlineSpecializeExpr then + Result:=ParentNeedsExprResult(TInlineSpecializeExpr(P)) else if C.InheritsFrom(TPasExpr) then Result:=true else if (C=TPasEnumValue) @@ -28419,7 +28545,7 @@ end; function TPasResolver.MethodIsStatic(El: TPasProcedure): boolean; begin - Result:=(ptmStatic in El.ProcType.Modifiers) + Result:=El.IsStatic or (El.ClassType=TPasClassConstructor) or (El.ClassType=TPasClassDestructor); end; @@ -28436,6 +28562,16 @@ begin Result:=IsMethod(ProcScope.DeclarationProc); end; +function TPasResolver.IsMethod_SelfIsClass(El: TPasElement): boolean; +var + C: TClass; +begin + if (El=nil) then exit(false); + C:=El.ClassType; + Result:=((C=TPasClassProcedure) or (C=TPasClassFunction) or (C=TPasClassOperator)) + and not TPasProcedure(El).IsStatic; +end; + function TPasResolver.IsHelperMethod(El: TPasElement): boolean; begin Result:=(El is TPasProcedure) and (El.Parent is TPasClassType) @@ -28702,7 +28838,7 @@ begin end; end; -procedure TPasResolver.FinishSpecializedClassOrRecIntf(Scope: TPasGenericScope); +procedure TPasResolver.FinishGenericClassOrRecIntf(Scope: TPasGenericScope); var El: TPasGenericType; SpecializedItems: TObjectList; @@ -28750,6 +28886,71 @@ begin SpecializeGenericImpl(TPRSpecializedItem(SpecializedItems[i])); end; +procedure TPasResolver.CheckPendingForwardProcs(El: TPasElement); +var + i: Integer; + DeclEl: TPasElement; + Proc: TPasProcedure; + aClassOrRec: TPasMembersType; + ClassOrRecScope: TPasClassOrRecordScope; +begin + if IsElementSkipped(El) then exit; + if El is TPasDeclarations then + begin + for i:=0 to TPasDeclarations(El).Declarations.Count-1 do + begin + DeclEl:=TPasElement(TPasDeclarations(El).Declarations[i]); + if DeclEl is TPasProcedure then + begin + Proc:=TPasProcedure(DeclEl); + if ProcNeedsImplProc(Proc) + and (TPasProcedureScope(Proc.CustomData).ImplProc=nil) then + RaiseMsg(20170216152219,nForwardProcNotResolved,sForwardProcNotResolved, + [GetElementTypeName(Proc),Proc.Name],Proc); + end; + end; + end + else if El is TPasMembersType then + begin + aClassOrRec:=TPasMembersType(El); + if (aClassOrRec is TPasClassType) then + begin + if (TPasClassType(aClassOrRec).ObjKind in [okInterface,okDispInterface]) then + exit; + if TPasClassType(aClassOrRec).IsForward then + exit; + if TPasClassType(aClassOrRec).IsExternal then + exit; + end; + ClassOrRecScope:=aClassOrRec.CustomData as TPasClassOrRecordScope; + if ClassOrRecScope.SpecializedFromItem<>nil then + exit; + // finish implementation of (generic) class/record + if ClassOrRecScope.GenericStep<>psgsInterfaceParsed then + RaiseNotYetImplemented(20190804115324,El); + for i:=0 to aClassOrRec.Members.Count-1 do + begin + DeclEl:=TPasElement(aClassOrRec.Members[i]); + if DeclEl is TPasProcedure then + begin + Proc:=TPasProcedure(DeclEl); + if Proc.IsAbstract or Proc.IsExternal then continue; + if TPasProcedureScope(Proc.CustomData).ImplProc=nil then + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.CheckPendingForwardProcs Proc.ParentPath=',Proc.PathName); + {$ENDIF} + RaiseMsg(20170216152221,nForwardProcNotResolved,sForwardProcNotResolved, + [GetElementTypeName(Proc),Proc.Name],Proc); + end; + end; + end; + ClassOrRecScope.GenericStep:=psgsImplementationParsed; + if ClassOrRecScope.SpecializedItems<>nil then + FinishSpecializations(ClassOrRecScope); + end; +end; + function TPasResolver.IsSpecialized(El: TPasGenericType): boolean; begin Result:=(El<>nil) and (El.CustomData is TPasGenericScope) @@ -28996,6 +29197,84 @@ begin Result:=(El.Args.Count>0) and (TPasArgument(El.Args[0]).ValueExpr=nil); end; +function TPasResolver.ProcHasSelf(El: TPasProcedure): boolean; +var + C: TClass; +begin + if El.IsStatic then + exit(false); + C:=El.Parent.ClassType; + if C.InheritsFrom(TPasSection) or (C=TProcedureBody) then + exit(false); + C:=El.ClassType; + if (C=TPasClassConstructor) or (C=TPasClassDestructor) then + exit(false); + Result:=true; +end; + +procedure TPasResolver.CreateProcSelfArg(Proc: TPasProcedure); +var + SelfArg: TPasArgument; + SelfType, LoSelfType: TPasType; + ProcScope: TPasProcedureScope; + ClassOrRecScope: TPasClassOrRecordScope; + ClassRecType: TPasMembersType; +begin + if Proc.IsStatic or Proc.IsExternal then exit; + + // add 'Self' + if (Proc.ClassType=TPasClassConstructor) + or (Proc.ClassType=TPasClassDestructor) then + // actually class constructor/destructor are static + exit; + + ProcScope:=TPasProcedureScope(Proc.CustomData); + ClassOrRecScope:=ProcScope.ClassRecScope; + if ClassOrRecScope=nil then exit; + ClassRecType:=TPasMembersType(ClassOrRecScope.Element); + + if (Proc.ClassType=TPasClassProcedure) + or (Proc.ClassType=TPasClassFunction) then + begin + if (ClassOrRecScope is TPasClassScope) + and (TPasClassScope(ClassOrRecScope).CanonicalClassOf<>nil) then + begin + // 'Self' in a class method is the hidden classtype argument + // Note: this is true in classes, adv records and helpers + SelfArg:=TPasArgument.Create('Self',Proc); + ProcScope.SelfArg:=SelfArg; + {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} + SelfArg.Access:=argConst; + SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf; + SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; + end + else + RaiseInternalError(20190106121745); + end + else + begin + // 'Self' in a method is the hidden instance argument + SelfArg:=TPasArgument.Create('Self',Proc); + ProcScope.SelfArg:=SelfArg; + {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} + SelfType:=ClassRecType; + if (SelfType.ClassType=TPasClassType) + and (TPasClassType(SelfType).HelperForType<>nil) then + begin + // in a helper Self is a var argument of the helped variable + SelfType:=TPasClassType(SelfType).HelperForType; + end; + LoSelfType:=ResolveAliasType(SelfType); + if (LoSelfType is TPasClassType) + and (TPasClassType(LoSelfType).ObjKind=okClass) then + SelfArg.Access:=argConst + else + SelfArg.Access:=argVar; + SelfArg.ArgType:=SelfType; + SelfType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; + end; +end; + function TPasResolver.IsProcOverride(AncestorProc, DescendantProc: TPasProcedure ): boolean; var @@ -29569,7 +29848,8 @@ begin RaiseInternalError(20180215185302,GetObjName(El)); if Data.ClassType=TResElDataBaseType then Result:=BaseTypes[TResElDataBaseType(Data).BaseType] - else if Data.ClassType=TResElDataBuiltInProc then + else if (Data.ClassType=TResElDataBuiltInProc) + and (TResElDataBuiltInProc(Data).BuiltIn<>bfCustom) then Result:=BuiltInProcs[TResElDataBuiltInProc(Data).BuiltIn].Element else Result:=nil; @@ -29715,16 +29995,23 @@ function TPasResolver.CheckClassIsClass(SrcType, DestType: TPasType): integer; i: Integer; SrcParam, DestParam: TPasType; SrcParamScope, DestParamScope: TPasGenericScope; + SrcSpecializedFromItem, DestSpecializedFromItem: TPRSpecializedItem; begin - if SrcScope.SpecializedFromItem.GenericEl<>DestScope.SpecializedFromItem.GenericEl then + SrcSpecializedFromItem:=SrcScope.SpecializedFromItem; + DestSpecializedFromItem:=DestScope.SpecializedFromItem; + if SrcSpecializedFromItem=nil then + exit(false); + if DestSpecializedFromItem=nil then + exit(false); + if SrcSpecializedFromItem.GenericEl<>DestSpecializedFromItem.GenericEl then exit(false); // specialized from same generic -> check params - SrcParams:=SrcScope.SpecializedFromItem.Params; - DestParams:=DestScope.SpecializedFromItem.Params; + SrcParams:=SrcSpecializedFromItem.Params; + 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/avx512-0037785/packages/fcl-passrc/src/passrcutil.pp b/avx512-0037785/packages/fcl-passrc/src/passrcutil.pp index 3599c42204..63805a209a 100644 --- a/avx512-0037785/packages/fcl-passrc/src/passrcutil.pp +++ b/avx512-0037785/packages/fcl-passrc/src/passrcutil.pp @@ -123,8 +123,11 @@ begin D:=ExtractFilePath(FileName); If (D='') then D:='.'; + FResolver.ModuleDirectory:=D; FResolver.BaseDirectory:=D; - FResolver.AddIncludePath(D); + + FResolver.AddIncludePath(D); // still needed? + FScanner:=TPascalScanner.Create(FResolver); FScanner.OpenFile(FileName); FContainer:=TSrcContainer.Create; diff --git a/avx512-0037785/packages/fcl-passrc/src/pastree.pp b/avx512-0037785/packages/fcl-passrc/src/pastree.pp index ae10ffc38b..5fd41c8701 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pastree.pp +++ b/avx512-0037785/packages/fcl-passrc/src/pastree.pp @@ -111,7 +111,8 @@ type TPasMemberVisibility = (visDefault, visPrivate, visProtected, visPublic, visPublished, visAutomated, - visStrictPrivate, visStrictProtected); + visStrictPrivate, visStrictProtected, + visRequired, visOptional); TCallingConvention = (ccDefault,ccRegister,ccPascal,ccCDecl,ccStdCall, ccOldFPCCall,ccSafeCall,ccSysCall,ccMWPascal, @@ -119,7 +120,7 @@ type ccMS_ABI_Default,ccMS_ABI_CDecl, ccVectorCall); TProcTypeModifier = (ptmOfObject,ptmIsNested,ptmStatic,ptmVarargs, - ptmReferenceTo,ptmAsync); + ptmReferenceTo,ptmAsync,ptmFar,ptmCblock); TProcTypeModifiers = set of TProcTypeModifier; TPackMode = (pmNone,pmPacked,pmBitPacked); @@ -446,6 +447,7 @@ type PackageName: string; Filename : String; // the IN filename, only written when not empty. end; + TPasModuleClass = class of TPasModule; { TPasUnitModule } @@ -533,6 +535,7 @@ type procedure ClearTypeReferences(aType: TPasElement); override; public DestType: TPasType; + SubType: TPasType; Expr: TPasExpr; end; @@ -571,6 +574,7 @@ type const Arg: Pointer); override; procedure AddConstraint(El: TPasElement); procedure ClearConstraints; + procedure ClearTypeReferences(aType: TPasElement); override; Public TypeConstraint: String deprecated; // deprecated in fpc 3.3.1 Constraints: TPasElementArray; // list of TPasExpr or TPasType, can be nil! @@ -597,6 +601,7 @@ type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full: boolean) : string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -611,6 +616,7 @@ type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : Boolean): string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -650,6 +656,7 @@ type procedure SetParent(const AValue: TPasElement); override; public destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; public @@ -667,6 +674,7 @@ type TPasFileType = class(TPasType) public destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -708,6 +716,7 @@ type TPasSetType = class(TPasType) public destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -755,6 +764,7 @@ type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -793,6 +803,7 @@ type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; @@ -826,11 +837,11 @@ type TPasArgument = class(TPasElement) public destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; procedure ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); override; - procedure ClearTypeReferences(aType: TPasElement); override; public Access: TArgumentAccess; ArgType: TPasType; // can be nil, when Access<>argDefault @@ -853,6 +864,7 @@ type public constructor Create(const AName: string; AParent: TPasElement); override; destructor Destroy; override; + procedure ClearTypeReferences(aType: TPasElement); override; class function TypeName: string; virtual; function ElementTypeName: string; override; function GetDeclaration(full : boolean) : string; override; @@ -963,6 +975,7 @@ type TPasExportSymbol = class(TPasElement) public + NameExpr: TPasExpr; // only if name is not a simple identifier ExportName : TPasExpr; ExportIndex : TPasExpr; Destructor Destroy; override; @@ -1158,7 +1171,8 @@ type otBitwiseAnd, otbitwiseXor, otLogicalAnd, otLogicalNot, otLogicalXor, otRightShift, - otEnumerator, otIn + otEnumerator, otIn, + otInitialize // Management operator ); TOperatorTypes = set of TOperatorType; @@ -1691,7 +1705,7 @@ const VisibilityNames: array[TPasMemberVisibility] of string = ( 'default','private', 'protected', 'public', 'published', 'automated', - 'strict private', 'strict protected'); + 'strict private', 'strict protected','required','optional'); ObjKindNames: array[TPasObjKind] of string = ( 'object', 'class', 'interface', @@ -1740,13 +1754,13 @@ const '>',':=','<>','<=','>=','**', '><','Inc','Dec','mod','-','+','Or','div', 'shl','or','and','xor','and','not','xor', - 'shr','enumerator','in'); + 'shr','enumerator','in',''); OperatorNames : Array[TOperatorType] of string = ('','implicit','explicit','multiply','add','subtract','divide','lessthan','equal', 'greaterthan','assign','notequal','lessthanorequal','greaterthanorequal','power', 'symmetricaldifference','inc','dec','modulus','negative','positive','bitwiseor','intdivide', 'leftshift','logicalor','bitwiseand','bitwisexor','logicaland','logicalnot','logicalxor', - 'rightshift','enumerator','in'); + 'rightshift','enumerator','in','initialize'); AssignKindNames : Array[TAssignKind] of string = (':=','+=','-=','*=','/=' ); @@ -1758,7 +1772,7 @@ const 'MS_ABI_Default','MS_ABI_CDecl', 'VectorCall'); ProcTypeModifiers : Array[TProcTypeModifier] of string = - ('of Object', 'is nested','static','varargs','reference to','async'); + ('of Object', 'is nested','static','varargs','reference to','async','far','cblock'); ModifierNames : Array[TProcedureModifier] of string = ('virtual', 'dynamic','abstract', 'override', @@ -1777,6 +1791,7 @@ function GenericTemplateTypesAsString(List: TFPList): string; procedure ReleaseProcNameParts(var NameParts: TProcedureNameParts); function dbgs(const s: TProcTypeModifiers): string; overload; +function WritePasElTree(Expr: TPasExpr; FollowPrefix: string = ''): string; {$IFDEF HasPTDumpStack} procedure PTDumpStack; @@ -1891,6 +1906,77 @@ begin Result:='['+Result+']'; end; +function WritePasElTree(Expr: TPasExpr; FollowPrefix: string): string; +{ TBinary Kind= OpCode= + +Left=TBinary Kind= OpCode= + | +Left=TParamsExpr[] + | | +Value=Prim Kind= Value= + | | +Params[1]=Prim Kind= Value= + +Right=Prim +} +var + C: TClass; + s: string; + ParamsExpr: TParamsExpr; + InlineSpecExpr: TInlineSpecializeExpr; + SubEl: TPasElement; + ArrayValues: TArrayValues; + i: Integer; +begin + if Expr=nil then exit('nil'); + C:=Expr.ClassType; + + Result:=C.ClassName; + str(Expr.Kind,s); + Result:=Result+' '+s; + str(Expr.OpCode,s); + Result:=Result+' '+s; + + if C=TPrimitiveExpr then + Result:=Result+' Value="'+TPrimitiveExpr(Expr).Value+'"' + else if C=TUnaryExpr then + Result:=Result+' Operand='+WritePasElTree(TUnaryExpr(Expr).Operand,FollowPrefix) + else if C=TBoolConstExpr then + Result:=Result+' Value='+BoolToStr(TBoolConstExpr(Expr).Value,'True','False') + else if C=TArrayValues then + begin + ArrayValues:=TArrayValues(Expr); + for i:=0 to length(ArrayValues.Values)-1 do + Result:=Result+sLineBreak+FollowPrefix+'+Values['+IntToStr(i)+']='+WritePasElTree(ArrayValues.Values[i],FollowPrefix+'| '); + end + else if C=TBinaryExpr then + begin + Result:=Result+sLineBreak+FollowPrefix+'+Left='+WritePasElTree(TBinaryExpr(Expr).left,FollowPrefix+'| '); + Result:=Result+sLineBreak+FollowPrefix+'+Right='+WritePasElTree(TBinaryExpr(Expr).right,FollowPrefix+'| '); + end + else if C=TParamsExpr then + begin + ParamsExpr:=TParamsExpr(Expr); + Result:=Result+sLineBreak+FollowPrefix+'+Value='+WritePasElTree(ParamsExpr.Value,FollowPrefix+'| '); + for i:=0 to length(ParamsExpr.Params)-1 do + Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']='+WritePasElTree(ParamsExpr.Params[i],FollowPrefix+'| '); + end + else if C=TInlineSpecializeExpr then + begin + InlineSpecExpr:=TInlineSpecializeExpr(Expr); + Result:=Result+sLineBreak+FollowPrefix+'+Name='+WritePasElTree(InlineSpecExpr.NameExpr,FollowPrefix+'| '); + if InlineSpecExpr.Params<>nil then + for i:=0 to InlineSpecExpr.Params.Count-1 do + begin + Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']='; + SubEl:=TPasElement(InlineSpecExpr.Params[i]); + if SubEl=nil then + Result:=Result+'nil' + else if SubEl is TPasExpr then + Result:=Result+WritePasElTree(TPasExpr(SubEl),FollowPrefix+'| ') + else + Result:=Result+SubEl.Name+':'+SubEl.ClassName; + end; + end + else + Result:=C.ClassName+' Kind='; +end; + Function IndentStrings(S : TStrings; indent : Integer) : string; Var I,CurrLen,CurrPos : Integer; @@ -1924,7 +2010,7 @@ begin if (AValue=nil) and (Parent<>nil) then begin // parent is cleared - // -> clear all child references to this array (releasing loops) + // -> clear all child references to self (releasing loops) ForEachCall(@ClearChildReferences,nil); end; inherited SetParent(AValue); @@ -2027,6 +2113,7 @@ begin for i:=0 to length(Constraints)-1 do begin aConstraint:=Constraints[i]; + if aConstraint=nil then continue; if aConstraint.Parent=Self then aConstraint.Parent:=nil; aConstraint.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; @@ -2034,6 +2121,22 @@ begin Constraints:=nil; end; +procedure TPasGenericTemplateType.ClearTypeReferences(aType: TPasElement); +var + i: SizeInt; + aConstraint: TPasElement; +begin + for i:=length(Constraints)-1 downto 0 do + begin + aConstraint:=Constraints[i]; + if aConstraint=aType then + begin + aConstraint.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; + Constraints[i]:=nil; + end; + end; +end; + {$IFDEF HasPTDumpStack} procedure PTDumpStack; begin @@ -2126,13 +2229,29 @@ destructor TInlineSpecializeExpr.Destroy; var i: Integer; begin - TPasElement(NameExpr).Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; + ReleaseAndNil(TPasElement(NameExpr){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF}); for i:=0 to Params.Count-1 do TPasElement(Params[i]).Release{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.Params'){$ENDIF}; FreeAndNil(Params); inherited Destroy; end; +procedure TInlineSpecializeExpr.ClearTypeReferences(aType: TPasElement); +var + i: Integer; + El: TPasElement; +begin + for i:=Params.Count-1 downto 0 do + begin + El:=TPasElement(Params[i]); + if El=aType then + begin + El.Release{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.Params'){$ENDIF}; + Params.Delete(i); + end; + end; +end; + function TInlineSpecializeExpr.ElementTypeName: string; begin Result:=SPasTreeSpecializedExpr; @@ -2183,6 +2302,23 @@ begin inherited Destroy; end; +procedure TPasSpecializeType.ClearTypeReferences(aType: TPasElement); +var + i: Integer; + El: TPasElement; +begin + inherited ClearTypeReferences(aType); + for i:=Params.Count-1 downto 0 do + begin + El:=TPasElement(Params[i]); + if El=aType then + begin + El.Release{$IFDEF CheckPasTreeRefCount}('TPasSpecializeType.Params'){$ENDIF}; + Params.Delete(i); + end; + end; +end; + function TPasSpecializeType.ElementTypeName: string; begin Result:=SPasTreeSpecializedType; @@ -2466,6 +2602,7 @@ end; destructor TPasExportSymbol.Destroy; begin + ReleaseAndNil(TPasElement(NameExpr){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.NameExpr'{$ENDIF}); ReleaseAndNil(TPasElement(ExportName){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.ExportName'{$ENDIF}); ReleaseAndNil(TPasElement(ExportIndex){$IFDEF CheckPasTreeRefCount},'TPasExportSymbol.ExportIndex'{$ENDIF}); inherited Destroy; @@ -2489,6 +2626,7 @@ procedure TPasExportSymbol.ForEachCall(const aMethodCall: TOnForEachPasElement; const Arg: Pointer); begin inherited ForEachCall(aMethodCall, Arg); + ForEachChildCall(aMethodCall,Arg,NameExpr,false); ForEachChildCall(aMethodCall,Arg,ExportName,false); ForEachChildCall(aMethodCall,Arg,ExportIndex,false); end; @@ -2775,7 +2913,9 @@ begin Result := Result + ', '; Result := Result + TPasArgument(ProcType.Args[i]).ArgType.Name; end; - Result := Result + '): ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name; + Result := Result + ')'; + if (OperatorType<>otInitialize) and Assigned(TPasFunctionType(ProcType).ResultEl.ResultType) then + Result:=Result+': ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name; If WithPath then begin S:=Self.ParentPath; @@ -2960,7 +3100,7 @@ begin CN:=CN+' '+IntToStr(FRefCount); //If Assigned(Parent) then // CN:=CN+' ('+Parent.ClassName+')'; - Writeln('TPasElement.Release : ',Cn); + Writeln('TPasElement.Release : ',Cn,' at ',aId); {AllowWriteln-} {$endif} {$IFDEF CheckPasTreeRefCount} @@ -2996,7 +3136,7 @@ begin Dec(FGlobalRefCount); {$endif} end; -{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released : ',Cn); {$endif} +{$if defined(debugrefcount) or defined(VerbosePasTreeMem)} Writeln('TPasElement.Released : ',Cn,' at ',aID); {$endif} end; procedure TPasElement.ForEachCall(const aMethodCall: TOnForEachPasElement; @@ -3212,7 +3352,7 @@ end; procedure TPasPointerType.SetParent(const AValue: TPasElement); begin if (AValue=nil) and (Parent<>nil) and (DestType<>nil) - and ((DestType.Parent=Parent) or (DestType=Self)) then + and ((DestType.HasParent(Parent)) or (DestType=Self)) then begin // DestType in same type section can create a loop // -> break loop when type section is closed @@ -3231,7 +3371,7 @@ end; procedure TPasAliasType.SetParent(const AValue: TPasElement); begin if (AValue=nil) and (Parent<>nil) and (DestType<>nil) - and ((DestType.Parent=Parent) or (DestType=Self)) then + and ((DestType.HasParent(Parent)) or (DestType=Self)) then begin // DestType in same type section can create a loop // -> break loop when type section is closed @@ -3243,6 +3383,7 @@ end; destructor TPasAliasType.Destroy; begin + ReleaseAndNil(TPasElement(SubType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.SubType'{$ENDIF}); ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); ReleaseAndNil(TPasElement(Expr){$IFDEF CheckPasTreeRefCount},'TPasAliasType.Expr'{$ENDIF}); inherited Destroy; @@ -3261,7 +3402,7 @@ begin begin if CurArr.ElType=Self then begin - ReleaseAndNil(TPasElement(CurArr.ElType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF}); + ReleaseAndNil(TPasElement(CurArr.ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF}); break; end; CurArr:=TPasArrayType(CurArr.ElType); @@ -3280,12 +3421,25 @@ begin inherited Destroy; end; +procedure TPasArrayType.ClearTypeReferences(aType: TPasElement); +begin + inherited ClearTypeReferences(aType); + if ElType=aType then + ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasArrayType.ElType'{$ENDIF}); +end; + destructor TPasFileType.Destroy; begin ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasFileType.ElType'{$ENDIF}); inherited Destroy; end; +procedure TPasFileType.ClearTypeReferences(aType: TPasElement); +begin + if aType=ElType then + ReleaseAndNil(TPasElement(ElType){$IFDEF CheckPasTreeRefCount},'TPasFileType.ElType'{$ENDIF}); +end; + constructor TPasEnumType.Create(const AName: string; AParent: TPasElement); begin inherited Create(AName, AParent); @@ -3405,9 +3559,19 @@ begin inherited Destroy; end; +procedure TPasRecordType.ClearTypeReferences(aType: TPasElement); +begin + inherited ClearTypeReferences(aType); + if VariantEl=aType then + ReleaseAndNil(TPasElement(VariantEl){$IFDEF CheckPasTreeRefCount},'TPasRecordType.VariantEl'{$ENDIF}); +end; + { TPasClassType } procedure TPasClassType.SetParent(const AValue: TPasElement); +var + i: Integer; + Intf: TPasElement; begin if (AValue=nil) and (Parent<>nil) then begin @@ -3417,6 +3581,15 @@ begin ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF}); if HelperForType=Self then ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF}); + for i := Interfaces.Count - 1 downto 0 do + begin + Intf:=TPasElement(Interfaces[i]); + if Intf=Self then + begin + Intf.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF}; + Interfaces.Delete(i); + end; + end; end; inherited SetParent(AValue); end; @@ -3443,6 +3616,27 @@ begin inherited Destroy; end; +procedure TPasClassType.ClearTypeReferences(aType: TPasElement); +var + i: Integer; + El: TPasElement; +begin + inherited ClearTypeReferences(aType); + if AncestorType=aType then + ReleaseAndNil(TPasElement(AncestorType){$IFDEF CheckPasTreeRefCount},'TPasClassType.AncestorType'{$ENDIF}); + if HelperForType=aType then + ReleaseAndNil(TPasElement(HelperForType){$IFDEF CheckPasTreeRefCount},'TPasClassType.HelperForType'{$ENDIF}); + for i := Interfaces.Count - 1 downto 0 do + begin + El:=TPasElement(Interfaces[i]); + if El=aType then + begin + El.Release{$IFDEF CheckPasTreeRefCount}('TPasClassType.Interfaces'){$ENDIF}; + Interfaces[i]:=nil; + end; + end; +end; + function TPasClassType.ElementTypeName: string; begin case ObjKind of @@ -3557,6 +3751,45 @@ begin inherited Destroy; end; +procedure TPasArgument.ClearTypeReferences(aType: TPasElement); +begin + if ArgType=aType then + ReleaseAndNil(TPasElement(ArgType){$IFDEF CheckPasTreeRefCount},'TPasArgument.ArgType'{$ENDIF}); +end; + +function TPasArgument.GetDeclaration (full : boolean) : string; +begin + If Assigned(ArgType) then + begin + If ArgType.Name<>'' then + Result:=ArgType.SafeName + else + Result:=ArgType.GetDeclaration(False); + If Full and (Name<>'') then + Result:=SafeName+': '+Result; + end + else If Full then + Result:=SafeName + else + Result:=''; +end; + +procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement; + const Arg: Pointer); +begin + inherited ForEachCall(aMethodCall, Arg); + ForEachChildCall(aMethodCall,Arg,ArgType,true); + ForEachChildCall(aMethodCall,Arg,ValueExpr,false); +end; + +function TPasArgument.Value: String; +begin + If Assigned(ValueExpr) then + Result:=ValueExpr.GetDeclaration(true) + else + Result:=''; +end; + { TPasProcedureType } // inline @@ -3632,6 +3865,13 @@ begin inherited Destroy; end; +procedure TPasProcedureType.ClearTypeReferences(aType: TPasElement); +begin + inherited ClearTypeReferences(aType); + if VarArgsType=aType then + ReleaseAndNil(TPasElement(VarArgsType){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF}); +end; + class function TPasProcedureType.TypeName: string; begin Result := 'procedure'; @@ -4356,6 +4596,12 @@ begin inherited Destroy; end; +procedure TPasSetType.ClearTypeReferences(aType: TPasElement); +begin + if EnumType=aType then + ReleaseAndNil(TPasElement(EnumType){$IFDEF CheckPasTreeRefCount},'TPasSetType.EnumType'{$ENDIF}); +end; + function TPasSetType.GetDeclaration (full : boolean) : string; Var @@ -5105,45 +5351,6 @@ begin Result:=ptDestructor; end; -function TPasArgument.GetDeclaration (full : boolean) : string; -begin - If Assigned(ArgType) then - begin - If ArgType.Name<>'' then - Result:=ArgType.SafeName - else - Result:=ArgType.GetDeclaration(False); - If Full and (Name<>'') then - Result:=SafeName+': '+Result; - end - else If Full then - Result:=SafeName - else - Result:=''; -end; - -procedure TPasArgument.ForEachCall(const aMethodCall: TOnForEachPasElement; - const Arg: Pointer); -begin - inherited ForEachCall(aMethodCall, Arg); - ForEachChildCall(aMethodCall,Arg,ArgType,true); - ForEachChildCall(aMethodCall,Arg,ValueExpr,false); -end; - -procedure TPasArgument.ClearTypeReferences(aType: TPasElement); -begin - if ArgType=aType then - ReleaseAndNil(TPasElement(ArgType){$IFDEF CheckPasTreeRefCount},'TPasArgument.ArgType'{$ENDIF}); -end; - -function TPasArgument.Value: String; -begin - If Assigned(ValueExpr) then - Result:=ValueExpr.GetDeclaration(true) - else - Result:=''; -end; - { TPassTreeVisitor } procedure TPassTreeVisitor.Visit(obj: TPasElement); @@ -5722,7 +5929,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/avx512-0037785/packages/fcl-passrc/src/pasuseanalyzer.pas b/avx512-0037785/packages/fcl-passrc/src/pasuseanalyzer.pas index 177f94c63a..320a83a1ff 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/avx512-0037785/packages/fcl-passrc/src/pasuseanalyzer.pas @@ -62,6 +62,10 @@ const // non fpc hints nPAParameterInOverrideNotUsed = 4501; sPAParameterInOverrideNotUsed = 'Parameter "%s" not used'; + nPAFieldNotUsed = 4502; + sPAFieldNotUsed = 'Field "%s" not used'; + nPAFieldIsAssignedButNeverUsed = 4503; + sPAFieldIsAssignedButNeverUsed = 'Field "%s" is assigned but never used'; // fpc hints: use same IDs as fpc nPAUnitNotUsed = 5023; sPAUnitNotUsed = 'Unit "%s" not used in %s'; @@ -180,7 +184,7 @@ type {$ifdef pas2js} constructor Create(const OnItemToName, OnKeyToName: TPASItemToNameProc); reintroduce; {$else} - constructor Create(const OnCompareMethod: TListSortCompare; + constructor Create(const OnCompareProc: TListSortCompare; const OnCompareKeyWithData: TListSortCompare); {$endif} destructor Destroy; override; @@ -198,7 +202,7 @@ type TPasAnalyzerOption = ( paoOnlyExports, // default: use all class members accessible from outside (protected, but not private) - paoImplReferences, // collect references of top lvl proc implementations, initializationa dn finalization sections + paoImplReferences, // collect references of top lvl proc implementations, initializationa and finalization sections paoSkipGenericProc // ignore generic procedure body ); TPasAnalyzerOptions = set of TPasAnalyzerOption; @@ -434,10 +438,10 @@ begin FItems:=TJSObject.new; end; {$else} -constructor TPasAnalyzerKeySet.Create(const OnCompareMethod: TListSortCompare; +constructor TPasAnalyzerKeySet.Create(const OnCompareProc: TListSortCompare; const OnCompareKeyWithData: TListSortCompare); begin - FTree:=TAVLTree.Create(OnCompareMethod); + FTree:=TAVLTree.Create(OnCompareProc); FCompareKeyWithData:=OnCompareKeyWithData; end; {$endif} @@ -1009,6 +1013,8 @@ procedure TPasAnalyzer.MarkImplScopeRef(El, RefEl: TPasElement; if (RefEl.Name='') and not (RefEl is TInterfaceSection) then exit; // reference to anonymous type -> not needed + if RefEl=ElImplScope.Element then + exit; if ElImplScope is TPasProcedureScope then TPasProcedureScope(ElImplScope).AddReference(RefEl,Access) else if ElImplScope is TPasInitialFinalizationScope then @@ -1279,7 +1285,7 @@ begin if CanSkipGenericType(ProcType) then exit; for i:=0 to ProcType.Args.Count-1 do UseSubEl(TPasArgument(ProcType.Args[i]).ArgType); - if El is TPasFunctionType then + if (El is TPasFunctionType) and (TPasFunctionType(El).ResultEl<>nil) then UseSubEl(TPasFunctionType(El).ResultEl.ResultType); end else if C=TPasSpecializeType then @@ -1311,6 +1317,9 @@ begin UseElement(El,rraNone,true); UseAttributes(El); + + if El.Parent is TPasMembersType then + UseTypeInfo(El.Parent); end; procedure TPasAnalyzer.UseAttributes(El: TPasElement); @@ -1541,12 +1550,15 @@ begin UseExpr(ForLoop.StartExpr); UseExpr(ForLoop.EndExpr); ForScope:=ForLoop.CustomData as TPasForLoopScope; - MarkImplScopeRef(ForLoop,ForScope.GetEnumerator,psraRead); - UseProcedure(ForScope.GetEnumerator); - MarkImplScopeRef(ForLoop,ForScope.MoveNext,psraRead); - UseProcedure(ForScope.MoveNext); - MarkImplScopeRef(ForLoop,ForScope.Current,psraRead); - UseVariable(ForScope.Current,rraRead,false); + if ForScope<>nil then + begin + MarkImplScopeRef(ForLoop,ForScope.GetEnumerator,psraRead); + UseProcedure(ForScope.GetEnumerator); + MarkImplScopeRef(ForLoop,ForScope.MoveNext,psraRead); + UseProcedure(ForScope.MoveNext); + MarkImplScopeRef(ForLoop,ForScope.Current,psraRead); + UseVariable(ForScope.Current,rraRead,false); + end; UseImplElement(ForLoop.Body); end else if C=TPasImplIfElse then @@ -1648,12 +1660,14 @@ procedure TPasAnalyzer.UseExpr(El: TPasExpr); UseElement(SubEl,rraAssign,false); end; - procedure UseBuilInFuncTypeInfo; + procedure UseBuiltInFuncTypeInfo; var ParentParams: TPRParentParams; ParamResolved: TPasResolverResult; SubEl: TPasElement; Params: TPasExprArray; + ProcScope: TPasProcedureScope; + Proc: TPasProcedure; begin Resolver.GetParamsOfNameExpr(El,ParentParams); if ParentParams.Params=nil then @@ -1670,7 +1684,11 @@ procedure TPasAnalyzer.UseExpr(El: TPasExpr); if (ParamResolved.IdentEl is TPasProcedure) and (TPasProcedure(ParamResolved.IdentEl).ProcType is TPasFunctionType) then begin - SubEl:=TPasFunctionType(TPasProcedure(ParamResolved.IdentEl).ProcType).ResultEl.ResultType; + Proc:=TPasProcedure(ParamResolved.IdentEl); + ProcScope:=Proc.CustomData as TPasProcedureScope; + if ProcScope.DeclarationProc<>nil then + Proc:=ProcScope.DeclarationProc; + SubEl:=TPasFunctionType(Proc.ProcType).ResultEl.ResultType; MarkImplScopeRef(El,SubEl,psraTypeInfo); UseTypeInfo(SubEl); end @@ -1749,7 +1767,7 @@ begin end; bfTypeInfo: begin - UseBuilInFuncTypeInfo; + UseBuiltInFuncTypeInfo; exit; end; bfAssert: @@ -2386,6 +2404,8 @@ begin RaiseNotSupported(20180328224632,aClass,GetObjName(o)); end; end; + + UseAttributes(El); end; procedure TPasAnalyzer.UseClassConstructor(El: TPasMembersType); @@ -2664,6 +2684,7 @@ begin {$IFDEF VerbosePasAnalyzer} writeln('TPasAnalyzer.EmitSectionHints ',GetElModName(Section)); {$ENDIF} + if Section=nil then exit; // initialization, program or library sections aModule:=Section.GetModule; UsesClause:=Section.UsesClause; @@ -2810,8 +2831,14 @@ begin sPAPrivateFieldIsNeverUsed,[El.FullName],El); end else if El.ClassType=TPasVariable then - EmitMessage(20170311234201,mtHint,nPALocalVariableNotUsed, - sPALocalVariableNotUsed,[El.Name],El) + begin + if El.Parent is TPasMembersType then + EmitMessage(20201229033108,mtHint,nPAFieldNotUsed, + sPAFieldNotUsed,[El.Name],El) + else + EmitMessage(20170311234201,mtHint,nPALocalVariableNotUsed, + sPALocalVariableNotUsed,[El.Name],El); + end else EmitMessage(20170314221334,mtHint,nPALocalXYNotUsed, sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El); @@ -2825,6 +2852,9 @@ begin if El.Visibility in [visPrivate,visStrictPrivate] then EmitMessage(20170311234159,mtHint,nPAPrivateFieldIsAssignedButNeverUsed, sPAPrivateFieldIsAssignedButNeverUsed,[El.FullName],El) + else if El.Parent is TPasMembersType then + EmitMessage(20201229033618,mtHint,nPAFieldIsAssignedButNeverUsed, + sPAFieldIsAssignedButNeverUsed,[El.Name],El) else EmitMessage(20170311233825,mtHint,nPALocalVariableIsAssignedButNeverUsed, sPALocalVariableIsAssignedButNeverUsed,[El.Name],El); @@ -3155,15 +3185,10 @@ begin end; function TPasAnalyzer.IsSpecializedGenericType(El: TPasElement): boolean; -var - GenScope: TPasGenericScope; begin - if El is TPasGenericType then - begin - GenScope:=El.CustomData as TPasGenericScope; - if (GenScope<>nil) and (GenScope.SpecializedFromItem<>nil) then - exit(true); - end; + if (El is TPasGenericType) and (El.CustomData is TPasGenericScope) + and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil) then + exit(true); Result:=false; end; diff --git a/avx512-0037785/packages/fcl-passrc/src/paswrite.pp b/avx512-0037785/packages/fcl-passrc/src/paswrite.pp index cf3da304f8..54cd8973bb 100644 --- a/avx512-0037785/packages/fcl-passrc/src/paswrite.pp +++ b/avx512-0037785/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; @@ -1571,7 +1659,7 @@ procedure WritePasFile(AElement: TPasElement; const AFilename: string); var Stream: TFileStream; begin - Stream := TFileStream.Create(AFilename, fmCreate); + Stream := TFileStream.Create(AFilename, fmCreate or fmShareDenyNone); try WritePasFile(AElement, Stream); finally diff --git a/avx512-0037785/packages/fcl-passrc/src/pparser.pp b/avx512-0037785/packages/fcl-passrc/src/pparser.pp index f28240efaa..59e54088b1 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pparser.pp +++ b/avx512-0037785/packages/fcl-passrc/src/pparser.pp @@ -311,7 +311,7 @@ type function CheckProcedureArgs(Parent: TPasElement; Args: TFPList; // list of TPasArgument ProcType: TProcType): boolean; - function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean; + function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility; IsObjCProtocol : Boolean = False): Boolean; procedure ParseExc(MsgNumber: integer; const Msg: String); procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif}); procedure ParseExcExpectedIdentifier; @@ -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 @@ -1191,29 +1192,40 @@ procedure TPasParser.ChangeToken(tk: TToken); var Cur, Last: PTokenRec; IsLast: Boolean; + + Procedure DoChange(tk1,tk2 : TToken); + + begin + // change last token '>>' into two '>' + Cur:=@FTokenRing[FTokenRingCur]; + Cur^.Token:=tk2; + Cur^.AsString:=TokenInfos[tk2]; + Last:=@FTokenRing[FTokenRingEnd]; + Last^.Token:=tk2; + Last^.AsString:=TokenInfos[tk2]; + if Last^.Comments<>nil then + Last^.Comments.Clear; + Last^.SourcePos:=Cur^.SourcePos; + dec(Cur^.SourcePos.Column); + Last^.TokenPos:=Cur^.TokenPos; + inc(Last^.TokenPos.Column); + FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize; + if FTokenRingStart=FTokenRingEnd then + FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize; + FCurToken:=tk1; + FCurTokenString:=TokenInfos[tk1]; + end; + begin //writeln('TPasParser.ChangeToken FTokenBufferSize=',FTokenRingStart,' FTokenBufferIndex=',FTokenRingCur); IsLast:=((FTokenRingCur+1) mod FTokenRingSize)=FTokenRingEnd; - if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then + if (CurToken=tkGreaterEqualThan) and (tk=tkGreaterThan) and IsLast then begin - // change last token '>>' into two '>' - Cur:=@FTokenRing[FTokenRingCur]; - Cur^.Token:=tkGreaterThan; - Cur^.AsString:='>'; - Last:=@FTokenRing[FTokenRingEnd]; - Last^.Token:=tkGreaterThan; - Last^.AsString:='>'; - if Last^.Comments<>nil then - Last^.Comments.Clear; - Last^.SourcePos:=Cur^.SourcePos; - dec(Cur^.SourcePos.Column); - Last^.TokenPos:=Cur^.TokenPos; - inc(Last^.TokenPos.Column); - FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize; - if FTokenRingStart=FTokenRingEnd then - FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize; - FCurToken:=tkGreaterThan; - FCurTokenString:='>'; + DoChange(tkGreaterThan,tkEqual); + end + else if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then + begin + DoChange(tkGreaterThan,tkGreaterThan); end else CheckToken(tk); @@ -1381,11 +1393,21 @@ begin Result:=true; PTM:=ptmVarargs; end + else if CompareText(S,ProcTypeModifiers[ptmFar])=0 then + begin + Result:=true; + PTM:=ptmFar; + end else if CompareText(S,ProcTypeModifiers[ptmStatic])=0 then begin Result:=true; PTM:=ptmStatic; end + else if CompareText(S,ProcTypeModifiers[ptmCblock])=0 then + begin + Result:=true; + PTM:=ptmCblock; + end else if (CompareText(S,ProcTypeModifiers[ptmAsync])=0) and (po_AsyncProcs in Options) then begin Result:=true; @@ -1742,12 +1764,20 @@ begin end; // read nested specialize arguments ReadSpecializeArguments(ST,ST.Params); - // Important: resolve type reference AFTER args, because arg count is needed - ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count); - if CurToken<>tkGreaterThan then ParseExcTokenError('[20190801113005]'); - // ToDo: cascaded specialize A<B>.C<D> + + // Check for cascaded specialize A<B>.C or A<B>.C<D> + NextToken; + if CurToken<>tkDot then + UnGetToken + else + begin + NextToken; + ST.SubType:=ParseSimpleType(ST,CurSourcePos,GenName,False); + end; + // Important: resolve type reference AFTER args, because arg count is needed + ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count); Engine.FinishScope(stTypeDef,ST); Result:=ST; @@ -1769,7 +1799,7 @@ begin Try // only allowed: ^dottedidentifer // forbidden: ^^identifier, ^array of word, ^A<B> - ExpectIdentifier; + ExpectTokens([tkIdentifier,tkFile]); Name:=CurTokenString; repeat NextToken; @@ -1781,7 +1811,14 @@ begin else break; until false; - UngetToken; + if CurToken=tkLessThan then + begin + Repeat + NextToken; // We should do something with this. + Until CurToken=tkGreaterThan; + end + else + UngetToken; Result.DestType:=ResolveTypeReference(Name,Result); Engine.FinishScope(stTypeDef,Result); ok:=true; @@ -1997,7 +2034,10 @@ begin finally if not ok then if Result<>nil then + begin Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; + Result:=nil; + end; end; end; @@ -2487,11 +2527,16 @@ begin NextToken; if CurToken=tkspecialize then begin + // Obj.specialize ... if CanSpecialize=aMust then CheckToken(tkLessThan); CanSpecialize:=aMust; NextToken; - end; + end + else if msDelphi in CurrentModeswitches then + CanSpecialize:=aCan + else + CanSpecialize:=aCannot; if CurToken in [tkIdentifier,tktrue,tkfalse,tkself] then // true and false are sub identifiers as well begin aName:=aName+'.'+CurTokenString; @@ -2540,21 +2585,36 @@ begin Expr:=Result; if Expr.Kind=pekBinary then begin - if Expr.OpCode<>eopSubIdent then + Bin:=TBinaryExpr(Expr); + if Bin.OpCode<>eopSubIdent then ParseExcSyntaxError; - Expr:=TBinaryExpr(Expr).right; - end; + Expr:=Bin.right; + end + else + Bin:=nil; if Expr.Kind<>pekIdent then ParseExcSyntaxError; // read specialized params - ISE:=TInlineSpecializeExpr(CreateElement(TInlineSpecializeExpr,'',AParent,SrcPos)); + if Bin<>nil then + ISE:=TInlineSpecializeExpr(CreateElement(TInlineSpecializeExpr,'',Bin,SrcPos)) + else + ISE:=TInlineSpecializeExpr(CreateElement(TInlineSpecializeExpr,'',AParent,SrcPos)); ReadSpecializeArguments(ISE,ISE.Params); // A<B> or something.A<B> - ISE.NameExpr:=Result; - Result.Parent:=ISE; - Result:=ISE; + ISE.NameExpr:=Expr; + Expr.Parent:=ISE; + if Bin<>nil then + begin + // something.A<B> + Bin.Right:=ISE; + end + else + begin + // A<B> + Result:=ISE; + end; ISE:=nil; CanSpecialize:=aCannot; NextToken; @@ -3044,6 +3104,7 @@ begin FCurModule:=Module; HasFinished:=true; try + Scanner.CurModuleName:=AUnitName; if Assigned(Engine.Package) then begin Module.PackageName := Engine.Package.Name; @@ -3081,7 +3142,10 @@ begin FinishedModule; finally if HasFinished then + begin + Module.Release{$IFDEF CheckPasTreeRefCount}('TPasPackage.Modules'){$ENDIF}; FCurModule:=nil; // clear module if there is an error or finished parsing + end; end; end; @@ -3215,6 +3279,7 @@ begin HasFinished:=true; FCurModule:=Module; try + Scanner.CurModuleName:=N; if Assigned(Engine.Package) then begin Module.PackageName := Engine.Package.Name; @@ -3291,6 +3356,7 @@ begin HasFinished:=true; FCurModule:=Module; try + Scanner.CurModuleName:=N; if Assigned(Engine.Package) then begin Module.PackageName := Engine.Package.Name; @@ -3586,6 +3652,7 @@ begin pt:=GetProcTypeFromToken(CurToken,True); AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt, MustBeGeneric)); end; + tkAbsolute, tkIdentifier: begin Scanner.UnSetTokenOption(toOperatorToken); @@ -4177,8 +4244,12 @@ begin until CurToken<>tkComma; Engine.FinishScope(stTypeDef,T); until not (CurToken in [tkSemicolon,tkComma]); - if CurToken<>tkGreaterThan then - ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan]); + if Not (CurToken in [tkGreaterThan,tkGreaterEqualThan]) then + ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan]) + else if CurToken=tkGreaterEqualThan then + begin + ChangeToken(tkGreaterThan); + end; end; {$warn 5043 on} @@ -4273,26 +4344,43 @@ end; procedure TPasParser.ParseExportDecl(Parent: TPasElement; List: TFPList); Var E : TPasExportSymbol; + aName: String; + NameExpr: TPasExpr; begin - Repeat - if List.Count<>0 then - ExpectIdentifier; - E:=TPasExportSymbol(CreateElement(TPasExportSymbol,CurtokenString,Parent)); - List.Add(E); - NextToken; - if CurTokenIsIdentifier('INDEX') then - begin - NextToken; - E.Exportindex:=DoParseExpression(E,Nil) - end - else if CurTokenIsIdentifier('NAME') then - begin - NextToken; - E.ExportName:=DoParseExpression(E,Nil) - end; - if not (CurToken in [tkComma,tkSemicolon]) then - ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); - until (CurToken=tkSemicolon); + try + Repeat + if List.Count>0 then + ExpectIdentifier; + aName:=ReadDottedIdentifier(Parent,NameExpr,true); + E:=TPasExportSymbol(CreateElement(TPasExportSymbol,aName,Parent)); + if NameExpr.Kind=pekIdent then + // simple identifier -> no need to store NameExpr + NameExpr.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF} + else + begin + E.NameExpr:=NameExpr; + NameExpr.Parent:=E; + end; + NameExpr:=nil; + List.Add(E); + if CurTokenIsIdentifier('INDEX') then + begin + NextToken; + E.Exportindex:=DoParseExpression(E,Nil) + end + else if CurTokenIsIdentifier('NAME') then + begin + NextToken; + E.ExportName:=DoParseExpression(E,Nil) + end; + if not (CurToken in [tkComma,tkSemicolon]) then + ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon); + Engine.FinishScope(stDeclaration,E); + until (CurToken=tkSemicolon); + finally + if NameExpr<>nil then + NameExpr.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF} + end; end; function TPasParser.ParseProcedureType(Parent: TPasElement; @@ -4530,8 +4618,16 @@ begin begin Result:=True; NextToken; - Location:=ReadDottedIdentifier(Parent,AbsoluteExpr,true); - UnGetToken; + if Curtoken=tkNumber then + begin + AbsoluteExpr:=CreatePrimitiveExpr(Parent,pekNumber,CurTokenString); + Location:=CurTokenString + end + else + begin + Location:=ReadDottedIdentifier(Parent,AbsoluteExpr,true); + UnGetToken; + end end else UngetToken; @@ -4592,6 +4688,8 @@ begin Result := Result + ' ' + CurTokenText; LibName:=DoParseExpression(Parent); end; + if CurToken=tkSemiColon then + exit; if not CurTokenIsIdentifier('name') then ParseExcSyntaxError; NextToken; @@ -4849,8 +4947,23 @@ end; // Starts after the opening bracket token procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: TToken); + + Function GetParamName : string; + + begin + if ([msDelphi,msDelphiUnicode,msObjfpc]* CurrentModeswitches)<>[] then + Result := ExpectIdentifier + else + begin + NextToken; + if CurToken in [tkProperty,tkIdentifier,tkClass] then + Result:=CurTokenString + else + ParseExcTokenError('identifier') + end; + end; var - IsUntyped, ok, LastHadDefaultValue: Boolean; + OldForceCaret,IsUntyped, ok, LastHadDefaultValue: Boolean; Name : String; Value : TPasExpr; i, OldArgCount: Integer; @@ -4866,22 +4979,37 @@ begin IsUntyped := False; ArgType := nil; NextToken; - if CurToken = tkConst then + if CurToken = tkDotDotDot then + begin + expectToken(endToken); + Break; + end else if CurToken = tkConst then begin Access := argConst; - Name := ExpectIdentifier; + Name := GetParamName; end else if CurToken = tkConstRef then begin Access := argConstref; - Name := ExpectIdentifier; + Name := getParamName; end else if CurToken = tkVar then begin Access := ArgVar; - Name := ExpectIdentifier; + Name:=GetParamName; end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then begin - Access := ArgOut; - Name := ExpectIdentifier; + if ([msObjfpc, msDelphi, msDelphiUnicode, msOut] * CurrentModeswitches)<>[] then + begin + Access := ArgOut; + Name := ExpectIdentifier + end + else + Name := CurTokenString + end else if (CurToken = tkproperty) or (CurToken=tkClass) then + begin + if ([msDelphi,msDelphiUnicode,msObjfpc]* CurrentModeswitches)<>[] then + ParseExcTokenError('identifier') + else + Name := CurTokenString end else if CurToken = tkIdentifier then Name := CurTokenString else @@ -4914,9 +5042,11 @@ begin if not IsUntyped then begin Arg := TPasArgument(Args[OldArgCount]); - ArgType := ParseType(Arg,CurSourcePos); + ArgType:=Nil; ok:=false; + oldForceCaret:=Scanner.SetForceCaret(True); try + ArgType := ParseType(Arg,CurSourcePos); NextToken; if CurToken = tkEqual then begin @@ -4940,6 +5070,7 @@ begin UngetToken; ok:=true; finally + Scanner.SetForceCaret(oldForceCaret); if (not ok) and (ArgType<>nil) then ArgType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; end; @@ -4998,7 +5129,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 @@ -5236,6 +5367,7 @@ Var OK: Boolean; IsProcType: Boolean; // false = procedure, true = procedure type IsAnonymous: Boolean; + OldForceCaret : Boolean; PTM: TProcTypeModifier; ModTokenCount: Integer; LastToken: TToken; @@ -5253,7 +5385,12 @@ begin if CurToken = tkColon then begin ResultEl:=TPasFunctionType(Element).ResultEl; - ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); + OldForceCaret:=Scanner.SetForceCaret(True); + try + ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); + finally + Scanner.SetForceCaret(OldForceCaret); + end; end // In Delphi mode, the signature in the implementation section can be // without result as it was declared @@ -5291,16 +5428,20 @@ begin begin ResultEl.Name := CurTokenName; ExpectToken(tkColon); - end - else - if (CurToken=tkColon) then - ResultEl.Name := 'Result' - else - ParseExc(nParserExpectedColonID,SParserExpectedColonID); ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); + end + else if not ((Parent is TPasOperator) and (TPasOperator(Parent).OperatorType=otInitialize)) then + // Initialize operator has no result + begin + if (CurToken=tkColon) then + ResultEl.Name := 'Result' + else + ParseExc(nParserExpectedColonID,SParserExpectedColonID); + ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); + end; end; else - resultEl:=Nil; + ResultEl:=Nil; end; if OfObjectPossible then begin @@ -5312,7 +5453,7 @@ begin end else if (CurToken = tkIs) then begin - expectToken(tkIdentifier); + ExpectToken(tkIdentifier); if (lowerCase(CurTokenString)<>'nested') then ParseExc(nParserExpectedNested,SParserExpectedNested); Element.IsNested:=True; @@ -5338,8 +5479,8 @@ begin begin if IsAnonymous then CheckToken(tkbegin); // begin expected, but ; found - if LastToken=tkSemicolon then - ParseExcSyntaxError; + // if LastToken=tkSemicolon then + // ParseExcSyntaxError; continue; end else if TokenIsCallingConvention(CurTokenString,cc) then @@ -5354,9 +5495,9 @@ begin else // remove legacy or basesysv on MorphOS syscalls begin - if CurTokenIsIdentifier('legacy') or CurTokenIsIdentifier('BaseSysV') then + if CurTokenIsIdentifier('legacy') or CurTokenIsIdentifier('consoledevice') + or (Curtoken=tkIdentifier) and (Pos('base',LowerCase(CurtokenText))>0) then NextToken; - NextToken; // remove offset end; end; if IsProcType then @@ -5372,7 +5513,12 @@ begin else if IsAnonymous and TokenIsAnonymousProcedureModifier(Parent,CurTokenString,PM) then HandleProcedureModifier(Parent,PM) else if TokenIsProcedureTypeModifier(Parent,CurTokenString,PTM) then - HandleProcedureTypeModifier(Element,PTM) + begin + HandleProcedureTypeModifier(Element,PTM); + // Backwards compatibility + if (PTM=ptmFar) and (Parent is TPasProcedure) then + (Parent as TPasProcedure).AddModifier(pmFar) + end else if (not IsProcType) and (not IsAnonymous) and TokenIsProcedureModifier(Parent,CurTokenString,PM) then HandleProcedureModifier(Parent,PM) @@ -6784,6 +6930,24 @@ var Scanner.UnSetTokenOption(toOperatorToken); end; + Function CheckSection : Boolean; + + begin + // Advanced records can have empty sections. + { Use Case: + Record + type + const + var + Case Integer of + end; + } + NextToken; + Result:=CurToken in [tkvar,tktype,tkConst,tkCase]; + if Not Result then + UngetToken; + end; + Var VariantName : String; v : TPasMemberVisibility; @@ -6795,7 +6959,10 @@ Var CurEl: TPasElement; LastToken: TToken; AllowVisibility: Boolean; + IsGeneric : Boolean; + begin + IsGeneric:=False; AllowVisibility:=msAdvancedRecords in CurrentModeswitches; if AllowVisibility then v:=visPublic @@ -6812,6 +6979,8 @@ begin DisableIsClass; if Not AllowMethods then ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed); + if CheckSection then + continue; ExpectToken(tkIdentifier); ParseMembersLocalTypes(ARec,v); end; @@ -6820,6 +6989,8 @@ begin DisableIsClass; if Not AllowMethods then ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed); + if CheckSection then + continue; ExpectToken(tkIdentifier); ParseMembersLocalConsts(ARec,v); end; @@ -6827,6 +6998,8 @@ begin begin if Not AllowMethods then ParseExc(nErrRecordVariablesNotAllowed,SErrRecordVariablesNotAllowed); + if CheckSection then + continue; ExpectToken(tkIdentifier); OldCount:=ARec.Members.Count; ParseInlineVarDecl(ARec, ARec.Members, v, AEndToken=tkBraceClose); @@ -6875,7 +7048,7 @@ begin if Not AllowMethods then ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed); ProcType:=GetProcTypeFromToken(CurToken,LastToken=tkclass); - Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,false,v); + Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,IsGeneric,v); if Proc.Parent is TPasOverloadedProc then TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc) else @@ -6884,9 +7057,21 @@ begin end; tkDestructor: ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed); - tkabsolute,tkGeneric,tkSelf, // Counts as field name + tkGeneric, // Can count as field name + tkabsolute, + tkSelf, // Count as field name tkIdentifier : begin + if (Curtoken=tkGeneric) and AllowVisibility then + begin + NextToken; + if CurToken in [tkClass,tkOperator,tkFunction,tkProcedure] then + begin + IsGeneric:=True; + Continue; + end; + UnGetToken; + end; If AllowVisibility and CheckVisibility(CurTokenString,v) then begin if not (v in [visPrivate,visPublic,visStrictPrivate]) then @@ -6940,6 +7125,8 @@ begin break; LastToken:=CurToken; NextToken; + if not IsClass then + IsGeneric:=False; end; end; @@ -6973,18 +7160,20 @@ begin end; end; -Function IsVisibility(S : String; var AVisibility :TPasMemberVisibility) : Boolean; +Function IsVisibility(S : String; var AVisibility :TPasMemberVisibility; IsObjCProtocol : Boolean) : Boolean; Const VNames : array[TPasMemberVisibility] of string = - ('', 'private', 'protected', 'public', 'published', 'automated', '', ''); + ('', 'private', 'protected', 'public', 'published', 'automated', '', '','required','optional'); + VLast : Array[Boolean] of TPasMemberVisibility = (visAutomated,visOptional); + Var V : TPasMemberVisibility; begin Result:=False; S:=lowerCase(S); - For V :=Low(TPasMemberVisibility) to High(TPasMemberVisibility) do + For V :=Low(TPasMemberVisibility) to VLast[isObjCProtocol] do begin Result:=(VNames[V]<>'') and (S=VNames[V]); if Result then @@ -6995,8 +7184,7 @@ begin end; end; -function TPasParser.CheckVisibility(S: String; - var AVisibility: TPasMemberVisibility): Boolean; +function TPasParser.CheckVisibility(S: String; var AVisibility: TPasMemberVisibility; IsObjCProtocol : Boolean = false): Boolean; Var B : Boolean; @@ -7009,7 +7197,7 @@ begin NextToken; s:=LowerCase(CurTokenString); end; - Result:=isVisibility(S,AVisibility); + Result:=isVisibility(S,AVisibility,isObjCProtocol); if Result then begin if (AVisibility=visPublished) and (msOmitRTTI in Scanner.CurrentModeSwitches) then @@ -7245,7 +7433,7 @@ begin CurSection:=stVar; end; tkIdentifier: - if CheckVisibility(CurTokenString,CurVisibility) then + if CheckVisibility(CurTokenString,CurVisibility,(AType.ObjKind=okObjcProtocol)) then CurSection:=stNone else begin @@ -7263,6 +7451,8 @@ begin if not (AType.ObjKind in okWithFields) then ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowedInX,[ObjKindNames[AType.ObjKind]]); ParseClassFields(AType,CurVisibility,CurSection=stClassVar); + if Curtoken=tkEnd then // case Ta = Class x : String end; + UngetToken; HaveClass:=False; end; stClassVar: @@ -7414,7 +7604,7 @@ begin CheckToken(tkend); NextToken; AType.AncestorType := ParseTypeReference(AType,false,Expr); - if AType.ObjKind in [okClass,okObjCClass] then + if AType.ObjKind in [okClass,okObjCClass,okObjcProtocol] then while CurToken=tkComma do begin NextToken; @@ -7450,7 +7640,7 @@ end; function TPasParser.DoParseClassExternalHeader(AObjKind: TPasObjKind; out AExternalNameSpace, AExternalName: string): Boolean; begin Result:=False; - if ((aObjKind in [okObjcCategory,okObjcClass]) or + if ((aObjKind in [okObjcCategory,okObjcClass,okObjcProtocol]) or ((AObjKind in [okClass,okInterface]) and (msExternalClass in CurrentModeswitches))) and CurTokenIsIdentifier('external') then begin @@ -7462,7 +7652,7 @@ begin AExternalNameSpace:=CurTokenString; if (aObjKind in [okObjcCategory,okObjcClass]) then begin - // Name is optional in objcclass/category + // Name is optional in objcclass/category/protocol NextToken; if CurToken=tkBraceOpen then exit; diff --git a/avx512-0037785/packages/fcl-passrc/src/pscanner.pp b/avx512-0037785/packages/fcl-passrc/src/pscanner.pp index 069c83ded5..55c10fa3b7 100644 --- a/avx512-0037785/packages/fcl-passrc/src/pscanner.pp +++ b/avx512-0037785/packages/fcl-passrc/src/pscanner.pp @@ -68,6 +68,7 @@ const nErrWrongSwitchToggle = 1032; nNoResourceSupport = 1033; nResourceFileNotFound = 1034; + nErrInvalidMultiLineLineEnding = 1035; // resourcestring patterns of messages resourcestring @@ -107,6 +108,7 @@ resourcestring SInvalidDispatchFieldName = 'Invalid Dispatch field name'; SErrWrongSwitchToggle = 'Wrong switch toggle, use ON/OFF or +/-'; SNoResourceSupport = 'No support for resources of type "%s"'; + SErrInvalidMultiLineLineEnding = 'Invalid multilinestring line ending type: use one of CR/LF/CRLF/SOURCE/PLATFORM' ; type TMessageType = ( @@ -162,6 +164,8 @@ type tkAssignMul, // *= tkAssignDivision, // /= tkAtAt, // @@ + // Three-character tokens + tkDotDotDot, // ... (mac mode) // Reserved words tkabsolute, tkand, @@ -294,7 +298,8 @@ type msPrefixedAttributes, { Allow attributes, disable proc modifier [] } msOmitRTTI, { treat class section 'published' as 'public' and typeinfo does not work on symbols declared with this switch } msMultiHelpers, { off=only one helper per type, on=all } - msImplicitFunctionSpec { implicit function specialization } + msImplicitFunctionSpec, { implicit function specialization } + msMultiLineStrings { Multiline strings } ); TModeSwitches = Set of TModeSwitch; @@ -417,14 +422,18 @@ type end; { TLineReader } + TEOLStyle = (elPlatform,elSource,elLF,elCR,elCRLF); TLineReader = class Private FFilename: string; + Protected + EOLStyle : TEOLStyle; public constructor Create(const AFilename: string); virtual; function IsEOF: Boolean; virtual; abstract; function ReadLine: string; virtual; abstract; + function LastEOLStyle: TEOLStyle; virtual; property Filename: string read FFilename; end; @@ -490,12 +499,15 @@ type TBaseFileResolver = class private FBaseDirectory: string; + FMode: TModeSwitch; + FModuleDirectory: string; FResourcePaths, FIncludePaths: TStringList; FStrictFileCase : Boolean; Protected function FindIncludeFileName(const aFilename: string): String; virtual; abstract; procedure SetBaseDirectory(AValue: string); virtual; + procedure SetModuleDirectory(AValue: string); virtual; procedure SetStrictFileCase(AValue: Boolean); virtual; Property IncludePaths: TStringList Read FIncludePaths; Property ResourcePaths: TStringList Read FResourcePaths; @@ -507,8 +519,10 @@ type function FindResourceFileName(const AName: string): String; virtual; abstract; function FindSourceFile(const AName: string): TLineReader; virtual; abstract; function FindIncludeFile(const AName: string): TLineReader; virtual; abstract; - Property StrictFileCase : Boolean Read FStrictFileCase Write SetStrictFileCase; - property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; + property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; // e.g. current path of include file + property Mode: TModeSwitch read FMode write FMode; + property ModuleDirectory: string read FModuleDirectory write SetModuleDirectory; // e.g. path of module file + property StrictFileCase : Boolean Read FStrictFileCase Write SetStrictFileCase; end; TBaseFileResolverClass = Class of TBaseFileResolver; @@ -564,6 +578,11 @@ const '0', // false '1' // true Note: True is <>'0' ); + MACDirectiveBool: array[boolean] of string = ( + 'FALSE', // false + 'TRUE' // true Note: True is <>'0' + ); + type TMaxPrecInt = {$ifdef fpc}int64{$else}NativeInt{$endif}; TMaxFloat = {$ifdef fpc}extended{$else}double{$endif}; @@ -623,11 +642,13 @@ type procedure Push(const AnOperand: String; OperandPosition: integer); public Expression: String; + MsgCurLine : Integer; MsgPos: integer; MsgNumber: integer; MsgType: TMessageType; MsgPattern: String; // Format parameter - constructor Create; + isMac : Boolean; + constructor Create(aIsMac : Boolean = False); destructor Destroy; override; function Eval(const Expr: string): boolean; property OnEvalVariable: TCEEvalVarEvent read FOnEvalVariable write FOnEvalVariable; @@ -656,7 +677,8 @@ type po_ExtConstWithoutExpr, // allow typed const without expression in external class and with external modifier po_StopOnUnitInterface, // parse only a unit name and stop at interface keyword po_IgnoreUnknownResource,// Ignore resources for which no handler is registered. - po_AsyncProcs // allow async procedure modifier + po_AsyncProcs, // allow async procedure modifier + po_DisableResources // Disable resources altogether ); TPOptions = set of TPOption; @@ -702,6 +724,7 @@ type FAllowedModeSwitches: TModeSwitches; FAllowedValueSwitches: TValueSwitches; FConditionEval: TCondDirectiveEvaluator; + FCurModulename: string; FCurrentBoolSwitches: TBoolSwitches; FCurrentModeSwitches: TModeSwitches; FCurrentValueSwitches: TValueSwitchArray; @@ -723,6 +746,8 @@ type FModuleRow: Integer; FMacros: TStrings; // Objects are TMacroDef FDefines: TStrings; + FMultilineLineFeedStyle: TEOLStyle; + FMultilineLineTrimLeft: Integer; FNonTokens: TTokens; FOnComment: TPScannerCommentEvent; FOnDirective: TPScannerDirectiveEvent; @@ -787,17 +812,21 @@ type procedure Error(MsgNumber: integer; const Msg: string);overload; procedure Error(MsgNumber: integer; const Fmt: string; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif});overload; procedure PushSkipMode; + function GetMultiLineStringLineEnd(aReader: TLineReader): string; + function HandleDirective(const ADirectiveText: String): TToken; virtual; function HandleLetterDirective(Letter: char; Enable: boolean): TToken; virtual; procedure HandleBoolDirective(bs: TBoolSwitch; const Param: String); virtual; procedure DoHandleComment(Sender: TObject; const aComment : string); virtual; procedure DoHandleDirective(Sender: TObject; Directive, Param: String; var Handled: boolean); virtual; + procedure HandleMultilineStringTrimLeft(const AParam : String); + procedure HandleMultilineStringLineEnding(const AParam : string); procedure HandleIFDEF(const AParam: String); procedure HandleIFNDEF(const AParam: String); procedure HandleIFOPT(const AParam: String); - procedure HandleIF(const AParam: String); - procedure HandleELSEIF(const AParam: String); + procedure HandleIF(const AParam: String; aIsMac : Boolean); + procedure HandleELSEIF(const AParam: String; aIsMac : Boolean); procedure HandleELSE(const AParam: String); procedure HandleENDIF(const AParam: String); procedure HandleDefine(Param: String); virtual; @@ -805,6 +834,7 @@ type procedure HandleError(Param: String); virtual; procedure HandleMessageDirective(Param: String); virtual; procedure HandleIncludeFile(Param: String); virtual; + procedure HandleIncludeString(Param: String); virtual; procedure HandleResource(Param : string); virtual; procedure HandleOptimizations(Param : string); virtual; procedure DoHandleOptimization(OptName, OptValue: string); virtual; @@ -819,7 +849,9 @@ type procedure HandleWarn(Param: String); virtual; procedure HandleWarnIdentifier(Identifier, Value: String); virtual; procedure PushStackItem; virtual; + procedure PopStackItem; virtual; function DoFetchTextToken: TToken; + function DoFetchMultilineTextToken: TToken; function DoFetchToken: TToken; procedure ClearFiles; Procedure ClearMacros; @@ -863,6 +895,7 @@ type property Files: TStrings read FFiles; property CurSourceFile: TLineReader read FCurSourceFile; property CurFilename: string read FCurFilename; + property CurModuleName: string read FCurModulename Write FCurModuleName; property CurLine: string read FCurLine; property CurRow: Integer read FCurRow; property CurColumn: Integer read GetCurColumn; @@ -892,7 +925,8 @@ type property SkipGlobalSwitches: Boolean read FSkipGlobalSwitches write FSkipGlobalSwitches; property MaxIncludeStackDepth: integer read FMaxIncludeStackDepth write FMaxIncludeStackDepth default DefaultMaxIncludeStackDepth; property ForceCaret : Boolean read GetForceCaret; - + Property MultilineLineFeedStyle : TEOLStyle Read FMultilineLineFeedStyle Write FMultilineLineFeedStyle; + Property MultilineLineTrimLeft : Integer Read FMultilineLineTrimLeft Write FMultilineLineTrimLeft; property LogEvents : TPScannerLogEvents read FLogEvents write FLogEvents; property OnLog : TPScannerLogHandler read FOnLog write FOnLog; property OnFormatPath: TPScannerFormatPathEvent read FOnFormatPath write FOnFormatPath; @@ -951,6 +985,7 @@ const '*=', '/=', '@@', + '...', // Reserved words 'absolute', 'and', @@ -1084,7 +1119,8 @@ const 'PREFIXEDATTRIBUTES', 'OMITRTTI', 'MULTIHELPERS', - 'IMPLICITFUNCTIONSPECIALIZATION' + 'IMPLICITFUNCTIONSPECIALIZATION', + 'MULTILINESTRINGS' ); LetterSwitchNames: array['A'..'Z'] of string=( @@ -1452,12 +1488,16 @@ end; function TCondDirectiveEvaluator.IsFalse(const Value: String): boolean; begin Result:=Value=CondDirectiveBool[false]; + if (not Result) and isMac then + Result:=Value=MacDirectiveBool[false]; end; // inline function TCondDirectiveEvaluator.IsTrue(const Value: String): boolean; begin Result:=Value<>CondDirectiveBool[false]; + if Result and isMac then + Result:=Value<>MacDirectiveBool[False]; end; function TCondDirectiveEvaluator.IsInteger(const Value: String; out i: TMaxPrecInt @@ -1634,6 +1674,7 @@ begin '$': begin FToken:=tkNumber; + inc(FTokenEnd); {$ifdef UsePChar} while FTokenEnd^ in HexDigits do inc(FTokenEnd); {$else} @@ -1776,7 +1817,7 @@ begin OnLog(Self,Args); if not (aMsgType in [mtError,mtFatal]) then exit; end; - raise EScannerError.CreateFmt(MsgPattern+' at '+IntToStr(MsgPos),Args); + raise EScannerError.CreateFmt(MsgPattern+' at pos '+IntToStr(MsgPos)+' line '+IntToStr(MsgCurLine),Args); end; procedure TCondDirectiveEvaluator.LogXExpectedButTokenFound(const X: String; @@ -1800,6 +1841,12 @@ procedure TCondDirectiveEvaluator.ReadOperand(Skip: boolean); 'Abc' (expression) } + + Function IsMacNoArgFunction(aName : string) : Boolean; + begin + Result:=SameText(aName,'DEFINED') or SameText(aName,'UNDEFINED'); + end; + var i: TMaxPrecInt; e: extended; @@ -1807,6 +1854,7 @@ var Code: integer; NameStartP: {$ifdef UsePChar}PChar{$else}integer{$endif}; p, Lvl: integer; + begin {$IFDEF VerbosePasDirectiveEval} writeln('TCondDirectiveEvaluator.ReadOperand START Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken,BoolToStr(Skip,' SKIP','')); @@ -1876,7 +1924,9 @@ begin tkIdentifier: if Skip then begin + aName:=GetTokenString; NextToken; + // for macpas IFC we can have DEFINED A or DEFINED(A)... if FToken=tkBraceOpen then begin // only one parameter is supported @@ -1886,6 +1936,10 @@ begin if FToken<>tkBraceClose then LogXExpectedButTokenFound(')'); NextToken; + end + else if (IsMac and IsMacNoArgFunction(aName)) then + begin + NextToken; end; end else @@ -1916,6 +1970,14 @@ begin Push(S,p); NextToken; end + else if (IsMac and IsMacNoArgFunction(aName)) then + begin + if FToken<>tkIdentifier then + LogXExpectedButTokenFound('identifier'); + aName:=GetTokenString; + Push(CondDirectiveBool[OnEvalVariable(Self,aName,S)],p); + NextToken; + end else begin // variable @@ -2279,9 +2341,9 @@ begin {$ENDIF} end; -constructor TCondDirectiveEvaluator.Create; +constructor TCondDirectiveEvaluator.Create(aIsMac: Boolean); begin - + IsMac:=aIsMac end; destructor TCondDirectiveEvaluator.Destroy; @@ -2305,6 +2367,9 @@ begin NextToken; ReadExpression; Result:=IsTrue(FStack[0].Operand); + {$IFDEF VerbosePasDirectiveEval} + Writeln('COND Eval: ', Expr,' -> ',Result); + {$ENDIF} end; { TMacroDef } @@ -2320,6 +2385,17 @@ end; constructor TLineReader.Create(const AFilename: string); begin FFileName:=AFileName; + if LineEnding=#13 then + {%H-}EOLStyle:=elCR + else if LineEnding=#13#10 then + {%H-}EOLStyle:=elCRLF + else + EOLStyle:=elLF +end; + +function TLineReader.LastEOLStyle: TEOLStyle; +begin + Result:=EOLStyle; end; { --------------------------------------------------------------------- @@ -2408,11 +2484,20 @@ begin EOL:=(FContent[FPos] in [#10,#13]); until isEOF or EOL; If EOL then + begin + if FContent[FPOS]=#10 then + EOLSTYLE:=elLF + else + EOLStyle:=elCR; Result:=Copy(FContent,LPos,FPos-LPos) + end else Result:=Copy(FContent,LPos,FPos-LPos+1); If (not isEOF) and (FContent[FPos]=#13) and (FContent[FPos+1]=#10) then + begin inc(FPos); + EOLStyle:=elCRLF; + end; end; { TFileStreamLineReader } @@ -2450,22 +2535,30 @@ end; procedure TBaseFileResolver.SetBaseDirectory(AValue: string); begin + AValue:=IncludeTrailingPathDelimiter(AValue); if FBaseDirectory=AValue then Exit; FBaseDirectory:=AValue; end; +procedure TBaseFileResolver.SetModuleDirectory(AValue: string); +begin + AValue:=IncludeTrailingPathDelimiter(AValue); + if FModuleDirectory=AValue then Exit; + FModuleDirectory:=AValue; +end; + procedure TBaseFileResolver.SetStrictFileCase(AValue: Boolean); begin if FStrictFileCase=AValue then Exit; FStrictFileCase:=AValue; end; - constructor TBaseFileResolver.Create; begin inherited Create; FIncludePaths := TStringList.Create; FResourcePaths := TStringList.Create; + FMode:=msFPC; end; destructor TBaseFileResolver.Destroy; @@ -2552,15 +2645,27 @@ function TFileResolver.FindIncludeFileName(const AName: string): String; begin Result:=''; + // search in BaseDirectory (not in mode Delphi) + if (BaseDirectory<>'') + and ((ModuleDirectory='') or not (Mode in [msDelphi,msDelphiUnicode])) then + begin + Result:=SearchLowUpCase(BaseDirectory+FN); + if Result<>'' then exit; + end; + // search in ModuleDirectory + if (ModuleDirectory<>'') then + begin + Result:=SearchLowUpCase(ModuleDirectory+FN); + if Result<>'' then exit; + end; + // search in include paths I:=0; - While (Result='') and (I<FIncludePaths.Count) do + While (I<FIncludePaths.Count) do begin Result:=SearchLowUpCase(FIncludePaths[i]+FN); + if Result<>'' then exit; Inc(I); end; - // search in BaseDirectory - if (Result='') and (BaseDirectory<>'') then - Result:=SearchLowUpCase(BaseDirectory+FN); end; var @@ -2754,6 +2859,8 @@ begin Inc(J); end; end; + if (I=-1) and (BaseDirectory<>'') then + I:=FStreams.IndexOf(IncludeTrailingPathDelimiter(BaseDirectory)+aName); If (I<>-1) then Result:=FStreams.Objects[i] as TStream; end; @@ -2911,13 +3018,21 @@ begin end; procedure TPascalScanner.OpenFile(AFilename: string); + +Var + aPath : String; + begin Clearfiles; FCurSourceFile := FileResolver.FindSourceFile(AFilename); FCurFilename := AFilename; AddFile(FCurFilename); {$IFDEF HASFS} - FileResolver.BaseDirectory := IncludeTrailingPathDelimiter(ExtractFilePath(FCurFilename)); + aPath:=ExtractFilePath(FCurFilename); + if (aPath<>'') then + aPath:=IncludeTrailingPathDelimiter(aPath); + FileResolver.ModuleDirectory := aPath; + FileResolver.BaseDirectory := aPath; {$ENDIF} if LogEvent(sleFile) then DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[FormatPath(AFileName)],True); @@ -2967,11 +3082,32 @@ begin Result:=tkoperator; end; -function TPascalScanner.FetchToken: TToken; +procedure TPascalScanner.PopStackItem; + var IncludeStackItem: TIncludeStackItem; begin - FPreviousToken:=FCurToken; + IncludeStackItem := + TIncludeStackItem(FIncludeStack[FIncludeStack.Count - 1]); + FIncludeStack.Delete(FIncludeStack.Count - 1); + CurSourceFile.{$ifdef pas2js}Destroy{$else}Free{$endif}; + FCurSourceFile := IncludeStackItem.SourceFile; + FCurFilename := IncludeStackItem.Filename; + FileResolver.BaseDirectory:=ExtractFilePath(FCurFilename); + FCurToken := IncludeStackItem.Token; + FCurTokenString := IncludeStackItem.TokenString; + FCurLine := IncludeStackItem.Line; + FCurRow := IncludeStackItem.Row; + FCurColumnOffset := IncludeStackItem.ColumnOffset; + FTokenPos := IncludeStackItem.TokenPos; + IncludeStackItem.Free; +end; + +function TPascalScanner.FetchToken: TToken; + +begin + if Not (FCurToken in [tkWhiteSpace,tkLineEnding]) then + FPreviousToken:=FCurToken; while true do begin Result := DoFetchToken; @@ -2980,19 +3116,7 @@ begin begin if FIncludeStack.Count > 0 then begin - IncludeStackItem := - TIncludeStackItem(FIncludeStack[FIncludeStack.Count - 1]); - FIncludeStack.Delete(FIncludeStack.Count - 1); - CurSourceFile.{$ifdef pas2js}Destroy{$else}Free{$endif}; - FCurSourceFile := IncludeStackItem.SourceFile; - FCurFilename := IncludeStackItem.Filename; - FCurToken := IncludeStackItem.Token; - FCurTokenString := IncludeStackItem.TokenString; - FCurLine := IncludeStackItem.Line; - FCurRow := IncludeStackItem.Row; - FCurColumnOffset := IncludeStackItem.ColumnOffset; - FTokenPos := IncludeStackItem.TokenPos; - IncludeStackItem.Free; + PopStackitem; Result := FCurToken; end else @@ -3214,6 +3338,167 @@ begin [FormatPath(CurFilename),CurRow,CurColumn,FLastMsg]); end; +function TPascalScanner.GetMultiLineStringLineEnd(aReader : TLineReader) : string; + +Var + aLF : String; + aStyle: TEOLStyle; + + +begin + aStyle:=MultilineLineFeedStyle; + if aStyle=elSource then + aStyle:=aReader.LastEOLStyle; + case aStyle of + elCR : aLF:=#13; + elCRLF : aLF:=#13#10; + elLF : aLF:=#10; + elPlatform : alf:=sLineBreak; + else + aLF:=#10; + end; + Result:=aLF; +end; + +function TPascalScanner.DoFetchMultilineTextToken:TToken; + +var + StartPos,OldLength : Integer; + TokenStart : {$ifdef UsePChar}PChar{$else}integer{$endif}; + {$ifndef UsePChar} + s: String; + l: integer; + {$endif} + + + Procedure AddToCurString(addLF : Boolean); + var + SectionLength,i : Integer; + aLF : String; + + begin + i:=MultilineLineTrimLeft; + if I=-1 then + I:=StartPos+1; + if I>0 then + begin + While ({$ifdef UsePChar} TokenStart^{$ELSE}FCurLine[TokenStart]{$ENDIF} in [' ',#9]) and (TokenStart<=FTokenPos) and (I>0) do + begin + Inc(TokenStart); + Dec(I); + end; + end + else if I=-2 then + begin + While ({$ifdef UsePChar} TokenStart^{$ELSE}FCurLine[TokenStart]{$ENDIF} in [' ',#9]) and (TokenStart<=FTokenPos) do + Inc(TokenStart); + end; + + SectionLength := FTokenPos - TokenStart+Ord(AddLF); + {$ifdef UsePChar} + SetLength(FCurTokenString, OldLength + SectionLength); + if SectionLength > 0 then + Move(TokenStart^, FCurTokenString[OldLength + 1], SectionLength); + {$else} + FCurTokenString:=FCurTokenString+copy(FCurLine,TokenStart,SectionLength); + {$endif} + if AddLF then + begin + alf:=GetMultiLineStringLineEnd(FCurSourceFile); + FCurTokenString:=FCurTokenString+aLF; + Inc(OldLength,Length(aLF)); + end; + Inc(OldLength, SectionLength); + end; + +begin + Result:=tkEOF; + OldLength:=0; + FCurTokenString := ''; + {$ifndef UsePChar} + s:=FCurLine; + l:=length(s); + StartPos:=FTokenPos; + {$ELSE} + StartPos:=FTokenPos-PChar(FCurLine); + {$endif} + + repeat + {$ifndef UsePChar} + if FTokenPos>l then break; + {$endif} + case {$ifdef UsePChar}FTokenPos[0]{$else}s[FTokenPos]{$endif} of + '^' : + begin + TokenStart := FTokenPos; + Inc(FTokenPos); + if {$ifdef UsePChar}FTokenPos[0] in Letters{$else}(FTokenPos<l) and (s[FTokenPos] in Letters){$endif} then + Inc(FTokenPos); + if Result=tkEOF then Result := tkChar else Result:=tkString; + end; + '#': + begin + TokenStart := FTokenPos; + Inc(FTokenPos); + if {$ifdef UsePChar}FTokenPos[0]='$'{$else}(FTokenPos<l) and (s[FTokenPos]='$'){$endif} then + begin + Inc(FTokenPos); + repeat + Inc(FTokenPos); + until {$ifdef UsePChar}not (FTokenPos[0] in HexDigits){$else}(FTokenPos>l) or not (s[FTokenPos] in HexDigits){$endif}; + end else + repeat + Inc(FTokenPos); + until {$ifdef UsePChar}not (FTokenPos[0] in Digits){$else}(FTokenPos>l) or not (s[FTokenPos] in Digits){$endif}; + if Result=tkEOF then Result := tkChar else Result:=tkString; + end; + '`': + begin + TokenStart := FTokenPos; + Inc(FTokenPos); + + while true do + begin + if {$ifdef UsePChar}FTokenPos[0] = '`'{$else}(FTokenPos<=l) and (s[FTokenPos]=''''){$endif} then + if {$ifdef UsePChar}FTokenPos[1] = '`'{$else}(FTokenPos<l) and (s[FTokenPos+1]=''''){$endif} then + Inc(FTokenPos) + else + break; + + if {$ifdef UsePChar}FTokenPos[0] = #0{$else}FTokenPos>l{$endif} then + begin + FTokenPos:=FTokenPos-1; + AddToCurString(true); + // Writeln('Curtokenstring : >>',FCurTOkenString,'<<'); + if not Self.FetchLine then + Error(nErrOpenString,SErrOpenString); + // Writeln('Current line is now : ',FCurLine); + {$ifndef UsePChar} + s:=FCurLine; + l:=length(s); + {$ELSE} + FTokenPos:=PChar(FCurLine); + {$endif} + TokenStart:=FTokenPos; + end + else + Inc(FTokenPos); + end; + Inc(FTokenPos); + Result := tkString; + end; + else + Break; + end; + AddToCurString(false); + until false; + if length(FCurTokenString)>1 then + begin + FCurTokenString[1]:=''''; + FCurTokenString[Length(FCurTokenString)]:=''''; + end; +end; + function TPascalScanner.DoFetchTextToken:TToken; var OldLength : Integer; @@ -3327,6 +3612,8 @@ procedure TPascalScanner.HandleIncludeFile(Param: String); var NewSourceFile: TLineReader; + aFileName : string; + begin Param:=Trim(Param); if Length(Param)>1 then @@ -3342,16 +3629,57 @@ begin if not Assigned(NewSourceFile) then Error(nErrIncludeFileNotFound, SErrIncludeFileNotFound, [Param]); + PushStackItem; FCurSourceFile:=NewSourceFile; FCurFilename := Param; - if FCurSourceFile is TFileLineReader then - FCurFilename := TFileLineReader(FCurSourceFile).Filename; // nicer error messages + if FCurSourceFile is TLineReader then + begin + aFileName:=TLineReader(FCurSourceFile).Filename; + FileResolver.BaseDirectory := ExtractFilePath(aFileName); + FCurFilename := aFileName; // nicer error messages + end; AddFile(FCurFilename); If LogEvent(sleFile) then DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[FormatPath(FCurFileName)],True); end; +procedure TPascalScanner.HandleIncludeString(Param: String); + +var + NewSourceFile: TLineReader; + aString,aLine: string; + +begin + Param:=Trim(Param); + if Length(Param)>1 then + begin + if (Param[1]='''') then + begin + if Param[length(Param)]<>'''' then + Error(nErrOpenString,SErrOpenString,[]); + Param:=copy(Param,2,length(Param)-2); + end; + end; + NewSourceFile := FileResolver.FindIncludeFile(Param); + if not Assigned(NewSourceFile) then + Error(nErrIncludeFileNotFound, SErrIncludeFileNotFound, [Param]); + try + AString:=''; + While not NewSourceFile.IsEOF Do + begin + ALine:=NewSourceFile.ReadLine; + if aString<>'' then + aString:=aString+GetMultiLineStringLineEnd(NewSourceFile); + AString:=aString+aLine; + end; + finally + NewSourceFile.Free; + end; + FCurTokenString:=''''+AString+''''; + FCurToken:=tkString; +end; + procedure TPascalScanner.HandleResource(Param: string); Var @@ -3424,6 +3752,12 @@ begin if p=StartP then Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,['optimization']); OptName:=copy(Param,StartP,p-StartP); + if lowercase(LeftStr(OptName,2))='no' then + begin + Delete(OptName,1,2); + DoHandleOptimization(OptName,'-'); + exit; + end; // skip whitespace while (p<=l) and (Param[p] in [' ',#9,#10,#13]) do inc(p); @@ -3570,7 +3904,7 @@ begin MValue:=Trim(Param); MName:=Trim(Copy(MValue,1,Index-1)); Delete(MValue,1,Index+1); - AddMacro(MName,MValue); + AddMacro(MName,Trim(MValue)); end; end; @@ -3681,6 +4015,7 @@ procedure TPascalScanner.HandleMode(const Param: String); SetNonToken(tkotherwise); end; Handled:=false; + FileResolver.Mode:=LangMode; if Assigned(OnModeChanged) then OnModeChanged(Self,LangMode,false,Handled); end; @@ -3735,8 +4070,8 @@ begin SetMode(msMac,MacModeSwitches,false,bsMacPasMode); 'ISO': SetMode(msIso,ISOModeSwitches,false,[],[],false); - 'EXTENDED': - SetMode(msExtpas,ExtPasModeSwitches,false,[],[],false); + 'EXTENDEDPASCAL': + SetMode(msExtpas,ExtPasModeSwitches,false); 'GPC': SetMode(msGPC,GPCModeSwitches,false); else @@ -3902,7 +4237,7 @@ begin end; end; -procedure TPascalScanner.HandleIF(const AParam: String); +procedure TPascalScanner.HandleIF(const AParam: String; aIsMac: Boolean); begin PushSkipMode; @@ -3910,6 +4245,8 @@ begin PPSkipMode := ppSkipAll else begin + ConditionEval.MsgCurLine:=CurTokenPos.Row; + ConditionEval.isMac:=aIsMac; if ConditionEval.Eval(AParam) then PPSkipMode := ppSkipElseBranch else @@ -3925,12 +4262,13 @@ begin end; end; -procedure TPascalScanner.HandleELSEIF(const AParam: String); +procedure TPascalScanner.HandleELSEIF(const AParam: String; aIsMac : Boolean); begin if PPSkipStackIndex = 0 then Error(nErrInvalidPPElse,sErrInvalidPPElse); if PPSkipMode = ppSkipIfBranch then begin + ConditionEval.isMac:=aIsMac; if ConditionEval.Eval(AParam) then begin PPSkipMode := ppSkipElseBranch; @@ -3996,7 +4334,11 @@ begin Result:=tkComment; P:=Pos(' ',ADirectiveText); If P=0 then - P:=Length(ADirectiveText)+1; + begin + P:=Pos(#9,ADirectiveText); + If P=0 then + P:=Length(ADirectiveText)+1; + end; Directive:=Copy(ADirectiveText,2,P-2); // 1 is $ Param:=ADirectiveText; Delete(Param,1,P); @@ -4011,12 +4353,16 @@ begin HandleIFNDEF(Param); 'IFOPT': HandleIFOPT(Param); + 'IFC', 'IF': - HandleIF(Param); + HandleIF(Param,UpperCase(Directive)='IFC'); + 'ELIFC', 'ELSEIF': - HandleELSEIF(Param); + HandleELSEIF(Param,UpperCase(Directive)='ELIFC'); + 'ELSEC', 'ELSE': HandleELSE(Param); + 'ENDC', 'ENDIF': HandleENDIF(Param); 'IFEND': @@ -4040,7 +4386,9 @@ begin Case UpperCase(Directive) of 'ASSERTIONS': DoBoolDirective(bsAssertions); - 'DEFINE': + 'DEFINE', + 'DEFINEC', + 'SETC': HandleDefine(Param); 'GOTO': DoBoolDirective(bsGoto); @@ -4056,6 +4404,11 @@ begin DoBoolDirective(bsHints); 'I','INCLUDE': Result:=HandleInclude(Param); + 'INCLUDESTRING','INCLUDESTRINGFILE': + begin + HandleIncludeString(Param); + Result:=tkString; + end; 'INTERFACES': HandleInterfaces(Param); 'LONGSTRINGS': @@ -4068,6 +4421,10 @@ begin HandleMode(Param); 'MODESWITCH': HandleModeSwitch(Param); + 'MULTILINESTRINGLINEENDING': + HandleMultilineStringLineEnding(Param); + 'MULTILINESTRINGTRIMLEFT': + HandleMultilineStringTrimLeft(Param); 'NOTE': DoLog(mtNote,nUserDefined,SUserDefined,[Param]); 'NOTES': @@ -4081,7 +4438,8 @@ begin 'POINTERMATH': DoBoolDirective(bsPointerMath); 'R' : - HandleResource(Param); + if not (po_DisableResources in Options) then + HandleResource(Param); 'RANGECHECKS': DoBoolDirective(bsRangeChecks); 'SCOPEDENUMS': @@ -4100,6 +4458,11 @@ begin DoBoolDirective(bsWarnings); 'WRITEABLECONST': DoBoolDirective(bsWriteableConst); + 'ALIGN', + 'CALLING', + 'INLINE', + 'PACKRECORDS', + 'PACKENUM' : ; else Handled:=false; end; @@ -4187,6 +4550,44 @@ begin OnDirective(Sender,Directive,Param,Handled); end; +procedure TPascalScanner.HandleMultilineStringTrimLeft(const AParam: String); + +Var + S : String; + i : integer; + +begin + S:=UpperCase(Trim(aParam)); + Case UpperCase(S) of + 'ALL' : I:=-2; + 'AUTO' : I:=-1; + 'NONE' : I:=0; + else + If not TryStrToInt(S,I) then + I:=0; + end; + MultilineLineTrimLeft:=I; + +end; + +procedure TPascalScanner.HandleMultilineStringLineEnding(const AParam: string); + +Var + S : TEOLStyle; + +begin + Case UpperCase(Trim(aParam)) of + 'CR' : s:=elCR; + 'LF' : s:=elLF; + 'CRLF' : s:=elCRLF; + 'SOURCE' : s:=elSource; + 'PLATFORM' : s:=elPlatform; + else + Error(nErrInvalidMultiLineLineEnding,sErrInvalidMultiLineLineEnding); + end; + MultilineLineFeedStyle:=S; +end; + function TPascalScanner.DoFetchToken: TToken; var @@ -4284,6 +4685,13 @@ begin end; '#', '''': Result:=DoFetchTextToken; + '`' : + begin + If not (msMultiLineStrings in CurrentModeSwitches) then + Error(nErrInvalidCharacter, SErrInvalidCharacter, + [{$ifdef UsePChar}FTokenPos[0]{$else}s[FTokenPos]{$endif}]); + Result:=DoFetchMultilineTextToken; + end; '&': begin TokenStart := FTokenPos; @@ -4471,7 +4879,13 @@ begin else if {$ifdef UsePChar}FTokenPos[0]='.'{$else}(FTokenPos<=l) and (s[FTokenPos]='.'){$endif} then begin Inc(FTokenPos); - Result := tkDotDot; + if {$ifdef UsePChar}FTokenPos[0]='.'{$else}(FTokenPos<=l) and (s[FTokenPos]='.'){$endif} then + begin + Inc(FTokenPos); + Result:=tkDotDotDot; + end + else + Result := tkDotDot; end else Result := tkDot; @@ -4638,8 +5052,7 @@ begin begin if ForceCaret or PPisSkipping or (PreviousToken in [tkeof,tkTab,tkLineEnding,tkComment,tkIdentifier, - tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCaret, - tkWhitespace]) then + tkNil,tkOperator,tkBraceClose,tkSquaredBraceClose,tkCaret]) then begin Inc(FTokenPos); Result := tkCaret; @@ -4869,6 +5282,10 @@ end; procedure TPascalScanner.OnCondEvalLog(Sender: TCondDirectiveEvaluator; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif}); + +Var + Msg : String; + begin {$IFDEF VerbosePasDirectiveEval} writeln('TPascalScanner.OnCondEvalLog "',Sender.MsgPattern,'"'); @@ -4877,7 +5294,8 @@ begin if Sender.MsgType<=mtError then begin SetCurMsg(Sender.MsgType,Sender.MsgNumber,Sender.MsgPattern,Args); - raise EScannerError.Create(FLastMsg); + Msg:=Format('%s(%d,%d) : %s',[FormatPath(FCurFileName),CurRow,CurColumn,FLastMsg]); + raise EScannerError.Create(Msg); end else DoLog(Sender.MsgType,Sender.MsgNumber,Sender.MsgPattern,Args,true); diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcbaseparser.pas b/avx512-0037785/packages/fcl-passrc/tests/tcbaseparser.pas index 318fcaa216..6e2d027307 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcbaseparser.pas +++ b/avx512-0037785/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/avx512-0037785/packages/fcl-passrc/tests/tcclasstype.pas b/avx512-0037785/packages/fcl-passrc/tests/tcclasstype.pas index 30b54b8175..ea045d625e 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcclasstype.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcclasstype.pas @@ -33,7 +33,7 @@ type Procedure StartClass (AncestorName : String = 'TObject'; InterfaceList : String = ''; aClassType : TClassDeclType = cdtClass); Procedure StartExternalClass (AParent : String; AExternalName,AExternalNameSpace : String ); Procedure StartClassHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject'); - Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False); + Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False; UseObjcClass : Boolean = False; UseExternal : Boolean = False); Procedure StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject'); Procedure StartVisibility(A : TPasMemberVisibility); Procedure EndClass(AEnd : String = 'end'); @@ -105,6 +105,7 @@ type Procedure TestMethodWithDotFails; Procedure TestMethodWithDotOK; Procedure TestMethodFunctionWithDotOK; + Procedure TestNoSemicolon; Procedure TestClassMethodSimple; Procedure TestClassMethodSimpleComment; Procedure TestConstructor; @@ -170,6 +171,10 @@ type procedure TestClassHelperOneMethod; procedure TestInterfaceEmpty; procedure TestObjcProtocolEmpty; + procedure TestObjcProtocolEmptyExternal; + procedure TestObjcProtocolMultiParent; + procedure TestObjcProtocolOptional; + procedure TestObjcProtocolRequired; procedure TestInterfaceDisp; procedure TestInterfaceParentedEmpty; procedure TestInterfaceOneMethod; @@ -320,7 +325,7 @@ begin end; procedure TTestClassType.StartInterface(AParent: String; UUID: String; - Disp: Boolean = False; UseObjcClass : Boolean = False); + Disp: Boolean = False; UseObjcClass : Boolean = False; UseExternal : Boolean = False); Var S : String; begin @@ -328,7 +333,9 @@ begin if UseObjCClass then begin FDecl.Add('{$modeswitch objectivec1}'); - S:='TMyClass = objcprotocol' + S:='TMyClass = objcprotocol'; + if UseExternal then + S:=S+' external name ''abc'' '; end else if Disp then S:='TMyClass = DispInterface' @@ -971,6 +978,13 @@ begin AssertNotNull('1 method resolution procedure',TPasMethodResolution(members[0]).ImplementationProc); end; +procedure TTestClassType.TestNoSemicolon; +begin + StartClass; + fDecl.Add('Y : String'); + ParseClass; +end; + procedure TTestClassType.TestClassMethodSimple; begin @@ -1929,6 +1943,59 @@ begin AssertNull('No UUID',TheClass.GUIDExpr); end; +procedure TTestClassType.TestObjcProtocolEmptyExternal; +begin + StartInterface('','',False,True,true); + EndClass(); + ParseClass; + AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind); + AssertTrue('Is objectivec',TheClass.IsObjCClass); + AssertEquals('No members',0,TheClass.Members.Count); + AssertNull('No UUID',TheClass.GUIDExpr); +end; + +procedure TTestClassType.TestObjcProtocolMultiParent; +begin + StartInterface('A, B','',False,True,true); + FParent:='A'; + EndClass(); + ParseClass; + AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind); + AssertTrue('Is objectivec',TheClass.IsObjCClass); + AssertEquals('No members',0,TheClass.Members.Count); + AssertNull('No UUID',TheClass.GUIDExpr); + AssertEquals('Have 1 interface',1,TheClass.Interfaces.Count); + AssertNotNull('Correct class',TheClass.Interfaces[0]); + AssertEquals('Correct class',TPasUnresolvedTypeRef,TObject(TheClass.Interfaces[0]).ClassType); + AssertEquals('Interface name','B',TPasUnresolvedTypeRef(TheClass.Interfaces[0]).Name); +end; + +procedure TTestClassType.TestObjcProtocolOptional; +begin + StartInterface('','',False,True); + FDecl.Add(' optional'); + AddMember('Procedure DoSomething(A : Integer)'); + EndClass(); + ParseClass; + AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind); + AssertTrue('Is objectivec',TheClass.IsObjCClass); + AssertEquals('No members',1,TheClass.Members.Count); + AssertNull('No UUID',TheClass.GUIDExpr); +end; + +procedure TTestClassType.TestObjcProtocolRequired; +begin + StartInterface('','',False,True); + FDecl.Add(' required'); + AddMember('Procedure DoSomething(A : Integer)'); + EndClass(); + ParseClass; + AssertEquals('Is interface',okObjcProtocol,TheClass.ObjKind); + AssertTrue('Is objectivec',TheClass.IsObjCClass); + AssertEquals('No members',1,TheClass.Members.Count); + AssertNull('No UUID',TheClass.GUIDExpr); +end; + procedure TTestClassType.TestInterfaceDisp; begin diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcgenerics.pp b/avx512-0037785/packages/fcl-passrc/tests/tcgenerics.pp index 02414f37fb..95c3436807 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcgenerics.pp +++ b/avx512-0037785/packages/fcl-passrc/tests/tcgenerics.pp @@ -21,6 +21,7 @@ Type Procedure TestProcTypeGenerics; Procedure TestDeclarationDelphi; Procedure TestDeclarationFPC; + Procedure TestDeclarationFPCNoSpaces; Procedure TestMethodImplementation; // generic constraints @@ -108,6 +109,9 @@ begin Source.Add(' TSomeClass<T,T2> = Class(TObject)'); Source.Add(' b : T;'); Source.Add(' b2 : T2;'); + Source.Add(' FItems: ^TArray<T>;'); + Source.Add(' type'); + Source.Add(' TDictionaryEnumerator = TDictionary<T, TEmptyRecord>.TKeyEnumerator;'); Source.Add(' end;'); ParseDeclarations; AssertNotNull('have generic definition',Declarations.Classes); @@ -141,6 +145,27 @@ begin AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); end; +procedure TTestGenerics.TestDeclarationFPCNoSpaces; +Var + T : TPasClassType; +begin + Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches; + Source.Add('Type'); + Source.Add(' TSomeClass<T;T2>=Class(TObject)'); + Source.Add(' b : T;'); + Source.Add(' b2 : T2;'); + Source.Add(' end;'); + ParseDeclarations; + AssertNotNull('have generic definition',Declarations.Classes); + AssertEquals('have generic definition',1,Declarations.Classes.Count); + AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType); + T:=TPasClassType(Declarations.Classes[0]); + AssertNotNull('have generic templates',T.GenericTemplateTypes); + AssertEquals('2 template types',2,T.GenericTemplateTypes.Count); + AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent); + AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent); +end; + procedure TTestGenerics.TestMethodImplementation; begin With source do diff --git a/avx512-0037785/packages/fcl-passrc/tests/tconstparser.pas b/avx512-0037785/packages/fcl-passrc/tests/tconstparser.pas index efe5d21d35..8162cb6a3c 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tconstparser.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tconstparser.pas @@ -43,6 +43,7 @@ Type Procedure TestSimpleIdentifierConst; Procedure TestSimpleSetConst; Procedure TestSimpleExprConst; + Procedure TestSimpleAbsoluteConst; Procedure TestSimpleIntConstDeprecatedMsg; Procedure TestSimpleIntConstDeprecated; Procedure TestSimpleFloatConstDeprecated; @@ -255,6 +256,19 @@ begin DoTestSimpleExprConst; end; +procedure TTestConstParser.TestSimpleAbsoluteConst; + +// Found in xi.pp + +begin + Add('Const'); + Add(' Absolute = 1;'); + ParseDeclarations; + AssertEquals('One constant definition',1,Declarations.Consts.Count); + AssertEquals('First declaration is constant definition.',TPasConst,TObject(Declarations.Consts[0]).ClassType); + +end; + procedure TTestConstParser.TestSimpleIntConstDeprecatedMsg; begin Hint:='deprecated ''this is old''' ; diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcpaswritestatements.pas b/avx512-0037785/packages/fcl-passrc/tests/tcpaswritestatements.pas new file mode 100644 index 0000000000..773206c476 --- /dev/null +++ b/avx512-0037785/packages/fcl-passrc/tests/tcpaswritestatements.pas @@ -0,0 +1,2595 @@ +{ + 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('TestPasSrcWriter', + [TTestStatementWriterEmpty, TTestStatementWriterBlock, TTestStatementWriterAssignment, + TTestStatementWriterCall, TTestStatementWriterIf, TTestStatementWriterCase, + TTestStatementWriterWith, TTestStatementWriterLoops, TTestStatementWriterRaise, + TTestStatementWriterTry, TTestStatementWriterAsm, TTestStatementWriterSpecials]); + +end. + diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcprocfunc.pas b/avx512-0037785/packages/fcl-passrc/tests/tcprocfunc.pas index 2687fd76b8..971f9daf13 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcprocfunc.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcprocfunc.pas @@ -102,6 +102,9 @@ type Procedure TestFunctionArrayOfConstArg; procedure TestProcedureConstArrayOfConstArg; Procedure TestFunctionConstArrayOfConstArg; + procedure TestProcedureOnePointerArg; + procedure TestFUnctionPointerResult; + Procedure TestProcedureCdecl; Procedure TestFunctionCdecl; Procedure TestProcedureCdeclDeprecated; @@ -122,6 +125,10 @@ type procedure TestCallingConventionSysV_ABI_CDec; procedure TestCallingConventionSysV_ABI_Default; procedure TestCallingConventionVectorCall; + procedure TestCallingConventionSysCall; + procedure TestCallingConventionSysCallExecbase; + procedure TestCallingConventionSysCallUtilitybase; + procedure TestCallingConventionSysCallConsoleDevice; Procedure TestProcedurePublic; Procedure TestProcedurePublicIdent; Procedure TestFunctionPublic; @@ -174,6 +181,7 @@ type Procedure TestProcedureCdeclExternalName; Procedure TestFunctionCdeclExternalName; Procedure TestFunctionAlias; + Procedure TestOperatorNamedResult; Procedure TestOperatorTokens; procedure TestOperatorNames; Procedure TestAssignOperatorAfterObject; @@ -238,6 +246,7 @@ end; function TTestProcedureFunction.ParseFunction(const ASource : String;AResult: string = ''; const AHint: String = ''; CC : TCallingConvention = ccDefault): TPasProcedure; Var D :String; + aType : TPasType; begin if (AResult='') then AResult:='Integer'; @@ -248,8 +257,16 @@ begin Self.ParseFunction; Result:=FFunc; AssertNotNull('Have function result element',FuncType.ResultEl); - AssertNotNull('Have function result type element',FuncType.ResultEl.ResultType); - AssertEquals('Correct function result type name',AResult,FuncType.ResultEl.ResultType.Name); + aType:=FuncType.ResultEl.ResultType; + AssertNotNull('Have function result type element',aType); + if aResult[1]='^' then + begin + Delete(aResult,1,1); + AssertEquals('Result is pointer type',TPasPointerType,aType.ClassType); + aType:=TPasPointerType(aType).DestType; + AssertNotNull('Result pointer type has destination type',aType); + end; + AssertEquals('Correct function result type name',AResult,aType.Name); end; procedure TTestProcedureFunction.ParseOperator; @@ -349,6 +366,7 @@ procedure TTestProcedureFunction.AssertArg(ProcType: TPasProcedureType; Var A : TPasArgument; + T : TPasType; N : String; begin @@ -356,11 +374,21 @@ begin N:='Argument '+IntToStr(AIndex+1)+' : '; if (TypeName='') then AssertNull(N+' No argument type',A.ArgType) - else + else if TypeName[1]<>'^' then begin AssertNotNull(N+' Have argument type',A.ArgType); AssertEquals(N+' Correct argument type name',TypeName,A.ArgType.Name); + end + else + begin + AssertNotNull(N+' Have argument type',A.ArgType); + T:=A.ArgType; + AssertEquals(N+' type Is pointer type',TPasPointerType,T.CLassType); + T:=TPasPointerType(T).DestType; + AssertNotNull(N+'Have dest type',T); + AssertEquals(N+' Correct argument dest type name',Copy(TypeName,2,MaxInt),T.Name); end; + end; procedure TTestProcedureFunction.AssertArrayArg(ProcType: TPasProcedureType; @@ -476,6 +504,19 @@ begin AssertArg(ProcType,0,'B',argDefault,'Integer',''); end; +procedure TTestProcedureFunction.TestProcedureOnePointerArg; +begin + ParseProcedure('(B : ^Integer)'); + AssertProc([],[],ccDefault,1); + AssertArg(ProcType,0,'B',argDefault,'^Integer',''); +end; + +procedure TTestProcedureFunction.TestFunctionPointerResult; +begin + ParseFunction('()','^LongInt'); + AssertFunc([],[],ccDefault,0); +end; + procedure TTestProcedureFunction.TestFunctionOneArg; begin ParseFunction('(B : Integer)'); @@ -513,6 +554,7 @@ end; procedure TTestProcedureFunction.TestProcedureOneOutArg; begin + Parser.CurrentModeswitches:=[msObjfpc]; ParseProcedure('(Out B : Integer)'); AssertProc([],[],ccDefault,1); AssertArg(ProcType,0,'B',argOut,'Integer',''); @@ -520,6 +562,7 @@ end; procedure TTestProcedureFunction.TestFunctionOneOutArg; begin + Parser.CurrentModeswitches:=[msObjfpc]; ParseFunction('(Out B : Integer)'); AssertFunc([],[],ccDefault,1); AssertArg(FuncType,0,'B',argOut,'Integer',''); @@ -812,6 +855,30 @@ begin AssertProc([],[],ccVectorCall,0); end; +procedure TTestProcedureFunction.TestCallingConventionSysCall; +begin + ParseProcedure('; syscall abc'); + AssertProc([],[],ccSysCall,0); +end; + +procedure TTestProcedureFunction.TestCallingConventionSysCallExecbase; +begin + ParseProcedure('; syscall _execBase 123'); + AssertProc([],[],ccSysCall,0); +end; + +procedure TTestProcedureFunction.TestCallingConventionSysCallUtilitybase; +begin + ParseProcedure('; syscall _utilityBase 123'); + AssertProc([],[],ccSysCall,0); +end; + +procedure TTestProcedureFunction.TestCallingConventionSysCallConsoleDevice; +begin + ParseProcedure('; syscall ConsoleDevice 123'); + AssertProc([],[],ccSysCall,0); +end; + procedure TTestProcedureFunction.TestCallingConventionHardFloat; begin ParseProcedure('; HardFloat'); @@ -1005,14 +1072,14 @@ procedure TTestProcedureFunction.TestProcedureFar; begin AddDeclaration('procedure A; far;'); ParseProcedure; - AssertProc([pmfar],[],ccDefault,0); + AssertProc([pmfar],[ptmfar],ccDefault,0); end; procedure TTestProcedureFunction.TestFunctionFar; begin AddDeclaration('function A : integer; far;'); ParseFunction; - AssertFunc([pmfar],[],ccDefault,0); + AssertFunc([pmfar],[ptmfar],ccDefault,0); end; procedure TTestProcedureFunction.TestProcedureCdeclForward; @@ -1284,6 +1351,13 @@ begin AssertEquals('Alias name','''myalias''',Func.AliasName); end; +procedure TTestProcedureFunction.TestOperatorNamedResult; +begin + AddDeclaration('operator = (a,b : T) z : Integer;'); + ParseOperator; + AssertEquals('Correct operator type',otEqual,FOperator.OperatorType); +end; + procedure TTestProcedureFunction.TestProcedureAlias; begin AddDeclaration('Procedure A; Alias : ''myalias'''); @@ -1300,23 +1374,25 @@ Var begin For t:=otMul to High(TOperatorType) do + begin + if OperatorTokens[t]='' then continue; // No way to distinguish between logical/bitwise or/and/Xor - if not (t in [otBitwiseOr,otBitwiseAnd,otBitwiseXor]) then - begin - S:=GetEnumName(TypeInfo(TOperatorType),Ord(T)); - ResetParser; - if t in UnaryOperators then - AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]])) - else - AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]])); - ParseOperator; - AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased); - AssertEquals(S+': Correct operator type',T,FOperator.OperatorType); - if t in UnaryOperators then - AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name) - else - AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name); - end; + if t in [otBitWiseOr,otBitwiseAnd,otbitwiseXor] then continue; + + S:=GetEnumName(TypeInfo(TOperatorType),Ord(T)); + ResetParser; + if t in UnaryOperators then + AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]])) + else + AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]])); + ParseOperator; + AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased); + AssertEquals(S+': Correct operator type',T,FOperator.OperatorType); + if t in UnaryOperators then + AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name) + else + AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name); + end; end; procedure TTestProcedureFunction.TestOperatorNames; @@ -1327,21 +1403,25 @@ Var begin For t:=Succ(otUnknown) to High(TOperatorType) do - begin - S:=GetEnumName(TypeInfo(TOperatorType),Ord(T)); - ResetParser; - if t in UnaryOperators then - AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]])) - else - AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]])); - ParseOperator; - AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased); - AssertEquals(S+': Correct operator type',T,FOperator.OperatorType); - if t in UnaryOperators then - AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name) - else - AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name); - end; + begin + if OperatorNames[t]='' then continue; + // otInitialize has no result + if t=otInitialize then continue; + writeln('TTestProcedureFunction.TestOperatorTokens ',t); + S:=GetEnumName(TypeInfo(TOperatorType),Ord(T)); + ResetParser; + if t in UnaryOperators then + AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]])) + else + AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]])); + ParseOperator; + AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased); + AssertEquals(S+': Correct operator type',T,FOperator.OperatorType); + if t in UnaryOperators then + AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name) + else + AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name); + end; end; procedure TTestProcedureFunction.TestAssignOperatorAfterObject; diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcresolvegenerics.pas b/avx512-0037785/packages/fcl-passrc/tests/tcresolvegenerics.pas index 9e5f7a8b19..83f59c6c7c 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -64,6 +64,7 @@ type procedure TestGen_ClassObjFPC; procedure TestGen_ClassObjFPC_OverloadFail; procedure TestGen_ClassObjFPC_OverloadOtherUnit; + procedure TestGen_ClassGenAncestorWithoutParamFail; procedure TestGen_ClassForward; procedure TestGen_ClassForwardConstraints; procedure TestGen_ClassForwardConstraintNameMismatch; @@ -95,6 +96,7 @@ type procedure TestGen_Class_ReferenceTo; procedure TestGen_Class_TwoSpecsAreNotRelatedWarn; procedure TestGen_Class_List; + procedure TestGen_Class_Typecast; // ToDo: different modeswitches at parse time and specialize time // generic external class @@ -137,6 +139,7 @@ type procedure TestGenProc_FunctionDelphi; procedure TestGenProc_OverloadDuplicate; procedure TestGenProc_MissingTemplatesFail; + procedure TestGenProc_SpecializeNonGenericFail; procedure TestGenProc_Forward; procedure TestGenProc_External; procedure TestGenProc_UnitIntf; @@ -153,7 +156,7 @@ type procedure TestGenProc_TypeParamCntOverload; procedure TestGenProc_TypeParamCntOverloadNoParams; procedure TestGenProc_TypeParamWithDefaultParamDelphiFail; - procedure TestGenProc_ParamSpecWithT; // ToDo: Func<T>(Bird: TBird<T>) + procedure TestGenProc_ParamSpecWithT; // ToDo: NestedResultAssign // generic function infer types @@ -182,6 +185,8 @@ type procedure TestGenMethod_OverloadTypeParamCntObjFPC; procedure TestGenMethod_OverloadTypeParamCntDelphi; procedure TestGenMethod_OverloadArgs; + procedure TestGenMethod_TypeCastParam; + procedure TestGenMethod_TypeCastIdentDot; end; implementation @@ -259,8 +264,8 @@ begin ' TBirdAlias = TBird;', 'begin', '']); - CheckResolverException('type expected, but TBird<> found', - nXExpectedButYFound); + CheckResolverException('Generics without specialization cannot be used as a type for a variable', + nGenericsWithoutSpecializationAsType); end; procedure TTestResolveGenerics.TestGen_TemplNameEqTypeNameFail; @@ -938,6 +943,22 @@ begin ParseProgram; end; +procedure TTestResolveGenerics.TestGen_ClassGenAncestorWithoutParamFail; +begin + StartProgram(false); + Add([ + '{$mode objfpc}', + 'type', + ' TObject = class end;', + ' generic TBird<T> = class end;', + ' generic TEagle<T> = class(TBird)', + ' end;', + 'begin', + '']); + CheckResolverException('Generics without specialization cannot be used as a type for a variable', + nGenericsWithoutSpecializationAsType); +end; + procedure TTestResolveGenerics.TestGen_ClassForward; begin StartProgram(false); @@ -1629,6 +1650,35 @@ begin ParseProgram; end; +procedure TTestResolveGenerics.TestGen_Class_Typecast; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + 'type', + ' TObject = class end;', + ' TList<T> = class', + ' end;', + ' TEagle = class;', + ' TBird = class', + ' FLegs: TList<TBird>;', + ' property Legs: TList<TBird> read FLegs write FLegs;', + ' end;', + ' TEagle = class(TBird)', + ' end;', + 'var', + ' B: TBird;', + ' List: TList<TEagle>;', + 'begin', + ' List:=TList<TEagle>(B.Legs);', + ' TList<TEagle>(B.Legs):=List;', + '', + '']); + ParseProgram; + // FPC/pas2js: Class types "TList<afile.TBird>" and "TList<afile.TEagle>" are not related + // Delphi: no warning +end; + procedure TTestResolveGenerics.TestGen_ExtClass_Array; begin StartProgram(false); @@ -1901,7 +1951,7 @@ begin ' PRec = ^specialize TRec<word>;', 'begin', '']); - CheckParserException('Expected "Identifier" at token "specialize" in file afile.pp at line 4 column 11',nParserExpectTokenError); + CheckParserException('Expected "Identifier or file"',nParserExpectTokenError); end; procedure TTestResolveGenerics.TestGen_HelperForArray; @@ -2186,6 +2236,19 @@ begin CheckParserException('Expected "<"',nParserExpectTokenError); end; +procedure TTestResolveGenerics.TestGenProc_SpecializeNonGenericFail; +begin + StartProgram(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'begin', + ' specialize Run<word>();', + '']); + CheckResolverException('Run expected, but Run<> found',nXExpectedButYFound); +end; + procedure TTestResolveGenerics.TestGenProc_Forward; begin StartProgram(false); @@ -2921,6 +2984,59 @@ begin ParseProgram; end; +procedure TTestResolveGenerics.TestGenMethod_TypeCastParam; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class end;', + ' TAnt = class end;', + ' TArray<T> = array of T;', + ' TBird = class', + ' F: TArray<TObject>;', + ' procedure Run<S>(a: TArray<S>);', + ' end;', + 'implementation', + 'procedure TBird.Run<S>(a: TArray<S>);', + 'begin', + ' a:=TArray<S>(a);', + ' F:=TArray<TObject>(a);', + 'end;', + 'var B: TBird;', + 'initialization', + ' B.Run<TAnt>(nil);', + '']); + ParseUnit; +end; + +procedure TTestResolveGenerics.TestGenMethod_TypeCastIdentDot; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class end;', + ' TBird = class end;', + ' TEagle = class(TBird)', + ' procedure Run<S>(p: S);', + ' procedure Fly;', + ' end;', + 'implementation', + 'procedure TEagle.Run<S>(p: S);', + 'begin', + 'end;', + 'procedure TEagle.Fly;', + 'var Bird: TBird;', + 'begin', + ' TEagle(Bird).Run<word>(3);', + 'end;', + '']); + ParseUnit; +end; + initialization RegisterTests([TTestResolveGenerics]); diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcresolver.pas b/avx512-0037785/packages/fcl-passrc/tests/tcresolver.pas index 13e4b33328..587d86c3bf 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcresolver.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcresolver.pas @@ -142,7 +142,9 @@ type Procedure TearDown; override; procedure CreateEngine(var TheEngine: TPasTreeContainer); override; procedure ParseModule; override; + procedure ParseMain(ExpectedModuleClass: TPasModuleClass); virtual; procedure ParseProgram; virtual; + procedure ParseLibrary; virtual; procedure ParseUnit; virtual; procedure CheckReferenceDirectives; virtual; procedure CheckResolverHint(MsgType: TMessageType; MsgNumber: integer; @@ -172,6 +174,7 @@ type ImplementationSrc: string): TTestEnginePasResolver; procedure AddSystemUnit(Parts: TSystemUnitParts = []); procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); + procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); procedure StartUnit(NeedSystemUnit: boolean); property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property ModuleCount: integer read GetModuleCount; @@ -299,7 +302,7 @@ type Procedure TestIntegerBoolFail; Procedure TestBooleanOperators; Procedure TestStringOperators; - Procedure TestWideCharOperators; + Procedure TestWideCharOperators_DelphiUnicode; Procedure TestFloatOperators; Procedure TestCAssignments; Procedure TestTypeCastBaseTypes; @@ -975,6 +978,16 @@ type Procedure TestAttributes_NonConstParam_Fail; Procedure TestAttributes_UnknownAttrWarning; Procedure TestAttributes_Members; + + // library + Procedure TestLibrary_Empty; + Procedure TestLibrary_ExportFunc; + Procedure TestLibrary_ExportFunc_NameIntFail; + Procedure TestLibrary_ExportFunc_IndexStringFail; + Procedure TestLibrary_ExportVar; // ToDo + Procedure TestLibrary_Initialization_Finalization; + Procedure TestLibrary_ExportFuncOverloadFail; // ToDo + // ToDo Procedure TestLibrary_UnitExports; end; function LinesToStr(Args: array of const): string; @@ -1069,6 +1082,7 @@ begin FHub:=TPasResolverHub.Create(Self); inherited SetUp; Parser.Options:=Parser.Options+[po_ResolveStandardTypes]; + Parser.CurrentModeswitches:=[msObjfpc]; Scanner.OnDirective:=@OnScannerDirective; Scanner.OnLog:=@OnScannerLog; end; @@ -1192,7 +1206,7 @@ begin end; end; -procedure TCustomTestResolver.ParseProgram; +procedure TCustomTestResolver.ParseMain(ExpectedModuleClass: TPasModuleClass); var aFilename: String; aRow, aCol: Integer; @@ -1207,7 +1221,7 @@ begin aRow:=E.Row; aCol:=E.Column; WriteSources(aFilename,aRow,aCol); - writeln('ERROR: TTestResolver.ParseProgram Parser: '+E.ClassName+':'+E.Message, + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Parser: '+E.ClassName+':'+E.Message, ' Scanner at' +' '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')' +' Line="'+Scanner.CurLine+'"'); @@ -1224,17 +1238,22 @@ begin ResolverEngine.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aCol); end; WriteSources(aFilename,aRow,aCol); - writeln('ERROR: TTestResolver.ParseProgram PasResolver: '+E.ClassName+':'+E.Message + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' PasResolver: '+E.ClassName+':'+E.Message +' at '+aFilename+'('+IntToStr(aRow)+','+IntToStr(aCol)+')'); Fail(E.Message); end; on E: Exception do begin - writeln('ERROR: TTestResolver.ParseProgram Exception: '+E.ClassName+':'+E.Message); + writeln('ERROR: TTestResolver.ParseMain ',ExpectedModuleClass.ClassName,' Exception: '+E.ClassName+':'+E.Message); Fail(E.Message); end; end; TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine); +end; + +procedure TCustomTestResolver.ParseProgram; +begin + ParseMain(TPasProgram); AssertEquals('Has program',TPasProgram,Module.ClassType); AssertNotNull('Has program section',PasProgram.ProgramSection); AssertNotNull('Has initialization section',PasProgram.InitializationSection); @@ -1244,39 +1263,18 @@ begin CheckReferenceDirectives; end; +procedure TCustomTestResolver.ParseLibrary; +begin + ParseMain(TPasLibrary); + AssertEquals('Has library',TPasLibrary,Module.ClassType); + AssertNotNull('Has library section',PasLibrary.LibrarySection); + AssertNotNull('Has initialization section',PasLibrary.InitializationSection); + CheckReferenceDirectives; +end; + procedure TCustomTestResolver.ParseUnit; begin - FFirstStatement:=nil; - try - ParseModule; - except - on E: EParserError do - begin - writeln('ERROR: TTestResolver.ParseUnit Parser: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); - Fail(E.Message); - end; - on E: EPasResolve do - begin - writeln('ERROR: TTestResolver.ParseUnit PasResolver: '+E.ClassName+':'+E.Message - +' File='+Scanner.CurFilename - +' LineNo='+IntToStr(Scanner.CurRow) - +' Col='+IntToStr(Scanner.CurColumn) - +' Line="'+Scanner.CurLine+'"' - ); - Fail(E.Message); - end; - on E: Exception do - begin - writeln('ERROR: TTestResolver.ParseUnit Exception: '+E.ClassName+':'+E.Message); - Fail(E.Message); - end; - end; - TAssert.AssertSame('Has resolver',ResolverEngine,Parser.Engine); + ParseMain(TPasModule); AssertEquals('Has unit',TPasModule,Module.ClassType); AssertNotNull('Has interface section',Module.InterfaceSection); AssertNotNull('Has implementation section',Module.ImplementationSection); @@ -2180,6 +2178,8 @@ begin Result.OnFindUnit:=@OnPasResolverFindUnit; Result.OnLog:=@OnPasResolverLog; Result.Hub:=Hub; + Result.ExprEvaluator.DefaultStringCodePage:=CP_UTF8; + Result.ExprEvaluator.DefaultSourceCodePage:=CP_UTF8; FModules.Add(Result); end; @@ -2195,7 +2195,8 @@ function TCustomTestResolver.AddModuleWithIntfImplSrc(aFilename, InterfaceSrc, var Src: String; begin - Src:='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding; + Src:='{$mode objfpc}'; + Src+='unit '+ExtractFileUnitName(aFilename)+';'+LineEnding; Src+=LineEnding; Src+='interface'+LineEnding; Src+=LineEnding; @@ -2329,6 +2330,16 @@ begin Add('program '+ExtractFileUnitName(MainFilename)+';'); end; +procedure TCustomTestResolver.StartLibrary(NeedSystemUnit: boolean; + SystemUnitParts: TSystemUnitParts); +begin + if NeedSystemUnit then + AddSystemUnit(SystemUnitParts) + else + Parser.ImplicitUses.Clear; + Add('library '+ExtractFileUnitName(MainFilename)+';'); +end; + procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean); begin if NeedSystemUnit then @@ -3540,7 +3551,8 @@ begin ' s[9+1]:=''b'';', ' s[10]:='''''''';', ' s[11]:=^g;', - ' s[12]:=^H;']); + ' s[12]:=^H;', + '']); ParseProgram; end; @@ -3618,6 +3630,7 @@ begin ' m=low(char)+high(char);', ' n = string(''A'');', ' o = UnicodeString(''A'');', + ' p = ^C''bird'';', 'begin']); ParseProgram; CheckResolverUnexpectedHints; @@ -4281,6 +4294,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; @@ -4667,9 +4689,9 @@ begin ParseProgram; end; -procedure TTestResolver.TestWideCharOperators; +procedure TTestResolver.TestWideCharOperators_DelphiUnicode; begin - ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF8; + ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF16; ResolverEngine.BaseTypeChar:=btWideChar; ResolverEngine.BaseTypeString:=btUnicodeString; StartProgram(false); @@ -14296,7 +14318,6 @@ end; procedure TTestResolver.TestStaticArrayOfChar; begin - ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF8; StartProgram(false); Add([ 'type', @@ -14318,7 +14339,6 @@ end; procedure TTestResolver.TestStaticArrayOfCharDelphi; begin - ResolverEngine.ExprEvaluator.DefaultStringCodePage:=CP_UTF8; StartProgram(false); Add([ '{$mode delphi}', @@ -16480,7 +16500,7 @@ begin Add([ 'type p = ^(red, green);', 'begin']); - CheckParserException('Expected "Identifier" at token "(" in file afile.pp at line 2 column 11', + CheckParserException('Expected "Identifier or file"', nParserExpectTokenError); end; @@ -18725,6 +18745,114 @@ begin CheckAttributeMarkers; end; +procedure TTestResolver.TestLibrary_Empty; +begin + StartLibrary(false); + Add(['begin']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_ExportFunc; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'procedure Fly;', + 'begin', + 'end;', + 'exports', + ' Run,', + ' Fly name ''FlyHi'';', + 'exports', + ' Run index 3+4;', + 'begin', + '']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_ExportFunc_NameIntFail; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'exports', + ' Run name 4;', + 'begin', + '']); + CheckResolverException('string expected, but Longint found',nXExpectedButYFound); +end; + +procedure TTestResolver.TestLibrary_ExportFunc_IndexStringFail; +begin + StartLibrary(false); + Add([ + 'procedure Run;', + 'begin', + 'end;', + 'exports', + ' Run index ''abc'';', + 'begin', + '']); + CheckResolverException('integer expected, but String found',nXExpectedButYFound); +end; + +procedure TTestResolver.TestLibrary_ExportVar; +begin + exit; + + StartLibrary(false); + Add([ + 'var', + ' Size: word; export name ''size'';', + 'exports', + ' Size,', + ' Fly as ''FlyHi'',', + ' Run index 3+4;', + 'begin', + '']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_Initialization_Finalization; +begin + StartLibrary(false); + Add([ + 'procedure Run(w: word);', + 'begin', + 'end;', + 'exports', + ' Run;', + 'initialization', + ' Run(3);', + 'finalization', + ' Run(4);', + '']); + ParseLibrary; +end; + +procedure TTestResolver.TestLibrary_ExportFuncOverloadFail; +begin + exit; + + StartLibrary(false); + Add([ + 'procedure Run(w: word); overload;', + 'begin', + 'end;', + 'procedure Run(d: double); overload;', + 'begin', + 'end;', + 'exports', + ' Run,', + ' afile.run;', + 'begin']); + CheckResolverException('The symbol cannot be exported from a library',123); +end; + initialization RegisterTests([TTestResolver]); diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcscanner.pas b/avx512-0037785/packages/fcl-passrc/tests/tcscanner.pas index 59d16c3911..c03778dd35 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcscanner.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcscanner.pas @@ -57,20 +57,27 @@ type FResolver : TStreamResolver; FDoCommentCalled : Boolean; FComment: string; + FPathPrefix : String; + FTestTokenString: String; protected procedure DoComment(Sender: TObject; aComment: String); procedure SetUp; override; procedure TearDown; override; + Procedure DoMultilineError; Function TokenToString(tk : TToken) : string; Procedure AssertEquals(Msg : String; Expected,Actual : TToken); overload; Procedure AssertEquals(Msg : String; Expected,Actual : TModeSwitch); overload; Procedure AssertEquals(Msg : String; Expected,Actual : TModeSwitches); overload; + // creates a virtual source file with name 'afile.pp', prepended with PathPrefix procedure NewSource(Const Source : string; DoClear : Boolean = True); Procedure DoTestToken(t : TToken; Const ASource : String; Const CheckEOF : Boolean = True); Procedure TestToken(t : TToken; Const ASource : String; Const CheckEOF : Boolean = True); Procedure TestTokens(t : array of TToken; Const ASource : String; Const CheckEOF : Boolean = True;Const DoClear : Boolean = True); Property LastIDentifier : String Read FLI Write FLi; Property Scanner : TPascalScanner Read FScanner; + // Path for source filename. + Property PathPrefix : String Read FPathPrefix Write FPathPrefix; + Property TestTokenString : String Read FTestTokenString; published Procedure TestEmpty; procedure TestEOF; @@ -94,9 +101,21 @@ type procedure TestSelf; procedure TestSelfNoToken; procedure TestString; + procedure TestMultilineStringError; + procedure TestMultilineStringSource; + Procedure TestMultilineStringLF; + Procedure TestMultilineStringCR; + Procedure TestMultilineStringCRLF; + Procedure TestMultilineStringPlatform; + Procedure TestMultilineLineEndingDirective; + Procedure TestMultilineTrimLeftDirective; + procedure TestMultilineStringTrimAll; + procedure TestMultilineStringTrimAuto; + procedure TestMultilineStringTrim2; procedure TestNumber; procedure TestChar; procedure TestCharString; + procedure TestCaretString; procedure TestBraceOpen; procedure TestBraceClose; procedure TestMul; @@ -235,6 +254,10 @@ type Procedure TestDefine14; Procedure TestInclude; Procedure TestInclude2; + Procedure TestInclude3; + Procedure TestIncludeString; + Procedure TestIncludeStringFile; + Procedure TestIncludeString2Lines; Procedure TestUnDefine1; Procedure TestMacro1; procedure TestMacro2; @@ -256,6 +279,10 @@ type procedure TestIFLesserEqualThan; procedure TestIFDefinedElseIf; procedure TestIfError; + procedure TestIFCDefined; + procedure TestIFCNotDefined; + procedure TestIFCAndDefined; + procedure TestIFCFalse; Procedure TestModeSwitch; Procedure TestOperatorIdentifier; Procedure TestUTF8BOM; @@ -392,6 +419,7 @@ end; procedure TTestScanner.SetUp; begin + FTestTokenString:=''; FDoCommentCalled:=False; FResolver:=TStreamResolver.Create; FResolver.OwnsStreams:=True; @@ -405,6 +433,11 @@ begin FreeAndNil(FResolver); end; +procedure TTestScanner.DoMultilineError; +begin + TestToken(pscanner.tkString,'`A '#10'multiline string`'); +end; + function TTestScanner.TokenToString(tk: TToken): string; begin Result:=GetEnumName(TypeInfo(TToken),Ord(tk)); @@ -444,17 +477,25 @@ begin end; procedure TTestScanner.NewSource(const Source: string; DoClear : Boolean = True); + +Var + aFile : String; + begin + aFile:=''; if DoClear then FResolver.Clear; - FResolver.AddStream('afile.pp',TStringStream.Create(Source)); + if (FPathPrefix<>'') then + aFile:=IncludeTrailingPathDelimiter(FPathPrefix); + aFile:=aFile+'afile.pp'; + FResolver.AddStream(aFile,TStringStream.Create(Source)); {$ifndef NOCONSOLE} // JC: To get the tests to run with GUI Writeln('// '+TestName); Writeln(Source); {$EndIf} // FreeAndNil(FScanner); // FScanner:=TTestingPascalScanner.Create(FResolver); - FScanner.OpenFile('afile.pp'); + FScanner.OpenFile(aFile); end; procedure TTestScanner.DoTestToken(t: TToken; const ASource: String; @@ -467,6 +508,7 @@ begin NewSource(ASource); tk:=FScanner.FetchToken; AssertEquals('Read token equals expected token.',t,tk); + FTestTokenString:=FScanner.CurTokenString; if CheckEOF then begin tk:=FScanner.FetchToken; @@ -505,7 +547,9 @@ begin tk:=FScanner.FetchToken; AssertEquals(Format('Read token %d equals expected token.',[i]),t[i],tk); if tk=tkIdentifier then - LastIdentifier:=FScanner.CurtokenString; + LastIdentifier:=FScanner.CurtokenString + else if tk=tkString then + fTestTokenString:=FScanner.CurTokenString; end; if CheckEOF then begin @@ -646,12 +690,154 @@ begin TestToken(pscanner.tkString,'''A string'''); end; +procedure TTestScanner.TestMultilineStringError; +begin + AssertException('Need modeswitch',EScannerError,@DoMultilineError); +end; + +procedure TTestScanner.TestMultilineStringSource; + +const + S = '''AB'#13#10'CD'''; + +begin + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elSource; + DoTestToken(pscanner.tkString,'`AB'#13#10'CD`'); + AssertEquals('Correct lineending',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineStringLF; + +const + S = '''AB'#10'CD'''; + +begin + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elLF; + DoTestToken(pscanner.tkString,'`AB'#13#10'CD`'); + AssertEquals('Correct lineending',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineStringCR; +const + S = '''AB'#13'CD'''; + +begin + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elCR; + DoTestToken(pscanner.tkString,'`AB'#10'CD`'); + AssertEquals('Correct lineending',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineStringCRLF; +const + S = '''AB'#13#10'CD'''; + +begin + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elCRLF; + DoTestToken(pscanner.tkString,'`AB'#10'CD`'); + AssertEquals('Correct lineending',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineStringPlatform; + +const + S = '''AB'+sLineBreak+'CD'''; + +begin + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elPlatform; + DoTestToken(pscanner.tkString,'`AB'#13#10'CD`'); + AssertEquals('Correct lineending',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineLineEndingDirective; +begin + AssertTrue('Default platform', FSCanner.MultilineLineFeedStyle=elPlatform); + TestTokens([tkComment],'{$MULTILINESTRINGLINEENDING CR}'); + AssertTrue('CR', FSCanner.MultilineLineFeedStyle=elCR); + TestTokens([tkComment],'{$MULTILINESTRINGLINEENDING LF}'); + AssertTrue('LF', FSCanner.MultilineLineFeedStyle=elLF); + TestTokens([tkComment],'{$MULTILINESTRINGLINEENDING CRLF}'); + AssertTrue('CRLF', FSCanner.MultilineLineFeedStyle=elCRLF); + TestTokens([tkComment],'{$MULTILINESTRINGLINEENDING SOURCE}'); + AssertTrue('SOURCE', FSCanner.MultilineLineFeedStyle=elSOURCE); + TestTokens([tkComment],'{$MULTILINESTRINGLINEENDING PLATFORM}'); + AssertTrue('Platform', FSCanner.MultilineLineFeedStyle=elPlatform); + +end; + +procedure TTestScanner.TestMultilineTrimLeftDirective; +begin + AssertTrue('Default', FSCanner.MultilineLineTrimLeft=0); + TestTokens([tkComment],'{$MULTILINESTRINGTRIMLEFT 1}'); + AssertTrue('1', FSCanner.MultilineLineTrimLeft=1); + TestTokens([tkComment],'{$MULTILINESTRINGTRIMLEFT 2}'); + AssertTrue('2', FSCanner.MultilineLineTrimLeft=2); + TestTokens([tkComment],'{$MULTILINESTRINGTRIMLEFT ALL}'); + AssertTrue('ALL', FSCanner.MultilineLineTrimLeft=-2); + TestTokens([tkComment],'{$MULTILINESTRINGTRIMLEFT AUTO}'); + AssertTrue('AUTO', FSCanner.MultilineLineTrimLeft=-1); +end; + +procedure TTestScanner.TestMultilineStringTrimAll; + +const + S = '''AB'#10'CD'''; + +begin + SCanner.MultilineLineTrimLeft:=-2; + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elLF; + DoTestToken(pscanner.tkString,'`AB'#13#10' CD`'); + AssertEquals('Correct trim',S,TestTokenString); + +end; + +procedure TTestScanner.TestMultilineStringTrimAuto; +const + S = '''AB'#10' CD'''; + +begin + SCanner.MultilineLineTrimLeft:=-1; + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elLF; + Scanner.SkipWhiteSpace:=True; + DoTestToken(pscanner.tkString,' `AB'#13#10' CD`'); + AssertEquals('Correct trim',S,TestTokenString); +end; + +procedure TTestScanner.TestMultilineStringTrim2; + +const + S = '''AB'#10' CD'''; + S2 = '''AB'#10'CD'''; + +begin + SCanner.MultilineLineTrimLeft:=2; + Scanner.CurrentModeSwitches:=[msMultiLineStrings]; + Scanner.MultilineLineFeedStyle:=elLF; + Scanner.SkipWhiteSpace:=True; + DoTestToken(pscanner.tkString,' `AB'#13#10' CD`'); + AssertEquals('Correct trim',S,TestTokenString); + DoTestToken(pscanner.tkString,' `AB'#13#10' CD`'); + AssertEquals('Correct trim 2',S2,TestTokenString); +end; + procedure TTestScanner.TestCharString; begin TestToken(pscanner.tkChar,'''A'''); end; +procedure TTestScanner.TestCaretString; +begin + + TestTokens([tkIdentifier,tkWhiteSpace,tkEqual,tkwhiteSpace,pscanner.tkString,tkSemicolon],'a = ^C''abc'';',false); +end; + procedure TTestScanner.TestNumber; begin @@ -1625,6 +1811,44 @@ begin TestTokens([tkIf,tkTrue,tkThen,tkElse],'{$I myinclude.inc} else',True,False); end; +procedure TTestScanner.TestInclude3; +begin + PathPrefix:='src'; + FResolver.AddStream('src/myinclude2.inc',TStringStream.Create(' true ')); + FResolver.AddStream('src/myinclude1.inc',TStringStream.Create('if {$i myinclude2.inc} then ')); + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkIf,tkTrue,tkThen,tkElse],'{$I src/myinclude1.inc} else',True,False); +end; + +procedure TTestScanner.TestIncludeString; +begin + FResolver.AddStream('myinclude.inc',TStringStream.Create('if true then')); + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkString],'{$INCLUDESTRING myinclude.inc}',False,False); + AssertEquals('Correct string','''if true then''',TestTokenString) +end; + +procedure TTestScanner.TestIncludeStringFile; +begin + FResolver.AddStream('myinclude.inc',TStringStream.Create('if true then')); + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkString],'{$INCLUDESTRINGFILE myinclude.inc}',False,False); + AssertEquals('Correct string','''if true then''',TestTokenString) +end; + +procedure TTestScanner.TestIncludeString2Lines; +begin + FResolver.AddStream('myinclude.inc',TStringStream.Create('if true then'#10'else')); + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.MultilineLineFeedStyle:=elCRLF; + TestTokens([tkString],'{$INCLUDESTRING myinclude.inc}',False,False); + AssertEquals('Correct string','''if true then'#13#10'else''',TestTokenString) +end; + procedure TTestScanner.TestUnDefine1; begin FSCanner.Defines.Add('ALWAYS'); @@ -1811,6 +2035,61 @@ begin +'end.',True,False); end; +procedure TTestScanner.TestIFCDefined; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddDefine('cpu32'); + TestTokens([tkconst,tkIdentifier,tkEqual,tkString,tkSemicolon,tkbegin,tkend,tkDot], + 'const platform = '+LineEnding + +'{$ifc defined cpu32} ''x86'''+LineEnding + +'{$elseif defined(cpu64)} 1 '+LineEnding + +'{$else} {$error unknown platform} {$endc};'+LineEnding + +'begin end.',True,False); +end; + +procedure TTestScanner.TestIFCNotDefined; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddDefine('cpu32'); + TestTokens([tkconst,tkIdentifier,tkEqual,tkNumber,tkSemicolon,tkbegin,tkend,tkDot], + 'const platform = '+LineEnding + +'{$ifc not defined cpu32} ''x86'''+LineEnding + +'{$else} 1 '+LineEnding + +'{$endc};'+LineEnding + +'begin end.',True,False); +end; + +procedure TTestScanner.TestIFCAndDefined; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddDefine('cpu32'); + FScanner.AddDefine('alpha'); + TestTokens([tkconst,tkIdentifier,tkEqual,tkstring,tkSemicolon,tkbegin,tkend,tkDot], + 'const platform = '+LineEnding + +'{$ifc defined cpu32 and defined alpha} ''x86'''+LineEnding + +'{$else} 1 '+LineEnding + +'{$endc};'+LineEnding + +'begin end.',True,False); +end; + +procedure TTestScanner.TestIFCFalse; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddDefine('cpu32'); + FScanner.AddDefine('alpha'); + FScanner.AddMacro('MY','FALSE'); + TestTokens([tkconst,tkIdentifier,tkEqual,tkNumber,tkSemicolon,tkbegin,tkend,tkDot], + 'const platform = '+LineEnding + +'{$IFC MY} ''x86'''+LineEnding + +'{$else} 1 '+LineEnding + +'{$endc};'+LineEnding + +'begin end.',True,False); +end; + procedure TTestScanner.TestModeSwitch; Const @@ -1846,7 +2125,7 @@ begin DoTestToken(tkLineEnding,#$EF+#$BB+#$BF); end; -Procedure TTestScanner.TestBooleanSwitch; +procedure TTestScanner.TestBooleanSwitch; begin Scanner.CurrentBoolSwitches:=[bsHints]; diff --git a/avx512-0037785/packages/fcl-passrc/tests/tctypeparser.pas b/avx512-0037785/packages/fcl-passrc/tests/tctypeparser.pas index 1818e85e96..9aa49a9497 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tctypeparser.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tctypeparser.pas @@ -50,6 +50,7 @@ type Procedure DoTestClassOf(Const AHint : string); Published Procedure TestAliasType; + procedure TestAbsoluteAliasType; Procedure TestCrossUnitAliasType; Procedure TestAliasTypeDeprecated; Procedure TestAliasTypePlatform; @@ -168,6 +169,7 @@ type Procedure TestTypeHelperWithParent; procedure TestPointerReference; Procedure TestPointerKeyWord; + Procedure TestPointerFile; end; { TTestRecordTypeParser } @@ -361,9 +363,13 @@ type Procedure TestAdvRec_ProcOverrideFail; Procedure TestAdvRec_ProcMessageFail; Procedure TestAdvRec_DestructorFail; + Procedure TestAdvRec_CaseInVar; + Procedure TestAdvRec_EmptySections; Procedure TestAdvRecordInFunction; Procedure TestAdvRecordInAnonFunction; Procedure TestAdvRecordClassOperator; + Procedure TestAdvRecordInitOperator; + Procedure TestAdvRecordGenericFunction; end; { TTestProcedureTypeParser } @@ -459,6 +465,11 @@ type Procedure TestFunctionOneArg; Procedure TestFunctionOfObject; Procedure TestFunctionOneArgOfObject; + Procedure TestCBlock; + Procedure TestMacPasoutArg; + Procedure TestMacPasPropertyArg; + Procedure TestMacPasPropertyVarArg; + Procedure TestMacPasClassArg; end; @@ -1175,6 +1186,48 @@ begin end; +procedure TTestProcedureTypeParser.TestCBlock; + + +begin + ParseType('reference to procedure (a: integer); cblock;',TPasProcedureType,''); + FProc:=Definition as TPasProcedureType; + AssertEquals('Argument count',1,Proc.Args.Count); + AssertEquals('Is cblock',True,ptmCblock in Proc.Modifiers); +end; + +procedure TTestProcedureTypeParser.TestMacPasoutArg; +begin + Parser.CurrentModeswitches:=[msMac]; + ParseType('procedure (out: integer); ',TPasProcedureType,''); + FProc:=Definition as TPasProcedureType; + AssertEquals('Argument count',1,Proc.Args.Count); +end; + +procedure TTestProcedureTypeParser.TestMacPasPropertyArg; +begin + Parser.CurrentModeswitches:=[msMac]; + ParseType('procedure (property : integer); ',TPasProcedureType,''); + FProc:=Definition as TPasProcedureType; + AssertEquals('Argument count',1,Proc.Args.Count); +end; + +procedure TTestProcedureTypeParser.TestMacPasPropertyVarArg; +begin + Parser.CurrentModeswitches:=[msMac]; + ParseType('procedure (var property : integer); ',TPasProcedureType,''); + FProc:=Definition as TPasProcedureType; + AssertEquals('Argument count',1,Proc.Args.Count); +end; + +procedure TTestProcedureTypeParser.TestMacPasClassArg; +begin + Parser.CurrentModeswitches:=[msMac]; + ParseType('procedure (class : integer); ',TPasProcedureType,''); + FProc:=Definition as TPasProcedureType; + AssertEquals('Argument count',1,Proc.Args.Count); +end; + { TTestRecordTypeParser } function TTestRecordTypeParser.GetC(AIndex: Integer): TPasConst; @@ -2610,6 +2663,29 @@ begin ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed); end; +procedure TTestRecordTypeParser.TestAdvRec_CaseInVar; + +// Found in System.UITypes.pas + +begin + StartRecord(true); + AddMember('var'); + AddMember('Case Integer of'); + AddMember(' 1 : (x: integer);'); + AddMember(' 2 : (y,z: integer)'); + ParseRecord; +end; + +procedure TTestRecordTypeParser.TestAdvRec_EmptySections; +begin + StartRecord(true); + AddMember('const'); + AddMember('type'); + AddMember('var'); + AddMember(' x: integer;'); + ParseRecord; +end; + procedure TTestRecordTypeParser.TestAdvRecordInFunction; // Src from bug report 36179 @@ -2688,6 +2764,51 @@ begin ParseModule; // We're just interested in that it parses. end; +procedure TTestRecordTypeParser.TestAdvRecordInitOperator; +// Source from bug id 36180 + +Const + SRC = + '{$mode objfpc}'+sLineBreak+ + '{$modeswitch advancedrecords}'+sLineBreak+ + 'program afile;'+sLineBreak+ + 'type'+sLineBreak+ + ' TMyRecord = record'+sLineBreak+ + ' class operator initialize (var self: TMyRecord);'+sLineBreak+ + ' end;'+sLineBreak+ + 'class operator TMyRecord.initialize (a, b: TMyRecord);'+sLineBreak+ + 'begin'+sLineBreak+ + ' result := (@a = @b);'+sLineBreak+ + 'end;'+sLineBreak+ + 'begin'+sLineBreak+ + 'end.'; + +begin + Source.Text:=Src; + ParseModule; // We're just interested in that it parses. +end; + +procedure TTestRecordTypeParser.TestAdvRecordGenericFunction; + +Const + SRC = + '{$mode objfpc}'+sLineBreak+ + '{$modeswitch advancedrecords}'+sLineBreak+ + 'program afile;'+sLineBreak+ + 'type'+sLineBreak+ + ' TMyRecord = record'+sLineBreak+ + ' generic class procedure doit<T> (a: T);'+sLineBreak+ + ' end;'+sLineBreak+ + 'generic class procedure TMyRecord.DoIt<T>(a: T);'+sLineBreak+ + 'begin'+sLineBreak+ + 'end;'+sLineBreak+ + 'begin'+sLineBreak+ + 'end.'; +begin + Source.Text:=Src; + ParseModule; // We're just interested in that it parses. +end; + { TBaseTestTypeParser } Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass; @@ -2751,6 +2872,7 @@ begin FErrorSource:=''; FHint:=''; FType:=Nil; + Parser.CurrentModeswitches:=[msObjfpc]; end; Procedure TBaseTestTypeParser.TearDown; @@ -2893,11 +3015,21 @@ begin end; procedure TTestTypeParser.TestAliasType; + begin DoTestAliasType('othertype',''); AssertEquals('Unresolved type name ','othertype',TPasUnresolvedTypeRef(TPasAliasType(TheType).DestType).name); end; +procedure TTestTypeParser.TestAbsoluteAliasType; +begin + Add('Type'); + Add(' Absolute = Integer;'); + ParseDeclarations; + AssertEquals('First declaration is type definition.',TPasAliasType,TPasElement(Declarations.Types[0]).ClassType); + AssertEquals('First declaration has correct name.','Absolute',TPasElement(Declarations.Types[0]).Name); +end; + procedure TTestTypeParser.TestCrossUnitAliasType; begin DoTestAliasType('otherunit.othertype',''); @@ -3674,6 +3806,15 @@ begin AssertEquals('object definition count',1,Declarations.Classes.Count); end; +procedure TTestTypeParser.TestPointerFile; +begin + Add('type'); + Add(' pfile = ^file;'); + ParseDeclarations; + AssertEquals('object definition count',1,Declarations.Types.Count); +end; + + initialization RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]); diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcuseanalyzer.pas b/avx512-0037785/packages/fcl-passrc/tests/tcuseanalyzer.pas index c8fb81497e..3c145ee229 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -78,6 +78,7 @@ type procedure TestM_Class; procedure TestM_ClassForward; procedure TestM_Class_Property; + procedure TestM_ClassForward_Generic; procedure TestM_Class_PropertyProtected; procedure TestM_Class_PropertyOverride; procedure TestM_Class_PropertyOverride2; @@ -178,6 +179,7 @@ type procedure TestWP_Attributes; procedure TestWP_Attributes_ForwardClass; procedure TestWP_Attributes_Params; + procedure TestWP_Attributes_PublishedFields; // ToDo // scope references procedure TestSR_Proc_UnitVar; @@ -943,9 +945,9 @@ begin 'begin', ' DoIt;']); AnalyzeProgram; - CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "b" not used'); - CheckUseAnalyzerHint(mtHint,nPALocalVariableIsAssignedButNeverUsed, - 'Local variable "c" is assigned but never used'); + CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "b" not used'); + CheckUseAnalyzerHint(mtHint,nPAFieldIsAssignedButNeverUsed, + 'Field "c" is assigned but never used'); CheckUseAnalyzerUnexpectedHints; end; @@ -1152,6 +1154,30 @@ begin AnalyzeProgram; end; +procedure TTestUseAnalyzer.TestM_ClassForward_Generic; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' {tobject_used}TObject = class', + ' end;', + ' TBird = class;', + ' TAnt = class end;', + ' TBird = class end;', + 'implementation', + 'type', + ' TBird2 = class;', + ' TAnt2 = class end;', + ' TBird2 = class end;', + 'var Bird2: TBird2;', + 'begin', + ' if Bird2=nil then;', + '']); + AnalyzeUnit; +end; + procedure TTestUseAnalyzer.TestM_Class_PropertyProtected; begin StartUnit(false); @@ -2252,9 +2278,9 @@ begin Add('begin'); Add(' Point(1);'); AnalyzeProgram; - CheckUseAnalyzerHint(mtHint,nPALocalVariableIsAssignedButNeverUsed, - 'Local variable "X" is assigned but never used'); - CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used'); + CheckUseAnalyzerHint(mtHint,nPAFieldIsAssignedButNeverUsed, + 'Field "X" is assigned but never used'); + CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used'); CheckUseAnalyzerUnexpectedHints; end; @@ -2293,7 +2319,7 @@ begin Add('begin'); Add(' Point();'); AnalyzeProgram; - CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used'); + CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used'); CheckUseAnalyzerUnexpectedHints; end; @@ -2359,7 +2385,7 @@ begin ' specialize Point<word>();', '']); AnalyzeProgram; - CheckUseAnalyzerHint(mtHint,nPALocalVariableNotUsed,'Local variable "Y" not used'); + CheckUseAnalyzerHint(mtHint,nPAFieldNotUsed,'Field "Y" not used'); CheckUseAnalyzerUnexpectedHints; end; @@ -2659,7 +2685,9 @@ procedure TTestUseAnalyzer.TestWP_Published; begin StartProgram(false); Add('type'); - Add(' {#tobject_used}TObject = class'); + Add(' {#tobject_notypeinfo}TObject = class'); + Add(' end;'); + Add(' {#tobject_typeinfo}TBird = class'); Add(' private'); Add(' {#fcol_used}FCol: string;'); Add(' {#fbird_notused}FBird: string;'); @@ -2669,9 +2697,9 @@ begin Add(' property {#col_used}Col: string read FCol;'); Add(' end;'); Add('var'); - Add(' {#o_used}o: TObject;'); + Add(' {#b_used}b: TBird;'); Add('begin'); - Add(' o:=nil;'); + Add(' b:=nil;'); AnalyzeWholeProgram; end; @@ -3427,15 +3455,20 @@ begin ' TObject = class', ' constructor {#TObject_Create_used}Create;', ' end;', + ' {#TRedAttribute_notused}TRedAttribute = class', + ' end;', ' {#TCustomAttribute_used}TCustomAttribute = class', ' end;', ' [TCustom]', ' TBird = class;', ' TMyInt = word;', ' TBird = class end;', - 'constructor TObject.Create; begin end;', + 'constructor TObject.Create;', 'begin', - ' if typeinfo(TBird)=nil then ;', + 'end;', + 'var b: TBird;', + 'begin', + ' b:=TBird.Create;', '']); AnalyzeWholeProgram; end; @@ -3471,6 +3504,46 @@ begin AnalyzeWholeProgram; end; +procedure TTestUseAnalyzer.TestWP_Attributes_PublishedFields; +begin + exit; + + StartProgram(false); + Add([ + '{$modeswitch prefixedattributes}', + 'type', + ' TObject = class', + ' constructor {#TObject_Create_notused}Create;', + ' destructor {#TObject_Destroy_used}Destroy; virtual;', + ' end;', + ' {#TCustomAttribute_used}TCustomAttribute = class', + ' end;', + ' {#BigAttribute_used}BigAttribute = class(TCustomAttribute)', + ' constructor {#Big_A_used}Create(Id: word = 3); overload;', + ' destructor {#Big_B_used}Destroy; override;', + ' end;', + ' {$M+}', + ' TBird = class', + ' public', + ' FColor: word;', + ' published', + ' Size: word;', + ' procedure Fly;', + ' [Big(3)]', + ' property Color: word read FColor;', + ' end;', + 'constructor TObject.Create; begin end;', + 'destructor TObject.Destroy; begin end;', + 'constructor BigAttribute.Create(Id: word); begin end;', + 'destructor BigAttribute.Destroy; begin end;', + 'var', + ' b: TBird;', + 'begin', + ' if typeinfo(b)=nil then ;', + '']); + AnalyzeWholeProgram; +end; + procedure TTestUseAnalyzer.TestSR_Proc_UnitVar; begin StartUnit(false); diff --git a/avx512-0037785/packages/fcl-passrc/tests/tcvarparser.pas b/avx512-0037785/packages/fcl-passrc/tests/tcvarparser.pas index c3bee4110d..b6092b340c 100644 --- a/avx512-0037785/packages/fcl-passrc/tests/tcvarparser.pas +++ b/avx512-0037785/packages/fcl-passrc/tests/tcvarparser.pas @@ -26,6 +26,7 @@ Type Procedure TearDown; override; Published Procedure TestSimpleVar; + Procedure TestSimpleVarAbsoluteName; Procedure TestSimpleVarHelperName; procedure TestSimpleVarHelperType; Procedure TestSimpleVarDeprecated; @@ -34,9 +35,12 @@ Type procedure TestSimpleVarInitializedDeprecated; procedure TestSimpleVarInitializedPlatform; Procedure TestSimpleVarAbsolute; + Procedure TestSimpleVarAbsoluteAddress; Procedure TestSimpleVarAbsoluteDot; Procedure TestSimpleVarAbsolute2Dots; Procedure TestVarProcedure; + procedure TestVarProcedureCdecl; + procedure TestVarFunctionFar; Procedure TestVarFunctionINitialized; Procedure TestVarProcedureDeprecated; Procedure TestVarRecord; @@ -49,6 +53,7 @@ Type Procedure TestVarExternalLib; Procedure TestVarExternalLibName; procedure TestVarExternalNoSemiColon; + procedure TestVarExternalLibNoName; Procedure TestVarCVar; Procedure TestVarCVarExternal; Procedure TestVarPublic; @@ -127,6 +132,21 @@ begin AssertVariableType('b'); end; +procedure TTestVarParser.TestSimpleVarAbsoluteName; +Var + R : TPasVariable; + +begin + Add('Var'); + Add(' Absolute : integer;'); +// Writeln(source.text); + ParseDeclarations; + AssertEquals('One variable definition',1,Declarations.Variables.Count); + AssertEquals('First declaration is type definition.',TPasVariable,TObject(Declarations.Variables[0]).ClassType); + R:=TPasVariable(Declarations.Variables[0]); + AssertEquals('First declaration has correct name.','Absolute',R.Name); +end; + procedure TTestVarParser.TestSimpleVarHelperName; Var @@ -192,6 +212,13 @@ begin AssertExpression('correct absolute location',TheVar.AbsoluteExpr,pekIdent,'v'); end; +procedure TTestVarParser.TestSimpleVarAbsoluteAddress; +begin + ParseVar('q absolute $123',''); + AssertVariableType('q'); + AssertExpression('correct absolute location',TheVar.AbsoluteExpr,pekNumber,'$123'); +end; + procedure TTestVarParser.TestSimpleVarAbsoluteDot; var B: TBinaryExpr; @@ -222,6 +249,18 @@ begin AssertVariableType(TPasProcedureType); end; +procedure TTestVarParser.TestVarProcedureCdecl; +begin + ParseVar('procedure; cdecl;',''); + AssertVariableType(TPasProcedureType); +end; + +procedure TTestVarParser.TestVarFunctionFar; +begin + ParseVar('function (cinfo : j_decompress_ptr) : int; far;',''); + AssertVariableType(TPasFunctionType); +end; + procedure TTestVarParser.TestVarFunctionINitialized; begin ParseVar('function (device: pointer): pointer; cdecl = nil',''); @@ -325,6 +364,17 @@ begin AssertNotNull('Library symbol',TheVar.ExportName); end; + +procedure TTestVarParser.TestVarExternalLibNoName; +begin + // Found in e.g.apache headers + ParseVar('integer; external ''mylib''',''); + AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers); + AssertNotNull('Library name',TheVar.LibraryName); + +end; + + procedure TTestVarParser.TestVarExternalLibName; begin ParseVar('integer; external ''mylib'' name ''de''',''); |