Changeset 6801

Timestamp:

09/06/05 17:00:17 (3 years ago)

Author:

iblech

Message:

* Usual svn props.
* t/var/constant.t: Minor fixes.
* Pugs.PIL1, Pugs.Compile: PSub and PCode contain a p[Sub]?IsMulti? field now,

so PIL2JS and PIL-Run can know which subs are multis and which subs are not.

* Pugs.CodeGen?.PIR: Accomodate for the above change.
* PIL2JS: (Simple) multi subs!

• PIL2JS.js: If necessary, try to call all .variants of a multi to find out whether the parameters match the sub signature. (Hack)
• PIL::Subs: Emit appropriate code for multis --

multi foo {...} # is compiled as
our &foo ::= PIL2JS.new_multi(); &foo.add_variant({...});

* Test.pm: Removed the skip_rest_anti_multi-hack which was previously needed

for PIL2JS. :)

Files:

• debian/patches/00list (modified) (2 props)
• debian/patches/10smoker.dpatch (modified) (2 props)
• debian/smoker.yml (modified) (2 props)
• ext/Test/lib/Test.pm (modified) (1 diff)
• perl5/PIL2JS/lib/PIL.pm (modified) (1 diff)
• perl5/PIL2JS/lib/PIL/Subs.pm (modified) (5 diffs)
• perl5/PIL2JS/libjs/PIL2JS.js (modified) (2 diffs)
• src/Pugs/CodeGen/PIR.hs (modified) (4 diffs)
• src/Pugs/Compile.hs (modified) (6 diffs)
• src/Pugs/PIL1.hs (modified) (9 diffs)
• src/Pugs/PIL1.hs-drift (modified) (2 diffs)
• t/var/constant.t (modified) (4 diffs)
• util/cperl6-mode.el (modified) (2 props)

ext/Test/lib/Test.pm

@@ -182 +182 @@
 multi sub skip (Int $count, Str $reason, +$depends) returns Bool is export {
     for (1 .. $count) {
-        # Hack -- PIL2JS doesn't support multisubs yet
-        if $*OS eq "browser" {
-            Test::proclaim(1, "", "skip $reason", :depends($depends));
-        } else {
-            Test::skip $reason, :depends($depends);
-        }
+        Test::skip $reason, :depends($depends);
     }
 }

perl5/PIL2JS/lib/PIL.pm

@@ -201 +201 @@
   # B.pm: use A; my $a = 4;  # ==> my $a_1 = 4; XXX!
 
-  {
-    my %seen;
-    $self->{pilGlob} = [grep { not $seen{$_->{pSubName}}++ } @{ $self->{pilGlob} }];
-  }
+  #{
+  #  my %seen;
+  #  $self->{pilGlob} = [grep { not $seen{$_->{pSubName}}++ } @{ $self->{pilGlob} }];
+  #}
 
   my $fixed_tree = $self->fixup;

perl5/PIL2JS/lib/PIL/Subs.pm

@@ -14 +14 @@
 
   sub prefix { "Sub" }
-  sub name   :lvalue { $_[0]->{pSubName}   }
-  sub type   :lvalue { $_[0]->{pSubType}   }
-  sub params :lvalue { $_[0]->{pSubParams} }
-  sub lvalue :lvalue { $_[0]->{pSubLValue} }
-  sub body   :lvalue { $_[0]->{pSubBody}   }
+  sub name   :lvalue { $_[0]->{pSubName}    }
+  sub type   :lvalue { $_[0]->{pSubType}    }
+  sub params :lvalue { $_[0]->{pSubParams}  }
+  sub lvalue :lvalue { $_[0]->{pSubLValue}  }
+  sub body   :lvalue { $_[0]->{pSubBody}    }
+  sub multi  :lvalue { $_[0]->{pSubIsMulti} }
 
   sub fixup {
@@ -55 +56 @@
       if $self->name =~ /^__export_c.*import$/;
 
-    my $js = sprintf
-      "%s%s = new PIL2JS.Box(%s.FETCH());\n%s.FETCH().pil2js_name = %s;\n",
-      $PIL::IN_GLOBPIL ? "" : "var ",
+    my $def  = sprintf "new PIL2JS.Box(%s.FETCH())",  $self->SUPER::as_js;
+    my $name = sprintf "%s.FETCH().pil2js_name = %s",
       PIL::name_mangle($self->name),
-      $self->SUPER::as_js,
-      PIL::name_mangle($self->name),
+      PIL::doublequote(($self->name =~ /^&.*::(?:prefix:|postfix:|infix:|circumfix:|coerce:|self:|term:|postcircumfix:|rule_modifier:|trait_verb:|trait_auxiliary:|scope_declarator:|statement_control:|infix_postfix_meta_operator:|postfix_prefix_meta_operator:|prefix_postfix_meta_operator:|infix_circumfix_meta_operator:)?(.+)$/)[0] or $self->name);
       # "or $self->name" needed for the /^__export/ and /^__init/ subs.
-      PIL::doublequote(($self->name =~ /^&.*::(?:prefix:|postfix:|infix:|circumfix:|coerce:|self:|term:|postcircumfix:|rule_modifier:|trait_verb:|trait_auxiliary:|scope_declarator:|statement_control:|infix_postfix_meta_operator:|postfix_prefix_meta_operator:|prefix_postfix_meta_operator:|infix_circumfix_meta_operator:)?(.+)$/)[0] or $self->name);
+
+    my $decl = $self->multi
+      ? sprintf "if(!%s) var %s = new PIL2JS.Box(PIL2JS.new_multi());\n%s.FETCH().pil2js_multi.add_variant(%s, %d)",
+        PIL::name_mangle($self->name),
+        PIL::name_mangle($self->name),
+        PIL::name_mangle($self->name),
+        $def,
+        $self->arity
+      : sprintf "%s%s = %s;",
+        $PIL::IN_GLOBPIL ? "" : "var ",
+        PIL::name_mangle($self->name),
+        $def;
+    my $js = "$decl;\n$name;\n";
 
     # Special magic for methods.
@@ -96 +107 @@
   sub prefix { "" }
   sub name   { "<anonymous@{[$PIL::CUR_SUBNAME ? ' in ' . $PIL::CUR_SUBNAME : '']}>" }
-  sub type   :lvalue { $_[0]->{pType}   }
-  sub params :lvalue { $_[0]->{pParams} }
-  sub lvalue :lvalue { $_[0]->{pLValue} }
-  sub body   :lvalue { $_[0]->{pBody}   }
+  sub arity  { $_[0]->params->arity }
+  sub type   :lvalue { $_[0]->{pType}    }
+  sub params :lvalue { $_[0]->{pParams}  }
+  sub lvalue :lvalue { $_[0]->{pLValue}  }
+  sub body   :lvalue { $_[0]->{pBody}    }
+  sub multi  :lvalue { $_[0]->{pIsMulti} }
 
   sub fixup {
@@ -120 +133 @@
         ? (pSubName => $self->name)
         : (),
-      "p" . $self->prefix . "Type"   => $self->type,
-      "p" . $self->prefix . "LValue" => $self->lvalue,
+      "p" . $self->prefix . "Type"    => $self->type,
+      "p" . $self->prefix . "LValue"  => $self->lvalue,
+      "p" . $self->prefix . "IsMulti" => $self->multi,
       $self->params->fixup(
         $self->prefix,
@@ -199 +213 @@
     my $wrappedbody = "$new_pad;\n$callchain$magical_vars\n$bind;\n\n$body";
 
-    my $jsbody = $params . "\n" . $self->params->autothread_wrapper($wrappedbody);
-
-    return sprintf "PIL2JS.Box.constant_func(%d, function (args) {\n%s;\n%s;\n%s\n%s\n})",
-      $self->params->arity,
+    my $jsbody = $self->multi
+      ? "$params\nif(only_check_for_params) return;\n\n" . $self->params->autothread_wrapper($wrappedbody)
+      : $params . "\n" . $self->params->autothread_wrapper($wrappedbody);
+
+    return sprintf "PIL2JS.Box.constant_func(%d, function (args) {\n%s;\n%s%s;\n%s\n%s\n})",
+      $self->arity,
       # Lexicalize PIL2JS and thus speed up PIL2JS
       PIL::add_indent(1, "var PIL2JS = AlsoPIL2JS_SpeedupHack"),
+      $self->multi
+        ? PIL::add_indent(1, "var only_check_for_params = args.only_check_for_params;\n")
+        : "",
       PIL::add_indent(1, $backup),
       PIL::add_indent(1, $ccsetup),

perl5/PIL2JS/libjs/PIL2JS.js

@@ -105 +105 @@
 
   var candidates = [];
-  for(var i = 0; i < this.variants; i++) {
-    if(this.variants[arity] == argc) {
-      candidates.push(this.variants[arity]);
+  for(var i = 0; i < this.variants.length; i++) {
+    if(this.variants[i].arity == argc) {
+      candidates.push(this.variants[i]);
+    }
+  }
+
+  if(candidates.length == 0) {
+    // Hack?
+    for(var i = 0; i < this.variants.length; i++) {
+      var pargs = [].concat(orig_args);
+      pargs.only_check_for_params = true;
+
+      var ok = true;
+      try { this.variants[i].code.FETCH()(pargs) } catch(err) {
+        // The sub wasn't able to bind pargs to its parameters.
+        ok = false;
+      }
+
+      // Was the sub able to bind pargs to its parameters?
+      if(ok) {
+        // Yes, so add the sub to our candidate list!
+        candidates.push(this.variants[i]);
+      }
     }
   }
@@ -117 +137 @@
   }
 
-  return canidates[0].code(orig_args);
+  return candidates[0].code.FETCH()(orig_args);
 };
 PIL2JS.new_multi = function () {

src/Pugs/CodeGen/PIR.hs

@@ -106 +106 @@
         tellLabel endL
         return (ExpLV this)
-    trans (PCode styp params _ body) = do
+    trans (PCode styp params _ _ body) = do
         [begL, endL] <- genLabel ["blockBegin", "blockEnd"]
         this    <- genPMC "block"
@@ -126 +126 @@
 
 instance Translate PIL_Decl Decl where
-    trans (PSub name styp params lvalue body) | Just (pkg, name') <- isQualified name = do
-        declC <- trans $ PSub name' styp params lvalue body
+    trans (PSub name styp params lvalue ismulti body) | Just (pkg, name') <- isQualified name = do
+        declC <- trans $ PSub name' styp params lvalue ismulti body
         return $ DeclNS pkg [declC]
-    trans (PSub name styp params _ body) = do
+    trans (PSub name styp params _ _ body) = do
         (_, stmts)  <- listen $ do
             let prms = map tpParam params
@@ -186 +186 @@
         tellIns $ lhsC <:= rhsC
         return lhsC
-    trans (PApp _ exp@(PCode _ _ _ _) Nothing []) = do
+    trans (PApp _ exp@(PCode _ _ _ _ _) Nothing []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
@@ -383 +383 @@
             , InsNew tempPMC PerlScalar
             , "store_global"    .- [lit "$_", tempPMC]
-            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ _ <- pilGlob penv ] ++
+            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ _ _ <- pilGlob penv ] ++
             [ StmtRaw (text "main()")
             , StmtIns $ tempPMC  <-- "find_global" $ [lit "Perl6::Internals", lit "&exit"]

src/Pugs/Compile.hs

@@ -105 +105 @@
                 name' | ':' `elem` name = name
                       | otherwise = "main::" ++ name -- XXX wrong
-            return [PSub initL SubPrim [] False bodyC]
+            return [PSub initL SubPrim [] False False bodyC]
         canCompile _ = return []
         doCode name vsub = case subBody vsub of
@@ -117 +117 @@
     compile (name, decls) = do
         let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing []
-                    | PSub sub _ _ _ _ <- decls
+                    | PSub sub _ _ _ _ _ <- decls
                     ]
-        return (PSub name SubPrim [] False (combine bodyC PNil):decls)
+        return (PSub name SubPrim [] False False (combine bodyC PNil):decls)
 
 instance Compile (SubName, VCode) [PIL_Decl] where
@@ -126 +126 @@
             bodyC   = PStmts (PStmt . PExp $ storeC) PNil
             exportL = "__export_" ++ (render $ varText name)
-        return [PSub exportL SubPrim [] False bodyC]
+        return [PSub exportL SubPrim [] False False bodyC]
     compile (name, vsub) = do
         bodyC   <- enter cxtItemAny . compile $ case subBody vsub of
@@ -132 +132 @@
             body                -> body
         paramsC <- compile $ subParams vsub
-        return [PSub name (subType vsub) paramsC (subLValue vsub) bodyC]
+        return [PSub name (subType vsub) paramsC (subLValue vsub) (isMulti vsub) bodyC]
 
 instance Compile (String, [(TVar Bool, TVar VRef)]) PIL_Expr where
@@ -236 +236 @@
 
 pBlock :: PIL_Stmts -> PIL_Expr
-pBlock = PCode SubBlock [] False
+pBlock = PCode SubBlock [] False False
 
 {-
@@ -372 +372 @@
             exp                 -> exp
         paramsC <- compile $ subParams sub
-        return $ PCode (subType sub) paramsC (subLValue sub) bodyC
+        return $ PCode (subType sub) paramsC (subLValue sub) (isMulti sub) bodyC
     compile (Syn "module" _) = compile Noop
     compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong

src/Pugs/PIL1.hs

@@ -73 +73 @@
         , pParams  :: ![TParam]
         , pLValue  :: !Bool
+        , pIsMulti :: !Bool
         , pBody    :: !PIL_Stmts
         }
@@ -82 +83 @@
     , pSubParams    :: ![TParam]
     , pSubLValue    :: !Bool
+    , pSubIsMulti   :: !Bool
     , pSubBody      :: !PIL_Stmts
     }
@@ -258 +260 @@
             putByte bh 3
             put_ bh ad
-    put_ bh (PCode ae af ag ah) = do
+    put_ bh (PCode ae af ag ah ai) = do
             putByte bh 4
             put_ bh ae
@@ -264 +266 @@
             put_ bh ag
             put_ bh ah
+            put_ bh ai
     get bh = do
             h <- getByte bh
@@ -284 +287 @@
                     ag <- get bh
                     ah <- get bh
-                    return (PCode ae af ag ah)
+                    ai <- get bh
+                    return (PCode ae af ag ah ai)
 
 instance Perl5 PIL_Expr where
@@ -293 +297 @@
     showPerl5 (PThunk aa) = showP5HashObj "PThunk"
               [("pThunk", showPerl5 aa)]
-    showPerl5 (PCode aa ab ac ad) = showP5HashObj "PCode"
+    showPerl5 (PCode aa ab ac ad ae) = showP5HashObj "PCode"
               [("pType", showPerl5 aa) , ("pParams", showPerl5 ab) ,
-               ("pLValue", showPerl5 ac) , ("pBody", showPerl5 ad)]
+               ("pLValue", showPerl5 ac) , ("pIsMulti", showPerl5 ad) ,
+               ("pBody", showPerl5 ae)]
 
 instance JSON PIL_Expr where
@@ -304 +309 @@
     showJSON (PThunk aa) = showJSHashObj "PThunk"
              [("pThunk", showJSON aa)]
-    showJSON (PCode aa ab ac ad) = showJSHashObj "PCode"
+    showJSON (PCode aa ab ac ad ae) = showJSHashObj "PCode"
              [("pType", showJSON aa) , ("pParams", showJSON ab) ,
-              ("pLValue", showJSON ac) , ("pBody", showJSON ad)]
+              ("pLValue", showJSON ac) , ("pIsMulti", showJSON ad) ,
+              ("pBody", showJSON ae)]
 
 instance Binary PIL_Decl where
-    put_ bh (PSub aa ab ac ad ae) = do
+    put_ bh (PSub aa ab ac ad ae af) = do
             put_ bh aa
             put_ bh ab
@@ -315 +321 @@
             put_ bh ad
             put_ bh ae
+            put_ bh af
     get bh = do
     aa <- get bh
@@ -321 +328 @@
     ad <- get bh
     ae <- get bh
-    return (PSub aa ab ac ad ae)
+    af <- get bh
+    return (PSub aa ab ac ad ae af)
 
 instance Perl5 PIL_Decl where
-    showPerl5 (PSub aa ab ac ad ae) = showP5HashObj "PSub"
+    showPerl5 (PSub aa ab ac ad ae af) = showP5HashObj "PSub"
               [("pSubName", showPerl5 aa) , ("pSubType", showPerl5 ab) ,
                ("pSubParams", showPerl5 ac) , ("pSubLValue", showPerl5 ad) ,
-               ("pSubBody", showPerl5 ae)]
+               ("pSubIsMulti", showPerl5 ae) , ("pSubBody", showPerl5 af)]
 
 instance JSON PIL_Decl where
-    showJSON (PSub aa ab ac ad ae) = showJSHashObj "PSub"
+    showJSON (PSub aa ab ac ad ae af) = showJSHashObj "PSub"
              [("pSubName", showJSON aa) , ("pSubType", showJSON ab) ,
               ("pSubParams", showJSON ac) , ("pSubLValue", showJSON ad) ,
-              ("pSubBody", showJSON ae)]
+              ("pSubIsMulti", showJSON ae) , ("pSubBody", showJSON af)]
 
 instance Binary PIL_Literal where

src/Pugs/PIL1.hs-drift

@@ -71 +71 @@
         , pParams  :: ![TParam]
         , pLValue  :: !Bool
+        , pIsMulti :: !Bool
         , pBody    :: !PIL_Stmts
         }
@@ -80 +81 @@
     , pSubParams    :: ![TParam]
     , pSubLValue    :: !Bool
+    , pSubIsMulti   :: !Bool
     , pSubBody      :: !PIL_Stmts
     }

t/var/constant.t

@@ -122 +122 @@
     eval '
         {
-            my constant grtz = 42;
-            $ok++ if grtz == 42;
+            my constant wack = 42;
+            $ok++ if wack == 42;
         }
 
-        $ok++ unless eval "grtz; 1";
+        $ok++ unless eval "wack; 1";
     ';
 
@@ -136 +136 @@
 
     eval '
-        my constant grtz = 42;
-        $ok++ if grtz == 42;
+        my constant wack = 42;
+        $ok++ if wack == 42;
 
         {
-            my constant grtz = 23;
-            $ok++ if grtz == 23;
+            my constant wack = 23;
+            $ok++ if wack == 23;
         }
 
-        $ok++ if grtz == 23;
+        $ok++ if wack == 23;
     ';
 
@@ -155 +155 @@
     eval '
         {
-            our constant grtz = 42;
-            $ok++ if grtz == 42;
+            our constant globconst1 = 42;
+            $ok++ if globconst1 == 42;
         }
 
-        $ok++ if grtz;
+        $ok++ if globconst1 == 42;
     ';
 
@@ -170 +170 @@
     eval '
         {
-            constant grtz = 42;
-            $ok++ if grtz == 42;
+            constant globconst2 = 42;
+            $ok++ if globconst2 == 42;
         }
 
-        $ok++ if grtz;
+        $ok++ if globconst2 == 42;
     ';