Skip to content

Instantly share code, notes, and snippets.

@ujihisa
Created December 21, 2011 07:53
  • Star 1 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save ujihisa/1505131 to your computer and use it in GitHub Desktop.
#include <stdio.h>
#include <stdlib.h>
#include "runtime.h"
int main(int argc, char const* argv[])
{
value v1, v2, v3, v4, v5, v6, v7, v8, v9;
v1 = new_value(dot);
v1->body = 'H';
v2 = new_value(dot);
v2->body = 'i';
v3 = apply(v1, v2);
v4 = new_value(builtin);
v4->body = 's';
v5 = new_value(builtin);
v5->body = 'k';
v6 = apply(v4, v5);
v7 = new_value(builtin);
v7->body = 'k';
v8 = apply(v6, v7);
v9 = apply(v3, v8);
//value v = new_value(dot);
//v->body = 'H';
//display_value(v);
//puts("");
//v->type = builtin;
//display_value(v);
puts("");
//puts("hello, world!");
return 0;
}
// IStore (Dot 'H') 1
// IStore (Dot 'i') 2
// IApply 1 2 3
// IStore (Builtin 's') 4
// IStore (Builtin 'k') 5
// IApply 4 5 6
// IStore (Builtin 'k') 7
// IApply 6 7 8
// IApply 3 8 9
#include <stdio.h>
#include <stdlib.h>
#include "runtime.h"
value new_value(valuetype type)
{
value v = (value)malloc(sizeof(struct value_));
v->type = type;
return v;
}
/*
void display_value(value v)
{
switch (v->type) {
case dot:
printf("Dot '%c'", v->body);
break;
case builtin:
printf("Builtin '%c'", v->body);
break;
default:
puts("must not happen!");
exit(EXIT_FAILURE);
}
}
*/
value apply(value f, value x)
{
value v, v2;
switch (f->type) {
case dot:
putchar((int)f->body);
return x;
case builtin:
switch (f->body) {
case 's':
v = new_value(pending_s1);
v->x1 = x;
return v;
case 'k':
v = new_value(pending_k);
v->x1 = x;
return v;
default:
puts("must not happen!");
exit(EXIT_FAILURE);
}
break;
case pending_k:
return f->x1;
case pending_s1:
v = new_value(pending_s2);
v->x1 = f;
v->x2 = x;
return v;
case pending_s2:
v = apply(f->x1, x);
v2 = apply(f->x2, x);
return apply(v, v2);
default:
puts("must not happen!");
exit(EXIT_FAILURE);
}
}
typedef enum valuetype_ {
dot,
builtin,
pending_k,
pending_s1,
pending_s2
} valuetype;
typedef struct value_ {
valuetype type;
char body;
struct value_ *x1;
struct value_ *x2;
} *value;
value new_value(valuetype type);
value apply(value f, value x);
import qualified Text.Parsec as P
import Control.Applicative ((*>), (<$>), (<*>))
import qualified Control.Monad.State as S
import qualified Data.Map as M
import Data.Maybe (fromJust)
import qualified Data.Set as Set
data AST = Apply AST AST | Val Value
instance Show AST where
show (Apply a b) = "(" ++ show a ++ " " ++ show b ++ ")"
show (Val (Dot c)) = "put-" ++ [c]
show (Val (Builtin c)) = [c]
show (Val x) = show x
data Value = Dot Char
| Builtin Char
| PendingK Value
| PendingS1 Value
| PendingS2 Value Value
deriving (Show, Eq, Ord)
newtype AsmProgram = AsmProgram (Set.Set Value, [Inst])
instance Show AsmProgram where
show (AsmProgram (defs, insts)) =
unlines (map show $ Set.toList defs) ++ "\n" ++ unlines (map show insts)
fromAsmProgram :: AsmProgram -> [Inst]
fromAsmProgram (AsmProgram (_, x)) = x
newtype Inst = Inst (VMVal, VMVal, Int)
instance Show Inst where
show (Inst (a, b, c)) = '%' : show c ++ " = " ++ show (a, b)
data VMVal = RegRef Int | Immed Value
instance Show VMVal where
show (RegRef i) = '%' : show i
show (Immed v) = show v
type Register = M.Map Int Value
main :: IO ()
main = do
print $ compile $ parse "```k.a.bk"
run $ fromAsmProgram $ compile $ parse "```k.a.bk"
print "ok"
let helloworld = "``.H.ii" -- "`r```````````.H.e.l.l.o. .w.o.r.l.di"
--let fibonacci = "```s``s``sii`ki`k.*``s``s`ks``s`k`s`ks``s``s`ks``s`k`s`kr``s`k`sikk`k``s`ksk"
print $ desugar $ parse helloworld
let asmprogram = compile $ desugar $ parse helloworld
print asmprogram
run $ fromAsmProgram asmprogram
parse :: String -> AST
parse = either (error . show) id . P.parse parse' "unlambda"
parse' :: P.Parsec String () AST
parse' = P.try (P.char '`' *> (Apply <$> parse' <*> parse'))
P.<|>
P.try (P.char '.' *> (Val . Dot <$> P.anyChar))
P.<|>
P.try (Val . Builtin <$> P.anyChar)
desugar :: AST -> AST
desugar (Apply a b) = Apply (desugar a) (desugar b)
desugar (Val (Builtin 'r')) = Val (Dot '\n')
desugar (Val (Builtin 'i')) = Apply (Apply (Val (Builtin 's')) (Val (Builtin 'k'))) (Val (Builtin 'k')) -- i = ``skk
desugar x = x
compile :: AST -> AsmProgram
compile ast =
let ((insts, _), (defs, _, _)) = S.runState (compile' ast) (Set.empty, M.empty, 0) in
AsmProgram (defs, insts)
compile' :: AST -> S.State (Set.Set Value, Register, Int) ([Inst], VMVal)
compile' (Apply a b) = do
(a', ra) <- compile' a
(b', rb) <- compile' b
ir <- newRegId
return (a' ++ b' ++ [Inst (ra, rb, ir)], RegRef ir)
compile' (Val x) = do
modify1 (Set.insert x)
return ([], Immed x)
newRegId :: S.State (Set.Set Value, Register, Int) Int
newRegId = modify3 (+ 1)
modify1 :: (Set.Set Value -> Set.Set Value) -> S.State (Set.Set Value, Register, Int) (Set.Set Value)
modify1 f = do
(w, x, y) <- S.get
S.put (f w, x, y)
return $ f w
modify3 :: (Int -> Int) -> S.State (Set.Set Value, Register, Int) Int
modify3 f = do
(w, x, y) <- S.get
S.put (w, x, f y)
return $ f y
run :: [Inst] -> IO ()
run insts = fst `fmap` S.runStateT (mapM_ run' insts) M.empty
run' :: Inst -> S.StateT Register IO ()
run' (Inst (rx, ry, iz)) = do
x <- getVal rx
y <- getVal ry
-- reg <- S.get
-- let x = fromJust $ M.lookup rx reg
-- let y = fromJust $ M.lookup ry reg
z <- S.liftIO $ apply x y
S.modify $ M.insert iz z
return ()
getVal :: VMVal -> S.StateT Register IO Value
getVal (RegRef i) = do
r <- S.get
return $ fromJust $ M.lookup i r
getVal (Immed i) = return i
apply :: Value -> Value -> IO Value
apply (Dot c) x = putChar c >> return x
apply (Builtin 'k') x = return $ PendingK x
apply (Builtin 's') x = return $ PendingS1 x
apply (Builtin _) _ = error "must not happen"
apply (PendingK x) _ = return x
apply (PendingS1 x) y = return $ PendingS2 x y
apply (PendingS2 x y) z = do
a <- apply x z
b <- apply y z
apply a b
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment