diff --git a/CodeExamples/SimpleTypeclassesImplementation.pas b/CodeExamples/SimpleTypeclassesImplementation.pas index 99f99fb43..6416fc73a 100644 --- a/CodeExamples/SimpleTypeclassesImplementation.pas +++ b/CodeExamples/SimpleTypeclassesImplementation.pas @@ -1,4 +1,4 @@ -uses System; +uses System, PABCSystem; type TMonthType = (January, February, March, April, May, June, July, August, September, October, November, December); @@ -131,7 +131,7 @@ function ArrayEq(l1, l2: array of T): boolean; where Eq[T]; begin Result := true; for var i :=0 to l1.Length - 1 do - if Eq&[T].notEqual(l1[i], l2[i]) then + if notEqual(l1[i], l2[i]) then begin Result := false; break; @@ -163,7 +163,7 @@ begin var sorted := true; for var j := 0 to a.Length - 1 - i do begin - if Ord&[T].greater(a[j], a[j + 1]) then + if greater(a[j], a[j + 1]) then begin swap(a[j], a[j + 1]); sorted := false; diff --git a/SyntaxVisitors/TypeclassVisitors/ReplaceTypeclassVisitor.cs b/SyntaxVisitors/TypeclassVisitors/ReplaceTypeclassVisitor.cs index c609eb11b..e0c47acc3 100644 --- a/SyntaxVisitors/TypeclassVisitors/ReplaceTypeclassVisitor.cs +++ b/SyntaxVisitors/TypeclassVisitors/ReplaceTypeclassVisitor.cs @@ -276,7 +276,7 @@ namespace SyntaxVisitors.TypeclassVisitors var procDef = new procedure_definition( memberHeaderNew, new statement_list( - GetInstanceSingleton(templateName), + GetInstanceSingletonVarStatement(templateName), exec)); cdbNew.Add(procDef); } @@ -355,7 +355,9 @@ namespace SyntaxVisitors.TypeclassVisitors { var typeclassWhere = where as where_typeclass_constraint; var newName = TypeclassRestrctionToTemplateName(typeclassWhere.restriction.name, typeclassWhere.restriction.restriction_args); - + newName.attributes = new attribute_list(new simple_attribute_list(new attribute(null, + new named_type_reference("__TypeclassGenericParameter"), + new expression_list(new string_const(GetInstanceSingletonName(newName.name)))))); additionalTemplateArgs.Add(newName); // Create name for template that replaces typeclass(for ex. SumTC) @@ -377,7 +379,7 @@ namespace SyntaxVisitors.TypeclassVisitors var blockProc = (_procedure_definition.proc_body as block); foreach (var arg in additionalTemplateArgs.idents) { - blockProc.program_code.AddFirst(GetInstanceSingleton(arg.name)); + blockProc.program_code.AddFirst(GetInstanceSingletonVarStatement(arg.name)); } //var list = _procedure_definition.proc_body.DescendantNodes().OfType(); @@ -402,20 +404,30 @@ namespace SyntaxVisitors.TypeclassVisitors var procedureDefTranslated = new procedure_definition( headerTranslated, _procedure_definition.proc_body, _procedure_definition.is_short_definition, _procedure_definition.source_context); - + procedureDefTranslated.proc_header.attributes = _procedure_definition.proc_header.attributes; + if (procedureDefTranslated.proc_header.attributes == null) + { + procedureDefTranslated.proc_header.attributes = new attribute_list(); + } + procedureDefTranslated.proc_header.attributes.Add(new simple_attribute_list(new attribute(null, new named_type_reference("__TypeclassRestrictedFunctionAttribute"), new expression_list()))); Replace(_procedure_definition, procedureDefTranslated); } - private static var_statement GetInstanceSingleton(string typeName) + private static var_statement GetInstanceSingletonVarStatement(string typeName) { return new var_statement(new var_def_statement( - typeName + "Instance", + GetInstanceSingletonName(typeName), new dot_node( new ident_with_templateparams(new ident("__ConceptSingleton"), new template_param_list(new List { new named_type_reference(typeName) })), new ident("Instance") ))); } + private static string GetInstanceSingletonName(string typeName) + { + return typeName + "Instance"; + } + private static where_definition GetWhereRestriction(type_definition restriction, ident templateName) { return // where diff --git a/TreeConverter/TreeConversion/syntax_tree_visitor.cs b/TreeConverter/TreeConversion/syntax_tree_visitor.cs index 3b06c893b..509d4e6d9 100644 --- a/TreeConverter/TreeConversion/syntax_tree_visitor.cs +++ b/TreeConverter/TreeConversion/syntax_tree_visitor.cs @@ -4908,8 +4908,30 @@ namespace PascalABCCompiler.TreeConverter } } } + + // Typeclasses voloshinbogdan 2018.21.05 - search methods at typeclasses + if (sil == null) + { + var testTopFunctionForTypeclassRestriction = context.func_stack.top()?.attributes?.Any(x => x.AttributeType.name == "__TypeclassRestrictedFunctionAttribute"); + if (testTopFunctionForTypeclassRestriction.HasValue && testTopFunctionForTypeclassRestriction.Value && sil == null) + { + var func = context.func_stack.top(); + var typeclasses = func.generic_params.Where(x => x.Attributes != null && x.Attributes.Any(attr => attr.AttributeType.name == "__TypeclassGenericParameterAttribute")); + foreach (var item in typeclasses) + { + var args = item.Attributes.First(x => x.AttributeType.name == "__TypeclassGenericParameterAttribute").Arguments; + var silTmp = (item as type_node)?.find_in_type(id.name, context.CurrentScope); + if (silTmp != null) + { + deref_value = new dot_node((args.First() as string_const_node).constant_value, id); + break; + } + } + } + } + // ! Typeclasses } - else + if (sil == null) { SyntaxTree.dot_node _dot_node = deref_value as SyntaxTree.dot_node; if (_dot_node != null) @@ -10996,6 +11018,8 @@ namespace PascalABCCompiler.TreeConverter id.name, SemanticTree.type_access_level.tal_public, context.converted_namespace, convertion_data_and_alghoritms.symbol_table.CreateInterfaceScope(null, SystemLibrary.SystemLibrary.object_type.Scope, null), get_location(id)); + // voloshinbogdan 2018.05.21 Fix missing attributes translation for generic parameters + make_attributes_for_declaration(id, par); SystemLibrary.SystemLibrary.init_reference_type(par); par.SetBaseType(SystemLibrary.SystemLibrary.object_type); par.generic_function_container = cfn; diff --git a/bin/Lib/PABCSystem.pas b/bin/Lib/PABCSystem.pas index 85884ab4b..f2941d365 100644 --- a/bin/Lib/PABCSystem.pas +++ b/bin/Lib/PABCSystem.pas @@ -2073,6 +2073,25 @@ type end; end; + +type + ///-- + __TypeclassRestrictedFunctionAttribute = class(Attribute) + public + constructor; + begin + end; + end; + + + ///-- + __TypeclassGenericParameterAttribute = class(Attribute) + public + constructor(instanceName: string); + begin + end; + end; + // ----------------------------------------------------- // Internal procedures for PABCRTL.dll // -----------------------------------------------------