From: Mart Lubbers Date: Thu, 3 Mar 2016 14:11:03 +0000 (+0100) Subject: externalized ast X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=fe40818bbc1d327f0adfbbbfe7ecfbe15d4eb053;p=cc1516.git externalized ast --- diff --git a/AST.dcl b/AST.dcl new file mode 100644 index 0000000..340aec6 --- /dev/null +++ b/AST.dcl @@ -0,0 +1,43 @@ +definition module AST + +from Data.Maybe import :: Maybe +from StdOverloaded import class toString + +:: Pos = {line :: Int, col :: Int} + +:: AST = AST [VarDecl] [FunDecl] +:: VarDecl = VarDecl Type String Expr +:: Type + = TupleType (Type, Type) + | ListType Type + | IdType String + | IntType + | BoolType + | CharType + | VarType +:: Expr + = VarExpr VarDef + | Op2Expr Expr Op2 Expr + | Op1Expr Op1 Expr + | IntExpr Int + | CharExpr Char + | BoolExpr Bool + | FunExpr FunCall + | EmptyListExpr + | TupleExpr (Expr, Expr) +:: VarDef = VarDef String [FieldSelector] +:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd +:: Op1 = UnNegation | UnMinus +:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser | + BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons +:: FunDecl = FunDecl String [String] (Maybe FunType) [VarDecl] [Stmt] +:: FunType = FunType [Type] (Maybe Type) +:: FunCall = FunCall String [Expr] +:: Stmt + = IfStmt Expr [Stmt] [Stmt] + | WhileStmt Expr [Stmt] + | AssStmt VarDef Expr + | FunStmt FunCall + | ReturnStmt (Maybe Expr) + +instance toString AST diff --git a/AST.icl b/AST.icl new file mode 100644 index 0000000..6023056 --- /dev/null +++ b/AST.icl @@ -0,0 +1,101 @@ +implementation module AST + +import StdEnv + +from Data.List import map, intercalate, replicate, flatten, isEmpty +from Data.Func import $ +from Text import class Text(concat), instance Text String +from Data.Maybe import :: Maybe, maybe + +instance toString AST where + toString (AST v f) = concat ( + ["\n":printersperse "\n" v] ++ + ["\n":printersperse "\n" f]) + +class print a :: a -> [String] + +printersperse :: String [a] -> [String] | print a +printersperse i j = intercalate [i] (map print j) + +instance print FunDecl where + print (FunDecl i as t vs ss) = + ["\n", i, " (":printersperse "," as] ++ + [")"] ++ maybe [] (\tt->[" :: ":print tt]) t ++ + ["{\n\t":printersperse "\n\t" vs] ++ + ["\n":printStatements ss 1] ++ ["}\n"] + +printStatements :: [Stmt] Int -> [String] +printStatements [] i = [] +printStatements [s:ss] i = (case s of + (IfStmt b thens elses) = indent i ["if (":print b] ++ [")"] ++ + printCodeBlock thens i ++ + indent i ["else ":printCodeBlock elses i] ++ ["\n"] + (WhileStmt b dos) = indent i ["while (":print b] ++ + [")":printCodeBlock dos i] + (AssStmt vardef val) = + indent i $ print vardef ++ ["=":print val] ++ [";\n"] + (FunStmt fc) = indent i $ print fc ++ [";\n"] + (ReturnStmt me) = indent i ["return ":maybe [""] print me] ++ [";\n"] + ) ++ printStatements ss i + where + printCodeBlock :: [Stmt] Int -> [String] + printCodeBlock [] _ = ["{}\n"] + printCodeBlock [x] i = ["\n":printStatements [x] (i+1)] + printCodeBlock x i = + ["{\n":printStatements x (i+1)] ++ indent i ["}\n"] + + indent :: Int [String] -> [String] + indent i rest = replicate i "\t" ++ rest + +instance print FunType where + print (FunType at rt) = printersperse " " at ++ + [if (isEmpty at) "" "->":maybe ["Void"] print rt] + +instance print VarDecl where + print (VarDecl t i e) = print t ++ [" ":i:"=":print e] ++ [";"] + +instance print Type where + print (TupleType (t1, t2)) = ["(":print t1] ++ [",":print t2] ++ [")"] + print (ListType t) = ["[":print t] ++ ["]"] + print (IdType s) = print s + print IntType = print "Int" + print BoolType = print "Bool" + print CharType = print "Char" + print VarType = print "var" + +instance print String where + print s = [s] + +instance print FieldSelector where + print FieldHd = print "hd" + print FieldTl = print "tl" + print FieldSnd = print "snd" + print FieldFst = print "fst" + +instance print VarDef where + print (VarDef i fs) = printersperse "." [i:flatten $ map print fs] + +instance print FunCall where + print (FunCall i args) = [i,"(":printersperse "," args] ++ [")"] + +instance print Expr where + print (VarExpr vd) = print vd + print (Op2Expr e1 o e2) = ["(":print e1] ++ [" ",case o of + BiPlus = "+"; BiMinus = "-"; BiTimes = "*"; BiDivide = "/" + BiMod = "%"; BiEquals = "="; BiLesser = "<"; BiGreater = ">" + BiLesserEq = "<="; BiGreaterEq = ">="; BiUnEqual = "!="; + BiAnd = "&&"; BiOr = "||"; BiCons = ":" + ," ":print e2] ++ [")"] + print (Op1Expr o e) = ["(",case o of + UnNegation = "!"; UnMinus = "-" + :print e] ++ [")"] + print (IntExpr i) = [toString i] + print (CharExpr c) = ["\'", case c of + '\b' = "\\b"; '\f' = "\\f"; '\n' = "\\n" + '\r' = "\\r"; '\t' = "\\t"; '\v' = "\\v" + c = if (c == toChar 7) "\\a" (toString c) + ,"\'"] + print (BoolExpr b) = [toString b] + print (FunExpr fc) = print fc + print EmptyListExpr = ["[]"] + print (TupleExpr (e1, e2)) = ["(":print e1] ++ [",":print e2] ++ [")"] diff --git a/lex.dcl b/lex.dcl index e78d495..a6cf7c6 100644 --- a/lex.dcl +++ b/lex.dcl @@ -3,10 +3,9 @@ definition module lex from Data.Either import :: Either from yard import :: Error -:: Token = { - line :: Int, - column :: Int, - token :: TokenValue} +from AST import :: Pos + +:: Token :== (Pos, TokenValue) :: TokenValue //Value tokens = IdentToken String // Identifier diff --git a/lex.icl b/lex.icl index 21a29e9..e3fb2c1 100644 --- a/lex.icl +++ b/lex.icl @@ -9,6 +9,7 @@ import StdChar import StdString import yard +from AST import :: Pos(..) :: LexItem = LexToken Int TokenValue @@ -30,7 +31,7 @@ lexProgram line column = lexToken >>= \t->case t of (LexItemError e) = fail PositionalError line column ("LexerError: " +++ e) (LexToken c t) = lexProgram line (column+c) - >>= \rest->pure [{line=line, column=column, token=t}:rest] + >>= \rest->pure [({line=line,col=column}, t):rest] lexToken :: Parser Char LexItem lexToken = diff --git a/parse.dcl b/parse.dcl index 281c804..c5d2724 100644 --- a/parse.dcl +++ b/parse.dcl @@ -5,44 +5,8 @@ from Data.Maybe import :: Maybe from StdString import class toString import lex +from AST import :: AST :: ParserOutput :== Either Error AST -:: AST = AST [VarDecl] [FunDecl] -:: VarDecl = VarDecl Type String Expr -:: Type - = TupleType (Type, Type) - | ListType Type - | IdType String - | IntType - | BoolType - | CharType - | VarType -:: Expr - = VarExpr VarDef - | Op2Expr Expr Op2 Expr - | Op1Expr Op1 Expr - | IntExpr Int - | CharExpr Char - | BoolExpr Bool - | FunExpr FunCall - | EmptyListExpr - | TupleExpr (Expr, Expr) -:: VarDef = VarDef String [FieldSelector] -:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd -:: Op1 = UnNegation | UnMinus -:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser | - BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons -:: FunDecl = FunDecl String [String] (Maybe FunType) [VarDecl] [Stmt] -:: FunType = FunType [Type] (Maybe Type) -:: FunCall = FunCall String [Expr] -:: Stmt - = IfStmt Expr [Stmt] [Stmt] - | WhileStmt Expr [Stmt] - | AssStmt VarDef Expr - | FunStmt FunCall - | ReturnStmt (Maybe Expr) - -instance toString AST - parser :: LexerOutput -> ParserOutput diff --git a/parse.icl b/parse.icl index 120935f..24b860b 100644 --- a/parse.icl +++ b/parse.icl @@ -15,6 +15,7 @@ import GenPrint import yard import lex +import AST parser :: LexerOutput -> ParserOutput parser (Left e) = Left e @@ -163,7 +164,7 @@ parseTuple p = satTok BraceOpenToken *> <* satTok BraceCloseToken trans2 :: TokenValue (TokenValue -> a) -> Parser Token a -trans2 t f = liftM (\{token}->f token) $ satTok t +trans2 t f = liftM (\(_,token)->f token) $ satTok t trans1 :: TokenValue a -> Parser Token a trans1 t r = trans2 t $ const r @@ -171,8 +172,8 @@ trans1 t r = trans2 t $ const r derive gPrint TokenValue derive gEq TokenValue satTok :: TokenValue -> Parser Token Token -satTok t = top >>= \tok=:{line,column,token} -> if (eq t token) - (pure tok) (fail PositionalError line column +satTok t = top >>= \tok=:({line,col},token) -> if (eq t token) + (pure tok) (fail PositionalError line col ("ParseError: Unexpected token: " +++ printToString token)) where eq (IdentToken _) (IdentToken _) = True @@ -187,96 +188,3 @@ parseSepList sep p = parseIdent :: Parser Token String parseIdent = trans2 (IdentToken "") (\(IdentToken e).toString e) - -instance toString AST where - toString (AST v f) = concat ( - ["\n":printersperse "\n" v] ++ - ["\n":printersperse "\n" f]) - -class print a :: a -> [String] - -printersperse :: String [a] -> [String] | print a -printersperse i j = intercalate [i] (map print j) - -instance print FunDecl where - print (FunDecl i as t vs ss) = - ["\n", i, " (":printersperse "," as] ++ - [")"] ++ maybe [] (\tt->[" :: ":print tt]) t ++ - ["{\n\t":printersperse "\n\t" vs] ++ - ["\n":printStatements ss 1] ++ ["}\n"] - -printStatements :: [Stmt] Int -> [String] -printStatements [] i = [] -printStatements [s:ss] i = (case s of - (IfStmt b thens elses) = indent i ["if (":print b] ++ [")"] ++ - printCodeBlock thens i ++ - indent i ["else ":printCodeBlock elses i] ++ ["\n"] - (WhileStmt b dos) = indent i ["while (":print b] ++ - [")":printCodeBlock dos i] - (AssStmt vardef val) = - indent i $ print vardef ++ ["=":print val] ++ [";\n"] - (FunStmt fc) = indent i $ print fc ++ [";\n"] - (ReturnStmt me) = indent i ["return ":maybe [""] print me] ++ [";\n"] - ) ++ printStatements ss i - where - printCodeBlock :: [Stmt] Int -> [String] - printCodeBlock [] _ = ["{}\n"] - printCodeBlock [x] i = ["\n":printStatements [x] (i+1)] - printCodeBlock x i = - ["{\n":printStatements x (i+1)] ++ indent i ["}\n"] - - indent :: Int [String] -> [String] - indent i rest = replicate i "\t" ++ rest - -instance print FunType where - print (FunType at rt) = printersperse " " at ++ - [if (isEmpty at) "" "->":maybe ["Void"] print rt] - -instance print VarDecl where - print (VarDecl t i e) = print t ++ [" ":i:"=":print e] ++ [";"] - -instance print Type where - print (TupleType (t1, t2)) = ["(":print t1] ++ [",":print t2] ++ [")"] - print (ListType t) = ["[":print t] ++ ["]"] - print (IdType s) = print s - print IntType = print "Int" - print BoolType = print "Bool" - print CharType = print "Char" - print VarType = print "var" - -instance print String where - print s = [s] - -instance print FieldSelector where - print FieldHd = print "hd" - print FieldTl = print "tl" - print FieldSnd = print "snd" - print FieldFst = print "fst" - -instance print VarDef where - print (VarDef i fs) = printersperse "." [i:flatten $ map print fs] - -instance print FunCall where - print (FunCall i args) = [i,"(":printersperse "," args] ++ [")"] - -instance print Expr where - print (VarExpr vd) = print vd - print (Op2Expr e1 o e2) = ["(":print e1] ++ [" ",case o of - BiPlus = "+"; BiMinus = "-"; BiTimes = "*"; BiDivide = "/" - BiMod = "%"; BiEquals = "="; BiLesser = "<"; BiGreater = ">" - BiLesserEq = "<="; BiGreaterEq = ">="; BiUnEqual = "!="; - BiAnd = "&&"; BiOr = "||"; BiCons = ":" - ," ":print e2] ++ [")"] - print (Op1Expr o e) = ["(",case o of - UnNegation = "!"; UnMinus = "-" - :print e] ++ [")"] - print (IntExpr i) = [toString i] - print (CharExpr c) = ["\'", case c of - '\b' = "\\b"; '\f' = "\\f"; '\n' = "\\n" - '\r' = "\\r"; '\t' = "\\t"; '\v' = "\\v" - c = if (c == toChar 7) "\\a" (toString c) - ,"\'"] - print (BoolExpr b) = [toString b] - print (FunExpr fc) = print fc - print EmptyListExpr = ["[]"] - print (TupleExpr (e1, e2)) = ["(":print e1] ++ [",":print e2] ++ [")"] diff --git a/spl.icl b/spl.icl index 63b1487..893d699 100644 --- a/spl.icl +++ b/spl.icl @@ -16,6 +16,7 @@ from Text import class Text(concat), instance Text String import parse import lex +import AST from yard import :: Error, instance toString Error :: Opts = { @@ -68,8 +69,8 @@ Start w printTokens :: [Token] -> String printTokens ts = concat $ flatten $ map pt ts where - pt {line,column,token} = [toString line, ":", - toString column, ": ", printToString token, "\n"] + pt ({line,col},token) = [toString line, ":", + toString col, ": ", printToString token, "\n"] parseArgs :: *World -> (Opts, *World) parseArgs w diff --git a/spl.prj b/spl.prj index da6268b..1f2a0a9 100644 --- a/spl.prj +++ b/spl.prj @@ -56,6 +56,20 @@ MainModule ReuseUniqueNodes: True Fusion: False OtherModules + Module + Name: AST + Dir: {Project} + Compiler + NeverMemoryProfile: False + NeverTimeProfile: False + StrictnessAnalysis: True + ListTypes: StrictExportTypes + ListAttributes: True + Warnings: True + Verbose: True + ReadableABC: False + ReuseUniqueNodes: True + Fusion: False Module Name: lex Dir: {Project}