CLM?=clm
-CLMFLAGS?=
+CLMFLAGS?=-b
CLMLIBS?=-IL Platform
all: main
clean:
$(RM) -r "Clean System Files" main
+
+%: %.o rts.o
+ $(CC) $(CFLAGS) $(LDFLAGS) $(TARGET_ARCH) $^ $(OUTPUT_OPTION)
+
| App Expression Expression
| Lambda [Char] Expression
| Builtin [Char] [Expression]
+ | Let [Char] Expression
:: Value
= Int Int
| Bool Bool
- | Char Char
| Func Int [Expression] ([Expression] -> Expression)
:: Type
= TVar [Char]
| TInt
| TBool
- | TChar
| TFun Type Type
instance toString AST, Function, Expression, Value, Type
instance toString Value where
toString (Int i) = toString i
toString (Bool b) = toString b
- toString (Char b) = "'" +++ toString b +++ "'"
toString (Func a as _) = "Function arity " +++ toString a +++ " curried " +++ join "," (map toString as)
instance toString Type where
toString (TVar a) = toString a
toString TInt = "Int"
toString TBool = "Bool"
- toString TChar = "Char"
toString (TFun a b) = "(" +++ toString a +++ ") ->" +++ toString b
infer (Lit v) = case v of
Int _ = pure TInt
Bool _ = pure TBool
- Char _ = pure TChar
infer (Var s) = asks ('DM'.get s)
>>= maybe (liftT $ Left ["Unbound variable " +++ toString s]) instantiate
infer (App e1 e2)
unifies :: Type Type -> Solve Unifier
unifies TInt TInt = pure ('DM'.newMap, [])
unifies TBool TBool = pure ('DM'.newMap, [])
-unifies TChar TChar = pure ('DM'.newMap, [])
unifies (TVar a) (TVar b)
| a == b = pure ('DM'.newMap, [])
unifies (TVar v) t = tbind v t
import StdEnv
import Data.Either
+import Data.Func
import Text
import ast
gen :: AST -> Either [String] [String]
-gen (AST fs) = Right (genCode fs [])
+gen (AST fs) = Right
+ ["#include \"rts.h\"\n"
+ :genCode fs []
+ ]
class genCode a :: a [String] -> [String]
instance genCode String where genCode s c = [s:c]
genCode [a:as] c = genCode a (genCode as c)
instance genCode Function where
genCode (Function name args body) c
- = ["stackval_t ", toString name, "(":genCode (join ", " (map toString args)) [") { return ":genCode body ["; }\n":c]]]
+ = ["struct stackval_t *", toString name, "(":genCode (join ", " ["struct stackval_t *" +++ toString a\\a<-args]) [") { return ":genCode body ["; }\n":c]]]
instance genCode Value where
- genCode (Int i) c = genCode (toString i) c
- genCode (Char i) c = genCode ['\'',i,'\''] c
- genCode (Bool i) c = genCode (if i "true" "false") c
+ genCode (Int i) c = ["lit(",toString i,")":c]
+ genCode (Bool i) c = ["lit(",if i "true" "false",")":c]
genCode (Func _ _ _) c = abort "help"
instance genCode Expression where
genCode (Lit l) c = genCode l c
- genCode (Var v) c = genCode v c
+ genCode (Var ['if']) c = genCode (Var ['_if']) c
+ genCode (Var v) c = ["var(",toString v,")":c]
genCode (App a b) c = ["ap(":genCode a [", ":genCode b [")":c]]]
genCode (Lambda a b) c = abort "help"
genCode (Builtin b args) c = genCode b ["(":genCode args [")":c]]
:: Token
lex :: [Char] -> Either [String] [Token]
-parse :: ([Token] -> Either [String] AST)
+parse :: [Token] -> Either [String] AST
import Control.Applicative
import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
import Data.Either
+import Data.GenEq
import Data.Functor
import Data.Func
+import Data.List
import StdEnv
-import Text.Parsers.Simple.ParserCombinators => qualified parse
import ast
(<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
(<:>) l r = (\xs->[l:xs]) <$> r
-:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTChar Char | TTInt Int | TTIdent [Char]
-
+:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
+derive gEq Token
lex :: [Char] -> Either [String] [Token]
lex [] = pure []
lex ['=':ts] = TTEq <:> lex ts
lex ['(':ts] = TTBrackOpen <:> lex ts
lex ['True':ts] = TTBool True <:> lex ts
lex ['False':ts] = TTBool False <:> lex ts
-lex ['\'',c,'\'':ts] = TTChar c <:> lex ts
lex ['-',t:ts]
| isDigit t = lex [t:ts] >>= \v->case v of
[TTInt i:rest] = Right [TTInt (~i):rest]
| isDigit t
# (i, ts) = span isDigit [t:ts]
= TTInt (toInt (toString i)) <:> lex ts
- | isAlpha t
- # (i, ts) = span isAlpha [t:ts]
+ | isIdent t
+ # (i, ts) = span isIdent [t:ts]
= TTIdent i <:> lex ts
= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
+where
+ isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
+
+:: Parser a :== StateT ParseState (Either [String]) a
+:: ParseState =
+ { tokens :: [Token]
+ , infixs :: [(Bool, [Char], Int)]
+ }
+instance zero ParseState where zero = {tokens=[],infixs=[]}
+
+pTop :: Parser Token
+pTop = getState >>= \s->case s.tokens of
+ [t:ts] = put {s & tokens=ts} >>| pure t
+ [] = liftT (Left ["Fully consumed input"])
+
+pSatisfy :: (Token -> Bool) -> Parser Token
+pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
-parse :: ([Token] -> Either [String] AST)
-parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
+pToken :: (Token -> Parser Token)
+pToken = pSatisfy o (===)
+
+pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
+pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
+
+pChainr :: (Parser (a a -> a)) (Parser a) -> Parser a
+pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
+
+parse :: [Token] -> Either [String] AST
+parse ts = case runStateT pAST {zero & tokens=ts} of
+ Right (a, {tokens=[]}) = Right a
+ Right (a, _) = Left ["No complete parse result"]
+ Left e = Left e
where
+ pAST :: Parser AST
+ pAST = AST <$> many pFunction
+
pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
+ pOp t` = pId >>= \t->if (t == t`) (pure t) empty
- pFunction :: Parser Token Function
+ pFunction :: Parser Function
pFunction
= Function
<$> pId
<*> many pId
- <* pSatisfy (\t->t=:TTEq)
+ <* pToken TTEq
<*> pExpression
- <* pSatisfy (\t->t=:TTSemiColon)
+ <* pToken TTSemiColon
+
+ pExpression :: Parser Expression
+ pExpression = getState >>= \{infixs}->foldr ($) pBasic
+ [ pChainl (pure App)
+ : [ if ifxr pChainr pChainl $ App o App (Var op) <$ pOp op
+ \\(ifxr, op, _)<-infixs]]
- pExpression :: Parser Token Expression
- pExpression = flip pChainl1 (pure App) $
- (Lambda <$ pSatisfy (\t->t=:TTLambda) <*> pId <* pSatisfy (\t->t=:TTDot) <*> pExpression)
- <<|> (pSatisfy (\t->t=:TTBrackOpen) *> pExpression <* pSatisfy (\t->t=:TTBrackClose))
- <<|> ((\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _)))
- <<|> ((\(TTChar i)->Lit (Char i)) <$> pSatisfy (\t->t=:(TTChar _)))
- <<|> ((\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _)))
- <<|> (Var <$> pId)
+ pBasic :: Parser Expression
+ pBasic
+ = Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
+ <|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
+ <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
+ <|> (\(TTInt i)->Lit (Int i)) <$> pSatisfy (\t->t=:(TTInt _))
+ <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
+ <|> Var <$> pId
--- /dev/null
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "rts.h"
+
+extern struct stackval_t *start();
+
+struct stackval_t *eq(struct stackval_t *l, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = CODE;
+ t->data.code = EQ;
+ return ap(ap(t, l), r);
+}
+struct stackval_t *add(struct stackval_t *l, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = CODE;
+ t->data.code = ADD;
+ return ap(ap(t, l), r);
+}
+struct stackval_t *mul(struct stackval_t *l, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = CODE;
+ t->data.code = MUL;
+ return ap(ap(t, l), r);
+}
+
+struct stackval_t *sub(struct stackval_t *l, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = CODE;
+ t->data.code = SUB;
+ return ap(ap(t, l), r);
+}
+
+struct stackval_t *_if(struct stackval_t *l, struct stackval_t *m, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = CODE;
+ t->data.code = IF;
+ return ap(ap(ap(t, l), m), r);
+}
+
+struct stackval_t *lit(uint64_t i)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = LIT;
+ t->data.lit = i;
+ return t;
+}
+
+struct stackval_t *ap(struct stackval_t *l, struct stackval_t *r)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = AP;
+ t->data.app.l = l;
+ t->data.app.r = r;
+ return t;
+}
+
+struct stackval_t *var(void *i)
+{
+ struct stackval_t *t = malloc(sizeof(struct stackval_t));
+ t->type = FUN;
+ t->data.fun.arity = 1;
+ t->data.fun.fun = i;
+ return t;
+}
+
+void print_stackval_t(struct stackval_t *sv)
+{
+ if(sv == NULL){
+ printf("null");
+ }
+ switch(sv->type) {
+ case FUN:
+ printf("Func(%lu)", sv->data.fun.arity);
+ break;
+ case LIT:
+ printf("%llu", sv->data.lit);
+ break;
+ case CODE:
+ switch(sv->data.code){
+ case ADD:
+ printf("add");
+ break;
+ case MUL:
+ printf("mul");
+ break;
+ case EQ:
+ printf("eq");
+ break;
+ case SUB:
+ printf("sub");
+ break;
+ case IF:
+ printf("if");
+ break;
+ default:
+ printf("halp: %lu", sv->data.code);
+ break;
+ }
+ case AP:
+ printf("(");
+ print_stackval_t(sv->data.app.l);
+ printf(" ");
+ print_stackval_t(sv->data.app.r);
+ printf(")");
+ break;
+ default:
+ printf("halp: %lu", sv->type);
+ break;
+ }
+}
+
+struct stackval_t *reduce(struct stackval_t *sv)
+{
+ switch(sv->type) {
+ case FUN:
+ printf("Cannot reduce func\n");
+ return NULL;
+ case LIT:
+ return sv;
+ case CODE:
+ printf("Cannot reduce bultin\n");
+ return NULL;
+ case AP:
+ switch(sv->data.app.l->type){
+// case CODE:
+// printf("APp to code");
+// return NULL:
+ case FUN:
+ switch(sv->data.app.l->data.fun.arity){
+ case 1:
+ return ((struct stackval_t *(*)(struct stackval_t *))sv->data.app.l->data.fun.fun)(sv->data.app.r);
+ }
+ printf("App to fun");
+ return NULL;
+ default:
+ printf("Cannot apply to: ");
+ print_stackval_t(sv->data.app.l);
+ return NULL;
+ }
+ return NULL;
+ default:
+ printf("halp: %lu", sv->type);
+ return NULL;
+ }
+}
+
+int main(int argc, char **argv)
+{
+ struct stackval_t *sv = NULL;
+ sv = start();
+ while(sv != NULL && sv->type != LIT){
+ print_stackval_t(sv);
+ printf("\n");
+ sv = reduce(sv);
+ }
+ return EXIT_SUCCESS;
+}
--- /dev/null
+#ifndef RTS_H
+#define RTS_H
+
+#include <stdint.h>
+
+enum stackval_type {FUN, LIT, AP, CODE};
+enum builtin {ADD,SUB,IF,EQ,MUL};
+struct stackval_t {
+ enum stackval_type type;
+ union {
+ struct {
+ uint64_t arity;
+ void *fun;
+ } fun;
+ uint64_t lit;
+ enum builtin code;
+ struct {
+ struct stackval_t *l;
+ struct stackval_t *r;
+ } app;
+ } data;
+};
+
+struct stackval_t *lit(uint64_t i);
+struct stackval_t *var(void *i);
+struct stackval_t *ap (struct stackval_t *, struct stackval_t *);
+
+struct stackval_t *_if(struct stackval_t *, struct stackval_t *, struct stackval_t *);
+struct stackval_t *sub(struct stackval_t *, struct stackval_t *);
+struct stackval_t *add(struct stackval_t *, struct stackval_t *);
+struct stackval_t *mul(struct stackval_t *, struct stackval_t *);
+struct stackval_t *eq (struct stackval_t *, struct stackval_t *);
+
+#endif
repositories / minfp.git / commitdiff