shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Fix bug in C'

--- a/ghc/PrimTable.hs

+++ b/ghc/PrimTable.hs

@@ -4,28 +4,33 @@

 import System.IO

 import Unsafe.Coerce

 import GHC.Types(Any)

+import Debug.Trace

 primitive :: String -> Any

+primitive s | trace ("primitive " ++ show s) False = undefined

+primitive "dynsym" = unsafeCoerce dynsym

 primitive s = fromMaybe (error $ "primitive: " ++ s) $ lookup s primOps

-newtype DIO a = DIO { unDIO :: IO a }

-

 primOps :: [(String, Any)]

 primOps =

   [ comb "S" (\ f g x -> f x (g x))

-  , comb "S'" (\ k f g x -> k f x (g x))

   , comb "K" (\ x _y -> x)

-  , comb "A" (\ _x y -> y)

-  , comb "T" (\ x y -> y x)

   , comb "I" (\ x -> x)

-  , comb "Y" (\ f -> let r = f r in r)

   , comb "B" (\ f g x -> f (g x))

-  , comb "B'" (\ k f g x -> k f (g x))

-  , comb "BK" (\ f g _x -> f g)

   , comb "C" (\ f g x -> f x g)

-  , comb "C'" (\ k f g x -> k f x g)

+  , comb "S'" (\ k f g x -> k (f x) (g x))

+  , comb "B'" (\ k f g x -> k f (g x))

+  , comb "C'" (\ k f g x -> k (f x) g)

+  , comb "A" (\ _x y -> y)

+  , comb "U" (\ x y -> y x)

+  , comb "Y" (\ f -> let r = f r in r)

+  , comb "Z" (\ f g _x -> f g)

   , comb "P" (\ x y f -> f x y)

+  , comb "R" (\ x y f -> y f x)

   , comb "O" (\ x y _g f -> f x y)

+  , comb "K2" (\ x _y _z -> x)

+  , comb "K3" (\ x _y _z _w -> x)

+  , comb "K4" (\ x _y _z _w _v -> x)

   , arith "+" (+)

   , arith "-" (-)

@@ -36,13 +41,6 @@

   , farith "fadd" (+)

   , farith "fsub" (-)

   , farith "fmul" (*)

-  , cmp "feq" (==)

-  , cmp "fne" (/=)

-  , cmp "flt" (<)

-  , cmp "fle" (<=)

-  , cmp "fgt" (>)

-  , cmp "fge" (>=)

-  , comb "fshow" (show :: Double -> String)

   , cmp "==" (==)

   , cmp "/=" (/=)

   , cmp "<"  (<)

@@ -49,13 +47,19 @@

   , cmp "<=" (<=)

   , cmp ">"  (>)

   , cmp ">=" (>=)

-  , cmp "error" err

+  , fcmp "feq" (==)

+  , fcmp "fne" (/=)

+  , fcmp "flt" (<)

+  , fcmp "fle" (<=)

+  , fcmp "fgt" (>)

+  , fcmp "fge" (>=)

+  , comb "fshow" (show :: Double -> String)

+  , comb "error" err

   , comb "ord" ord

   , comb "chr" chr

   , comb "IO.>>=" iobind

   , comb "IO.>>" iothen

   , comb "IO.return" ioret

---  , comb "IO.getChar" getc

   , comb "IO.putChar" putc

   , comb "IO.stdin" stdin

   , comb "IO.stdout" stdout

@@ -69,23 +73,20 @@

     farith = comb

     cmp :: String -> (Int -> Int -> Bool) -> (String, Any)

     cmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)

+    fcmp :: String -> (Double -> Double -> Bool) -> (String, Any)

+    fcmp n f = comb n (\ x y -> if f x y then cTrue else cFalse)

     cTrue _x y = y

     cFalse x _y = x

-    iobind :: DIO a -> (a -> DIO b) -> DIO b

-    iobind a k = DIO (unDIO a >>= \ x -> unDIO (k x))

-    iothen :: DIO a -> DIO b -> DIO b

-    iothen a b = DIO (unDIO a >> unDIO b)

-    ioret :: a -> DIO a

-    ioret a = DIO (return a)

---    getc h = undefined -- fromEnum <$> hGetChar h  -- XXX

-    putc :: Handle -> Int -> DIO ()

-    putc h c = DIO $ do

---      let h = unsafeCoerce hh :: Handle

---          c = unsafeCoerce cc :: Int

---      print (h, c)

-      hPutChar h (toEnum c)

---    open = undefined

---    close = undefined

---    isnull = undefined

+    iobind :: IO a -> (a -> IO b) -> IO b

+    iobind = (>>=)

+    iothen :: IO a -> IO b -> IO b

+    iothen = (>>)

+    ioret :: a -> IO a

+    ioret = return

+    putc :: Int -> IO ()

+    putc c = hPutChar stdout (chr c)

     err _ = error "ERROR"

+

+dynsym :: String -> Any

+dynsym cfun = error $ "dynsym " ++ cfun

-- 

⑨