From 91cfcd28b6e9379bf9288c207fedb2495d2c7bf8 Mon Sep 17 00:00:00 2001 From: Haoqiang Fan Date: Mon, 19 Dec 2016 02:26:01 +0800 Subject: [PATCH] first commit --- UData.hs | 79 +++++++++++++++++++++++ UEnvironment.hs | 131 ++++++++++++++++++++++++++++++++++++++ UParse.bak.hs | 40 ++++++++++++ UParse.hs | 162 +++++++++++++++++++++++++++++++++++++++++++++++ URunTime.back.hs | 154 ++++++++++++++++++++++++++++++++++++++++++++ URunTime.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++ a.u | 10 +++ io.u | 39 ++++++++++++ prelude.u | 37 +++++++++++ str.u | 3 + 10 files changed, 808 insertions(+) create mode 100644 UData.hs create mode 100644 UEnvironment.hs create mode 100644 UParse.bak.hs create mode 100644 UParse.hs create mode 100644 URunTime.back.hs create mode 100644 URunTime.hs create mode 100644 a.u create mode 100644 io.u create mode 100644 prelude.u create mode 100644 str.u diff --git a/UData.hs b/UData.hs new file mode 100644 index 0000000..635a9ca --- /dev/null +++ b/UData.hs @@ -0,0 +1,79 @@ +module UData where + +data BNum = BInt Int | BFloat Double deriving Show +data BBinaryArith = BAdd | BSub | BMul | BDiv | BMod deriving Show +data BArith = BArith2 BBinaryArith BNum | BToInt | BToFloat deriving Show +data BFunc = BArithFunc BArith | BArith2Func BBinaryArith deriving Show +data BValue = BNumVal BNum | BFuncVal BFunc | BIntList [Int] deriving Show +data BResult = BClean BValue | BException [Char] deriving Show + +numToBResult :: BNum -> BResult +numToBResult a = BClean (BNumVal a) + +data BCompType = BLe | BGe | BNLe | BNGe | BEq | BNEq deriving Show + +applyBVal :: BValue -> BValue -> BResult +applyBVal (BFuncVal b) (BNumVal v) = applyBFunc b v +applyBVal (BFuncVal b) _ = BException ("cannot apply non-numeric argument to builtin function "++(show b)) +applyBVal (BIntList args) (BNumVal (BInt v)) = BClean (BIntList (v:args)) +applyBVal (BIntList args) _ = BException "cannot append non-integer number in IntList" +applyBVal _ _ = BException "cannot use numeric value as function" + +applyBFunc :: BFunc -> BNum -> BResult +applyBFunc (BArith2Func a) d = BClean (BFuncVal (BArithFunc (BArith2 a d))) +applyBFunc (BArithFunc a) v = applyBArith a v + +applyBArith :: BArith -> BNum -> BResult +applyBArith (BArith2 a b) c = applyBBinaryArith a b c +applyBArith BToInt (BInt a) = numToBResult (BInt a) +applyBArith BToInt (BFloat a) = numToBResult (BInt (floor a)) +applyBArith BToFloat (BFloat a) = numToBResult (BFloat a) +applyBArith BToFloat (BInt a) = numToBResult (BFloat (fromIntegral a)) + +applyBBinaryArith :: BBinaryArith -> BNum -> BNum -> BResult +applyBBinaryArith BAdd (BInt a) (BInt b) = numToBResult (BInt (a+b)) +applyBBinaryArith BAdd (BFloat a) (BInt b) = numToBResult (BFloat (a+(fromIntegral b))) +applyBBinaryArith BAdd (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)+b)) +applyBBinaryArith BAdd (BFloat a) (BFloat b) = numToBResult (BFloat (a+b)) +applyBBinaryArith BSub (BInt a) (BInt b) = numToBResult (BInt (a-b)) +applyBBinaryArith BSub (BFloat a) (BInt b) = numToBResult (BFloat (a-(fromIntegral b))) +applyBBinaryArith BSub (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)-b)) +applyBBinaryArith BSub (BFloat a) (BFloat b) = numToBResult (BFloat (a-b)) +applyBBinaryArith BMul (BInt a) (BInt b) = numToBResult (BInt (a*b)) +applyBBinaryArith BMul (BFloat a) (BInt b) = numToBResult (BFloat (a*(fromIntegral b))) +applyBBinaryArith BMul (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)*b)) +applyBBinaryArith BMul (BFloat a) (BFloat b) = numToBResult (BFloat (a*b)) +applyBBinaryArith BDiv _ (BInt 0) = BException "divided by zero" +applyBBinaryArith BDiv (BInt a) (BInt b) = numToBResult (BInt (a `div`b)) +applyBBinaryArith BDiv (BFloat a) (BInt b) = numToBResult (BFloat (a/(fromIntegral b))) +applyBBinaryArith BDiv (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)/b)) +applyBBinaryArith BDiv (BFloat a) (BFloat b) = numToBResult (BFloat (a/b)) +applyBBinaryArith BMod _ (BInt 0) = BException "mod by zero" +applyBBinaryArith BMod (BInt a) (BInt b) = numToBResult (BInt (a `div`b)) +applyBBinaryArith BMod _ _ = BException "cannot use non-integer value in mod" + +compBNum :: BCompType -> BNum -> BNum -> Bool +compBNum BLe (BInt a) (BInt b) = (a=b) +compBNum BNLe (BInt a) (BFloat b) = ((fromIntegral a)>=b) +compBNum BNLe (BFloat a) (BInt b) = (a>=(fromIntegral b)) +compBNum BNLe (BFloat a) (BFloat b) = (a>=b) +compBNum BGe (BInt a) (BInt b) = (a>b) +compBNum BGe (BInt a) (BFloat b) = ((fromIntegral a)>b) +compBNum BGe (BFloat a) (BInt b) = (a>(fromIntegral b)) +compBNum BGe (BFloat a) (BFloat b) = (a>b) +compBNum BNGe (BInt a) (BInt b) = (a<=b) +compBNum BNGe (BInt a) (BFloat b) = ((fromIntegral a)<=b) +compBNum BNGe (BFloat a) (BInt b) = (a<=(fromIntegral b)) +compBNum BNGe (BFloat a) (BFloat b) = (a<=b) +compBNum BEq (BInt a) (BInt b) = (a==b) +compBNum BEq (BInt a) (BFloat b) = ((fromIntegral a)==b) +compBNum BEq (BFloat a) (BInt b) = (a==(fromIntegral b)) +compBNum BEq (BFloat a) (BFloat b) = (a==b) +compBNum BNEq (BInt a) (BInt b) = (a/=b) +compBNum BNEq (BInt a) (BFloat b) = ((fromIntegral a)/=b) +compBNum BNEq (BFloat a) (BInt b) = (a/=(fromIntegral b)) +compBNum BNEq (BFloat a) (BFloat b) = (a/=b) diff --git a/UEnvironment.hs b/UEnvironment.hs new file mode 100644 index 0000000..a6f6945 --- /dev/null +++ b/UEnvironment.hs @@ -0,0 +1,131 @@ +module UEnvironment where + +import System.IO +import System.Environment +import Data.Char +import qualified Data.Map as Map + + + +class UEnv e where + eExit :: Int -> e () + eException :: [Char] -> e () + eOpen :: [Int] -> Int -> e Int + eClose :: Int -> e Int + eGetChar :: Int -> e Int + ePeekChar :: Int -> e Int + ePutChar :: Int -> Int -> e Int + eGetArg :: e Int + +efOpenModes = [ReadMode,WriteMode,AppendMode,ReadWriteMode] +-- currently, only r and w are supported + +data UFinishState a = URunning a | UFinished Int | UExceptionHappened [Char] deriving Show +data UFileList h = UFileList {flFiles::[Maybe h],flArgToRead::[Int]} deriving Show + +flAddHandle :: h -> UFileList h -> (Int,UFileList h) +flAddHandle h (UFileList hdls args) = findEmptySlot hdls id 0 where + findEmptySlot [] prefix curno = (curno,UFileList (prefix [Just h]) args) + findEmptySlot (Nothing:r) prefix curno = (curno,UFileList (prefix ((Just h):r)) args) + findEmptySlot (a:r) prefix curno = findEmptySlot r (\x -> prefix (a:x)) (curno+1) + +flGetHandle :: Int -> UFileList h -> Maybe h +flGetHandle fno (UFileList hdls args) + | fno>=0 && fno UFileList h -> UFileList h +flCloseHandle fno (UFileList hdls args) + | fno>=0 && fno (Int,UFileList h) +flGetArg (UFileList hdls []) = ((-1),UFileList hdls []) +flGetArg (UFileList hdls (a:ar)) = (a,UFileList hdls ar) + + +newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (UFinishState a,UFileList Handle)} + +instance Monad URealWorldEnv where + -- f :: UFileList -> IO (UFinishState a,UFileList) + -- g :: a -> URealWorldEnv (UFileList -> IO (UFinishState b,UFileList)) + (URealWorldEnv f) >>= g = URealWorldEnv (\initfiles -> + (f initfiles) >>= (\(finishstate1,files1) -> + case finishstate1 of + UFinished r -> return (UFinished r ,files1) + UExceptionHappened e -> return (UExceptionHappened e,files1) + URunning va -> runRealWorldEnv (g va) files1 + ) + ) + f >> g = (f >>= (const g)) + return a = URealWorldEnv (\f -> return (URunning a,f)) + +isValidCharInt :: Int -> Bool +isValidCharInt a = (a>=0 && a<1114112) + +instance UEnv URealWorldEnv where + eExit retval = URealWorldEnv (\initfiles -> + return (UFinished retval,initfiles)) + eException msg = URealWorldEnv (\initfiles -> + return (UExceptionHappened msg,initfiles)) + eOpen filename mode = URealWorldEnv (\initfiles -> + if (mode>=0 && mode<=length efOpenModes) then + return (URunning (-2),initfiles) + else if (any (not.isValidCharInt) filename) then + return (URunning (-3),initfiles) + else + (openFile (map chr filename) (efOpenModes!!mode) >>= + (\handle -> ( let (fno,files1) = flAddHandle handle initfiles in + return (URunning fno,files1) + ))) + ) + eClose fno = URealWorldEnv (\initfiles -> + case (flGetHandle fno initfiles) of + Nothing -> return (URunning (-2),initfiles) + Just hdl -> ( hClose hdl >> ( + return (URunning 0,(flCloseHandle fno initfiles)) + )) + ) + eGetChar fno = URealWorldEnv (\initfiles -> + case (flGetHandle fno initfiles) of + Nothing -> return (URunning (-2),initfiles) + Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of + False -> hGetChar hdl >>= (\c ->return (URunning (ord c),initfiles)) + True -> return (URunning (-1),initfiles) + ) + ) + ePeekChar fno = URealWorldEnv (\initfiles -> + case (flGetHandle fno initfiles) of + Nothing -> return (URunning (-2),initfiles) + Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of + False -> hLookAhead hdl >>= (\c -> return (URunning (ord c),initfiles)) + True -> return (URunning (-1),initfiles) + ) + ) + ePutChar fno content = URealWorldEnv (\initfiles -> + if isValidCharInt content then + case (flGetHandle fno initfiles) of + Nothing -> return (URunning (-2),initfiles) + Just hdl -> ( hPutChar hdl (chr content) >> ( + return (URunning (0),initfiles) + )) + else + return (URunning (-3),initfiles) + ) + eGetArg = URealWorldEnv (\initfiles -> + let (ret,files1)=flGetArg initfiles in + return (URunning ret,files1) + ) + +initRealWorldEnv = URealWorldEnv (\oldstate -> + getArgs >>= (\args -> + let iargs = listjoin (-1) (map (map ord) args) in + return (URunning (),UFileList [Just stdin,Just stdout] iargs))) where + listjoin s [] = [] + listjoin s (a:[]) = a + listjoin s (a:ar) = a++(s:(listjoin s ar)) +runRealWorld a = (runRealWorldEnv (initRealWorldEnv >> a) (UFileList [] [])) >>= (\(exitstate,_) -> + case exitstate of + UFinished 0 -> return () + UFinished a -> putStrLn ("exit with code "++show a) + UExceptionHappened e -> putStrLn e + URunning _ -> putStrLn "execution interupted" + ) diff --git a/UParse.bak.hs b/UParse.bak.hs new file mode 100644 index 0000000..87ee89b --- /dev/null +++ b/UParse.bak.hs @@ -0,0 +1,40 @@ +module UParse where + +import Data.Char + +data SToken = SUnresolved [Char] | SIntConst Int | SDoubleConst Double +type STokenPos = (SToken,Int) + +applySnd f (x,y) = (x,f y) +applyPair f g (x,y) = (f x,g y) +consFst a (x,y) = (a:x,y) + +dropSpaceAndComment :: [Char] -> [Char] +dropSpaceAndComment x + | null x = [] + | isSpace (head x) = dropSpaceAndComment (tail x) + | (head x)==';' = dropSpaceAndComment (dropWhile (/='\n') (tail x)) + | otherwise = x + +groupUntil get_next should_stop s + | should_stop s = ([],s) + | otherwise = (cur:remain_group,remain_s) where + (cur,s_other) = get_next s + (remain_group,remain_s) = groupUntil get_next should_stop s_other + +parseToStrings :: [Char] -> [[Char]] +parseToStrings = parseToStrings' . dropSpaceAndComment where + parseToStrings' = fst.(groupUntil nextString' null) + nextString' = (applySnd dropSpaceAndComment).nextString + nextString (x:xs) + | elem x ['\'','"'] = (consFst x) (nextLexical x xs) + | elem x ['(',')','\\'] = ([x],xs) + | otherwise = (span validIdChar (x:xs)) + validIdChar a = not (isSpace a) && not (elem a ['(',')','\\']) + nextLexical d [] = ([],[]) + nextLexical d (x:xs) + | x==d = ([d],xs) + | x=='\\' && not (null xs) && x1==d = (consFst x)$(consFst x1)$(nextLexical d x1s) + | otherwise = consFst x (nextLexical d xs) where + x1:x1s = xs + diff --git a/UParse.hs b/UParse.hs new file mode 100644 index 0000000..264ca02 --- /dev/null +++ b/UParse.hs @@ -0,0 +1,162 @@ +module UParse where + +import Data.Char + +type SPosition = (Int,Int) +data SMayFail a = SFail [Char] SPosition | SSucc a deriving Show +data SToken = STAtom [Char] | STInt Int | STDouble Double | SLeftPar | SRightPar | STLambda | STStr deriving Show +data STokenTree = STTNode SToken | STTList [(STokenTree,SPosition)] + +instance Show STokenTree where + show t = show' t 0 (0,0) where + show' t indent pos = case t of + STTNode token -> take indent (repeat ' ') ++ ((show token) ++" ;"++(show pos)++ "\n") + STTList trees -> ((take indent (repeat ' '))++"STTree ;"++(show pos)++"\n")++concat (map (\(x,p) -> show' x (indent+4) p) trees) + +data SSExp = SSInt Int | SSDouble Double | SSLambda [Char] (SSExp,SPosition) | SSRef [Char] | SSApply (SSExp,SPosition) (SSExp,SPosition) deriving Show +data SSImport = SSImport [Char] Bool deriving Show +data SSDef = SSDef [Char] (SSExp,SPosition) Bool deriving Show +data SSModule = SSMainModule [(SSImport,SPosition)] [(SSDef,SPosition)] (SSExp,SPosition) | SSSubModule [Char] [(SSImport,SPosition)] [(SSDef,SPosition)] deriving Show + +instance Monad SMayFail where + (SSucc a) >>= g = g a + (SFail a b) >>= g = SFail a b + return a = SSucc a + +annotatePositions :: [Char] -> [(Char,SPosition)] +annotatePositions content = zip content (scanl (\(l0,c0) c -> + if c=='\n' then (l0+1,0) else (l0,c0+1)) (0,0) content) + +dropWhiteSpace :: [(Char,SPosition)] -> [(Char,SPosition)] +dropWhiteSpace [] = [] +dropWhiteSpace ((a,ap):ar) + | isSpace a = dropWhiteSpace ar + | a==';' = dropWhiteSpace (dropWhile (\(b,_) -> b/='\n') ar) + | otherwise = ((a,ap):ar) + +isValidCharInt :: Int -> Bool +isValidCharInt a = (a>=0 && a<1114112) + +intFromDigits a = intFromDigits' a 0 where + intFromDigits' [] cur = cur + intFromDigits' (d:ar) cur = intFromDigits' ar (cur*10+((ord d)-(ord '0'))) + + +splitChrSpecial :: [(Char,SPosition)] -> SPosition -> SMayFail (Char,[(Char,SPosition)]) +splitChrSpecial ar ap = case ar of + [] -> SFail "incomplete escape sequence" ap + (('a',_):arr) -> SSucc ('\a',arr) + (('b',_):arr) -> SSucc ('\b',arr) + (('n',_):arr) -> SSucc ('\n',arr) + (('r',_):arr) -> SSucc ('\r',arr) + (('v',_):arr) -> SSucc ('\v',arr) + (('f',_):arr) -> SSucc ('\f',arr) + (('t',_):arr) -> SSucc ('\t',arr) + (('\\',_):arr) -> SSucc ('\\',arr) + (('\'',_):arr) -> SSucc ('\'',arr) + (('\"',_):arr) -> SSucc ('\"',arr) + (('x',_):arr) -> let + (npart,arrr) = span (\(x,_) -> isDigit x) arr in + if null npart then SFail "\\x must be followed by digits" ap + else let + c_int=((intFromDigits (map fst npart))) in + if isValidCharInt c_int then SSucc ((chr c_int),arrr) + else SFail "\\x value not in range" ap + ((c,_):arr) -> SSucc (c,arr) +splitStrLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) +splitStrLiteral ar ap = case ar of + ('"',_):arr -> SSucc ((STAtom "",ap),arr) + ('\\',arp):arr -> do + (c,arrr) <- splitChrSpecial arr arp + (((STAtom sr),_),arrrr) <- splitStrLiteral arrr ap + return ((STAtom (c:sr),ap),arrrr) + (ah,_):arr -> do + (((STAtom sr),_),arrr) <- splitStrLiteral arr ap + return ((STAtom (ah : sr),ap),arrr) + [] -> SFail "unmatched \"" ap +splitCharLiteral :: [(Char,SPosition)] -> SPosition -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) +splitCharLiteral ar ap = case ar of + ('\'',_):[] -> SFail "empty ''" ap + ('\\',_):arr -> do + (c,arrr) <- splitChrSpecial arr ap + case arrr of + ('\'',_):arrr -> SSucc (((STInt (ord c)),ap),arrr) + _ -> SFail "unmatched \'" ap + (c0,_):('\'',_):arr -> SSucc (((STInt (ord c0)),ap),arr) + [] -> SFail "unmatched \"" ap + +isStopChar c = isSpace c || elem c "()\\;" +splitNumLiteral :: [(Char,SPosition)] -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) +splitNumLiteral a = let + ap = snd (head a) + (sign,a1) = (case a of + ('+',_):ar -> (1,ar) + ('-',_):ar -> ((-1),ar) + ar -> (1,ar) + ) + (before_dot,after_dot1) = span (isDigit.fst) a1 in + if (null after_dot1) || (isStopChar$fst$head$after_dot1) then + SSucc (((STInt (((intFromDigits (map fst before_dot)))*sign)),snd (head a)),after_dot1) + else let + after_dot = (case after_dot1 of + ('.',_):r -> r + r -> r + ) + (before_e,after_e1) = span (isDigit.fst) after_dot + (has_e,after_e) = (case after_e1 of + ('e',_):r -> (True,r) + ('E',_):r -> (True,r) + r -> (False,r) + ) + (sign_e,after_es) =(if has_e then (case after_e of + ('+',_):r -> (1,r) + ('-',_):r -> ((-1),r) + r -> (1,r) + )else (1,after_e) + ) + (before_end,remain) = span (isDigit.fst) after_es in + if has_e && null before_end then SFail "invalid float literal " (snd (head a)) else let + int_part = intFromDigits (map fst before_dot) + mentisa_part = (sum (zipWith (*) (map (\(x,_) -> fromIntegral ((ord x)-(ord '0'))) before_e) (iterate (*0.1) 0.1)))::Double + e_part = (if has_e then (10.0 ** (fromIntegral (sign_e * intFromDigits (map fst before_end)))) else 1.0)::Double in + SSucc (((STDouble ((fromIntegral sign)*((fromIntegral int_part)+mentisa_part)*e_part)),ap),remain) + +splitFirstString :: [(Char,SPosition)] -> SMayFail ((SToken,SPosition),[(Char,SPosition)]) +splitFirstString ((a,ap):ar) + | a=='(' = SSucc ((SLeftPar,ap),ar) + | a==')' = SSucc ((SRightPar,ap),ar) + | a=='\\' = SSucc ((STLambda,ap),ar) + | a=='"' = splitStrLiteral ar ap + | a=='\'' = splitCharLiteral ar ap + | elem a "0123456789" || (elem a "+-." && (not (null ar)) && elem (fst (head ar)) "0123456789") = splitNumLiteral ((a,ap):ar) + | elem a "0123456789" = SFail "invalid number literal" ap + | otherwise = (let (al,arr) =span (\(x,_) -> not (isStopChar x)) ((a,ap):ar) in + SSucc ((STAtom (map fst al),ap),arr)) +groupStrings :: [(Char,SPosition)] -> SMayFail [(SToken,SPosition)] +groupStrings = groupStrings' . dropWhiteSpace where + groupStrings' [] = SSucc [] + groupStrings' a = do + (f,r) <- splitFirstString a + remain <- groupStrings r + return (f:remain) + +groupTokenTree :: [(SToken,SPosition)] -> SMayFail (STokenTree,SPosition) +groupTokenTree [] = SFail "empty file" (0,0) +groupTokenTree a = (groupTokenTree' a) >>= (\(r,remain) -> case remain of + [] -> SSucc r + ((_,p)):_ -> SFail "extra tokens at end of file" p + ) where + groupTokenTree' a = case a of + ((SLeftPar,p):r) -> do + (trees,remain) <- groupUntilRightPar r p + if null trees then SFail "empty ()" p else + return (((STTList trees),p),remain) + ((SRightPar,p):r) -> SFail "unmatched )" p + ((ah,p):r) -> return (((STTNode ah),p),r) + groupUntilRightPar a sp = case a of + [] -> SFail "unmatched (" sp + ((SRightPar,_):r) -> return ([],r) + _ -> do + (t,rr) <- groupTokenTree' a + (ts,rrr) <- groupUntilRightPar rr sp + return ((t:ts),rrr) diff --git a/URunTime.back.hs b/URunTime.back.hs new file mode 100644 index 0000000..d38114e --- /dev/null +++ b/URunTime.back.hs @@ -0,0 +1,154 @@ +module URunTime where + +import Data.Char +import Data.Int +import qualified Data.Map as Map + +{- list of builtin functions +Add Add1 builtin.+ a b +Sub Sub1 builtin.- a b +Mul Mul1 builtin.* a b +Div Div1 builtin./ a b +Mod Mod1 builtin.% a b +Eq Eq1 builtin.= a b +NEq NEq1 builtin.!= a b +Le Le1 builtin.< a b +Ge Ge1 builtin.> a b +NLe NLe1 builtin.>= a b +NGe NGe1 builtin.<= a b +ToInt builtin.toInt a +ToFloat builtin.toFloat a +-} + +data BuiltinNode = BAdd | BAddI Int | BAddF Double | + BSub | BSubI Int | BSubF Double | + BMul | BMulI Int | BMulF Double | + BMul | BMul1 Value | BDiv | BDiv1 Value | + BMod | BMod1 Value | BToInt | BToFloat | + BEq | BEq1 Value | BNEq | BNEq1 Value | + BLe | BLe1 Value | BGe | BGe1 Value | + BNLe | BNLe1 Value | BNGe | BNGe1 Value + deriving Show +data Value = IntVal Int | FloatVal Double | AbsNode Value | ApplyNode Value Value | RefNode Int | SyscallVal [Int] | BuiltinVal BuiltinNode | ExceptionVal [Char] deriving Show + +data BoundValue = BoundValue Value [BoundValue] deriving Show +pureValue v = BoundValue v [] +stripBound (BoundValue v _) = v + +isIntVal (IntVal _) = True +isIntVal _ = False +getIntVal (IntVal x) =x +isFloatVal (FloatVal _) = True +isFloatVal _ = False +getFloatVal (FloatVal x) =x + +--(evalExp e) guarentees that e is not ApplyNode or RefNode +applyFunc :: BoundValue -> BoundValue -> BoundValue +applyFunc (BoundValue f f_context) (BoundValue x x_context) = case f of + IntVal v -> pureValue (ExceptionVal "cannot use int as function") + FloatVal v -> pureValue (ExceptionVal "cannot use float as function") + AbsNode v -> evalExp (BoundValue v ((BoundValue x x_context):f_context)) + SyscallVal v -> pureValue (SyscallVal (x:v)) + BuiltinVal v -> pureValue (applyBuiltin v x) + ExceptionVal v -> pureValue f -- exception eats all value +evalExp :: BoundValue -> BoundValue +evalExp (BoundValue e context) = case e of + ApplyNode f x -> applyFunc (evalExp (BoundValue f context)) (evalExp (BoundValue x context)) + RefNode v -> evalExp (context!!v) + _ -> (BoundValue e context) + +-- True = \x \y x +vTrue = AbsNode (AbsNode (RefNode 1)) +-- False = \x \y y +vFalse = AbsNode (AbsNode (RefNode 0)) + +vFromBool True = vTrue +vFromBool False = vFalse + +applyBuiltin :: BuiltinNode -> Value -> Value +applyBuiltin BAdd v = BuiltinVal (BAdd1 v) +applyBuiltin (BAdd1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> IntVal (ai+bi) + (FloatVal ai,FloatVal bi) -> FloatVal (ai+bi) + (IntVal ai, FloatVal bi) -> FloatVal (ai+bi) + (FloatVal ai,IntVal bi ) -> FloatVal (ai+bi) + _ -> ExceptionVal "type mismatch for +" +applyBuiltin BSub v = BuiltinVal (BSub1 v) +applyBuiltin (BSub1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> IntVal (ai-bi) + (FloatVal ai,FloatVal bi) -> FloatVal (ai-bi) + (IntVal ai, FloatVal bi) -> FloatVal (ai-bi) + (FloatVal ai,IntVal bi ) -> FloatVal (ai-bi) + _ -> ExceptionVal "type mismatch for -" +applyBuiltin BMul v = BuiltinVal (BMul1 v) +applyBuiltin (BMul1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> IntVal (ai*bi) + (FloatVal ai,FloatVal bi) -> FloatVal (ai*bi) + (IntVal ai, FloatVal bi) -> FloatVal (ai*bi) + (FloatVal ai,IntVal bi ) -> FloatVal (ai*bi) + _ -> ExceptionVal "type mismatch for *" +applyBuiltin BDiv v = BuiltinVal (BDiv1 v) +applyBuiltin (BDiv1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) + | bi /= 0 -> IntVal (ai `div` bi) + | otherwise -> ExceptionVal "divided by zero" + (FloatVal ai,FloatVal bi) -> FloatVal (ai/bi) + (IntVal ai, FloatVal bi) -> FloatVal (ai/bi) + (FloatVal ai,IntVal bi ) -> FloatVal (ai/bi) + _ -> ExceptionVal "type mismatch for /" +applyBuiltin BMod v = BuiltinVal (BMod1 v) +applyBuiltin (BMod1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> IntVal (ai `mod` bi) + _ -> ExceptionVal "invalid argument type for %" +applyBuiltin BLe v = BuiltinVal (BLe1 v) +applyBuiltin (BLe1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai vFromBool (ai vFromBool (ai vFromBool (ai ExceptionVal "type mismatch for <" +applyBuiltin BNLe v = BuiltinVal (BNLe1 v) +applyBuiltin (BNLe1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai>=bi) + (FloatVal ai,FloatVal bi) -> vFromBool (ai>=bi) + (IntVal ai, FloatVal bi) -> vFromBool (ai>=bi) + (FloatVal ai,IntVal bi ) -> vFromBool (ai>=bi) + _ -> ExceptionVal "type mismatch for >=" +applyBuiltin BGe v = BuiltinVal (BGe1 v) +applyBuiltin (BGe1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai>bi) + (FloatVal ai,FloatVal bi) -> vFromBool (ai>bi) + (IntVal ai, FloatVal bi) -> vFromBool (ai>bi) + (FloatVal ai,IntVal bi ) -> vFromBool (ai>bi) + _ -> ExceptionVal "type mismatch for >" +applyBuiltin BNGe v = BuiltinVal (BNGe1 v) +applyBuiltin (BNGe1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai<=bi) + (FloatVal ai,FloatVal bi) -> vFromBool (ai<=bi) + (IntVal ai, FloatVal bi) -> vFromBool (ai<=bi) + (FloatVal ai,IntVal bi ) -> vFromBool (ai<=bi) + _ -> ExceptionVal "type mismatch for <=" +applyBuiltin BEq v = BuiltinVal (BEq1 v) +applyBuiltin (BEq1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai==bi) + (FloatVal ai,FloatVal bi) -> vFromBool (ai==bi) + (IntVal ai, FloatVal bi) -> vFromBool (ai==bi) + (FloatVal ai,IntVal bi ) -> vFromBool (ai==bi) + _ -> ExceptionVal "type mismatch for =" +applyBuiltin BNEq v = BuiltinVal (BNEq1 v) +applyBuiltin (BNEq1 a) b = case (a,b) of + (IntVal ai, IntVal bi ) -> vFromBool (ai/=bi) + (FloatVal ai,FloatVal bi) -> vFromBool (ai/=bi) + (IntVal ai, FloatVal bi) -> vFromBool (ai/=bi) + (FloatVal ai,IntVal bi ) -> vFromBool (ai/=bi) + _ -> ExceptionVal "type mismatch for /=" +applyBuiltin BToInt v = case v of + (IntVal ai) -> v + (FloatVal ai) -> IntVal (floor ai) + _ -> ExceptionVal "type mismatch for toInt" +applyBuiltin BToFloat v = case v of + (IntVal ai) -> FloatVal ai + (FloatVal ai) -> v + _ -> ExceptionVal "type mismatch for toFloat" + + diff --git a/URunTime.hs b/URunTime.hs new file mode 100644 index 0000000..25a5edb --- /dev/null +++ b/URunTime.hs @@ -0,0 +1,153 @@ +module URunTime where + +import qualified Data.Map as Map +import UData +import UEnvironment + +data VComp = VComp BCompType | VComp1 BCompType BNum deriving Show +data VSysCall = VExit | VExit1 Int | VOpen | VOpen1 [Int] | VOpen2 [Int] Int | VOpen3 [Int] Int VResult | VClose | VClose1 Int | VClose2 Int VResult | VGetChar | VGetChar1 Int | VGetChar2 Int VResult | VPeekChar | VPeekChar1 Int | VPeekChar2 Int VResult | VPutChar | VPutChar1 Int | VPutChar2 Int Int | VPutChar3 Int Int VResult | VGetArg | VGetArg1 VResult deriving Show +data Value = VBuiltin BValue | VAbs [Char] VExpression | VCompFunc VComp | VSys VSysCall deriving Show +data VExpression = VClean Value | VApply VExpression VExpression | VRef [Char] deriving Show +type VContext=Map.Map [Char] VResult +type BoundValue = (Value,VContext) +data VResult = VGood BoundValue | VException [Char] deriving Show + +veAbs a b = VClean (VAbs a b) + +vTrue = VAbs "x" (veAbs "y" (VRef "x")) +vFalse = VAbs "x" (veAbs "y" (VRef "y")) +vEmpty = VAbs "f" (veAbs "g" (VRef "f")) +vCons = VAbs "x" (veAbs "y" (veAbs "f" (veAbs "g" (VApply (VApply (VRef "g") (VRef "x")) (VRef "y"))))) +veTrue = VClean vTrue +veFalse = VClean vFalse +veCons = VClean vCons +veEmpty = VClean vEmpty +boolValue :: Bool -> Value +boolValue True = vTrue +boolValue False = vTrue + +veInt a=VClean (VBuiltin (BNumVal (BInt a))) +veFloat a=VClean (VBuiltin (BNumVal (BFloat a))) + +vBuiltInList=[ + ("+", (VBuiltin (BFuncVal (BArith2Func BAdd)))), + ("-", (VBuiltin (BFuncVal (BArith2Func BSub)))), + ("*", (VBuiltin (BFuncVal (BArith2Func BMul)))), + ("/", (VBuiltin (BFuncVal (BArith2Func BDiv)))), + ("%", (VBuiltin (BFuncVal (BArith2Func BMod)))), + ("<", (VCompFunc (VComp BLe))), + (">=", (VCompFunc (VComp BNLe))), + (">", (VCompFunc (VComp BGe))), + ("<=", (VCompFunc (VComp BNGe))), + ("/=", (VCompFunc (VComp BEq))), + ("==", (VCompFunc (VComp BNEq))), + ("exit", (VSys (VExit))), + ("open", (VSys (VOpen))), + ("close", (VSys (VClose))), + ("getChar", (VSys (VGetChar1 0))), + ("getCharF", (VSys (VGetChar))), + ("peekChar", (VSys (VPeekChar1 0))), + ("peekCharF", (VSys (VPeekChar))), + ("putChar", (VSys (VPutChar1 1))), + ("putCharF", (VSys (VPutChar))), + ("getArgs", (VSys (VGetArg))), + ("makeIntList", (VBuiltin (BIntList []))) + ] + +emptyContext = (Map.empty::VContext) +veBuiltInDict = Map.fromList (map (\(x,y) -> (x,(VClean y))) vBuiltInList) +vrBuiltInDict = Map.fromList (map (\(x,y) -> (x,(VGood (y, emptyContext)))) vBuiltInList) + + +applyFunc :: BoundValue -> VResult -> VResult +applyFunc ((VBuiltin a),ca) br = (case br of + (VException e) -> VException e + (VGood (VBuiltin b,_)) -> bValToVResult (applyBVal a b) + )where + bValToVResult (BException e) = VException e + bValToVResult (BClean v) = VGood (VBuiltin v,emptyContext) +applyFunc ((VAbs k v),ca) br = evalExp v (Map.insert k br ca) +applyFunc (VCompFunc (VComp c),_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal a)),_)) -> VGood (VCompFunc (VComp1 c a),emptyContext) + _ -> VException "cannot compare non-numeric values" +applyFunc (VCompFunc (VComp1 c a),_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal b)),_)) -> VGood (boolValue (compBNum c a b),emptyContext) + _ -> VException "cannot compare non-numeric values" +applyFunc (VSys VExit,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VExit1 b),emptyContext) + _ -> VException "cannot call Exit with non-integer value" +applyFunc (VSys (VExit1 _),_) _ = VException "too many arguments given to syscall exit" +applyFunc (VSys VOpen,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BIntList b)),_)) -> VGood (VSys (VOpen1 (reverse b)),emptyContext) + _ -> VException "cannot call Open with non-IntList filename" +applyFunc (VSys (VOpen1 a),_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VOpen2 a b),emptyContext) + _ -> VException "cannot call Open with non-integer mode" +applyFunc (VSys (VOpen2 a b),_) br = VGood (VSys (VOpen3 a b br),emptyContext) +applyFunc (VSys (VOpen3 _ _ _),_) _ = VException "too many arguments given to syscall open" +applyFunc (VSys VClose,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VClose1 b),emptyContext) + _ -> VException "cannot call Close with non-integer handle" +applyFunc (VSys (VClose1 a),_) br = VGood (VSys (VClose2 a br),emptyContext) +applyFunc (VSys (VClose2 _ _),_) _ = VException "too many arguments given to syscall close" +applyFunc (VSys VGetChar,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VGetChar1 b),emptyContext) + _ -> VException "cannot call GetChar with non-integer handle" +applyFunc (VSys (VGetChar1 a),_) br = VGood (VSys (VGetChar2 a br),emptyContext) +applyFunc (VSys (VGetChar2 _ _),_) _ = VException "too many arguments given to syscall getChar" +applyFunc (VSys VPeekChar,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPeekChar1 b),emptyContext) + _ -> VException "cannot call PeekChar with non-integer handle" +applyFunc (VSys (VPeekChar1 a),_) br = VGood (VSys (VPeekChar2 a br),emptyContext) +applyFunc (VSys (VPeekChar2 _ _),_) _ = VException "too many arguments given to syscall peekChar" +applyFunc (VSys VPutChar,_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPutChar1 b),emptyContext) + _ -> VException "cannot call PutChar with non-integer handle" +applyFunc (VSys (VPutChar1 a),_) br = case br of + (VException e) -> VException e + (VGood ((VBuiltin (BNumVal (BInt b))),_)) -> VGood (VSys (VPutChar2 a b),emptyContext) + _ -> VException "cannot call PutChar with non-integer handle" +applyFunc (VSys (VPutChar2 a b),_) br = VGood (VSys (VPutChar3 a b br),emptyContext) +applyFunc (VSys (VPutChar3 _ _ _),_) _ = VException "too many arguments given to syscall putChar" +applyFunc (VSys VGetArg,_) br = VGood (VSys (VGetArg1 br),emptyContext) +applyFunc (VSys (VGetArg1 _),_) br = VException "too many arguments given to syscall getArgs" + +evalExp :: VExpression -> VContext -> VResult +evalExp (VClean v) context = VGood (v,context) +evalExp (VApply a b) context = (case (evalExp a context) of + (VException e) -> VException e + (VGood (av,ac)) -> applyFunc (av,ac) (evalExp b context) + ) +evalExp (VRef k) context = case (Map.lookup k context) of + Nothing -> VException ("cannot find variable "++k) + Just v -> v + +feedVResult :: VResult -> VExpression -> VResult +feedVResult (VException e) _ = (VException e) +feedVResult (VGood (cont,context)) val = evalExp (VApply (VClean cont) val) context + +executeVResult :: (UEnv e) => (Monad e) => VResult -> e () +executeVResult vr = case vr of + VException e -> eException e + VGood (val,context) -> (case val of + (VSys (VExit1 e)) -> eExit e + (VSys (VOpen3 f m cont)) -> (eOpen f m) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys (VClose2 f cont)) -> (eClose f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys (VPutChar3 f c cont)) -> (ePutChar f c) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys (VGetChar2 f cont)) -> (eGetChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys (VPeekChar2 f cont)) -> (ePeekChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys (VGetArg1 cont)) -> eGetArg >>= (\retval -> (executeVResult (feedVResult cont (veInt retval)))) + (VSys _) -> eException "insufficient syscall args" + _ -> eException "expression not evaluated to a syscall" + ) +executeVExp :: (UEnv e) => (Monad e) => VExpression -> e() +executeVExp exp = executeVResult (evalExp exp vrBuiltInDict) diff --git a/a.u b/a.u new file mode 100644 index 0000000..f8c5d2e --- /dev/null +++ b/a.u @@ -0,0 +1,10 @@ +((import io) + +(run + (a io.readInt) + (b io.readInt) + (let c (+ a b)) + (_ (io.putStrLn (show c))) + (exit 0) +) +) diff --git a/io.u b/io.u new file mode 100644 index 0000000..ba1aab8 --- /dev/null +++ b/io.u @@ -0,0 +1,39 @@ +((import str) + +;impl helpers +(let readIfF (\handle\condition + (do + (c (peekCharF handle)) + (if (condition c) + (run + (_ getCharF) ; must be c + (return (just c)) + ) + (return nothing) + ) + ) +)) +(let readWhileF (\handle\condition (recur \r + (do + (c_m (readIfF handle condition)) + (c_m + (return []) + (\c (run + (remain r) + (return (cons c remain)) + )) + ) + ) +))) + +; the numerics +(def readIntF (\handle + (do + (sign_m (readIfF handle (== '-'))) + (let sign (sign_m 1 (neg 1))) + (numbers_c (readWhileF handle str.isDigit)) + (let numbers (atoi numbers_c)) + (return (* sign numbers)) + ) +)) +) diff --git a/prelude.u b/prelude.u new file mode 100644 index 0000000..84e631b --- /dev/null +++ b/prelude.u @@ -0,0 +1,37 @@ +( +(def id (\x x)) +(def recur (\x (x x))) + +; the Bool protocol: (b true_value false_value) +(def True (\x\y x)) +(def False (\x\y y)) +(def if id) +(def not (\x False True)) +(def and (\x\y (x y False))) +(def or (\x\y (x True y))) + +; the Pair protocol: (p (\first\second pair_value)) +(def pair (\x\y\f (f x y))) +(def fst True) +(def snd False) + +; the List protocol: (l null_value (\head\tail list_value)) +(def empty fst) +(def cons (\x\xs\f\g (g x xs))) +(def foldl (\f \x0 (\recur (\g (\l + (l x0 (\x\xs + (f x (g xs)) + )) +))))) + +; the Maybe protocol: (m nothing_value (\v just_value)) +(def nothing fst) +(def just (v (\f\g (g v)))) + +; functional utils +(def apply id) +(def feed (\x\y (y x))) + +; numeric utils +(def neg (- 0)) +) diff --git a/str.u b/str.u new file mode 100644 index 0000000..54a7088 --- /dev/null +++ b/str.u @@ -0,0 +1,3 @@ +((module str) +(def isDigit (\x (and (>= x '0') (<= x '9')))) +)