Changeset 4262 for src/perl5

Timestamp:

06/01/05 13:28:02 (4 years ago)

Author:

clkao

svk:copy_cache_prev:

5801

Message:

Misc reference from p5 access fixes and tests.

Location:

src/perl5

Files:

• README (modified) (1 diff)
• perl5.c (modified) (10 diffs)
• pugsembed.c (modified) (2 diffs)

src/perl5/README

@@ -15 +15 @@
 them to actual caller P6 namespace.
 
-=item Reference args
+=item Reference access from perl5
 
-Make C<Getopt::Long> work.
+=over 
+
+=item scalar
+
+Make C<Getopt::Long> work.  C<MkValRef> gets dereferenced value, pending the fix to this.
+
+=item array
+
+C<STORE> / C<PUSH> fails, the array is correct in the accessor applied
+in perl5 tie, but not properly propogate back.  perhaps because args
+not marked as rw at the beginning.
+
+=item hash
+
+Requires C<eval_apply> to return multiple value so we can store the
+list for key iterator.
+
+=back
 
 =back

src/perl5/perl5.c

@@ -4 +4 @@
 #include "pugsembed.c"
 
-/* undefine to enable pugsembed debug messages */
+/* define to enable pugsembed debug messages */
+#define PERL5_EMBED_DEBUG 0
+
+#if PERL5_EMBED_DEBUG
+#define oRZ ""
+#define hate Perl_croak(aTHX_ "hate software")
+#else
 #define oRZ "#"
-#define hate Perl_croak(aTHX_ "hate software")
+#define hate
+#endif
 
 /* Workaround for mapstart: the only op which needs a different ppaddr */
@@ -37 +44 @@
 "            return $array; }\n\n"
 
+"sub Hash { my ($class, $val) = @_;\n"
+"           my $hash; tie %$hash, 'pugs::hash', $val;\n"
+oRZ"   warn 'returning '.$hash;\n"
+"            return $hash; }\n\n"
+
 "our $AUTOLOAD;\n"
 "sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n"
@@ -43 +55 @@
 
 "package pugs::array;\n"
+
+"our $AUTOLOAD;\n"
+"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n"
+"               warn 'unhandled supported: '.$type } \n"
+
 "sub TIEARRAY {\n"
 "       my ($class, $val) = @_;\n"
@@ -50 +67 @@
 "       my ($self, $index, $elem) = @_;\n"
 oRZ"    warn 'store! '.$elem;\n"
-"       pugs::guts::eval_apply('{ $^x[$^y] = $^z }', $$self, $index, $elem) }\n\n"
+"       pugs::guts::eval_apply('sub ($x is rw, $y, $z) { $x[$y] = $z;\n"
+oRZ"                                                     warn $x\n"
+"                               }', $$self, $index, $elem) }\n\n"
+
+"sub PUSH {\n"
+"       my ($self, $elem) = @_;\n"
+"       pugs::guts::eval_apply('sub ($x is rw, $z) { $x.push($z);\n"
+oRZ"                                                 warn $x\n"
+"                               }', $$self, $elem) }\n\n"
 
 "sub FETCHSIZE {\n"
 "       my ($self) = @_;\n"
 "       my $ret = pugs::guts::invoke('elems', $$self); \n"
-oRZ"    warn 'FETCHSIZE: '.$ret; $ret; }\n\n"
+oRZ"    warn 'FETCHSIZE: '.$ret;\n"
+"       $ret; }\n\n"
+
+"sub EXISTS {\n"
+"       my ($self, $index) = @_;\n"
+"       pugs::guts::eval_apply('sub ($x, $y) { $x.exists($y) }', $$self, $index) }\n"
 
 "sub FETCH {\n"
 "       my ($self, $index) = @_;\n"
-"       pugs::guts::eval_apply('{ $^x[$^y] }', $$self, $index) }\n"
+oRZ"    warn 'FETCH: '.$index;\n"
+"       pugs::guts::eval_apply('sub ($x, $y) { $x.[$y] }', $$self, $index) }\n"
+
+"package pugs::hash;\n"
+
+"our $AUTOLOAD;\n"
+"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n"
+"               warn 'unhandled supported: '.$type } \n"
+
+"sub TIEHASH {\n"
+"       my ($class, $val) = @_;\n"
+"       bless [$val,0], $class; }\n\n"
+
+"sub FIRSTKEY {\n"
+"       my ($self) = @_;\n"
+"       my $ret = pugs::guts::invoke('keys', $self->[0]); \n"
+oRZ"       warn $ret;\n"
+"       $self->[1] = 0; $self->[2] = $ret;"
+"       $self->NEXTKEY; }\n"
+
+"sub NEXTKEY {\n"
+"       my ($self) = @_;\n"
+"       return undef if $self->[1] > $#{$self->[2]};"
+"       $self->[2]->[$self->[1]++]; }"
+
+
 oRZ"warn 'compiled';\n"
 "1;\n";
@@ -68 +123 @@
     int i;
     dXSARGS;
-    if (items < 1)
+    if (items < 1) {
       hate;
+    }
 
     sv = ST(0);
@@ -102 +158 @@
     int i;
     dXSARGS;
-    if (items < 1)
+    if (items < 1) {
         hate;
+    }
 
     val = pugs_Eval(SvPV_nolen(ST(0)));
@@ -109 +166 @@
     stack = (Val **)malloc(sizeof(Val*)*items-1);
     for (i = 1; i < items; ++i) {
+#if PERL5_EMBED_DEBUG
         fprintf(stderr, "put into stack: %s\n", SvPV_nolen(ST(i)));
+#endif
         stack[i-1] = pugs_SvToVal(ST(i));
     }
@@ -213 +272 @@
     newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__);
 
-#ifndef oRZ
+#if PERL5_EMBED_DEBUG
     fprintf(stderr, "(%s)", pugs_guts_code);
 #endif
@@ -219 +278 @@
 
     if (SvTRUE(ERRSV)) {
-        fprintf(stderr, "Hate!\n");
         STRLEN n_a;
         printf("Error init perl: %s\n", SvPV(ERRSV,n_a));
@@ -308 +366 @@
     SPAGAIN;
 
-    /* fprintf(stderr, "%d is count\n", count); */
     Newz(42, out, count+1, SV*);
 

src/perl5/pugsembed.c

@@ -28 +28 @@
 
     type = pugs_Apply(pugs_PvToVal("&ref"), val, isa, G_SCALAR);
+#if PERL5_EMBED_DEBUG
     fprintf(stderr, "query the type: got %s\n", SvPV_nolen(type));
+#endif
     if (SvTRUE( type )) {
         SV **rv;
@@ -40 +42 @@
         }
         else {
+            /* for scalar ref, should still turn into tied one */
+#if PERL5_EMBED_DEBUG
             fprintf(stderr, "unknown type\n");
+#endif
         }
     }