diff --git a/encore.cabal b/encore.cabal index 67bf183af..568d93c9d 100644 --- a/encore.cabal +++ b/encore.cabal @@ -80,6 +80,7 @@ executable encorec , Makefile , ModuleExpander , Optimizer.Optimizer + , Optimizer.TypedDesugarer , Parser.Parser , SystemUtils , Typechecker.Capturechecker diff --git a/modules/standard/Boxed/MutBox.enc b/modules/standard/Boxed/MutBox.enc new file mode 100644 index 000000000..b83a5887f --- /dev/null +++ b/modules/standard/Boxed/MutBox.enc @@ -0,0 +1,10 @@ +module MutBox + +local class MutBox[t] + + var value : t + + def init( v : t) : unit + this.value = v + end +end diff --git a/modules/standard/Collections/Mutable/ArrayList.enc b/modules/standard/Collections/Mutable/ArrayList.enc index e45a989b5..979fb1d48 100644 --- a/modules/standard/Collections/Mutable/ArrayList.enc +++ b/modules/standard/Collections/Mutable/ArrayList.enc @@ -4,8 +4,9 @@ import Data.Maybe(cat_maybes) import Data.Either import Data.Array import Collections.Mutable.Collection +import Collections.Mutable.Functor -local class ArrayList[t] : Collection[t](next_empty, int_arr, foreach(), shift_right(), shift_left(), ensure_can_accomodate(), resize()) +local class ArrayList[t] : Collection[t](next_empty, int_arr, foreach(), shift_right(), shift_left(), ensure_can_accomodate(), resize()) + Functor[t](map(), flatMap()) var int_arr : [Maybe[t]] var next_empty : uint @@ -151,7 +152,7 @@ local class ArrayList[t] : Collection[t](next_empty, int_arr, foreach(), shift_r val clone = new ArrayList[t]() for x <- this.int_arr do - match x with + match x with case Just(ice) => clone.append(ice) case Nothing => { break; () } end diff --git a/modules/standard/Collections/Mutable/Functor.enc b/modules/standard/Collections/Mutable/Functor.enc new file mode 100644 index 000000000..906bb4f44 --- /dev/null +++ b/modules/standard/Collections/Mutable/Functor.enc @@ -0,0 +1,8 @@ +module Functor +import Collections.Mutable.Collection + +local trait Functor[t] + require def map[u](f : local ((t) -> u)) : Functor[u] + require def flatMap[u](f : local ((t) -> Functor[u])) : Collection[u] + require def foreach(f : local ((t) -> unit)) : unit +end diff --git a/modules/standard/Collections/Mutable/HashMap.enc b/modules/standard/Collections/Mutable/HashMap.enc index 324054dd2..272fed8cc 100644 --- a/modules/standard/Collections/Mutable/HashMap.enc +++ b/modules/standard/Collections/Mutable/HashMap.enc @@ -44,11 +44,11 @@ local class HashMapIterator[k : Hashable + Eq[k], v] this.current_index = this.current_index + 1 while this.current_index < this.map.size do - val l = (this.map.internal_map)(this.current_index) + val l = (this.map.internal_map)(this.current_index) if l.size > 0 then return l.first end - + this.current_index = this.current_index + 1 end @@ -107,7 +107,7 @@ local class HashMap[k : Hashable + Eq[k], v] : Map[k, v](size, internal_map, ite def init() : unit this.items = 0 this.size = 32 - this.internal_map = Array.new_with_generator(this.size, + this.internal_map = Array.new_with_generator(this.size, fun (x: int) => new LinkedList[Entry[k,v]]()) end @@ -277,7 +277,7 @@ local class HashMap[k : Hashable + Eq[k], v] : Map[k, v](size, internal_map, ite end result end - + def populate(pairs : [(k, v)]) : unit for kv <- pairs do this.set(kv.0, kv.1) diff --git a/modules/standard/Collections/Mutable/LinkedList.enc b/modules/standard/Collections/Mutable/LinkedList.enc index 3e181ff42..69ec0bcd0 100644 --- a/modules/standard/Collections/Mutable/LinkedList.enc +++ b/modules/standard/Collections/Mutable/LinkedList.enc @@ -3,7 +3,8 @@ module LinkedList import Data.Either import Data.Maybe import Collections.Mutable.Collection --- import Collections.Mutable.Iterable + +import Collections.Mutable.Functor local class LinkedNode[t] : Id var value : t @@ -16,7 +17,7 @@ local class LinkedNode[t] : Id end end -local class LinkedList[t] : Collection[t](drop(), first, last, size) + Id +local class LinkedList[t] : Collection[t](drop(), first, last, size) + Id + Functor[t](first, map(), flatMap(), foreach()) var first : Maybe[LinkedNode[t]] var last : Maybe[LinkedNode[t]] var size : int @@ -325,7 +326,7 @@ local class LinkedList[t] : Collection[t](drop(), first, last, size) + Id end end - def map[u](f : t -> u) : LinkedList[u] + def map[u](f : local ((t) -> u)) : LinkedList[u] val result = new LinkedList[u]() -- Iterate over list, perform f() on each value, put result in new list. @@ -358,7 +359,8 @@ local class LinkedList[t] : Collection[t](drop(), first, last, size) + Id return result end - def flatMap[u](f : t -> LinkedList[u]) : LinkedList[u] + + def flatMap[u](f : local ((t) -> Functor[u])) : LinkedList[u] val result = new LinkedList[u]() var cursor = this.first diff --git a/modules/standard/Data/Array.enc b/modules/standard/Data/Array.enc index beeb97538..ba3672080 100644 --- a/modules/standard/Data/Array.enc +++ b/modules/standard/Data/Array.enc @@ -4,7 +4,7 @@ module Array -- new_with_default :: (int, a) -> [a] -- new_with_default(size, default) creates an array of size default --- with each element +-- with each element fun new_with_default[a](size : int, default : a) : [a] val arr = new [a](size) for i <- [0 .. size - 1] do @@ -72,8 +72,8 @@ end -- count(pred, arr) counts the number of elements of arr satisfying predicate pred fun count[a](pred : a -> bool, arr : [a]) : int var count = 0 - for a <- arr do - if pred(a) then + for x <- arr do + if pred(x) then count += 1 end end @@ -83,14 +83,76 @@ end -- map :: (a -> b, [a]) -> [b] -- map(f, arr) produces a new array containing the results of applying f to the -- elements of arr -fun map[a,b](f : a -> b, arr : [a]) : [b] +fun map[a,b](f : local ((a) -> b), arr : [a]) : [b] val ret = new [b](|arr|) - for i <- [0 .. |arr|-1] do + var i = 0 + while (i <= |arr|-1) do ret(i) = f((arr)(i)) + i += 1 end ret end +-- flatMap :: (a -> [b], [a]) -> [b] +-- flatMap(f, arr) produces a new array containeing the flatened results of applying f to +-- the elements of arr +fun flatMap[a, b](f : local ((a) -> [b]), arr : [a]) : [b] + val size = |arr| + var result = new [b](0) + var i = 0 + while (i < size) do + var ret = f(arr(i)) + result = concat[b](result, ret) + i += 1 + end + return result +end + +-- foreach(a -> unit, [a]) -> unit +-- forach(f, arr) applied f to all elements of an array, resulting in unit. +fun foreach[a](f : local ((a) -> unit), arr : [a]) : unit + val size = |arr| + var i = 0 + while i < size do + f(arr(i)) + i += 1 + end +end + + +fun maybeForeach[a](f : local ((a) -> Maybe[unit]), arr : [a]) : Maybe[unit] + val size = |arr| + var i = 0 + while i < size do + var res = f(arr(i)) + if res == Nothing then + return Nothing + end + i += 1 + end + return Just(()) +end + +-- concat :: ([a], [a]) -> [a] +-- concat(firstArr, secondArr) produces a new array that is the concatination of +-- the two input arrays. +fun concat[a](firstArr : [a], secondArr : [a]) : [a] + val firstSize = |firstArr| + val secondSize = |secondArr| + val result = new [a](firstSize + secondSize) + var i = 0 + while i < firstSize do + result(i) = firstArr(i) + i += 1 + end + var j = 0 + while j < secondSize do + result(j+firstSize) = secondArr(j) + j += 1 + end + return result +end + -- show :: (a -> unit, [a]) -> unit -- show(showEl, arr) prints out array arr using function showEl to print the elements -- of the array @@ -123,7 +185,7 @@ fun contains[t](arr : [t], to_find : t) : bool end -- contains_str :: ([String], String) -> bool --- contains_str(arr, elem) is true if and only if elem appears in arr +-- contains_str(arr, elem) is true if and only if elem appears in arr -- tested using String.compare fun contains_str(arr : [String], to_find : String) : bool var retval = false @@ -147,7 +209,7 @@ fun clone[t](src : [t]) : [t] end -- nclone :: ([t], int) -> Maybe[[t]] --- nclone(arr,n) results in Just(arr') where arr' is a new array containing +-- nclone(arr,n) results in Just(arr') where arr' is a new array containing -- the first n elements of arr, in the case where n < |arr|, otherwise Nothing -- a new array containing the same contents as arr fun nclone[t](src : [t], n : uint) : Maybe[[t]] @@ -160,5 +222,4 @@ fun nclone[t](src : [t], n : uint) : Maybe[[t]] end Just(new_arr) end -end - +end \ No newline at end of file diff --git a/modules/standard/Data/Maybe.enc b/modules/standard/Data/Maybe.enc index d13295084..754561a50 100644 --- a/modules/standard/Data/Maybe.enc +++ b/modules/standard/Data/Maybe.enc @@ -2,11 +2,11 @@ module Maybe import qualified Data.Array as A --- This package implements common functions for operating on +-- This package implements common functions for operating on -- Maybe types. It is inspired heavily by Data.Maybe in Haskell. --- unjust :: Maybe[a] -> a --- unjust(mval) eliminates the Just constructor, assuming that the +-- unjust :: Maybe[a] -> a +-- unjust(mval) eliminates the Just constructor, assuming that the -- mval is Just(x). Results in an error otherwise fun unjust[a](mval : Maybe[a]) : a match mval with @@ -18,8 +18,8 @@ fun unjust[a](mval : Maybe[a]) : a end end --- unjust_with_default :: (a, Maybe[a]) -> a --- unjust_with_default(default, mval) eliminates the Just constructor from mval, +-- unjust_with_default :: (a, Maybe[a]) -> a +-- unjust_with_default(default, mval) eliminates the Just constructor from mval, -- assuming that the input value is Just(x). Results in an default, otherwise fun unjust_with_default[a](default : a, mval : Maybe[a]) : a maybe(default, id[a], mval) @@ -54,7 +54,7 @@ fun is_just[a](mval : Maybe[a]) : bool case Nothing => false end end - + -- is_nothing :: Maybe[a] -> bool -- is_nothing(mval) is true whenever mval is Nothing fun is_nothing[a](mval : Maybe[a]) : bool @@ -91,9 +91,9 @@ end fun cat_maybes[a](marr : [Maybe[a]]) : [a] val arr = new [a](A.count(is_just[a], marr)) -- why do I need [a]? var count = 0 - for a <- marr do - if is_just(a) then - arr(count) = unjust(a) + for b <- marr do + if is_just(b) then + arr(count) = unjust(b) count += 1 end end @@ -101,9 +101,8 @@ fun cat_maybes[a](marr : [Maybe[a]]) : [a] end -- map_maybe :: (a -> Maybe[a], [a]) -> [b] --- map_maybe(f, arr) maps the function f on the array producing a new array, +-- map_maybe(f, arr) maps the function f on the array producing a new array, -- filtering out elements that result in Nothing fun map_maybe[a,b](f : a -> Maybe[b], arr : [a]) : [b] cat_maybes[b](A.map[a, Maybe[b]](f, arr)) end - diff --git a/modules/standard/Data/RRange.enc b/modules/standard/Data/RRange.enc new file mode 100644 index 000000000..06b7f35a5 --- /dev/null +++ b/modules/standard/Data/RRange.enc @@ -0,0 +1,33 @@ +module RRange + +read class RRange + val start : int + val stop : int + val step : int + + def init(start : int, stop : int, step : int) : unit + this.start = start + this.stop = stop + this.step = step + end + + def foreach(f : local ((int) -> unit)) : unit + var current = this.start + while (current <= this.stop) do + f(current) + current += this.step + end + end + + def maybeForeach(f : local ((int) -> Maybe[unit])) : Maybe[unit] + var current = this.start + while (current <= this.stop) do + var ret = f(current) + if ret == Nothing then + return Nothing + end + current += this.step + end + return Just(()) + end +end diff --git a/src/back/CCode/Main.hs b/src/back/CCode/Main.hs index c36abaf63..55baf2db7 100644 --- a/src/back/CCode/Main.hs +++ b/src/back/CCode/Main.hs @@ -30,6 +30,7 @@ class UsableAs a b where instance UsableAs Name Lval where instance UsableAs Lval Expr where instance UsableAs Name Expr where + instance UsableAs a a where instance UsableAs Stat Expr where diff --git a/src/back/CodeGen/Closure.hs b/src/back/CodeGen/Closure.hs index ff13e36c0..4d36b6fb1 100644 --- a/src/back/CodeGen/Closure.hs +++ b/src/back/CodeGen/Closure.hs @@ -25,7 +25,6 @@ import Types as Ty import Control.Monad.State hiding (void) import Control.Arrow(first) -import Debug.Trace varSubFromTypeVars :: [Type] -> [(ID.Name, CCode Lval)] varSubFromTypeVars = map each diff --git a/src/back/CodeGen/Expr.hs b/src/back/CodeGen/Expr.hs index b145ee98f..822de1c56 100644 --- a/src/back/CodeGen/Expr.hs +++ b/src/back/CodeGen/Expr.hs @@ -26,7 +26,6 @@ import Data.List import Data.List.Utils(split) import qualified Data.Set as Set import Data.Maybe -import Debug.Trace instance Translatable ID.BinaryOp (CCode Name) where translate op = Nam $ case op of @@ -314,7 +313,7 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where let exitCall = Call (Nam "exit") [narg] return (unit, Seq [Statement targ, Statement exitCall]) - translate abort@(A.Abort {A.args = []}) = do + translate abort@(A.Abort {A.args}) = do let abortCall = Call (Nam "abort") ([]::[CCode Lval]) return (unit, Statement abortCall) @@ -677,77 +676,6 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where (_,tbody) <- translate body return (unit, While (StatAsExpr ncond tcond) (Statement tbody)) - translate for@(A.For {A.name, A.step, A.src, A.body}) = do - indexVar <- Var <$> Ctx.genNamedSym "index" - eltVar <- Var <$> Ctx.genNamedSym (show name) - startVar <- Var <$> Ctx.genNamedSym "start" - stopVar <- Var <$> Ctx.genNamedSym "stop" - stepVar <- Var <$> Ctx.genNamedSym "step" - srcStepVar <- Var <$> Ctx.genNamedSym "src_step" - - (srcN, srcT) <- if A.isRangeLiteral src - then return (undefined, Comm "Range not generated") - else translate src - - let srcType = A.getType src - eltType = if Ty.isRangeType srcType - then int - else translate $ Ty.getResultType (A.getType src) - srcStart = if Ty.isRangeType srcType - then Call rangeStart [srcN] - else Int 0 -- Arrays start at 0 - srcStop = if Ty.isRangeType srcType - then Call rangeStop [srcN] - else BinOp (translate ID.MINUS) - (Call arraySize [srcN]) - (Int 1) - srcStep = if Ty.isRangeType srcType - then Call rangeStep [srcN] - else Int 1 - - (srcStartN, srcStartT) <- translateSrc src A.start startVar srcStart - (srcStopN, srcStopT) <- translateSrc src A.stop stopVar srcStop - (srcStepN, srcStepT) <- translateSrc src A.step srcStepVar srcStep - - (stepN, stepT) <- translate step - substituteVar name eltVar - (bodyN, bodyT) <- translate body - unsubstituteVar name - - let stepDecl = Assign (Decl (int, stepVar)) - (BinOp (translate ID.TIMES) stepN srcStepN) - stepAssert = Statement $ Call rangeAssertStep [stepVar] - indexDecl = Seq [AsExpr $ Decl (int, indexVar) - ,If (BinOp (translate ID.GT) - (AsExpr stepVar) (Int 0)) - (Assign indexVar srcStartN) - (Assign indexVar srcStopN)] - cond = BinOp (translate ID.AND) - (BinOp (translate ID.GTE) indexVar srcStartN) - (BinOp (translate ID.LTE) indexVar srcStopN) - eltDecl = - Assign (Decl (eltType, eltVar)) - (if Ty.isRangeType srcType - then AsExpr indexVar - else AsExpr $ fromEncoreArgT eltType (Call arrayGet [srcN, indexVar])) - inc = Assign indexVar (BinOp (translate ID.PLUS) indexVar stepVar) - theBody = Seq [eltDecl, Statement bodyT, inc] - theLoop = While cond theBody - - return (unit, Seq [srcT - ,srcStartT - ,srcStopT - ,srcStepT - ,stepT - ,stepDecl - ,stepAssert - ,indexDecl - ,theLoop]) - where - translateSrc src selector var rhs - | A.isRangeLiteral src = translate (selector src) - | otherwise = return (var, Assign (Decl (int, var)) rhs) - translate ite@(A.IfThenElse { A.cond, A.thn, A.els }) = do tmp <- Ctx.genNamedSym "ite" (ncond, tcond) <- translate cond @@ -1025,7 +953,7 @@ instance Translatable A.Expr (State Ctx.Context (CCode Lval, CCode Stat)) where translate get@(A.Get{A.val}) | Ty.isFutureType $ A.getType val = do (nval, tval) <- translate val - let resultType = translate (Ty.getResultType $ A.getType val) + let resultType = translate (Ty.getResultType $ A.getType val) theGet = fromEncoreArgT resultType (Call futureGetActor [encoreCtxVar, nval]) tmp <- Ctx.genSym return (Var tmp, Seq [tval, Assign (Decl (resultType, Var tmp)) theGet]) diff --git a/src/front/ModuleExpander.hs b/src/front/ModuleExpander.hs index 84c1044ec..d8aa3524e 100644 --- a/src/front/ModuleExpander.hs +++ b/src/front/ModuleExpander.hs @@ -45,7 +45,7 @@ shortenPrelude preludePaths source = then basename source else source -stdLib source = [lib "String", lib "Std"] +stdLib source = [lib "String", lib "Std", lib "Data/Array", lib "Data/RRange", lib "Boxed/MutBox"] where lib s = Import{imeta = meta $ newPos (initialPos source) ,itarget = explicitNamespace [Name s] diff --git a/src/front/TopLevel.hs b/src/front/TopLevel.hs index c7a3d9971..681bdadfc 100644 --- a/src/front/TopLevel.hs +++ b/src/front/TopLevel.hs @@ -9,6 +9,7 @@ file I/O. module Main where + import System.Environment import System.Directory import System.IO @@ -42,6 +43,7 @@ import Typechecker.Environment(buildLookupTable) import Typechecker.Prechecker(precheckProgram) import Typechecker.Typechecker(typecheckProgram, checkForMainClass) import Typechecker.Capturechecker(capturecheckProgram) +import Optimizer.TypedDesugarer import Optimizer.Optimizer import CodeGen.Main import CodeGen.ClassDecl @@ -243,7 +245,7 @@ compileProgram prog sourcePath options = customFlags = case find isCustomFlags options of Just (CustomFlags str) -> str Nothing -> "" - flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -ldl -lm -Wno-attributes" + flags = "-std=gnu11 -Wall -fms-extensions -Wno-format -latomic -Wno-microsoft -Wno-parentheses-equality -Wno-unused-variable -Wno-unused-value" <+> customFlags <+> "-lpthread -ldl -lm -Wno-attributes" oFlag = "-o" <+> execName defines = getDefines options incs = "-I" <+> incPath <+> "-I ." @@ -338,8 +340,17 @@ main = verbose options "== Capturechecking ==" capturecheckedTable <- capturecheckProgramTable typecheckedTable + verbose options "== Typed Desugaring ==" + let desugaredTypedTable = fmap desugarTypedProgram capturecheckedTable + + verbose options "== Re - Typechecking ==" + typecheckedTableTwo <- typecheckProgramTable desugaredTypedTable + + verbose options "== Re-Capturechecking ==" + capturecheckedTableTwo <- capturecheckProgramTable typecheckedTableTwo + verbose options "== Optimizing ==" - let optimizedTable = fmap optimizeProgram capturecheckedTable + let optimizedTable = fmap optimizeProgram capturecheckedTableTwo verbose options "== Generating code ==" let (mainDir, mainName) = dirAndName sourceName @@ -428,4 +439,4 @@ main = optionBox = longBox Box.<+> shortBox Box.<+> descBox flags = intercalate "\n" $ map ((" " ++) . strip) . lines $ - Box.render optionBox \ No newline at end of file + Box.render optionBox diff --git a/src/ir/AST/AST.hs b/src/ir/AST/AST.hs index 807a945da..3ba65524e 100644 --- a/src/ir/AST/AST.hs +++ b/src/ir/AST/AST.hs @@ -19,6 +19,7 @@ import Identifiers import Types import AST.Meta as Meta hiding(Closure, Async) + data FileDescriptor = Stdout | Stderr deriving (Show, Eq) @@ -600,6 +601,12 @@ data VarDecl = varType :: Type} deriving(Eq, Show) +data ForSource = + ForSource { fsName :: Name, + fsTy :: Maybe Type, + collection :: Expr} + deriving(Eq, Show) + data Expr = Skip {emeta :: Meta Expr} | Break {emeta :: Meta Expr} | Continue {emeta :: Meta Expr} @@ -685,10 +692,8 @@ data Expr = Skip {emeta :: Meta Expr} times :: Expr, body :: Expr} | For {emeta :: Meta Expr, - name :: Name, - step :: Expr, - src :: Expr, - body :: Expr} + sources :: [ForSource], + body :: Expr} | Match {emeta :: Meta Expr, arg :: Expr, clauses :: [MatchClause]} @@ -816,6 +821,10 @@ isForward :: Expr -> Bool isForward Forward {} = True isForward _ = False +isAssign :: Expr -> Bool +isAssign Assign {} = True +isAssign _ = False + isVarAccess :: Expr -> Bool isVarAccess VarAccess{} = True isVarAccess _ = False @@ -828,6 +837,14 @@ isTask :: Expr -> Bool isTask Async {} = True isTask _ = False +isBreak :: Expr -> Bool +isBreak Break{} = True +isBreak _ = False + +isFor :: Expr -> Bool +isFor For{} = True +isFor _ = False + isRangeLiteral :: Expr -> Bool isRangeLiteral RangeLiteral {} = True isRangeLiteral _ = False @@ -866,16 +883,22 @@ isPrimitiveLiteral _ = False isValidPattern :: Expr -> Bool isValidPattern TypedExpr{body} = isValidPattern body -isValidPattern FunctionCall{} = True -isValidPattern MaybeValue{mdt = JustData{e}} = isValidPattern e -isValidPattern MaybeValue{mdt = NothingData} = True -isValidPattern Tuple{args} = all isValidPattern args -isValidPattern VarAccess{} = True -isValidPattern Null{} = True +isValidPattern FunctionCall{} = True +isValidPattern MaybeValue{mdt = JustData{e}} = isValidPattern e +isValidPattern MaybeValue{mdt = NothingData} = True +isValidPattern Tuple{args} = all isValidPattern args +isValidPattern VarAccess{} = True +isValidPattern Null{} = True +isValidPattern ExtractorPattern{} = True +isValidPattern AdtExtractorPattern{} = True isValidPattern e - | isPrimitiveLiteral e = True + | isPrimitiveLiteral e = True | otherwise = False +isExtractorPattern :: Expr -> Bool +isExtractorPattern ExtractorPattern{} = True +isExtractorPattern _ = False + isImpure :: Expr -> Bool isImpure MethodCall {} = True isImpure MessageSend {} = True diff --git a/src/ir/AST/Desugarer.hs b/src/ir/AST/Desugarer.hs index 228cdc018..7ed9a9e78 100644 --- a/src/ir/AST/Desugarer.hs +++ b/src/ir/AST/Desugarer.hs @@ -389,7 +389,8 @@ desugar FunctionCall{emeta, qname = QName{qnlocal = Name "exit"} Exit emeta args -- Abort -desugar FunctionCall{emeta, qname=QName{qnlocal=Name "abort"} , args=[msg]} = +desugar FunctionCall{emeta, qname = QName{qnlocal = Name "abort"} + ,args=[msg]} = Seq{emeta, eseq=[Print emeta Stderr [StringLiteral emeta "{}\n", msg] ,Print emeta Stderr [StringLiteral emeta $ Meta.showPos emeta ++ "\n"] ,Abort{emeta, args=[msg]}]} @@ -495,6 +496,13 @@ desugar Unless{emeta, cond = originalCond, thn} = ,thn ,els = Skip (cloneMeta emeta) } +-- Desugars +-- [e1 .. e2] by e3 +-- into +-- new RRange(e1, e2, e3) +desugar RangeLiteral{emeta, start, stop, step} = + NewWithInit{emeta, ty, args = [start, stop, step]} + where ty = rangeObjectType -- Desugars -- repeat id <- e1 e2 diff --git a/src/ir/AST/PrettyPrinter.hs b/src/ir/AST/PrettyPrinter.hs index 12dee89c0..307d8f608 100644 --- a/src/ir/AST/PrettyPrinter.hs +++ b/src/ir/AST/PrettyPrinter.hs @@ -369,15 +369,13 @@ ppExpr Repeat {name, times, body} = "repeat" <+> ppName name <+> "<-" <+> ppExpr times <+> "do" $+$ indent (ppBody body) $+$ "end" -ppExpr For {name, step = IntLiteral{intLit = 1}, src, body} = - "for" <+> ppName name <+> "<-" <+> ppExpr src <+> "do" $+$ - indent (ppBody body) $+$ - "end" -ppExpr For {name, step, src, body} = - "for" <+> ppName name <+> "<-" <+> ppExpr src <+> - "by" <+> ppExpr step <+> "do" $+$ - indent (ppBody body) $+$ +ppExpr For {sources, body} = + "for" <+> commaSep (map ppForSource sources) <+> "do" $+$ + indent (ppBody body) $+$ "end" + where + ppForSource (ForSource {fsName, collection}) = + ppName fsName <+> "<-" <+> ppExpr collection ppExpr Match {arg, clauses} = "match" <+> ppExpr arg <+> "with" $+$ ppMatchClauses clauses $+$ diff --git a/src/ir/AST/Util.hs b/src/ir/AST/Util.hs index 70c088efc..03ff02315 100644 --- a/src/ir/AST/Util.hs +++ b/src/ir/AST/Util.hs @@ -93,7 +93,9 @@ getChildren Unless {cond, thn} = [cond, thn] getChildren While {cond, body} = [cond, body] getChildren DoWhile {cond, body} = [cond, body] getChildren Repeat {name, times, body} = [times, body] -getChildren For {name, step, src, body} = [step, src, body] +getChildren For {sources, body} = body : concatMap getChildrenFor' sources + where + getChildrenFor' ForSource {collection} = [collection] getChildren Match {arg, clauses} = arg:getChildrenClauses clauses where getChildrenClauses = concatMap getChildrenClause @@ -173,7 +175,8 @@ putChildren [cond, thn] e@(Unless {}) = e{cond = cond, thn = thn} putChildren [cond, body] e@(While {}) = e{cond = cond, body = body} putChildren [cond, body] e@(DoWhile {}) = e{cond = cond, body = body} putChildren [times, body] e@(Repeat {}) = e{times = times, body = body} -putChildren [step, src, body] e@(For {}) = e{step = step, src = src, body = body} +putChildren (body:collectionList) e@(For {sources}) = + e{body = body, sources = zipWith (\collec s -> s{collection = collec}) collectionList sources} putChildren (arg:clauseList) e@(Match {clauses}) = e{arg = arg, clauses=putClausesChildren clauseList clauses} where putClausesChildren [] [] = [] @@ -295,6 +298,11 @@ foldrExp f l e = let childResult = List.foldr (\expr acc -> foldrExp f acc expr) l (getChildren e) in f e childResult +exContains :: (Expr -> Bool) -> Expr -> Bool +exContains f e = + let children = List.filter f (getChildren e) + in not $ null children + -- | Like a map, but where the function has access to the -- substructure of each node, not only the element. For lists, -- extend f [1,2,3,4] = [f [1,2,3,4], f [2,3,4], f [3,4], f [4]]. @@ -443,8 +451,10 @@ freeVariables bound expr = List.nub $ freeVariables' bound expr fvDecls (vars, expr) (free, bound) = let xs = map (qLocal . varName) vars in (freeVariables' bound expr ++ free, xs ++ bound) - freeVariables' bound e@For{name, step, src, body} = - freeVariables' (qLocal name:bound) =<< getChildren e + freeVariables' bound e@For{sources, body} = + freeVariables' (getName++bound) =<< getChildren e + where + getName = map (\ForSource{fsName, collection} -> qLocal fsName) sources freeVariables' bound e = concatMap (freeVariables' bound) (getChildren e) markStatsInBody ty e @@ -475,8 +485,10 @@ mark asParent s@Let{body, decls} = where markDecl (n, e) = (n, markAsExpr e) mark asParent s@While{cond, body} = asParent s{cond=markAsExpr cond, body=markAsStat body} -mark asParent s@For{step, src, body} = - asParent s{step=markAsExpr step, src=markAsExpr src, body=markAsStat body} +mark asParent s@For{sources, body} = + asParent s{sources = map markAsForSource sources, body=markAsExpr body} + where + markAsForSource ForSource{fsName, fsTy, collection} = ForSource {fsName, fsTy, collection = markAsExpr collection} mark asParent s = let children = AST.Util.getChildren s diff --git a/src/opt/Optimizer/TypedDesugarer.hs b/src/opt/Optimizer/TypedDesugarer.hs new file mode 100644 index 000000000..8e3d48287 --- /dev/null +++ b/src/opt/Optimizer/TypedDesugarer.hs @@ -0,0 +1,319 @@ +module Optimizer.TypedDesugarer(desugarTypedProgram) where + + +import Control.Monad.Reader +import Control.Monad.Except +import Control.Monad.State +import Data.Maybe +import Data.List +import Data.Map.Strict(Map) +import qualified Data.Map.Strict as Map +import SystemUtils +import Typechecker.TypeError + +-- Modular dependancies +import Identifiers +import AST.AST +import AST.Util +import Identifiers +import qualified AST.Meta as Meta +import Types +import Typechecker.Environment +import Typechecker.TypeError +import AST.PrettyPrinter + +desugarTypedProgram :: Program -> Program +desugarTypedProgram p@(Program{classes, traits, functions}) = + p{classes = map desugarClass classes + ,traits = map desugarTrait traits + ,functions = map desugarFunction functions} + where + desugarFunction f@(Function{funbody}) = + f{funbody = desugarExpr funbody} + + desugarTrait t@(Trait{tmethods}) = + t{tmethods = map desugarMethod tmethods} + + desugarClass c@(Class{cname, cmethods})= + c{cmethods = map desugarMethod cmethods} + + desugarMethod m = + m{mbody = desugarExpr (mbody m)} + + desugarExpr ast = + foldl (\ast opt -> opt ast) ast desugarPasses + +-- | The functions in this list will be performed in order during desugaring +desugarPasses :: [Expr -> Expr] +desugarPasses = [boxRemainingFor] + +boxRemainingFor = extend boxRemainingFor' + where + boxRemainingFor' e + | isFor e = desugarAndBoxForR' e + | otherwise = e + +-- forDesugared (for x <- listA, y <- listB do +-- fun +-- end) -> listA.flatMap(listB.flatMap(listC.map(fun))) + +-- forDesugared (for x <- listA, y <- listB do +-- fun +-- end) -> listA.foreach(listB.flatMap(listC.foreach(fun))) +forDesugared :: Expr -> Expr +forDesugared e@For{emeta, sources, body} = + let closureRetType = getType e + collectionType = getType $ collection $ head sources + callNameList = getCallName e collectionType $ length sources + revSources = reverse sources + elemType = getType body + noBreakBody = changeBreak e + desugaredFor = nestCalls emeta callNameList revSources noBreakBody elemType closureRetType + in desugaredFor + where + nestCalls :: Meta.Meta Expr -> [Name] -> [ForSource] -> Expr -> Type -> Type -> Expr + nestCalls meta (name:_) (fs:[]) body elemType closureRetType = intoCall meta name fs body elemType closureRetType + nestCalls meta (name:restOfNames) (fs:restFS) body elemType closureRetType = + let nestedCall = intoCall meta name fs body elemType closureRetType + in nestCalls meta restOfNames restFS nestedCall elemType closureRetType + + intoCall :: Meta.Meta Expr -> Name -> ForSource -> Expr -> Type -> Type ->Expr + intoCall met callName ForSource{fsName, fsTy, collection} bodyOrMethodCall elemType closureRetType = + if isRefType (getType collection) + then let param = [intoParam met Val fsName fsTy] + retType = getRetType callName elemType closureRetType + elemT= if callName == Name "foreach" || callName == Name "maybeForeach" + then [] + else [elemType] + arguments = [intoClosure met param retType bodyOrMethodCall] + in intoMethodCall met elemT collection callName arguments + else let param = [intoParam met Val fsName fsTy] + retType = getRetType callName elemType closureRetType + elemT= if callName == Name "foreach" || callName == Name "maybeForeach" + then [fromMaybe intType fsTy] + else [(fromMaybe intType fsTy), elemType] + arguments = [intoClosure met param retType bodyOrMethodCall] ++ [collection] + name = intoQName callName + in intoFunctionCall met elemT name arguments + + getCallName For{body} collectionType leng + | containsBreak body = replicate leng (Name "maybeForeach") + | (unitType == getType body) || (isRangeObjectType collectionType) = replicate leng (Name "foreach") + | otherwise = [Name "map"] ++ replicate (leng-1) (Name "flatMap") + + containsBreak exp = not $ null $ AST.Util.filter isBreak exp + changeBreak For{emeta, body} + | not (containsBreak body) = body + | otherwise = let newBody = extend changeBreak' body + retUnit = JustData{ e = intoSkip emeta} + maybeRetUnit = intoMaybeValue emeta retUnit + retMaybeRetUnit = intoReturn emeta maybeRetUnit + in intoSeq emeta [newBody, retMaybeRetUnit] + where + changeBreak' Break{emeta} = + let maybeData = intoMaybeValue emeta NothingData + in intoReturn emeta maybeData + changeBreak' m = m + + getRetType callName elemType closureRetType + | callName == Name "foreach" = Nothing + | callName == Name "maybeForeach" = Just $ maybeType unitType + | callName == Name "map" = Just elemType + | callName == Name "flatMap" = Just closureRetType +forDesugared m = m + +-- Desugars and boxes the for-loop. The for in example: +-- var list = for x <- [1, 2, 3] do +-- x += 1 +-- x +-- end +-- into: +-- let __for_return_variable +-- in let __box_mutable__x = new MutBox(x) +-- in __for_return_variable = flatMap(__box_mutable__x.value += 1, __box_mutable__x.value, [1, 2, 3]) +-- x = __box_mutable__x.value +-- end +-- __for_return_variable +-- end +desugarAndBoxForR' :: Expr -> Expr +desugarAndBoxForR' for@For{emeta} = + let retVarDecl = [([intoVarDecl (Name "__for_return_variable")], intoTypedExpr emeta Null{emeta = Meta.meta (Meta.getPos emeta)} (getType for))] + retVarAcc = intoVarAccess emeta $ intoQName $ Name "__for_return_variable" + outerLet = intoLet emeta Var retVarDecl $ intoSeq emeta [newExpr, retVarAcc] + listOfVar = getVariables for + newExpr + | null listOfVar = if unitType == (getType for) || (unitType == getType (body for)) || isMaybeType (getType (body for)) + then forDesugared for + else intoAssignment emeta retVarAcc $ forDesugared for + | otherwise = + let listOfVarNames = map (\VarAccess{qname} -> qnlocal qname) listOfVar + unBoxing = unBox listOfVar + desugaredFor = if unitType == (getType for) || (unitType == getType (body for)) || isMaybeType (getType (body for)) + then forDesugared $ varBodyToFieldBody for [] listOfVarNames + else intoAssignment emeta retVarAcc (forDesugared $ varBodyToFieldBody for [] listOfVarNames) + letBod = intoSeq emeta (desugaredFor:unBoxing) + in boxVar emeta listOfVar letBod + output + | unitType == (getType for) || (unitType == getType (body for)) || isMaybeType (getType (body for)) = newExpr + | otherwise = outerLet + + getVariables :: Expr -> [Expr] + getVariables For{body} = removeDuplicates (fst (filterVar body)) [] [] + where + removeDuplicates :: [Expr] -> [Name] -> [Expr] -> [Expr] + removeDuplicates [] _ finalList = finalList + removeDuplicates (e@VarAccess{qname}:expr) listOfNames finalList + | (qnlocal qname) `elem` listOfNames = removeDuplicates expr listOfNames finalList + | otherwise = removeDuplicates expr ((qnlocal qname):listOfNames) (e:finalList) + removeDuplicates (_:expr) listOfNames finalList = undefined + + filterVar :: Expr -> ([Expr], [Name]) + filterVar = foldrExp (\e (acc, declAcc) -> if isNotLocalVar e declAcc + then ((getVar e):acc, declAcc) + else if isLet e + then (acc, (getDecls e) ++ declAcc) + else (acc, declAcc)) ([], []) + where + isNotLocalVar Assign{lhs = VarAccess{qname}} decl = not $ (Name (show (qnlocal qname))) `elem` decl + isNotLocalVar _ decl = False + isLet Let{} = True + isLet _ = False + getVar Assign{lhs} = lhs + getDecls Let{decls} = concatMap getDecls' $ fst $ unzip decls + getDecls' declList = map getDecl declList + getDecl VarNoType{varName} = varName + getDecl VarType{varName}= varName + in output + +-- Traverses the AST with body as the starting node, and exchanges all non-local VarAccess, part of boxVarList, into FieldAccess +-- varBodyToFieldBody (x = x + y) [] [x] -> __box_mutable__x.value = __box_mutable__x.value + y +varBodyToFieldBody body declList boxedVarList = extend (varBodyToFieldBody' declList boxedVarList) body + where + varBodyToFieldBody' declList boxedVarList v@VarAccess{qname} + | isLocalVar v declList && isBoxedVar v boxedVarList = varAccToFieldAcc v + | otherwise = v + varBodyToFieldBody' declList boxedVarList l@Let{decls, body} = l{decls, body = (varBodyToFieldBody body (getDecls l ++ declList) boxedVarList)} + varBodyToFieldBody' declList boxedVarList m = m + isLocalVar VarAccess{qname} decl = not $ (Name (show (qnlocal qname))) `elem` decl + isBoxedVar VarAccess{qname} boxedNameList = (qnlocal qname) `elem` boxedNameList + getDecls Let{decls} = concatMap getDecls' $ fst $ unzip decls + getDecls' declList = map getDecl declList + getDecl VarNoType{varName} = varName + getDecl VarType{varName}= varName + + varAccToFieldAcc VarAccess{emeta, qname} = + let boxQname = intoQName (Name ("__box_mutable__" ++ show (qnlocal qname))) + boxVarAcc = intoVarAccess emeta boxQname + in intoFieldAccess emeta boxVarAcc (Name "value") + +-- Takes a list of variables, and the scope they apply to, and boxes the variables in Let-IN clause. +-- boxVar meta [x] body -> let __box_mutable_x = new MutBox(x) +-- in body +boxVar meta listOfVar body = + intoLet meta Var (makeDecls meta listOfVar) body + where + makeDecls meta varAccess = map (makeDecl meta) varAccess + makeDecl emeta v@VarAccess{qname} = + let box = boxNewWithInit emeta [getType v] [v] + variableDecl = intoVarDecl $ Name ("__box_mutable__" ++ show (qnlocal qname)) + in ([variableDecl], box) + +-- Takes a list of variables that have been boxed, and assignes them their new value from their corresponsing boxes. +-- unBox [x, y, z] -> x = [__box_mutable_x.value, y = __box_mutable_y.value, z = __box_mutable_x.value] +unBox varAccList = map (unBoxVar) varAccList + where unBoxVar v@VarAccess{emeta, qname} = intoAssignment emeta (intoVarAccess emeta qname) (fieldAccessRhs emeta qname) + boxQname qname = intoQName (Name ("__box_mutable__" ++ show (qnlocal qname))) + boxVarAcc emeta qname = intoVarAccess emeta (boxQname qname) + fieldAccessRhs emeta qname = intoFieldAccess emeta (boxVarAcc emeta qname) (Name "value") + +-- returns Expr with clean meta Data +intoSkip meta = + Skip{emeta = Meta.meta (Meta.getPos meta)} + +-- returns Expr with clean meta Data +intoReturn meta value = + Return{emeta = Meta.meta (Meta.getPos meta) + ,val = value} +-- returns Expr with clean meta Data +intoMaybeValue meta mValue = + MaybeValue{emeta = Meta.meta (Meta.getPos meta) + ,mdt = mValue} +-- returns Expr +intoVarAccess meta name = + VarAccess{emeta = meta + ,qname = name} +-- returns Expr with clean meta Data +intoClosure meta parameters mty body = + Closure {emeta = Meta.meta (Meta.getPos meta) + ,eparams = parameters + ,mty = mty + ,body = body} + +-- returns Expr with clean meta Data +intoParam emetaP mutP nameP maybeTyP = + Param {pmeta = Meta.meta (Meta.getPos emetaP) + ,pmut = mutP + ,pname = nameP + ,ptype = fromMaybe intType maybeTyP + ,pdefault = Nothing} + +-- returns Expr with clean meta Data +intoFunctionCall meta typeArg name arguments = + FunctionCall {emeta = meta + ,typeArguments = typeArg + ,qname = name + ,args = arguments} + +-- returns a Qname +intoQName name = + QName{qnspace = Nothing + ,qnsource = Nothing + ,qnlocal = name} + +-- returns Expr +intoMethodCall meta typeArg object nam arguments = + MethodCall {emeta = meta, + typeArguments = typeArg, + target = object, + name = nam, + args = arguments} + +-- returns Expr with clean meta Data +intoAssignment meta left right = + Assign {emeta = Meta.meta (Meta.getPos meta), + lhs = left, + rhs = right} + +-- returns Expr with clean meta Data +intoFieldAccess meta object nam = + FieldAccess{ emeta = Meta.meta (Meta.getPos meta), + target = object, + name = nam} + +-- returns Expr +intoSeq meta listOfExpr = + Seq {emeta = meta, + eseq = listOfExpr} + +-- returns Expr +boxNewWithInit meta parameters arguments = + NewWithInit{emeta = Meta.meta (Meta.getPos meta), + ty = boxObjectType parameters, + args = arguments} + +-- return a VarDecl without typing informaion +intoVarDecl name = + VarNoType{varName = name} + +-- returns Expr +intoLet meta mut varDecls body = + Let {emeta = meta, + mutability = mut, + decls = varDecls, + body = body} + +-- returns Expr +intoTypedExpr meta body ty = + TypedExpr {emeta = Meta.meta (Meta.getPos meta), + body = body, + ty = ty} diff --git a/src/parser/Parser/Parser.hs b/src/parser/Parser/Parser.hs index 13b989179..eb5db9a3e 100644 --- a/src/parser/Parser/Parser.hs +++ b/src/parser/Parser/Parser.hs @@ -1444,17 +1444,18 @@ expr = notFollowedBy nl >> reserved "then" return $ \thn -> Unless{emeta, cond, thn} - for = blockedConstruct $ do + for = blockedConstruct $ do emeta <- buildMeta reserved "for" - name <- Name <$> identifier - reservedOp "<-" - src <- expression - stepMeta <- buildMeta - step <- option (IntLiteral stepMeta 1) - (do {reserved "by"; expression}) + sources <- option [] $ (commaSep getForSource) reserved "do" - return $ \body -> For{emeta, name, src, step, body} + return $ \body -> For{emeta, sources, body} + where + getForSource = do + fsName <- Name <$> identifier + reservedOp "<-" + collection <- expression + return ForSource {fsName, fsTy = Nothing, collection} while = blockedConstruct $ do emeta <- buildMeta diff --git a/src/runtime/pony/premake4.lua b/src/runtime/pony/premake4.lua index 3ac7a0d9e..44f0635c9 100644 --- a/src/runtime/pony/premake4.lua +++ b/src/runtime/pony/premake4.lua @@ -64,6 +64,7 @@ solution "ponyrt" buildoptions { "-mcx16", "-pthread", + "-latomic", "-std=gnu11", "-march=native", "-Wunused-parameter", diff --git a/src/tests/encore/basic/for-loop.enc b/src/tests/encore/basic/for-loop.enc index d4780e580..dcc5d70d1 100644 --- a/src/tests/encore/basic/for-loop.enc +++ b/src/tests/encore/basic/for-loop.enc @@ -1,50 +1,97 @@ --- This file was automatically converted by encorec +import Collections.Mutable.LinkedList -fun showRange(r : Range) : unit - for i <- r do - println(i) - end -end -active class Foo - def msg(m : String) : unit - println(m) +fun useList(list : LinkedList[String]) : unit + for elem <- list do + print("{}", elem) end + print("\n") end + active class Main - var foo : int def main() : unit - this.foo = 1 - let - fs = [new Foo, null, new Foo, null] - a = [false, false, true, false, true] - nums = [1, 2, 3, 4, 7, 8, 9, 1, 12] - r = [1..10] - in - for b <- a do - println(b) - end - println("--------------") - for n <- nums by 2 do - println(n) - end - println("--------------") - showRange(r) - println("--------------") - for i <- [1..3] by 2 do - println(i) - end - println("--------------") - for i <- [0..100 by 10] by - 3 do - println(i) - end - println("--------------") - for i <- [this.foo..1] do - println(i) - end - println("--------------") - for f <- fs by 2 do - f!msg("Foo") + + var linklistInt = new LinkedList[int]() + var linklistString = new LinkedList[String]() + + var range = [0 .. 10] + var range2 = [0 .. 5] + + var array = ["a", "b", "c", "d", "e"] + var array2 = ["1", "2", "3", "4", "5"] + + for x <- range do + linklistInt.append(x) + end + for x <- array do + linklistString.append(x) + end + + -- result in: 0 1 2 3 4 5 6 7 8 9 10 + for x <- range do + var k = 0 + print("{} ", x) + print(k ) + end + + print("\n") + + -- result in: 0 1 2 3 4 5 6 7 8 9 10 + for x <- linklistInt do + print("{} ", x) + end + + print("\n") + + -- result in: a b c d e + for x <- array do + print("{} ", x) + end + + print("\n") + + -- result in: a b c d e + for x <- linklistString do + print("{} ", x) + end + + var acc = "" + + print("\n") + -- result in: a1 a2 a3 a4 a5 b1 b2 b3 b4 b5 c1 c2 c3 c4 c5 d1 d2 d3 d4 d5 e1 e2 e3 e4 e5 + var retList = for x <- array, y <- array2 do + acc = x.concatenate(y) + print("{} ", acc) + acc + end + + -- result in: e5 + print("\n{}\n", acc) + + -- result in: a1 a2 a3 a4 a5 b1 b2 b3 b4 b5 c1 c2 c3 c4 c5 d1 d2 d3 d4 d5 e1 e2 e3 e4 e5 + for x <- retList do + print("{} ", x) + end + + print("\n") + + for i <- range do + for j <- ["y", "x"] do + print("{}{} ", i, j) end end + + print("\n") + + var acc2 = 0 + for i <- range, j <- range2 do + acc2 += (i + j) + end + print("{}", acc2) + print("\n") + -- result in: abcde + useList(for x <- linklistString do + x + end) + end end diff --git a/src/tests/encore/basic/for-loop.out b/src/tests/encore/basic/for-loop.out index 11b660f25..9d28a04a8 100644 --- a/src/tests/encore/basic/for-loop.out +++ b/src/tests/encore/basic/for-loop.out @@ -1,35 +1,10 @@ -false -false -true -false -true --------------- -1 -3 -7 -9 -12 --------------- -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 --------------- -1 -3 --------------- -100 -70 -40 -10 --------------- -1 --------------- -Foo -Foo +0 01 02 03 04 05 06 07 08 09 010 0 +0 1 2 3 4 5 6 7 8 9 10 +a b c d e +a b c d e +a1 a2 a3 a4 a5 b1 b2 b3 b4 b5 c1 c2 c3 c4 c5 d1 d2 d3 d4 d5 e1 e2 e3 e4 e5 +e5 +a1 a2 a3 a4 a5 b1 b2 b3 b4 b5 c1 c2 c3 c4 c5 d1 d2 d3 d4 d5 e1 e2 e3 e4 e5 +0y 0x 1y 1x 2y 2x 3y 3x 4y 4x 5y 5x 6y 6x 7y 7x 8y 8x 9y 9x 10y 10x +495 +abcde diff --git a/src/tests/encore/stdlib/Collections/Mutable/LinkedListTest.enc b/src/tests/encore/stdlib/Collections/Mutable/LinkedListTest.enc index c3b255ed9..5b9ebcda0 100644 --- a/src/tests/encore/stdlib/Collections/Mutable/LinkedListTest.enc +++ b/src/tests/encore/stdlib/Collections/Mutable/LinkedListTest.enc @@ -206,7 +206,7 @@ fun prepend_three_and_remove_middle() : bool list.prepend(420) list.remove(1) - + match list.first with case Just(first) => @@ -214,7 +214,7 @@ fun prepend_three_and_remove_middle() : bool match first.next with case Just(second) => is_nothing(second.next) && second.value == 42 case _ => false - end + end end case _ => false @@ -866,5 +866,3 @@ active class Main tests.run() end end - - diff --git a/src/tests/encore/stdlib/Data/BoxedTest.enc b/src/tests/encore/stdlib/Data/BoxedTest.enc index cbf167a26..9f01525e4 100644 --- a/src/tests/encore/stdlib/Data/BoxedTest.enc +++ b/src/tests/encore/stdlib/Data/BoxedTest.enc @@ -23,4 +23,4 @@ active class Main assertFalse((new Bool(false)).value()) assertTrue((new Real(12.12)).value() > (new Real(6.06)).value()) end -end \ No newline at end of file +end diff --git a/src/types/Typechecker/Capturechecker.hs b/src/types/Typechecker/Capturechecker.hs index d2528cdb4..274c72509 100644 --- a/src/types/Typechecker/Capturechecker.hs +++ b/src/types/Typechecker/Capturechecker.hs @@ -148,6 +148,9 @@ instance CaptureCheckable Expr where doCapturecheck e@Consume{} = free e + doCapturecheck e@For{body} = + return $ makeCaptured e + doCapturecheck e@Assign{lhs, rhs} = do let lType = getType lhs rType = getType rhs diff --git a/src/types/Typechecker/Typechecker.hs b/src/types/Typechecker/Typechecker.hs index 0e78b63fb..5f56e3807 100644 --- a/src/types/Typechecker/Typechecker.hs +++ b/src/types/Typechecker/Typechecker.hs @@ -14,7 +14,6 @@ import Data.List import Data.Map.Strict(Map) import qualified Data.Map.Strict as Map import Data.Maybe -import Debug.Trace import qualified Data.Text as T import Control.Monad.Reader import Control.Monad.Except @@ -26,7 +25,7 @@ import Identifiers import AST.AST hiding (hasType, getType) import qualified AST.AST as AST (getType) import qualified AST.Util as Util (freeVariables, filter, markStatsInBody, - isStatement, isForwardInExpr) + isStatement, isForwardInExpr, filter) import AST.PrettyPrinter import AST.Util(extend) import Types as Ty @@ -34,7 +33,6 @@ import Typechecker.Environment import Typechecker.TypeError import Typechecker.Util import Text.Printf (printf) -import Debug.Trace -- | The top-level type checking function typecheckProgram :: Map FilePath LookupTable -> Program -> @@ -584,12 +582,13 @@ instance Checkable Expr where -- E |- () : unit doTypecheck skip@(Skip {}) = return $ setType unitType skip + doTypecheck e@(ExtractorPattern{}) = return e -- -- ---------------- -- E |- break : unit doTypecheck break@(Break {emeta}) = do - unless (Util.isStatement break) $ - tcError BreakUsedAsExpressionError + --unless (Util.isStatement break) $ + --tcError BreakUsedAsExpressionError unlessM (asks checkValidUseOfBreak) $ tcError BreakOutsideOfLoopError return $ setType unitType break @@ -1266,19 +1265,23 @@ instance Checkable Expr where | isValidPattern pattern = hasType pattern argty | otherwise = tcError $ InvalidPatternError pattern - checkClause pt clause@MatchClause{mcpattern, mchandler, mcguard} = do - vars <- getPatternVars pt mcpattern - let duplicates = vars \\ nub vars - unless (null duplicates) $ - tcError $ - DuplicatePatternVarError (fst (head duplicates)) mcpattern - let withLocalEnv = local (extendEnvironmentImmutable vars) - ePattern <- withLocalEnv $ checkPattern mcpattern pt - eHandler <- withLocalEnv $ typecheck mchandler - eGuard <- withLocalEnv $ hasType mcguard boolType - return $ clause {mcpattern = extend makePattern ePattern - ,mchandler = eHandler - ,mcguard = eGuard} + checkClause pt clause@MatchClause{mcpattern, mchandler, mcguard} = + if isExtractorPattern mcpattern + then return clause + else + do + vars <- getPatternVars pt mcpattern + let duplicates = vars \\ nub vars + unless (null duplicates) $ + tcError $ + DuplicatePatternVarError (fst (head duplicates)) mcpattern + let withLocalEnv = local (extendEnvironmentImmutable vars) + ePattern <- withLocalEnv $ checkPattern mcpattern pt + eHandler <- withLocalEnv $ typecheck mchandler + eGuard <- withLocalEnv $ hasType mcguard boolType + return $ clause {mcpattern = extend makePattern ePattern + ,mchandler = eHandler + ,mcguard = eGuard} doTypecheck borrow@(Borrow{target, name, body}) = do eTarget <- typecheck target @@ -1727,28 +1730,70 @@ instance Checkable Expr where -- -------------------------- -- E |- for x <- rng e : ty - -- E |- arr : [ty] - -- E, x : int |- e : ty + -- E |- arr : [ty1] + -- E, x : ty1 |- e : ty -- -------------------------- -- E |- for x <- arr e : ty - doTypecheck for@(For {name, step, src, body}) = - do stepTyped <- doTypecheck step - srcTyped <- doTypecheck src - let srcType = AST.getType srcTyped - - unless (isArrayType srcType || isRangeType srcType) $ - pushError src $ NonIterableError srcType - - let elementType = if isRangeType srcType - then intType - else getResultType srcType - bodyTyped <- typecheckBody elementType body - return $ setType unitType for{step = stepTyped - ,src = srcTyped - ,body = bodyTyped} - where - addIteratorVariable ty = extendEnvironmentImmutable [(name, ty)] - typecheckBody ty = local (addIteratorVariable ty) . typecheck + + -- E |- col : isRefType, inner : ty1 + -- E, x : ty1 |- e : ty + -- -------------------------- + -- E |- for x <- col e : ty + doTypecheck for@(For {sources, body}) = do + sourceType <- firstSourceType $ head sources + sourcesTyped <- mapM (typeCheckSource sourceType) sources + nameList <- getNameTypeList sourcesTyped + bodyTyped <- typecheckBody nameList body + let returnType = getRetType bodyTyped $ head sourcesTyped + return $ setType returnType for{sources = sourcesTyped + ,body = bodyTyped} + where + typeCheckSource sourceType fors@(ForSource{fsTy, collection}) = do + collectionTyped <- doTypecheck collection + let collectionType = AST.getType collectionTyped + formalType <- firstSourceType fors + unless (formalType == sourceType) $ + pushError collection $ TypeMismatchError formalType sourceType + let mtyType = return $ getInnerType collectionType + return fors{fsTy = mtyType + ,collection = setType collectionType collectionTyped} + + firstSourceType ForSource{fsTy, collection} = do + collectionTyped <- doTypecheck collection + let collectionType = AST.getType collectionTyped + unless (isRefType collectionType || isArrayType collectionType) $ + pushError collection $ NonIterableError collectionType + formal <- if isRefType collectionType + then findFormalRefType collectionType + else return collectionType + return formal + + getNameTypeList sourceList = mapM getNameType sourceList + getNameType ForSource{fsName, collection} = do + let collectionType = AST.getType collection + let nameType = getInnerType collectionType + return (fsName, nameType) + + getInnerType collectionType + | isArrayType collectionType = getResultType collectionType + | isRangeObjectType collectionType = intType + | otherwise = head $ getTypeParameters collectionType + + typecheckBody nameList = local (extendEnvironmentImmutable nameList) . doTypecheck + + getRetType body ForSource{collection} = + let paraType = AST.getType body + collectionType = AST.getType collection + containsBreak exp = not $ null $ Util.filter isBreak exp + rettype + | containsBreak body = maybeType unitType + | AST.getType body == unitType = unitType + | isArrayType collectionType = setResultType collectionType paraType + | isRangeObjectType collectionType = unitType + | otherwise = setTypeParameters collectionType [paraType] + in rettype + + --- |- ty -- E |- size : int @@ -1847,7 +1892,7 @@ instance Checkable Expr where (length expectedTypes) (length args) eArgs <- mapM typecheck args matchArguments args expectedTypes - return $ setType bottomType abort{args=([]::[Expr])} + return $ setType bottomType abort{args = eArgs} doTypecheck stringLit@(StringLiteral {}) = do when (Util.isStatement stringLit) $ diff --git a/src/types/Types.hs b/src/types/Types.hs index a21cbb49f..d950df384 100644 --- a/src/types/Types.hs +++ b/src/types/Types.hs @@ -31,6 +31,9 @@ module Types( ,isPassiveClassType ,isMainType ,stringObjectType + ,rangeObjectType + ,boxObjectType + ,isRangeObjectType ,isStringObjectType ,conjunctiveType ,isConjunctiveType @@ -1036,9 +1039,17 @@ isMainType _ = False stringObjectType = setRefSourceFile "String.enc" $ makeRead $ classType "String" [] +boxObjectType param = classType "MutBox" param + +rangeObjectType = classType "RRange" [] + + isStringObjectType ty = isClassType ty && getId ty == "String" +isRangeObjectType ty = isClassType ty && getId ty == "RRange" + + replaceTypeVars :: [(Type, Type)] -> Type -> Type replaceTypeVars bindings = typeMap replace where replace ty =