From: Mart Lubbers Date: Thu, 15 Dec 2016 13:41:16 +0000 (+0100) Subject: add state to the bytecode generator X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=4d5f3a126218768cf63fc693a095dd42247aa2c9;p=mTask.git add state to the bytecode generator --- diff --git a/gCons.dcl b/gCons.dcl index 9733f4a..571aefe 100644 --- a/gCons.dcl +++ b/gCons.dcl @@ -10,10 +10,10 @@ definition module gCons import StdGeneric generic consName a :: a -> String -derive consName CONS of {gcd_name},UNIT,PAIR,EITHER,OBJECT,RECORD,FIELD,Int,Bool,Char,String,(->) +derive consName CONS of {gcd_name},UNIT,PAIR,EITHER,OBJECT,RECORD,FIELD,Int,Bool,Char,String,(->),[] generic consIndex a :: a -> Int -derive consIndex CONS of {gcd_index},UNIT,PAIR,EITHER,OBJECT,Int,Bool,Char,String +derive consIndex CONS of {gcd_index},UNIT,PAIR,EITHER,OBJECT,Int,Bool,Char,String,[] generic conses a :: [a] derive conses CONS,UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),{},{!},[],[! ],[ !],[!!],(->) diff --git a/gCons.icl b/gCons.icl index a7ce132..6e5aaa5 100644 --- a/gCons.icl +++ b/gCons.icl @@ -22,6 +22,7 @@ consName{|Int|} i = toString i consName{|Bool|} b = toString b consName{|Char|} c = toString c consName{|String|} s = s +consName{|[]|} _ _ = "[]" consName{|(->)|} f g x = g (x undef) generic consIndex a :: a -> Int @@ -35,6 +36,7 @@ consIndex{|Int|} i = i consIndex{|Bool|} b = if b 1 0 consIndex{|Char|} c = toInt c consIndex{|String|} _ = 0 +consIndex{|[]|} _ _ = 0 generic conses a :: [a] conses{|CONS|} f = [CONS (hd f)] diff --git a/int/mTaskSymbols.h b/int/mTaskSymbols.h index 90e4b66..35b211a 100644 --- a/int/mTaskSymbols.h +++ b/int/mTaskSymbols.h @@ -1,35 +1,36 @@ #ifndef MTASK_H #define MTASK_H #define BCNOP 1 -#define BCPUSH 2 -#define BCPOP 3 -#define BCSDSSTORE 4 -#define BCSDSFETCH 5 -#define BCSDSPUBLISH 6 -#define BCNOT 7 -#define BCADD 8 -#define BCSUB 9 -#define BCMUL 10 -#define BCDIV 11 -#define BCAND 12 -#define BCOR 13 -#define BCEQ 14 -#define BCNEQ 15 -#define BCLES 16 -#define BCGRE 17 -#define BCLEQ 18 -#define BCGEQ 19 -#define BCJMP 20 -#define BCJMPT 21 -#define BCJMPF 22 -#define BCSERIALAVAIL 23 -#define BCSERIALPRINT 24 -#define BCSERIALPRINTLN 25 -#define BCSERIALREAD 26 -#define BCSERIALPARSEINT 27 -#define BCANALOGREAD 28 -#define BCANALOGWRITE 29 -#define BCDIGITALREAD 30 -#define BCDIGITALWRITE 31 -#define BCTEST 32 +#define BCLAB 2 +#define BCPUSH 3 +#define BCPOP 4 +#define BCSDSSTORE 5 +#define BCSDSFETCH 6 +#define BCSDSPUBLISH 7 +#define BCNOT 8 +#define BCADD 9 +#define BCSUB 10 +#define BCMUL 11 +#define BCDIV 12 +#define BCAND 13 +#define BCOR 14 +#define BCEQ 15 +#define BCNEQ 16 +#define BCLES 17 +#define BCGRE 18 +#define BCLEQ 19 +#define BCGEQ 20 +#define BCJMP 21 +#define BCJMPT 22 +#define BCJMPF 23 +#define BCSERIALAVAIL 24 +#define BCSERIALPRINT 25 +#define BCSERIALPRINTLN 26 +#define BCSERIALREAD 27 +#define BCSERIALPARSEINT 28 +#define BCANALOGREAD 29 +#define BCANALOGWRITE 30 +#define BCDIGITALREAD 31 +#define BCDIGITALWRITE 32 +#define BCTEST 33 #endif diff --git a/mTaskCode.icl b/mTaskCode.icl index 3edd2ce..8402abe 100644 --- a/mTaskCode.icl +++ b/mTaskCode.icl @@ -395,10 +395,10 @@ embed e = (+.+) (C f) (C g) = C \rw c.g Rd (f Rd c) fresh :: (Int -> (Code a p)) -> (Code a p) -fresh f = C \rw c.unC (f c.fresh) rw {c & fresh = c.fresh + 1} +fresh f = C \rw c.unC (f c.fresh) rw {CODE | c & fresh = c.fresh + 1} freshMTask :: (Int -> (Code a p)) -> (Code a p) -freshMTask f = C \rw c.unC (f c.freshMTask) rw {c & freshMTask = c.freshMTask + 1} +freshMTask f = C \rw c.unC (f c.freshMTask) rw {CODE | c & freshMTask = c.freshMTask + 1} setCode :: Def -> (Code a p) setCode d = C \rw c.{c & def = d} diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl index 0939ab4..b8e7d75 100644 --- a/mTaskInterpret.dcl +++ b/mTaskInterpret.dcl @@ -6,7 +6,8 @@ import mTask :: BC = BCNop - | BCPush Int + | BCLab Int + | BCPush [Char] | BCPop //SDS functions | BCSdsStore Int @@ -45,11 +46,11 @@ import mTask | BCDigitalWrite Pin | BCTest AnalogPin -//:: ByteCode a p = BC (BCState -> ([BC], BCState)) -:: ByteCode a p = BC [BC] +:: ByteCode a p = BC (BCState -> ([BC], BCState)) +//:: ByteCode a p = BC [BC] //:: ByteCode a p = BC ((ReadWrite (ByteCode a Expr)) BCState -> ([BC], BCState)) :: BCState = { - a::() + freshl :: [Int] } class toByteCode a :: a -> [Char] @@ -61,7 +62,7 @@ instance toByteCode Long instance toByteCode Button toByteVal :: BC -> [Char] -toReadableByteVal :: BC -> String +//toReadableByteVal :: BC -> String //instance toCode Pin //instance toCode MTask diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index fff57e4..56d19e6 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -3,24 +3,27 @@ implementation module mTaskInterpret //import iTasks import gdynamic, gCons, GenEq, StdMisc, StdArray, GenBimap import GenPrint +import StdEnum import mTask import StdFile import StdString -from StdFunc import o +from StdFunc import o, const import StdBool import StdTuple import Data.Tuple +import Data.Monoid +import Data.Functor import StdList from Data.Func import $ from Text import class Text(concat,join,toUpperCase), instance Text String toByteVal :: BC -> [Char] toByteVal b -# bt = toByteCode b +# bt = toBC b = [bt:case b of - (BCPush i) = [toChar i] + (BCPush i) = i (BCAnalogRead i) = [toChar i] (BCAnalogWrite i) = [toChar i] (BCDigitalRead i) = [toChar i] @@ -30,7 +33,24 @@ toByteVal b (BCJmpF i) = [toChar i] _ = []] where - toByteCode b = toChar $ consIndex{|*|} b + 1 + toBC b = toChar $ consIndex{|*|} b + 1 + +instance Semigroup (ByteCode a p) where + mappend m n = BC \s->let (b1, (b2, t)) = runBC m <$> runBC m s in (b1 ++ b2, t) + +instance Monoid (ByteCode a p) where + mempty = retrn [] + +(<++>) infixl 2 :: (ByteCode a p) (ByteCode b q) -> ByteCode c r +(<++>) m n = BC \s->let (b1, (b2, t)) = runBC n <$> runBC m s in (b1 ++ b2, t) + +(<+->) infixr 1 +(<+->) m n :== m <++> retrn n + +runBC (BC m) = m + +retrn :: ([BC] -> ByteCode a p) +retrn = BC o tuple instance toByteCode Bool where toByteCode True = [toChar 1] @@ -49,11 +69,8 @@ derive gPrint BC, AnalogPin, Pin, DigitalPin derive consIndex BC, Pin, Button derive consName BC, Pin, Button -toReadableByteVal :: BC -> String -toReadableByteVal a = printToString a - instance arith ByteCode where - lit x = BC [BCPush 1] + lit x = retrn [BCPush $ toByteCode x] (+.) x y = x <++> y <+-> [BCAdd] (-.) x y = x <++> y <+-> [BCSub] (*.) x y = x <++> y <+-> [BCMul] @@ -71,11 +88,11 @@ instance boolExpr ByteCode where (>=.) x y = x <++> y <+-> [BCGeq] instance analogIO ByteCode where - analogRead p = BC [BCAnalogRead $ pin p] + analogRead p = retrn [BCAnalogRead $ pin p] analogWrite p b = b <+-> [BCAnalogWrite $ pin p] instance digitalIO ByteCode where - digitalRead p = BC [BCDigitalRead $ pin p] + digitalRead p = retrn [BCDigitalRead $ pin p] digitalWrite p b = b <+-> [BCDigitalWrite $ pin p] instance If ByteCode Stmt Stmt Stmt where If b t e = BCIfStmt b t e @@ -84,12 +101,18 @@ instance If ByteCode Stmt Stmt e where If b t e = BCIfStmt b t e instance If ByteCode x y Expr where If b t e = BCIfStmt b t e instance IF ByteCode where IF b t e = BCIfStmt b t e - (?) b t = BCIfStmt b t $ BC [] -BCIfStmt b t e = b <+-> [BCJmpF $ length <$> t + 1] <++> t - <+-> [BCJmp $ length <$> e] <++> e + (?) b t = BCIfStmt b t $ retrn [] +BCIfStmt b t e = withLabel \else->withLabel \endif->retrn [BCJmpF else] <++> t + <++> retrn [BCJmp endif] <++> e <++> retrn [BCLab endif] + +instance noOp ByteCode where noOp = mempty -instance noOp ByteCode where noOp = BC [] +withLabel :: (Int -> (ByteCode b q)) -> ByteCode b q +withLabel f = BC \s->let [fresh:fs] = s.freshl + in runBC (f fresh) {s & freshl=fs} + +/* instance sds ByteCode where sds f = undef/*{main = let var = 42 @@ -97,44 +120,49 @@ instance sds ByteCode where in unMain body }*/ con f = undef +*/ instance serial ByteCode where - serialAvailable = BC [BCSerialAvail] - serialPrint s = BC [BCSerialPrint] - serialPrintln s = BC [BCSerialPrintln] - serialRead = BC [BCSerialRead] - serialParseInt = BC [BCSerialParseInt] - -(<++>) infixl 7 -(<++>) (BC x) (BC y) = BC $ x ++ y -(<+->) infixl 7 -(<+->) (BC x) y = BC $ x ++ y -(<-+>) infixl 7 -(<-+>) x (BC y) = BC $ x ++ y - -(<$>) infixl 9 -(<$>) f (BC x) = f x + serialAvailable = retrn [BCSerialAvail] + serialPrint s = retrn [BCSerialPrint] + serialPrintln s = retrn [BCSerialPrintln] + serialRead = retrn [BCSerialRead] + serialParseInt = retrn [BCSerialParseInt] instance zero BCState where - zero = {a=()} + zero = {freshl=[1..]} toRealByteCode :: (ByteCode a Expr) -> String -toRealByteCode (BC x) = concat $ map (toString o toByteVal) x +toRealByteCode x +# (bc, st) = runBC x zero += concat $ map (toString o toByteVal) bc -//Start :: ByteCode Int Expr -//Start = (lit 36 +. lit 42) +. lit 84 +toReadableByteCode :: (ByteCode a Expr) -> String +toReadableByteCode x +# (bc, st) = runBC x zero += join "\n" $ map printToString bc + +toReadableByteVal :: BC -> String +toReadableByteVal a = printToString a -to16bit :: Int -> String -to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265)) -//Run test programma en pretty print -//Start :: String -//Start = "t" +++ to16bit (size b) +++ b -Start :: Main (ByteCode Int Expr) -Start = bc +Start :: String +Start = toReadableByteCode bc where - bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)} - b = toRealByteCode bc + bc :: ByteCode Int Expr + bc = (lit 36 +. lit 42) +. lit 44 + +//to16bit :: Int -> String +//to16bit i = toString (toChar (i/265)) +++ toString (toChar (i rem 265)) +// +////Run test programma en pretty print +////Start :: String +////Start = "t" +++ to16bit (size b) +++ b +//Start :: Main (ByteCode Int Expr) +//Start = bc +// where +// bc = sds \x=43 In {main = If (x ==. lit 42) (analogRead A1) (analogRead A0)} +// b = toRealByteCode bc //Start :: ByteCode Int Expr //Start = If (lit True) (analogRead A1) (analogRead A0) //Start = If ((lit 36) ==. (lit 42)) (noOp) (noOp)