Changeset 2629

Timestamp:

05/02/05 19:26:05 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

4152

Message:

* PGE is now part of Pugs; :P5 restriction lifted from rx// and s///.

Files:

• Makefile.PL (modified) (2 diffs)
• README (modified) (1 diff)
• inc/Module/Install/Pugs.pm (modified) (1 diff)
• src/Pugs/Eval.hs (modified) (5 diffs)
• src/pge (added)
• src/pge/pge.h (added)
• src/pge/pge_gen.c (added)
• src/pge/pge_opt.c (added)
• src/pge/pge_parse.c (added)
• src/pge/pge_parseglob.c (added)
• src/pge/pge_parsep5.c (added)

Makefile.PL

@@ -93 +93 @@
     my $pcre_c = "src/pcre/pcre.c";
     my @syck_c = glob("src/syck/*.c");
+    my @pge_c = glob("src/pge/*.c");
     my $pcre = "src/pcre/pcre.o";
     my @syck = map { substr($_, 0, -1) . 'o' } @syck_c;
+    my @pge = map { substr($_, 0, -1) . 'o' } @pge_c;
     my $unicode = "src/UnicodeC.o";
     my $unicode_c = "src/UnicodeC.c";
 
-    my @prereqs = ($config_h, $pcre, @syck, $unicode);
-    $ghc_output .= " $pcre @syck $unicode";
+    my @prereqs = ($config_h, $pcre, @syck, @pge, $unicode);
+    $ghc_output .= " $pcre @syck @pge $unicode";
 
     my $config = get_pugs_config();
@@ -126 +128 @@
         \$(NOOP)
 
-@{[join("\n", map {$emit->($_)} ($unicode_c, $pcre_c, @syck_c))]}
+@{[join("\n", map {$emit->($_)} ($unicode_c, $pcre_c, @syck_c, @pge_c))]}
 
 src/Pugs/Config.hs : util/PugsConfig.pm

README

@@ -13 +13 @@
 
 Pugs is Copyright 2005 by Autrijus Tang.  All Rights Reserved.
+
+The "PGE" subsystem is derived from PGE by Patrick Michaud,
+under the Perl license.  See src/pge/README.
 
 The "PCRE" subsystem is derived from PCRE 5.0 by Philip Hazel,

inc/Module/Install/Pugs.pm

@@ -163 +163 @@
 .
     }
-    my $ghc_flags = "-H0 -L. -Lsrc -Lsrc/syck -Lsrc/pcre -I. -Isrc -Isrc/pcre -Isrc/syck";
-    $ghc_flags .= " -i. -isrc -isrc/pcre -isrc/syck -static ";
+    my $ghc_flags = "-H0 -L. -Lsrc -Lsrc/syck -Lsrc/pge -Lsrc/pcre -I. -Isrc -Isrc/pcre -Isrc/syck -Isrc/pge";
+    $ghc_flags .= " -i. -isrc -isrc/pcre -isrc/syck -isrc/pge -static ";
     $ghc_flags .= " -Wall -Werror "
       unless $self->is_extension_build;

src/Pugs/Eval.hs

@@ -36 +36 @@
         syms <- initSyms
         glob <- newTVar (combine (pad ++ syms) $ mkPad [])
-        return $ Env
+        return $ MkEnv
             { envContext = CxtVoid
             , envLexical = mkPad []
@@ -508 +508 @@
         flag_i  <- fromAdverb hv ["i", "ignorecase"]
         when (not p5) $ do
-            fail "Perl 6 rules is not implemented yet, use :P5"
+            parsed <- liftIO $ parseRule ("(" ++ encodeUTF8 str ++ ")")
+            let banner = "\n*** Perl 6 rules support coming soon...\n"
+            error $ banner ++ parsed ++ banner
         retVal $ VRule $ MkRule
             { rxRegex  = mkRegexWithPCRE (encodeUTF8 str) $
@@ -788 +790 @@
 -- XXX - what about defaulting that depends on a junction?
 doApply :: Env -> VCode -> [Exp] -> [Exp] -> Eval Val
-doApply Env{ envClasses = cls } sub@MkCode{ subBody = fun, subType = typ } invs args =
+doApply env sub@MkCode{ subBody = fun, subType = typ } invs args =
     case bindParams sub invs args of
         Left errMsg -> fail errMsg
@@ -836 +838 @@
             v   <- eval
             typ <- evalValType v
+            let cls = envClasses env
             if isaType cls "Junction" typ then return v else do
             case (lv, rw) of
@@ -853 +856 @@
         return $ genericDrop n (concat elms :: [Val])
     isCollapsed typ
-        | isaType cls "Bool" typ        = True
-        | isaType cls "Junction" typ    = True
+        | isaType (envClasses env) "Bool" typ        = True
+        | isaType (envClasses env) "Junction" typ    = True
         | otherwise                     = False