[svn] r5919: nemerle/trunk: lib/internal.n macros/Util.n
ncc/external/InternalTypes.n ncc/external/Librari...
malekith
svnadmin at nemerle.org
Wed Nov 9 00:50:17 CET 2005
Log:
First sketch of extensible matching implementation ( http://nemerle.org/Extensible_matching ).
Author: malekith
Date: Wed Nov 9 00:50:13 2005
New Revision: 5919
Added:
nemerle/trunk/ncc/testsuite/positive/extensible-matching.n
nemerle/trunk/ncc/testsuite/positive/extensible-matching2.n
Modified:
nemerle/trunk/lib/internal.n
nemerle/trunk/macros/Util.n
nemerle/trunk/ncc/external/InternalTypes.n
nemerle/trunk/ncc/external/LibrariesLoader.n
nemerle/trunk/ncc/generation/HierarchyEmitter.n
nemerle/trunk/ncc/hierarchy/TypeInfo.n
nemerle/trunk/ncc/typing/Typer-PatternTyper.n
Modified: nemerle/trunk/lib/internal.n
==============================================================================
--- nemerle/trunk/lib/internal.n (original)
+++ nemerle/trunk/lib/internal.n Wed Nov 9 00:50:13 2005
@@ -26,6 +26,8 @@
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
+using Nemerle.Utility;
+
namespace Nemerle.Internal
{
public class NemerleAttribute : System.Attribute
@@ -152,6 +154,20 @@
global_ctx = ctx;
}
}
+
+ [System.AttributeUsage (System.AttributeTargets.Class, AllowMultiple = true)]
+ [Record]
+ public sealed class ExtensionPatternEncodingAttribute : NemerleAttribute
+ {
+ [Accessor]
+ name : string;
+
+ [Accessor]
+ identifiers : string;
+
+ [Accessor]
+ pattern : string;
+ }
}
namespace Nemerle.Utility
Modified: nemerle/trunk/macros/Util.n
==============================================================================
--- nemerle/trunk/macros/Util.n (original)
+++ nemerle/trunk/macros/Util.n Wed Nov 9 00:50:13 2005
@@ -242,4 +242,39 @@
current_type.Define (prop);
}
}
+
+
+ [Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
+ Nemerle.MacroTargets.Class,
+ Inherited = false, AllowMultiple = true)]
+ macro ExtensionPattern (par : TypeBuilder, e)
+ {
+ def get_name (e) {
+ | <[ $(id : dyn) ]> => Some (id)
+ | _ => None ()
+ }
+
+ match (e) {
+ | <[ $(id : dyn) ( .. $ids ) = $pat ]>
+ when ids.ForAll (fun (x) { get_name (x).IsSome }) =>
+ def ids = ids.Map (get_name).Map (Option.UnSome);
+ par.GetModifiers ().AddCustomAttribute (<[
+ Nemerle.Internal.ExtensionPatternEncodingAttribute (
+ $(id : string),
+ $(ids.ToString (",") : string),
+ $(pat.ToString () : string))
+ ]>);
+
+ def ext =
+ ExtensionPattern (parent = par,
+ name = id,
+ pattern = pat,
+ identifiers = ids);
+ par.AddExtensionPattern (ext)
+
+ | _ =>
+ Message.FatalError ("ExtensionPattern syntax is ``name (id_1, "
+ "..., id_n) = pattern''")
+ }
+ }
}
Modified: nemerle/trunk/ncc/external/InternalTypes.n
==============================================================================
--- nemerle/trunk/ncc/external/InternalTypes.n (original)
+++ nemerle/trunk/ncc/external/InternalTypes.n Wed Nov 9 00:50:13 2005
@@ -136,6 +136,11 @@
get { InternalType.TypeAliasAttribute_tc.SystemType }
}
+ public ExtensionPatternEncodingAttribute : System.Type
+ {
+ get { InternalType.ExtensionPatternEncodingAttribute_tc.SystemType }
+ }
+
/**
* Reflects a type using NamespaceTree
*/
@@ -369,6 +374,7 @@
public mutable VariantOptionAttribute_tc : TypeInfo;
public mutable VolatileModifier_tc : TypeInfo;
public mutable ConstantVariantOptionAttribute_tc : TypeInfo;
+ public mutable ExtensionPatternEncodingAttribute_tc : TypeInfo;
public mutable FlagsAttribute_tc : TypeInfo;
public mutable ParamArrayAttribute_tc : TypeInfo;
public mutable AssemblyVersionAttribute_tc : TypeInfo;
@@ -574,6 +580,8 @@
InternalType.VariantOptionAttribute_tc = lookup ("Nemerle.Internal.VariantOptionAttribute");
InternalType.VolatileModifier_tc = lookup ("Nemerle.Internal.VolatileModifier");
InternalType.ConstantVariantOptionAttribute_tc = lookup ("Nemerle.Internal.ConstantVariantOptionAttribute");
+ InternalType.ExtensionPatternEncodingAttribute_tc = lookup ("Nemerle.Internal.ExtensionPatternEncodingAttribute");
+
InternalType.Nemerle_list_tc = lookup ("Nemerle.Core.list");
}
}
Modified: nemerle/trunk/ncc/external/LibrariesLoader.n
==============================================================================
--- nemerle/trunk/ncc/external/LibrariesLoader.n (original)
+++ nemerle/trunk/ncc/external/LibrariesLoader.n Wed Nov 9 00:50:13 2005
@@ -2040,6 +2040,8 @@
tydecl = TypeDeclaration.Enum ()
else
tydecl = TypeDeclaration.Class ();
+
+ decode_extension_patterns ();
}
public override GetTydecl () : TypeDeclaration
@@ -2051,6 +2053,28 @@
{
constant_object
}
+
+ decode_extension_patterns () : void
+ {
+ def t = SystemType.ExtensionPatternEncodingAttribute;
+ def attrs = system_type.GetCustomAttributes (t, false);
+ when (attrs.Length > 0) {
+ def get_ids = t.GetMethod ("get_Identifiers");
+ def get_pat = t.GetMethod ("get_Pattern");
+ def get_name = t.GetMethod ("get_Name");
+ foreach (attr_obj in attrs) {
+ def ids = get_ids.Invoke (attr_obj, null) :> string;
+ def pat = get_pat.Invoke (attr_obj, null) :> string;
+ def name = get_name.Invoke (attr_obj, null) :> string;
+ def ext = ExtensionPattern (parent = this,
+ identifiers = NString.Split (ids, [',']),
+ pattern = MainParser.ParseExpr (GlobalEnv.Core, pat),
+ name = name);
+
+ AddExtensionPattern (ext);
+ }
+ }
+ }
}
}
} /* namespace */
Modified: nemerle/trunk/ncc/generation/HierarchyEmitter.n
==============================================================================
--- nemerle/trunk/ncc/generation/HierarchyEmitter.n (original)
+++ nemerle/trunk/ncc/generation/HierarchyEmitter.n Wed Nov 9 00:50:13 2005
@@ -457,7 +457,10 @@
when (custom_attribute != null) {
Manager.contains_nemerle_specifics = true;
type_builder.SetCustomAttribute (custom_attribute);
- };
+ }
+
+ when (extension_patterns.Count > 0)
+ Manager.contains_nemerle_specifics = true;
// Structs with no fields need to have at least one byte.
// The right thing would be to set the PackingSize in a DefineType
Modified: nemerle/trunk/ncc/hierarchy/TypeInfo.n
==============================================================================
--- nemerle/trunk/ncc/hierarchy/TypeInfo.n (original)
+++ nemerle/trunk/ncc/hierarchy/TypeInfo.n Wed Nov 9 00:50:13 2005
@@ -148,6 +148,8 @@
protected mutable member_map : Hashtable [string, list [IMember]];
+ protected extension_patterns : Hashtable [string, ExtensionPattern] = Hashtable ();
+
protected namespace_nd : NamespaceTree.Node;
public this (ns_node : NamespaceTree.Node)
@@ -170,6 +172,26 @@
[m];
}
+ public AddExtensionPattern (e : ExtensionPattern) : void
+ {
+ if (GetExtensionPattern (e.Name).IsSome)
+ Message.Error ("the extension pattern `$(e.Name)' is already defined on $this (or its supertype)");
+ else
+ extension_patterns [e.Name] = e;
+ }
+
+ public GetExtensionPattern (name : string) : option [ExtensionPattern]
+ {
+ match (extension_patterns.Get (name)) {
+ | None =>
+ match (SuperClass ()) {
+ | Some (tc) => tc.GetExtensionPattern (name)
+ | None => None ()
+ }
+ | x => x
+ }
+ }
+
#region Builtins
protected mutable special_members : Hashtable [string, list [IMember]];
protected MakeSingleParm (name : string) : void
Added: nemerle/trunk/ncc/testsuite/positive/extensible-matching.n
==============================================================================
--- (empty file)
+++ nemerle/trunk/ncc/testsuite/positive/extensible-matching.n Wed Nov 9 00:50:13 2005
@@ -0,0 +1,56 @@
+#pragma indent
+using Nemerle.Utility
+
+[ExtensionPattern ( Node (t1, el, t2) = SNode (t1, el, t2, _) )] \
+public variant Tree
+ | SNode
+ l : Tree
+ e : int
+ r : Tree
+ size : int
+ | Nil
+
+ Size : int
+ get
+ match (this)
+ | SNode (_,_,_,s) => s
+ | Nil => 0
+
+ public Node (l : Tree, e : int, r : Tree) : Tree
+ SNode (l, e, r, l.Size + r.Size + 1)
+
+ public Insert (e : int) : Tree
+ match (this)
+ | Node (l, e', r) =>
+ if (e < e') l.Insert (e)
+ else if (e > e') r.Insert (e)
+ else this
+ | Nil =>
+ Node (Nil (), e, Nil ())
+
+
+def t = Tree.Nil ().Insert (1).Insert (2).Insert (3)
+
+match (t)
+ | Node (_, e, _) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+match (t)
+ | Tree.Node (_, e, _) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+match (t)
+ | Tree.Node (el = e) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+
+/*
+BEGIN-OUTPUT
+3
+3
+3
+END-OUTPUT
+*/
Added: nemerle/trunk/ncc/testsuite/positive/extensible-matching2.n
==============================================================================
--- (empty file)
+++ nemerle/trunk/ncc/testsuite/positive/extensible-matching2.n Wed Nov 9 00:50:13 2005
@@ -0,0 +1,28 @@
+// REFERENCE: extensible-matching.exe
+#pragma indent
+
+def t = Tree.Nil ().Insert (1).Insert (2).Insert (3)
+
+match (t)
+ | Node (_, e, _) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+match (t)
+ | Tree.Node (_, e, _) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+match (t)
+ | Tree.Node (el = e) =>
+ System.Console.WriteLine (e)
+ | Nil => assert (false)
+
+
+/*
+BEGIN-OUTPUT
+3
+3
+3
+END-OUTPUT
+*/
Modified: nemerle/trunk/ncc/typing/Typer-PatternTyper.n
==============================================================================
--- nemerle/trunk/ncc/typing/Typer-PatternTyper.n (original)
+++ nemerle/trunk/ncc/typing/Typer-PatternTyper.n Wed Nov 9 00:50:13 2005
@@ -27,6 +27,7 @@
*/
using Nemerle.Collections;
+using Nemerle.Utility;
using Nemerle.Compiler;
using Nemerle.Compiler.Typedtree;
@@ -36,6 +37,117 @@
namespace Nemerle.Compiler
{
+ // pattern Foo (x1, x2, ..., xN) = expr
+ // Name = "Foo",
+ // Identifiers = ["x1", ..., "xN"]
+ // Pattern = expr
+ [Record]
+ public class ExtensionPattern
+ {
+ [Accessor]
+ parent : TypeInfo;
+
+ [Accessor]
+ name : string;
+
+ [Accessor]
+ identifiers : list [string];
+
+ [Accessor]
+ pattern : PT.PExpr;
+
+ public override ToString () : string
+ {
+ $ "extension pattern $parent.$name"
+ }
+
+ internal Transform (e : PT.PExpr) : PT.PExpr
+ {
+ def messenger = Passes.Solver.CurrentMessenger;
+
+ def is_assignment (expr) {
+ expr is PT.PExpr.Assign (PT.PExpr.Ref, _)
+ }
+
+ def add_wildcards (ids = Identifiers, m = Map ()) {
+ ids.FoldLeft (m, fun (id, m) { m.Add (id, <[ _ ]>) })
+ }
+
+ def handle_assigns (assigns) {
+ def (remaining, map) =
+ assigns.FoldLeft ((Identifiers, Map ()), fun (assign, acc) {
+ def (remaining, map) = acc;
+ match (assign) {
+ | <[ $(n : dyn) = $pat ]> =>
+ if (remaining.Contains (n)) {
+ (remaining.Remove (n), map.Add (n, pat))
+ } else if (Identifiers.Contains (n)) {
+ ReportError (messenger,
+ $ "the pattern for `$n' was already specified");
+ acc
+ } else {
+ ReportError (messenger,
+ $ "$this does not contain a field named `$n'");
+ acc
+ }
+ | _ => Util.ice ()
+ }
+ });
+ add_wildcards (remaining, map)
+ }
+
+ def handle_pats (pats) {
+ if (pats.Length != Identifiers.Length) {
+ ReportError (messenger,
+ $ "$this expects $(Identifiers.Length) patterns "
+ "as arguments, got $(pats.Length)");
+ add_wildcards ()
+ } else
+ List.FoldLeft2 (Identifiers, pats, Map (),
+ fun (n, p, m) { m.Add (n, p) });
+ }
+
+ def map =
+ match (e) {
+ | <[ _ ]> =>
+ add_wildcards ()
+
+ | <[ () ]> =>
+ unless (Identifiers is [])
+ ReportError (messenger,
+ $ "$this needs $Identifiers as parameters");
+ add_wildcards ()
+
+ | <[ $assign ]> when is_assignment (assign) =>
+ handle_assigns ([assign])
+
+ | <[ ( .. $assigns ) ]> when assigns.ForAll (is_assignment) =>
+ handle_assigns (assigns)
+
+ | <[ ( .. $pats ) ]> =>
+ handle_pats (pats)
+
+ | <[ $pat ]> =>
+ handle_pats ([pat])
+ }
+
+ def rename (_, is_post, e) {
+ match (e) {
+ | <[ $(n : dyn) ]> when is_post =>
+ match (map.Find (n)) {
+ | Some (e') => e'
+ | _ => e
+ }
+ | _ => e
+ }
+ }
+
+ def res = Macros.TraverseExpr (None (), Pattern, true, rename);
+ Message.Debug ($ "expand: $Pattern -> $res");
+ res
+ }
+ }
+
public partial class Typer
{
class PatternTyper
@@ -383,8 +495,50 @@
lookup (ti)
| [] =>
+ def ext_pattern =
+ match ((idl, matched_value_type.Hint)) {
+ | ([name], Some (MType.Class (tc, _))) =>
+ tc.GetExtensionPattern (name)
+ | _ =>
+ def (typ, field) = idl.DivideLast ();
+ def patterns =
+ env.LookupSymbol (typ, typer.current_type).FoldLeft ([],
+ fun (tc, acc) {
+ match (tc) {
+ | tc is TypeInfo =>
+ match (tc.GetExtensionPattern (field)) {
+ | Some (ext) => ext :: acc
+ | None => acc
+ }
+ | _ => acc
+ }
+ });
+ match (patterns) {
+ | [] => None ()
+ | [e] => Some (e)
+ | x =>
+ ReportError (messenger, $ "overloading ambiguity $(x.ToString (\", \"))");
+ None ()
+ }
+ }
+
+ match (ext_pattern) {
+ | Some (e) =>
+ def option_type = e.Parent.GetFreshType ();
+ if (matched_value_type.Require (option_type)) {
+ TypePattern (matched_value_type, e.Transform (pattern))
+ } else {
+ ReportError (messenger,
+ $ "the matched value type "
+ "$matched_value_type was expected "
+ "to be compatible with $option_type");
+ Pattern.Error ()
+ }
+
+ | _ =>
ReportError (messenger, $ "unbound type name $(idl.ToString (\".\"))");
Pattern.Error ()
+ }
| x =>
ReportError (messenger, $ "overloading ambiguity $(x.ToString (\", \"))");
@@ -531,7 +685,6 @@
| PT.PExpr.Call (PT.PExpr.Ref (n), _) when ConstantFolder.is_known_operator (n.Id) =>
-
def folded = ConstantFolder.FoldConstants (typer.env, pattern);
// constant folder will return the same object if it didn't do anything
if ((folded : object) == pattern) {
More information about the svn
mailing list