-
-
Save kamil-adam/f27632da01e39dc77f5b1bc9df4b8e70 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
*.o |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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); | |
} | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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); |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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