administrator/pascalabcnet
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Add search at methods at typeclasses for restricted functions

Browse source
This commit is contained in:
Voloshin Bogdan 2018-05-21 04:14:18 +03:00
parent 16d7e37ce1
commit e55242a9ef
4 changed files with 65 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
CodeExamples/SimpleTypeclassesImplementation.pas
View file

@ -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<T>(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;

24
SyntaxVisitors/TypeclassVisitors/ReplaceTypeclassVisitor.cs
View file

@ -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<typeclass_param_list>();
@ -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<type_definition> { 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

26
TreeConverter/TreeConversion/syntax_tree_visitor.cs
View file

@ -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;

19
bin/Lib/PABCSystem.pas
View file

@ -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
// -----------------------------------------------------