From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 1 Mar 2019 06:46:21 +0000 (+0100)
Subject: prepare for infix
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=098dd2284417a2b2b95c2b194e452beb09fcbd51;p=minfp.git

prepare for infix
---

diff --git a/.gitignore b/.gitignore
index a647da1..6662cb6 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,3 +5,4 @@ check
 parse
 gen
 ast
+*.o
diff --git a/Makefile b/Makefile
index 3daeee7..c0b5828 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CLM?=clm
-CLMFLAGS?=
+CLMFLAGS?=-b
 CLMLIBS?=-IL Platform
 
 all: main
@@ -9,3 +9,7 @@ all: main
 
 clean:
 	$(RM) -r "Clean System Files" main
+
+%: %.o rts.o
+	$(CC) $(CFLAGS) $(LDFLAGS) $(TARGET_ARCH) $^ $(OUTPUT_OPTION)
+
diff --git a/ast.dcl b/ast.dcl
index 392b589..eecc8b6 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -13,18 +13,17 @@ from StdOverloaded import class toString
 	| 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
diff --git a/ast.icl b/ast.icl
index f4d780b..d934dd2 100644
--- a/ast.icl
+++ b/ast.icl
@@ -20,12 +20,10 @@ instance toString Expression where
 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
diff --git a/check.icl b/check.icl
index 838e1fa..5cac054 100644
--- a/check.icl
+++ b/check.icl
@@ -135,7 +135,6 @@ infer :: Expression -> Infer Type
 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)
@@ -156,7 +155,6 @@ infer (Lambda s e)
 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
diff --git a/gen.icl b/gen.icl
index 8e96fec..01fa272 100644
--- a/gen.icl
+++ b/gen.icl
@@ -3,12 +3,16 @@ implementation module gen
 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]
@@ -18,15 +22,15 @@ instance genCode [a] | genCode a where
 	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]]
diff --git a/parse.dcl b/parse.dcl
index 7c609ae..84718fe 100644
--- a/parse.dcl
+++ b/parse.dcl
@@ -5,4 +5,4 @@ from ast import :: AST
 
 :: Token
 lex :: [Char] -> Either [String] [Token]
-parse :: ([Token] -> Either [String] AST)
+parse :: [Token] -> Either [String] AST
diff --git a/parse.icl b/parse.icl
index 355e136..c99f600 100644
--- a/parse.icl
+++ b/parse.icl
@@ -2,19 +2,22 @@ implementation module parse
 
 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
@@ -25,7 +28,6 @@ lex [')':ts] = TTBrackClose <:> 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]
@@ -35,30 +37,69 @@ lex [t:ts]
 	| 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
diff --git a/rts.c b/rts.c
new file mode 100644
index 0000000..c519b75
--- /dev/null
+++ b/rts.c
@@ -0,0 +1,163 @@
+#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;
+}
diff --git a/rts.h b/rts.h
new file mode 100644
index 0000000..6cbfe0d
--- /dev/null
+++ b/rts.h
@@ -0,0 +1,34 @@
+#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