[svn:parrot] r38353 - in trunk: lib/Parrot/Pmc2c src/pmc

whiteknight at svn.parrot.org whiteknight at svn.parrot.org
Sat Apr 25 17:23:12 UTC 2009


Author: whiteknight
Date: Sat Apr 25 17:23:11 2009
New Revision: 38353
URL: https://trac.parrot.org/parrot/changeset/38353

Log:
A fix for TT #544, plus proof-of-concept implementation in ManagedStruct PMC. Allows parsing arbitrary function pointers as ATTRs, to reduce the use of void* pointers floating around.

Modified:
   trunk/lib/Parrot/Pmc2c/Attribute.pm
   trunk/lib/Parrot/Pmc2c/PMCEmitter.pm
   trunk/lib/Parrot/Pmc2c/Parser.pm
   trunk/src/pmc/managedstruct.pmc

Modified: trunk/lib/Parrot/Pmc2c/Attribute.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Attribute.pm	Sat Apr 25 16:06:39 2009	(r38352)
+++ trunk/lib/Parrot/Pmc2c/Attribute.pm	Sat Apr 25 17:23:11 2009	(r38353)
@@ -99,6 +99,13 @@
     my $pmcname        = $pmc->{name};
     my $attrtype       = $self->{type};
     my $attrname       = $self->{name};
+    my $isfuncptr      = 0;
+    my $origtype       = $attrtype;
+    if($attrname =~ m/\(\*(\w*)\)\((.*?)\)/) {
+        $isfuncptr = 1;
+        $origtype = $attrtype . " (*)(" . $2 . ")";
+        $attrname = $1;
+    }
 
     # Store regexes used to check some types to avoid repetitions
     my $isptrtostring = qr/STRING\s*\*$/;
@@ -113,7 +120,14 @@
         if (PObj_is_object_TEST(pmc)) { \\
 EOA
 
-    if ($attrtype eq "INTVAL") {
+    if ($isfuncptr == 1) {
+        $decl .= <<"EOA";
+            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, \\
+                "Attributes of type '$origtype' cannot be " \\
+                "subclassed from a high-level PMC."); \\
+EOA
+    }
+    elsif ($attrtype eq "INTVAL") {
         $decl .= <<"EOA";
             PMC *attr_value = VTABLE_get_attr_str(interp, \\
                               pmc, Parrot_str_new_constant(interp, "$attrname")); \\
@@ -161,7 +175,14 @@
         if (PObj_is_object_TEST(pmc)) { \\
 EOA
 
-    if ($attrtype eq "INTVAL") {
+    if ($isfuncptr == 1) {
+        $decl .= <<"EOA";
+            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, \\
+                "Attributes of type '$origtype' cannot be " \\
+                "subclassed from a high-level PMC."); \\
+EOA
+    }
+    elsif ($attrtype eq "INTVAL") {
         $decl .= <<"EOA";
             PMC *attr_value = pmc_new(interp, enum_class_Integer); \\
             VTABLE_set_integer_native(interp, attr_value, value); \\

Modified: trunk/lib/Parrot/Pmc2c/PMCEmitter.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PMCEmitter.pm	Sat Apr 25 16:06:39 2009	(r38352)
+++ trunk/lib/Parrot/Pmc2c/PMCEmitter.pm	Sat Apr 25 17:23:11 2009	(r38353)
@@ -498,8 +498,12 @@
     my $attributes = $self->attributes;
     foreach my $attribute ( @$attributes ) {
         my $attrtype       = $attribute->{type};
+        my $attrname       = $attribute->{name};
         my $typeid = ':'; # Unhandled
-        if ($attrtype eq "INTVAL") {
+        if($attrname =~ m/\(*(\w+)\)\(.*?\)/) {
+            $attrname = $1;
+        }
+        elsif ($attrtype eq "INTVAL") {
             $typeid = 'I';
         }
         elsif ($attrtype eq "FLOATVAL") {
@@ -513,7 +517,7 @@
         }
 
         $cout .= $typeid;
-        $cout .= $attribute->name;
+        $cout .= $attrname;
         $cout .= ' ';
     }
 

Modified: trunk/lib/Parrot/Pmc2c/Parser.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Parser.pm	Sat Apr 25 16:06:39 2009	(r38352)
+++ trunk/lib/Parrot/Pmc2c/Parser.pm	Sat Apr 25 17:23:11 2009	(r38353)
@@ -135,7 +135,10 @@
 
         # name
         \s*
-        (\w+)
+        (
+            \w+
+          | \(\*\w*\)\(.*?\)
+        )
 
         # modifiers
         \s*

Modified: trunk/src/pmc/managedstruct.pmc
==============================================================================
--- trunk/src/pmc/managedstruct.pmc	Sat Apr 25 16:06:39 2009	(r38352)
+++ trunk/src/pmc/managedstruct.pmc	Sat Apr 25 17:23:11 2009	(r38353)
@@ -29,12 +29,12 @@
      * custom_free_func is called before the normal destroy() function does any
      * work.
      */
-    ATTR void *custom_free_func;
+    ATTR void (*custom_free_func)(PARROT_INTERP, void *, void *);
     ATTR void *custom_free_priv;
     /* if custom_clone_func is set, it will be called *instead* of the normal
      * clone() function logic.
      */
-    ATTR void *custom_clone_func;
+    ATTR PMC * (*custom_clone_func)(PARROT_INTERP, PMC *ptr, void *priv);
     ATTR void *custom_clone_priv;
 
 /*
@@ -86,8 +86,7 @@
     VTABLE void destroy() {
         void *ptr = PARROT_MANAGEDSTRUCT(SELF)->ptr;
         if (ptr) {
-            custom_free_func_t free_func =
-                (custom_free_func_t)PARROT_MANAGEDSTRUCT(SELF)->custom_free_func;
+            custom_free_func_t free_func = PARROT_MANAGEDSTRUCT(SELF)->custom_free_func;
             if (free_func) {
                 void *free_data = PARROT_MANAGEDSTRUCT(SELF)->custom_free_priv;
                 free_func(interp, ptr, free_data);
@@ -144,8 +143,7 @@
 */
 
     VTABLE PMC *clone() {
-        custom_clone_func_t clone_func =
-            (custom_clone_func_t)PARROT_MANAGEDSTRUCT(SELF)->custom_clone_func;
+        custom_clone_func_t clone_func = PARROT_MANAGEDSTRUCT(SELF)->custom_clone_func;
         PMC *dest;
         if (clone_func) {
             void *clone_data = PARROT_MANAGEDSTRUCT(SELF)->custom_clone_priv;


More information about the parrot-commits mailing list