Changeset 4231 for src/perl5

Timestamp:

06/01/05 01:23:56 (4 years ago)

Author:

clkao

svk:copy_cache_prev:

5801

Message:

Accessing p6 array(ref) in perl5, almost.

Location:

src/perl5

Files:

• perl5.c (modified) (4 diffs)
• pugsembed.c (modified) (1 diff)

src/perl5/perl5.c

@@ -16 +16 @@
 const char pugs_guts_code[] =
 "use strict;"
+
 "package pugs;"
 
@@ -21 +22 @@
 "sub AUTOLOAD { pugs::guts::invoke($AUTOLOAD, @_) } "
 "sub DESTROY {}"
+
 "package pugs::guts;"
 "our @ISA=('pugs');"
-"sub code { my ($class, $val) = @_;"
-"          sub { pugs::guts::invoke($val, undef, @_) } }"
+"sub Block { my ($class, $val) = @_;"
+"            sub { pugs::guts::invoke($val, undef, @_) } }"
+
+"sub Array { my ($class, $val) = @_;"
+"            my $array; tie @$array, 'pugs::array', $val;"
+"      warn 'returning '.$array;"
+"            return $array; }"
+
+"our $AUTOLOAD;"
+"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;"
+"               return if $type =~ m/^[A-Z]*$/; die 'unhandled supported type: '.$type } "
+"warn 'compiled .'.__PACKAGE__;"
+
+"package pugs::array;"
+"sub TIEARRAY {"
+"       my ($class, $val) = @_;"
+"       bless \\$val, $class; }"
+
+"sub STORE {"
+"       my ($self, $index, $elem) = @_;"
+"       warn 'store! '.$elem;"
+"       pugs::guts::eval_apply('{ $^x[$^y] = $^z }', $$self, $index, $elem) }"
+
+"sub FETCHSIZE {"
+"       my ($self) = @_;"
+"       my $ret = pugs::guts::invoke('elems', $$self); "
+"       warn 'FETCHSIZE: '.$ret; $ret; }"
+
+"sub FETCH {"
+"       my ($self, $index) = @_;"
+"       pugs::guts::eval_apply('{ $^x[$^y] }', $$self, $index) }"
+"warn 'compiled';"
 "1;";
-
-XS(_pugs_guts_eval) {
-    Val *val;
-
-    dXSARGS;
-    if (items < 1)
-        Perl_croak(aTHX_ "hate software");
-    val = pugs_Eval ( SvPV_nolen(ST(0)) );
-    ST(0) = pugs_ValToSv ( val );
-
-    XSRETURN(1);
-}
 
 XS(_pugs_guts_invoke) {
@@ -68 +88 @@
     ST(0) = pugs_Apply(val, inv, stack, GIMME_V);
     /* sv_dump (ret); */
+    free (stack);
+    
+    XSRETURN(1);
+}
+
+
+XS(_pugs_guts_eval_apply) {
+    Val *val, *inv, **stack;
+    int i;
+    dXSARGS;
+    if (items < 1)
+        Perl_croak(aTHX_ "hate software");
+
+    val = pugs_Eval(SvPV_nolen(ST(0)));
+
+    stack = (Val **)malloc(sizeof(Val*)*items-1);
+    for (i = 1; i < items; ++i) {
+        fprintf(stderr, "put into stack: %s\n", SvPV_nolen(ST(i)));
+        stack[i-1] = pugs_SvToVal(ST(i));
+    }
+    stack[i-1] = NULL;
+    
+    ST(0) = pugs_Apply(val, NULL, stack, GIMME_V);
     free (stack);
     
@@ -164 +207 @@
 
     newXS((char*) "pugs::guts::invoke", _pugs_guts_invoke, (char*)__FILE__);
-    newXS((char*) "pugs::guts::eval", _pugs_guts_eval, (char*)__FILE__);
-
+    newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__);
+
+    fprintf(stderr, "(%s)", pugs_guts_code);
     eval_pv(pugs_guts_code, TRUE);
 
     if (SvTRUE(ERRSV)) {
+        fprintf(stderr, "Hate!\n");
         STRLEN n_a;
         printf("Error init perl: %s\n", SvPV(ERRSV,n_a));

src/perl5/pugsembed.c

@@ -17 +17 @@
     SV *sv = newSV(0);
     Val *isa[2];
-    SV *stack[8];
+    SV *stack[8], *type;
 
     sv_setref_pv(sv, "pugs", val);
 
-    isa[0] = pugs_PvToVal("Code");
-    isa[1] = NULL;
-    if (SvTRUE(pugs_Apply(pugs_PvToVal("&isa"), val, isa, G_SCALAR))) {
-        if (__init) {
-            SV **rv;
+    if (!__init) {
+        fprintf(stderr, "MkValRef called before perl_init.\n");
+    }
+
+    isa[0] = NULL;
+
+    type = pugs_Apply(pugs_PvToVal("&ref"), val, isa, G_SCALAR);
+    fprintf(stderr, "query the type: got %s\n", SvPV_nolen(type));
+    if (SvTRUE( type )) {
+        SV **rv;
+        stack[0] = type;
+        stack[1] = NULL;
+        rv = perl5_apply(newSVpv("can", 0), newSVpv("pugs::guts", 0), stack, NULL, G_SCALAR);
+        if (SvTRUE( rv[0] )) {
             stack[0] = sv;
-            stack[1] = NULL;
-            rv = perl5_apply(newSVpv("code", 0), newSVpv("pugs::guts", 0), stack, NULL, G_SCALAR);
+            rv = perl5_apply(type, newSVpv("pugs::guts", 0), stack, NULL, G_SCALAR);
             sv = rv[0];
         }
         else {
-            fprintf(stderr, "MkValRef called before perl_init.\n");
+            fprintf(stderr, "unknown type\n");
         }
     }
+
     return (sv);
 }