Changeset 13684 for src/Pugs/Eval

Timestamp:

09/26/06 16:04:07 (2 years ago)

Author:

audreyt

Message:

* Implement hyperfold and hyperscan: [>>+<<] and [\>>+<<].

Files:

• src/Pugs/Eval/Var.hs (modified) (2 diffs)

src/Pugs/Eval/Var.hs

@@ -370 +370 @@
         let rv = fmap (either (const Nothing) Just) $
                 findSub var Nothing firstTwoArgs
-        maybeM rv $ \code -> return $ metaPrim
-            { subAssoc    = subAssoc code
-            , subParams   = makeParams ["Any", "Any"]
-            , subBody     = Prim (\[x, y] -> op2Hyper code x y)
-            }
-
-    buildReduce var keep = do
+        maybeM rv (return . makeInfixHyperCode)
+
+    makeInfixHyperCode code = metaPrim
+        { subAssoc    = subAssoc code
+        , subParams   = makeParams ["Any", "Any"]
+        , subBody     = Prim (\[x, y] -> op2Hyper code x y)
+        }
+
+    buildReduce var foldOrScan nilOrHyper = do
         let rv = fmap (either (const Nothing) Just) $
                 findSub var Nothing firstTwoArgs
@@ -388 +390 @@
             , subBody     = Prim $ \[vs] -> do
                 list_of_args <- fromVal vs
-                op2Reduce keep list_of_args (VCode code)
+                op2Reduce (foldOrScan == MScan) list_of_args . VCode $ case nilOrHyper of
+                    MHyper  -> makeInfixHyperCode code
+                    _       -> code
             }
 
     -- possiblyBuildMetaopVCode :: (_args :: [Exp]) => Var -> Eval (Maybe VCode)
     possiblyBuildMetaopVCode var@MkVar{ v_meta = meta } = case meta of
-        MPost   -> buildPrefixHyper var'         -- +<<
-        MPre    -> buildPostfixHyper var'        -- >>+
-        MHyper  -> buildInfixHyper var'          -- >>+<<
-        MFold   -> buildReduce varInfix False    -- [+]
-        MScan   -> buildReduce varInfix True     -- [\+]
-        _       -> return Nothing
+        MPost       -> buildPrefixHyper var'                -- +<<
+        MPre        -> buildPostfixHyper var'               -- >>+
+        MHyper      -> buildInfixHyper var'                 -- >>+<<
+        MFold       -> buildReduce varInfix MFold MNil      -- [+]
+        MScan       -> buildReduce varInfix MScan MNil      -- [\+]
+        MHyperFold  -> buildReduce varInfix MFold MHyper    -- [>>+<<]
+        MHyperScan  -> buildReduce varInfix MScan MHyper    -- [>>+<<]
+        _           -> return Nothing
         where
         var' = var{ v_meta = MNil }