From 27e2691cfbef21278c784eb227d1212057dccb53 Mon Sep 17 00:00:00 2001 From: Robert van der Hulst Date: Tue, 11 Feb 2025 14:44:15 +0100 Subject: [PATCH] Some changes in preparation for a patch (#1687) * SqlRdd updates * [Compiler] Simplified Keyword Rule (no need for separate rules for Base, Xpp, Fox). These is now a single rule for "soft" keywords. Added ThisForm keyword for FoxPro. The detection and translation is done in the TransformationFox. The implementation of the FindForm() call is inside the code that also handles Clipper arguments and PSZs inside TransformationRT. See https://www.xsharp.eu/forum/topic/5213 * [Tests] Adjust tests to work with X# 3: - Added method FindForm() for code that uses ThisForm - Cannot use .cs extension for source file - Disable an extra warning - * [Compiler tests] Added C934 for https://github.com/X-Sharp/XSharpPublic/issues/1673 * [Compiler tests] Added C935 for https://github.com/X-Sharp/XSharpPublic/issues/1677 * [XGui] Suppress wndproc because current code disables mouse move messages on fixed text controls * [Compiler] Fix for C935 and #1677 . The hascode is now calculated for the full filename including the path. Previously the hashcode was for the path only. * [Runtime] Added 2 functions (ASortFunc and ASortEx) to handle comparisons with duplicates better. * Fix for #1685 . Allow * comment lines to continue to the next line when the last non whitespace character is a semicolon. * [Runtime] Some changes to Asort() to handle duplicate elements, especially for multi dimensional arrays * Fix for #1686 . Added Delegate in the RuntimeState that gets called when an error occurs in the MacroCompiler. You can return a compile time codeblock, or a runtime codeblock created with MCompile(). * [Runtime] Improve performance of the __IsFoxArray property in the Array class, by making it virtual and overriding it in XSharp.VFP. --------- Co-authored-by: cpyrgas --- .../Parser/XSharpLexerCode.cs | 37 ++- src/Docs/VoFunctionDocs.xml | 240 +++++++++--------- src/Runtime/MacroCompiler.Example/VoTests.prg | 23 ++ .../MacroCompiler/Compiler/MacroCompiler.cs | 32 +++ src/Runtime/XSharp.Core/State/State.prg | 6 + .../XSharp.Core/Types/MacroSupport.prg | 15 ++ .../XSharp.RT.Tests/ArrayBaseTests.prg | 25 +- src/Runtime/XSharp.RT.Tests/ArrayTests.prg | 60 ++++- src/Runtime/XSharp.RT/Functions/Array.prg | 103 ++++++-- src/Runtime/XSharp.RT/Types/Array.prg | 2 +- src/Runtime/XSharp.VFP/ArrayFunctions.prg | 6 +- src/Runtime/XSharp.VFP/Classes/FoxArray.prg | 1 + 12 files changed, 401 insertions(+), 149 deletions(-) diff --git a/src/Compiler/src/Compiler/XSharpCodeAnalysis/Parser/XSharpLexerCode.cs b/src/Compiler/src/Compiler/XSharpCodeAnalysis/Parser/XSharpLexerCode.cs index 9202301278..a49ccb9d1c 100644 --- a/src/Compiler/src/Compiler/XSharpCodeAnalysis/Parser/XSharpLexerCode.cs +++ b/src/Compiler/src/Compiler/XSharpCodeAnalysis/Parser/XSharpLexerCode.cs @@ -436,14 +436,33 @@ void parseFoxProDate() return; } - void parseToEol() + bool parseToEol() { + bool endsWithSemicolon = false; var la1 = La(1); while (la1 != EOF && la1 != '\r' && la1 != '\n') { + if (ExpectAny(' ', '\t')) + { + ;// skip whitespace + } + else + { + if (la1 == ';') + { + endsWithSemicolon = true; + } + else if (endsWithSemicolon) + { + // non whitespace after semicolon + // will reset the endsWithSemicolon flag + endsWithSemicolon = false; + } + } parseOne(); la1 = La(1); } + return endsWithSemicolon; } bool tryParseNewLine() @@ -475,11 +494,21 @@ void parseWhitespace() parseOne(); } - void parseSlComment() + void parseSlComment(bool allowSemicolonContinue = false) { parseType(SL_COMMENT); _tokenChannel = TokenConstants.HiddenChannel; - parseToEol(); + var endsWithSemicolon = parseToEol(); + // FoxPro dialect allows * comments to continue on the next line when the line ends with a semicolon + if (Dialect == XSharpDialect.FoxPro && endsWithSemicolon && allowSemicolonContinue) + { + while (endsWithSemicolon) + { + tryParseNewLine(); + parseType(SL_COMMENT); + endsWithSemicolon = parseToEol(); + } + } } void parseDocComment() @@ -1186,7 +1215,7 @@ public override IToken NextToken() case '*': parseOne(MULT); if (AllowOldStyleComments && StartOfLine(LastToken)) - parseSlComment(); + parseSlComment(allowSemicolonContinue: true); else if (Expect('=')) parseOne(ASSIGN_MUL); else if (Expect('*')) diff --git a/src/Docs/VoFunctionDocs.xml b/src/Docs/VoFunctionDocs.xml index 9b490602df..53c82f7dec 100644 --- a/src/Docs/VoFunctionDocs.xml +++ b/src/Docs/VoFunctionDocs.xml @@ -337,23 +337,26 @@ AClone + + + The starting element.
+ A negative value starts from the end.
+ If is positive, the default value is 1; if is negative, the default value is the length of the array. + + + The number of elements to process from .
+ A negative value starts from the end.
+ The default is all elements to the end of the array. + + + Copy elements from one array to another. - + The array to copy elements from. The array to copy elements to. - - The starting element position in .
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to copy from , beginning at .
- A negative value starts from the end.
- If is not specified, all elements in beginning with the starting element are copied. - The starting element position in to receive elements from .
The default value is 1. @@ -560,16 +563,7 @@ The array to traverse. The code block to execute. - - The starting element.
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + A reference to .
The return value of the code block or is ignored — to assign the return value to each element in the array, use the AEvalA() function. @@ -616,16 +610,7 @@ The array to traverse. The code block to execute. - - The starting element.
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + A reference to . @@ -658,16 +643,7 @@ The array to traverse. The code block to execute. - - The starting element
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + A reference to .
The return value of the code block is ignored.
@@ -770,16 +746,7 @@ The array to fill. The value to place in each array element. - - The starting element.
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + A reference to . @@ -1538,16 +1505,7 @@ The value to scan for.
Unless this argument is a code block, it must match the data type of the elements in . - - The starting element.
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + If is a code block, AScan() returns the position of the first element for which the code block returns TRUE.
Otherwise, AScan() returns the position of the first matching element.
@@ -1702,16 +1660,7 @@ The value to scan for.
Unless this argument is a code block, it must match the data type of the elements in . - - The starting element.
- A negative value starts from the end.
- If is positive, the default value is 1; if is negative, the default value is the length of the array. - - - The number of elements to process from .
- A negative value starts from the end.
- The default is all elements to the end of the array. - + If is a code block, AScanExact() returns the position of the element if the code block returned TRUE.
Otherwise, AScanExact() returns the position of the first exact-matching element.
@@ -1832,7 +1781,7 @@ AFill AIns - + Sort an array. @@ -1846,6 +1795,13 @@ The number of elements to process from .
The default is all elements to the end of the array. + + A reference to . + + + + + A code block used to determine the sort order.
This argument is used to change the sorting order to descending or dictionary order.
@@ -1858,9 +1814,6 @@ Elements with high values are sorted toward the end of the array (the last element) - - A reference to . - ASort() sorts all or part of an array.
The array may contains USUALs of mixed types.
@@ -1898,7 +1851,68 @@ AScan Eval + ASortFunc + AsortEx + + + + The codeblock that is called to sort the elements. Should return signed integer, like IComparer.Compare + + + ASortEx() sorts all or part of an array.
+ The array may contains USUALs of mixed types.
+ + + This example creates an array of five unsorted elements, sorts the array in ascending order, then sorts the array in descending order using a code block: + + LOCAL testArray AS ARRAY + testArray := {"Fred", "Kate", "Fred", "ALVIN", "friend"} + ASortEx(testArray, 1,ALen(testArray), {|a,b| + if upper(a) < upper(b) + return -1 + elseif upper(a) > upper(b) + return 1 + endif + return 0 + }) + // The sort order after the code has run is ALVIN, Fred, Fred, friend, Kate + + + ASort + AsortFunc + IComparer.Compare + + + + + The function that is called to sort the elements. Should return signed integer, like IComparer.Compare + + + ASortFunc() sorts all or part of an array.
+ + + This example creates an array of five unsorted elements, sorts the array in ascending order: + + LOCAL FUNCTION SortFunc(a as usual,b as usual) AS INT + if upper(a) < upper(b) + return -1 + elseif upper(a) >> upper(b) + return 1 + endif + return 0 + END FUNCTION + LOCAL testArray AS ARRAY + testArray := {"Fred", "Kate", "Fred", "ALVIN", "friend"} + ASortFunc(testArray, 1,ALen(testArray), SortFunc) + // The sort order after the code has run is ALVIN, Fred, Fred, friend, Kate + + + ASort + AsortEx + IComparer.Compare + + Convert a value to a right-padded string. @@ -2935,17 +2949,9 @@ BLOBDirectImport BLOBExport - - - Retrieve data stored in a BLOB file without referencing a specific field. - - - - A pointer to the BLOB data.
- This pointer can be obtained using BLOBDirectPut(), BLOBDirectImport(), or DBFieldInfo(DBS_BLOB_POINTER, ). - + - The starting position in .
+ The starting position.
If is positive, the starting position is relative to the leftmost character in .
If is negative, it is relative to the rightmost character in .
If is omitted, it is assumed to be 1. @@ -2953,8 +2959,19 @@ The number of bytes of data to retrieve, beginning at .
If is larger than the amount of data stored, excess data is ignored.
- If omitted, BLOBDirectGet() retrieves to the end of the data. + If omitted, the function retrieves to the end of the data. + + + A pointer to the BLOB data.
+ This pointer can be obtained using BLOBDirectPut(), BLOBDirectImport(), or DBFieldInfo(DBS_BLOB_POINTER, ). + + + + + Retrieve data stored in a BLOB file without referencing a specific field. + + The data retrieved from the BLOB file.
The data type of the return value depends on the actual data stored.
@@ -3009,11 +3026,9 @@ Use the function's return value to refer to the newly stored data. - The name of the file from which to read the BLOB data, including an optional drive, directory, and extension. See SetDefault() and SetPath() for file searching and creation rules. No default extension is assumed.
- -
- - This function attempts to open in shared mode.
+ The name of the file from which to read the BLOB data, including an optional drive, directory, and extension. + See SetDefault() and SetPath() for file searching and creation rules. No default extension is assumed.
+ This function attempts to open in shared mode.
If the file does not exist, a runtime error is raised.
If the file is successfully opened, the operation proceeds.
If access is denied because, for example, another process has exclusive use of the file, NetErr() is set to TRUE. @@ -3024,15 +3039,20 @@ BLOBDirectImport() provides a mechanism for copying the contents of a file into a BLOB file. - BLOBDirectImport() is used in conjunction with BLOBDirectExport() to transfer data back and forth between external files and BLOB files. You can use BLOBDirectImport() with a variety of file types, including graphics images, word processor files, and printer fonts.
+ BLOBDirectImport() is used in conjunction with BLOBDirectExport() to transfer + data back and forth between external files and BLOB files. + You can use BLOBDirectImport() with a variety of file types, including graphics images, + word processor files, and printer fonts.
These two functions are excellent for creating databases of documents, graphics, sounds, and so on. - After importing a file with BLOBDirectImport(), nNewPointer, the return value, is the only way to access the data from the BLOB file.
+ After importing a file with BLOBDirectImport(), nNewPointer, the return value, is the only + way to access the data from the BLOB file.
It is up to you, the developer, to provide permanent storage for this reference (see example below) Note: DBFieldInfo(DBS_BLOB_TYPE, ) will return "C" (string) for any memo field created using BLOBDirectImport(). This example imports a .BMP file to be part of an array of startup data.
- The data, stored in the root area of the BLOB file, could then be used to display the application's startup screen: + The data, stored in the root area of the BLOB file, could then be used to display + the application's startup screen: FUNCTION PutPix() LOCAL cBMPFile AS STRING @@ -3046,7 +3066,7 @@ AAdd(aSettings, StartPaths()) // Get default color settings AAdd(aSettings, DefaultColors()) - // Get company logo for display at startup. + // Get company logo for display at startup. // There is nothing to free because this // is the first time importing. nPointer := BLOBDirectImport(0, cBMPFile) @@ -3187,17 +3207,7 @@ The position of the field in the database file structure. - - The starting position in the memo field of the BLOB data.
- If is positive, the starting position is relative to the leftmost character in .
- If is negative, it is relative to the rightmost character in .
- If is omitted, it is assumed to be 1. - - - The number of bytes of data to retrieve, beginning at .
- If is larger than the amount of data stored, excess data is ignored.
- If omitted, BLOBGet() retrieves to the end of the data. - + The BLOB data retrieved from the memo field.
The data type of the return value depends on the actual data stored.
@@ -3220,7 +3230,7 @@ // Field that contains word processor // documentation nPos := FIELDPOS("WP_DOC") - // Import a file (can be larger than 64 KB), then + // Import a file (can be larger than 64 KB), then // obtain the first 25 characters to show to the // user IF BLOBImport(nPos, "c:\application\temp.doc") @@ -3245,9 +3255,9 @@ The position of the field in the database file structure. - The name of the file from which to read the BLOB data, including an optional drive, directory, and extension. See SetDefault() and SetPath() for file searching and creation rules. No default extension is assumed.
- - This function attempts to open in shared mode.
+ The name of the file from which to read the BLOB data, including an optional drive, directory, and extension. + See SetDefault() and SetPath() for file searching and creation rules. No default extension is assumed.
+ This function attempts to open in shared mode.
If the file does not exist, a runtime error is raised.
If the file is successfully opened, the operation proceeds.
If access is denied because, for example, another process has exclusive use of the file, NetErr() is set to TRUE. @@ -3258,12 +3268,16 @@ BLOBImport() provides a mechanism for copying the contents of a file into a memo field as BLOB data. - BLOBImport() is used in conjunction with BLOBExport() to transfer BLOB data back and forth between files and memo fields. You can use BLOBImport() with a variety of file types, including graphics images, word processor files, and printer fonts.
+ BLOBImport() is used in conjunction with BLOBExport() to transfer BLOB data back + and forth between files and memo fields. You can use BLOBImport() with a variety of file types, + including graphics images, word processor files, and printer fonts.
These two functions are excellent for creating databases of documents, graphics, sounds, and so on. - Note: DBFieldInfo(DBS_BLOB_TYPE, ) will return "C" (string) for any memo field created using BLOBImport(). + Note: DBFieldInfo(DBS_BLOB_TYPE, ) will return "C" (string) for + any memo field created using BLOBImport(). - This example imports information from a word processing document into a field, then uses BLOBGet() to extract the first 25 characters of the field: + This example imports information from a word processing document into a field, + then uses BLOBGet() to extract the first 25 characters of the field: FUNCTION Populate() USE customer NEW INHERIT FROM {"DBFBLOB"} diff --git a/src/Runtime/MacroCompiler.Example/VoTests.prg b/src/Runtime/MacroCompiler.Example/VoTests.prg index 046fd0747b..5cf5e92b4a 100644 --- a/src/Runtime/MacroCompiler.Example/VoTests.prg +++ b/src/Runtime/MacroCompiler.Example/VoTests.prg @@ -694,10 +694,33 @@ BEGIN NAMESPACE MacroCompilerTest //typed and untyped parameters TestMacro(mc,"{|a,b| a + b }", Args(1,2), 3, typeof(INT)) TestMacro(mc,"{|a as int,b as int| a + b }", Args(1,2), 3, typeof(INT)) + RuntimeState.MacroCompilerErrorHandler := SubstituteErrorWithNil + TestMacro(mc, "{|| Left('abc,10) }", Args(),NULL, typeof(OBJECT)) + RuntimeState.MacroCompilerErrorHandler := SubstituteErrorWithNilMacro + TestMacro(mc, "{|| 0h }", Args(),NULL, typeof(OBJECT)) + TestMacro(mc, "{|| 0h1 }", Args(),NULL, typeof(OBJECT)) + RuntimeState.MacroCompilerErrorHandler := NULL + TestMacro(mc, "{|| Left('abc,10) }", Args(),typeof(Exception),NULL, ErrorCode.UnterminatedString) Console.WriteLine("Total pass: {0}/{1}", TotalSuccess, TotalTests) RETURN + FUNCTION SubstituteErrorWithNil (cmacro as string, oEx as Exception) as ICodeblock + Console.WriteLine() + Console.WriteLine(i"Intercepted error in macro ""{cmacro}"" :") + Console.WriteLine(oEx:Message) + //Console.ReadLine() + return {|| NIL} + + FUNCTION SubstituteErrorWithNilMacro (cmacro as string, oEx as Exception) as ICodeblock + //Console.ReadLine() + Console.WriteLine() + Console.WriteLine(i"Intercepted error in macro ""{cmacro}"" :") + Console.WriteLine(oEx:Message) + // Recursive, dangerous + return MCompile("NIL") + + END NAMESPACE diff --git a/src/Runtime/MacroCompiler/Compiler/MacroCompiler.cs b/src/Runtime/MacroCompiler/Compiler/MacroCompiler.cs index 310808e49f..818c550c4e 100644 --- a/src/Runtime/MacroCompiler/Compiler/MacroCompiler.cs +++ b/src/Runtime/MacroCompiler/Compiler/MacroCompiler.cs @@ -106,6 +106,14 @@ public ICodeblock Compile(string macro, bool lAllowSingleQuotes, Module module, var m = compiler.Compile(macro); if (m.Diagnostic != null) { + if (RuntimeState.MacroCompilerErrorHandler != null) + { + var result = RuntimeState.MacroCompilerErrorHandler(macro, m.Diagnostic); + if (result != null) + { + return result; + } + } throw m.Diagnostic; } if (m.CreatesAutoVars) @@ -123,6 +131,14 @@ public ICodeblock Compile(string macro) var m = compiler.Compile(macro); if (m.Diagnostic != null) { + if (RuntimeState.MacroCompilerErrorHandler != null) + { + var result = RuntimeState.MacroCompilerErrorHandler(macro, m.Diagnostic); + if (result != null) + { + return result; + } + } throw m.Diagnostic; } if (m.CreatesAutoVars) @@ -138,6 +154,14 @@ public _Codeblock CompileCodeblock(string macro, bool lAllowSingleQuotes, Module var m = compiler.Compile(macro); if (m.Diagnostic != null) { + if (RuntimeState.MacroCompilerErrorHandler != null) + { + var result = RuntimeState.MacroCompilerErrorHandler(macro, m.Diagnostic); + if (result != null) + { + return new _Codeblock(result, macro, isCodeblock,false); + } + } throw m.Diagnostic; } if (m.CreatesAutoVars) @@ -152,6 +176,14 @@ public _Codeblock CompileCodeblock(string macro) var m = compiler.Compile(macro); if (m.Diagnostic != null) { + if (RuntimeState.MacroCompilerErrorHandler != null) + { + var result = RuntimeState.MacroCompilerErrorHandler(macro, m.Diagnostic); + if (result != null) + { + return new _Codeblock(result, macro, true, false); ; + } + } throw m.Diagnostic; } if (m.CreatesAutoVars) diff --git a/src/Runtime/XSharp.Core/State/State.prg b/src/Runtime/XSharp.Core/State/State.prg index 83203ce3dd..902f6af41e 100644 --- a/src/Runtime/XSharp.Core/State/State.prg +++ b/src/Runtime/XSharp.Core/State/State.prg @@ -53,6 +53,7 @@ CLASS XSharp.RuntimeState STATIC CONSTRUCTOR AutoLock := NULL AutoUnLock := NULL + MacroCompilerErrorHandler := NULL detectDialect() SWITCH System.Environment.OSVersion:Platform CASE System.PlatformID.Win32NT @@ -1001,6 +1002,11 @@ CLASS XSharp.RuntimeState ENDIF END SET END PROPERTY + + /// + /// You can register an error handler that will be called when the macrocompiler encounters an error + /// + PUBLIC STATIC PROPERTY MacroCompilerErrorHandler as MacroCompilerErrorHandler AUTO /// This event is thrown when one of the codepages of the runtimestate is changed /// Clients can refresh cached information by registering to this event /// diff --git a/src/Runtime/XSharp.Core/Types/MacroSupport.prg b/src/Runtime/XSharp.Core/Types/MacroSupport.prg index f39d63aa8c..c46820034a 100644 --- a/src/Runtime/XSharp.Core/Types/MacroSupport.prg +++ b/src/Runtime/XSharp.Core/Types/MacroSupport.prg @@ -55,6 +55,21 @@ BEGIN NAMESPACE XSharp /// DELEGATE MacroCompilerResolveAmbiguousMatch(m1 AS MemberInfo, m2 AS MemberInfo, args AS System.Type[]) AS LONG + /// + /// You can register a function / method with this prototype in the RuntimeState to intercept errors in the macro compiler + /// + /// Source of the macro that causes the error + /// Exception describing the problem + /// An object that implements ICodeblock, or NULL to tell the macro compiler to throw the error/ + /// + /// This delegate is called when the macro compiler encounters an error. + /// The delegate can decide to return a codeblock that will be used instead of the original codeblock + /// In theory you can 'patch' the cMacro and call the macro compiler again. + /// However that may cause an other error, resulting in an endless loop. + /// + /// + DELEGATE MacroCompilerErrorHandler(cMacro as STRING, oEx as Exception) AS ICodeblock + /// /// This interface extends the Macro compiler and adds a method that is called to decide between ambigous methods or constructors /// diff --git a/src/Runtime/XSharp.RT.Tests/ArrayBaseTests.prg b/src/Runtime/XSharp.RT.Tests/ArrayBaseTests.prg index 352272978f..f18051ca29 100644 --- a/src/Runtime/XSharp.RT.Tests/ArrayBaseTests.prg +++ b/src/Runtime/XSharp.RT.Tests/ArrayBaseTests.prg @@ -8,13 +8,14 @@ USING System.Collections.Generic USING System.Linq USING System.Text USING XUnit - +using System.Diagnostics // Array tests are not working correctly yet with the current build BEGIN NAMESPACE XSharp.RT.Tests CLASS ArrayBaseTests // Normal non indexed developer + [DebuggerDisplay("{FirstName,nq} {LastName,nq}")]; CLASS Developer PROPERTY FirstName AS STRING AUTO PROPERTY LastName AS STRING AUTO @@ -26,6 +27,7 @@ BEGIN NAMESPACE XSharp.RT.Tests END CLASS // Special indexed developer + [DebuggerDisplay("{FirstName,nq} {LastName,nq}")]; CLASS DeveloperIndexed INHERIT Developer IMPLEMENTS IIndexedProperties CONSTRUCTOR() CONSTRUCTOR (cFirst AS STRING, cLast AS STRING) @@ -76,6 +78,8 @@ BEGIN NAMESPACE XSharp.RT.Tests aDevs := {} AADD(aDevs, Developer{"Chris","Pyrgas"}) AADD(aDevs, Developer{"Nikos","Kokkalis"}) + AADD(aDevs, Developer{"Robert","Van Der Hulst"}) + AADD(aDevs, Developer{"Fabrice","Foray"}) RETURN aDevs METHOD BuildIndexedArray() AS ARRAY OF DeveloperIndexed LOCAL aDevs AS ARRAY OF DeveloperIndexed @@ -83,14 +87,18 @@ BEGIN NAMESPACE XSharp.RT.Tests aDevs := {} AADD(aDevs, DeveloperIndexed{"Chris","Pyrgas"}) AADD(aDevs, DeveloperIndexed{"Nikos","Kokkalis"}) + AADD(aDevs, DeveloperIndexed{"Robert","Van Der Hulst"}) + AADD(aDevs, DeveloperIndexed{"Fabrice","Foray"}) RETURN aDevs [Trait("Category", "ArrayBase")]; [Fact]; METHOD TestIndices AS VOID VAR aDevs := SELF:BuildArray() - Assert.Equal( 2 , (INT) ALen(aDevs)) + Assert.Equal( 4 , (INT) ALen(aDevs)) Assert.Equal("Chris", aDevs[1]:FirstName) Assert.Equal("Pyrgas", aDevs[1]:LastName) + Assert.Equal("Fabrice", aDevs[4]:FirstName) + Assert.Equal("Foray", aDevs[4]:LastName) Assert.Equal("Nikos", aDevs[2]:FirstName) Assert.Equal("Kokkalis", aDevs[2]:LastName) Assert.Equal("Chris", aDevs[1,"FirstName"]) @@ -98,18 +106,18 @@ BEGIN NAMESPACE XSharp.RT.Tests Assert.Equal("Nikos", aDevs[2,"FirstName"]) Assert.Equal("Kokkalis", aDevs[2,"LastName"]) Assert.ThrowsAny({ => aDevs[1,"First"] }) - Assert.ThrowsAny({ => aDevs[3,"FirstName"] }) + Assert.ThrowsAny({ => aDevs[5,"FirstName"] }) [Trait("Category", "ArrayBase")]; [Fact]; METHOD TestSort AS VOID VAR aDevs := SELF:BuildArray() ASort(aDevs, {x, y => x:LastName <= y:LastName}) - Assert.Equal("Kokkalis", aDevs[1]:LastName) - Assert.Equal("Pyrgas", aDevs[2]:LastName) + Assert.Equal("Kokkalis", aDevs[2]:LastName) + Assert.Equal("Pyrgas", aDevs[3]:LastName) ASort(aDevs, {x, y => x:FirstName <= y:FirstName}) Assert.Equal("Chris", aDevs[1]:FirstName) - Assert.Equal("Nikos", aDevs[2]:FirstName) + Assert.Equal("Nikos", aDevs[3]:FirstName) [Trait("Category", "ArrayBase")]; [Fact]; @@ -118,7 +126,7 @@ BEGIN NAMESPACE XSharp.RT.Tests LOCAL result AS STRING result := "" Aeval(aDevs, { x => result += x:FirstName}) - Assert.Equal("ChrisNikos", result) + Assert.Equal("ChrisNikosRobertFabrice", result) [Trait("Category", "ArrayBase")]; @@ -127,7 +135,8 @@ BEGIN NAMESPACE XSharp.RT.Tests VAR aDevs := SELF:BuildArray() Assert.Equal(1, (INT) AScan(aDevs, { x => X:FirstName == "Chris" .AND. x:LastName == "Pyrgas"})) Assert.Equal(2, (INT) AScan(aDevs, { x => X:FirstName == "Nikos" .AND. x:LastName == "Kokkalis"})) - Assert.Equal(0, (INT) AScan(aDevs, { x => X:FirstName == "Fabrice" .AND. x:LastName == "Foray"})) + Assert.Equal(4, (INT) AScan(aDevs, { x => X:FirstName == "Fabrice" .AND. x:LastName == "Foray"})) + Assert.Equal(0, (INT) AScan(aDevs, { x => X:FirstName == "Bill" .AND. x:LastName == "Gates"})) VAR chris := aDevs[1] Assert.Equal(1, (INT) Ascan(adevs, chris)) diff --git a/src/Runtime/XSharp.RT.Tests/ArrayTests.prg b/src/Runtime/XSharp.RT.Tests/ArrayTests.prg index 28d083372a..27df622361 100644 --- a/src/Runtime/XSharp.RT.Tests/ArrayTests.prg +++ b/src/Runtime/XSharp.RT.Tests/ArrayTests.prg @@ -14,7 +14,49 @@ USING XUnit // Array tests are not working correctly yet with the current build BEGIN NAMESPACE XSharp.RT.Tests - CLASS ArrayTests + + CLASS ArrayTests + + [Trait("Category", "Array")]; + [Fact]; + METHOD AsortFuncTest() AS VOID + LOCAL FUNCTION SortFunc(a as usual,b as usual) AS INT + if upper(a) < upper(b) + return -1 + elseif upper(a) > upper(b) + return 1 + endif + return 0 + END FUNCTION + LOCAL testArray AS ARRAY + testArray := {"Fred", "Kate", "Fred", "ALVIN", "friend"} + ASortFunc(testArray, 1,ALen(testArray), SortFunc) + Assert.Equal(testArray[1],"ALVIN") + Assert.Equal(testArray[2],"Fred") + Assert.Equal(testArray[3],"Fred") + Assert.Equal(testArray[4],"friend") + Assert.Equal(testArray[5],"Kate") + RETURN + [Trait("Category", "Array")]; + [Fact]; + METHOD AsortExTest() AS VOID + LOCAL testArray AS ARRAY + testArray := {"Fred", "Kate", "Fred", "ALVIN", "friend"} + // Use multi line codeblock feature below + ASortEx(testArray, 1,ALen(testArray), {|a,b| + if upper(a) < upper(b) + return -1 + elseif upper(a) > upper(b) + return 1 + endif + return 0 + }) + Assert.Equal(testArray[1],"ALVIN") + Assert.Equal(testArray[2],"Fred") + Assert.Equal(testArray[3],"Fred") + Assert.Equal(testArray[4],"friend") + Assert.Equal(testArray[5],"Kate") + RETURN [Trait("Category", "Array")]; [Fact]; @@ -159,10 +201,11 @@ BEGIN NAMESPACE XSharp.RT.Tests Assert.Equal( 0, (INT) a[1]) Assert.Equal( 8, (INT) a[6]) - a := {8,2,1,4,3,0} + a := {8,2,1,4,3,0,8} ASort(a , 0 , 100) Assert.Equal( 0, (INT) a[1]) - Assert.Equal( 8, (INT) a[6]) + Assert.Equal( 8, (INT) a[6]) + Assert.Equal( 8, (INT) a[7]) a := {8,2,1,4,3,0} ASort(a , 0 , 100,IntegerSorter{}) @@ -173,7 +216,7 @@ BEGIN NAMESPACE XSharp.RT.Tests Assert.Equal( 0, (INT) a[6]) Assert.Equal( 8, (INT) a[1]) - a := {{ 1,1}, {1,2}, {2,3}, {2,4}} + a := {{ 1,1}, {2,3}, {1,2}, {2,4}} ASort(a, 0, 4, {|x,y| IIF (x[1] == y[1], x[2] <= y[2], x[1] < y[1])}) Assert.Equal( 1, (INT) a[1,2]) @@ -181,6 +224,15 @@ BEGIN NAMESPACE XSharp.RT.Tests Assert.Equal( 3, (INT) a[3,2]) Assert.Equal( 4, (INT) a[4,2]) + a := {{ 1,1}, {2,3}, {1,2}, {2,4}} + ASort(a, 0, 4, {|x,y| x[1] <= y[1]}) + + Assert.Equal( 1, (INT) a[1,2]) + Assert.Equal( 2, (INT) a[2,2]) + Assert.Equal( 3, (INT) a[3,2]) + Assert.Equal( 4, (INT) a[4,2]) + + [Trait("Category", "Array")]; [Fact]; diff --git a/src/Runtime/XSharp.RT/Functions/Array.prg b/src/Runtime/XSharp.RT/Functions/Array.prg index 10c41454e7..13a9b1bea8 100644 --- a/src/Runtime/XSharp.RT/Functions/Array.prg +++ b/src/Runtime/XSharp.RT/Functions/Array.prg @@ -958,14 +958,24 @@ INTERNAL STRUCTURE ArraySortComparer IMPLEMENTS System.Collections.Generic.ICom IF x == y RETURN 0 ENDIF - LOCAL u AS USUAL - u := _cb:EvalBlock( x, y ) - RETURN IIF ( (LOGIC) u , -1, 1 ) - - - END STRUCTURE - -INTERNAL STRUCTURE ArraySortComparer IMPLEMENTS System.Collections.Generic.IComparer + // There could be a problem when the codeblock uses <= comparison operators. + // we check for that by calling the codeblock twice, the second time with the arguments reversed + local l1 := Eval(_cb, x, y) as logic + if ! l1 + return 1 + else + local l2 := Eval(_cb , y, x) as logic + // when x <= y and y <= x then they are equal, so return 0 + if l2 + return 0 + else + return -1 + endif + endif + +END STRUCTURE + +internal structure ArraySortComparer IMPLEMENTS System.Collections.Generic.IComparer PRIVATE _cb AS @@Func @@ -977,18 +987,27 @@ INTERNAL STRUCTURE ArraySortComparer IMPLEMENTS System.Collections.Generi IF Object.Equals(x, y) RETURN 0 ENDIF - LOCAL u AS LOGIC - u := SELF:_cb( x, y ) - RETURN IIF ( u , -1, 1 ) - - - END STRUCTURE + // There could be a problem when the codeblock uses <= comparison operators. + // we check for that by calling the codeblock twice, the second time with the arguments reversed + local l1 := SELF:_cb( x, y) as logic + if ! l1 + return 1 + else + local l2 := SELF:_cb(y, x) as logic + // when x <= y and y <= x then they are equal, so return 0 + if l2 + return 0 + else + return -1 + endif + endif +end structure /// /// The type of the array elements FUNCTION ASort(aTarget AS __ArrayBase ,nStart AS INT,nCount AS INT,cbOrder AS @@Func) AS __ArrayBase ARRAYNULL aTarget - aTarget:Sort( nStart, nCount, ArraySortComparer { cbOrder } ) + aTarget:Sort( nStart, nCount, ArraySortComparer { cbOrder } ) RETURN aTarget @@ -996,7 +1015,7 @@ FUNCTION ASort(aTarget AS __ArrayBase ,nStart AS INT,nCount AS INT,cbOrder /// The type of the array elements FUNCTION ASort(aTarget AS __ArrayBase ,cbOrder AS @@Func) AS __ArrayBase ARRAYNULL aTarget - aTarget:Sort( ArraySortComparer { cbOrder } ) + aTarget:Sort( ArraySortComparer { cbOrder } ) RETURN aTarget @@ -1121,3 +1140,55 @@ FUNCTION AEvalOld(aArray AS ARRAY ,cbBlock AS ICodeblock) AS ARRAY ArrayHelpers.AEvalCheckArgs(aArray, cbBlock, REF uStart, REF uCount, "AEvalOld") RETURN ArrayHelpers.AEval( aArray, cbBlock, uStart,uCount , FALSE) +/// +function ASortFunc(aTarget as array, nStart as usual, nCount as usual, compFunction as System.Func) as array + var comp := ArraySortComparerFunction{compFunction} + aTarget:Sort(nStart, nCount, comp) + return aTarget + + +/// +function ASortEx(aTarget as array, nStart as usual, nCount as usual, compBlock as CodeBlock) as array + var comp := ArraySortComparerBlock{ compBlock } + aTarget:Sort(nStart, nCount, comp) + return aTarget + +#region Helper Classes + +internal structure ArraySortComparerFunction implements System.Collections.Generic.IComparer + + private _compFunc as System.Func + + constructor(compFunc as System.Func) + if compFunc == null + throw ArgumentNullException{"compFunc"} + endif + _compFunc := compFunc + return + + method Compare(x as usual, y as usual) as int => _compFunc:Invoke(x, y) + +end structure + + +internal structure ArraySortComparerBlock implements System.Collections.Generic.IComparer + + private _compBlock as ICodeblock + + constructor(compBlock as CodeBlock) + if compBlock == null + throw ArgumentNullException{"compBlock"} + endif + _compBlock := compBlock + return + + method Compare(x as usual, y as usual) as int + local uRes as USUAL + uRes := _compBlock:EvalBlock(x, y) + if IsNumeric(uRes) + RETURN (INT) uRes + ENDIF + throw InvalidOperationException{i"Codeblock returns {uRes}. Numeric result expected"} + +end structure +#endregion diff --git a/src/Runtime/XSharp.RT/Types/Array.prg b/src/Runtime/XSharp.RT/Types/Array.prg index f263ed75fc..d339dc17b1 100644 --- a/src/Runtime/XSharp.RT/Types/Array.prg +++ b/src/Runtime/XSharp.RT/Types/Array.prg @@ -26,7 +26,7 @@ BEGIN NAMESPACE XSharp PUBLIC CLASS __Array INHERIT __ArrayBase IMPLEMENTS IIndexer, ISerializable [NOSHOW] PRIVATE CONST FoxArrayName := "XSharp.__FoxArray" AS STRING [NOSHOW] STATIC FoxArrayHelpers := FoxArrayHelpers {} AS FoxArrayHelpers - [NOSHOW] INTERNAL PROPERTY __IsFoxArray AS LOGIC GET SELF:GetType():FullName == FoxArrayName + [NOSHOW] VIRTUAL PROTECTED INTERNAL PROPERTY __IsFoxArray AS LOGIC GET FALSE [NOSHOW] INTERNAL STATIC SuppressArrayIndexErrors := FALSE AS LOGIC // used for Get_Element to emulate strange VO behaviour /// diff --git a/src/Runtime/XSharp.VFP/ArrayFunctions.prg b/src/Runtime/XSharp.VFP/ArrayFunctions.prg index 4c2bf592dc..ddf8163e49 100644 --- a/src/Runtime/XSharp.VFP/ArrayFunctions.prg +++ b/src/Runtime/XSharp.VFP/ArrayFunctions.prg @@ -8,11 +8,11 @@ USING XSharp.Internal INTERNAL FUNCTION FoxALen(a as ARRAY) AS DWORD -RETURN ALen( (__FoxArray) a, 0) +RETURN XSharp.VFP.Functions.ALen( (__FoxArray) a, 0) /// FUNCTION ALen(a AS __FoxArray) AS DWORD - RETURN ALen(a, 0) + RETURN XSharp.VFP.Functions.ALen(a, 0) /// FUNCTION ALen(a AS __FoxArray, nArrayAttribute AS LONG) AS DWORD @@ -35,7 +35,7 @@ FUNCTION ALen(a AS __FoxArray, nArrayAttribute AS LONG) AS DWORD /// FUNCTION __FoxALen(a AS __FoxArray) AS DWORD - RETURN ALen(a, 0) + RETURN XSharp.VFP.Functions.ALen(a, 0) /// FUNCTION AElement(ArrayName AS __FoxArray, nRowSubscript AS DWORD) AS USUAL diff --git a/src/Runtime/XSharp.VFP/Classes/FoxArray.prg b/src/Runtime/XSharp.VFP/Classes/FoxArray.prg index 6dc1a197cd..f28cd76fc9 100644 --- a/src/Runtime/XSharp.VFP/Classes/FoxArray.prg +++ b/src/Runtime/XSharp.VFP/Classes/FoxArray.prg @@ -27,6 +27,7 @@ BEGIN NAMESPACE XSharp [DebuggerBrowsable(DebuggerBrowsableState.Never)]; PRIVATE _nCols := 0 AS DWORD [DebuggerBrowsable(DebuggerBrowsableState.Never)]; + OVERRIDE PROTECTED INTERNAL PROPERTY __IsFoxArray AS LOGIC GET TRUE PROPERTY MultiDimensional AS LOGIC GET _nCols > 0 PROPERTY Columns AS LONG GET (LONG) _nCols PROPERTY Rows AS LONG