refine standard library and interpreter

README.md

@@ -17,9 +17,9 @@ Getting Started
 
 U.hs uses file extension .u. Example of helloworld.u:
 ```
-(import io)
+(import* io)
 (def main (run
-	(_ (io.putStrLn "hello world"))
+	(_ (putStrLn "hello world"))
 	(exit 0)
 	)
 )
@@ -37,12 +37,15 @@ A basic repl calculator is also included.
 ```
 $runghc urepl.hs
 ; type :q to quit, :? for help
->(+ 3 1)
+prelude>(+ 3 1)
 4
->(putChar 'a' (\_ (putChar '\n' exit)))
-a
+prelude>(import* io)
+prelude io>(putStrLn "ha" print)
+ha
+0
 >:q
 ```
+Note that, "print" is just the identity function (\x x). When using it as a callback, the execution is terminated with result printed.
 
 Language Specification
 ----------------

UData.hs

@@ -78,7 +78,7 @@ applyBBinaryArith BDiv (BFloat a) (BInt b) = numToBResult (BFloat (a/(fromIntegr
 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 (BInt a) (BInt b) = numToBResult (BInt (a `mod` b))
 applyBBinaryArith BMod _ _ = BException "cannot use non-integer value in mod"
 
 compBNum :: BCompType -> BNum -> BNum -> Bool

UEnvironment.hs

@@ -3,6 +3,8 @@ module UEnvironment where
 import System.IO
 import System.Environment
 import Data.Char
+import System.Process
+import System.Exit
 import Control.Monad.Trans.Class
 
 class UEnv e where
@@ -15,6 +17,7 @@ class UEnv e where
 	ePeekChar :: Int -> e Int
 	ePutChar :: Int -> Int -> e Int
 	eGetArg :: e Int
+	eSystem :: [Int] -> e Int
 
 data UEvalResult r a = URunning a | UExited Int | UExceptionHappened [Char] | UResultReturned r
 newtype UEvalEnv r e a = UEvalEnv {runUEvalEnv :: e (UEvalResult r a)}
@@ -64,6 +67,9 @@ flGetArg (UFileList hdls (a:ar)) = (a,UFileList hdls ar)
 
 newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (a,UFileList Handle)}
 
+liftUR :: IO a -> URealWorldEnv a
+liftUR b = URealWorldEnv (\f -> (b>>=(\a -> return (a,f))))
+
 instance Monad URealWorldEnv where
 	(URealWorldEnv f) >>= g = URealWorldEnv (\initfiles -> 
 			((f initfiles) >>= (\(va,files1) -> runRealWorldEnv (g va) files1)))
@@ -75,7 +81,7 @@ isValidCharInt a = (a>=0 && a<1114112)
 
 instance UEnv URealWorldEnv where
 	eOpen filename mode = URealWorldEnv (\initfiles ->
-		if (mode>=0 && mode<=length efOpenModes) then
+		if (mode<0 || mode>=length efOpenModes) then
 			return ((-2),initfiles)
 		else if (any (not.isValidCharInt) filename) then
 			return ((-3),initfiles)
@@ -122,15 +128,25 @@ instance UEnv URealWorldEnv where
 		let (ret,files1)=flGetArg initfiles in
 		return (ret,files1)
 		)
+	eSystem cmd_int = URealWorldEnv (\initfiles -> do
+		if (all isValidCharInt cmd_int) then do
+			let cmd = map chr cmd_int
+			exit_code <- system cmd
+			case exit_code of
+				ExitSuccess -> return (0,initfiles)
+				ExitFailure a -> return (a,initfiles)
+		else
+			return ((-3),initfiles)
+		)
+
 
-initRealWorldEnv :: URealWorldEnv ()
-initRealWorldEnv = URealWorldEnv (\oldstate -> 
-	getArgs >>= (\args ->
-		let iargs = listjoin (-1) (map (map ord) args) in
-			return ((),UFileList [Just stdin,Just stdout] iargs))) where
+initRealWorldEnv :: [[Char]] -> URealWorldEnv ()
+initRealWorldEnv args = URealWorldEnv (\oldstate -> 
+		let iargs = listjoin 0 (map (map ord) args) in
+			return ((),UFileList [Just stdin,Just stdout] iargs)) where
 	listjoin s [] = []
 	listjoin s (a:[]) = a
 	listjoin s (a:ar) = a++(s:(listjoin s ar))
 
-runRealWorld :: URealWorldEnv a -> IO a
-runRealWorld f = (runRealWorldEnv (initRealWorldEnv>>f)) (UFileList [] []) >>= (return.fst)
+runRealWorld :: [[Char]] -> URealWorldEnv a -> IO a
+runRealWorld args f = (runRealWorldEnv (initRealWorldEnv args>>f)) (UFileList [] []) >>= (return.fst)

ULambdaExpression.hs

@@ -26,7 +26,7 @@ defaultBuiltinNames = [
 	"/=",
 	"=",
 	"exit",
-	"open",
+	"openCmd",
 	"close",
 	"getChar",
 	"getCharF",
@@ -35,5 +35,6 @@ defaultBuiltinNames = [
 	"putChar",
 	"putCharF",
 	"getArg",
-	"consFileName"
+	"consFileName",
+	"systemCmd"
 	]

UModuleLoader.hs

@@ -55,7 +55,8 @@ mAddDefs modname revimports defs c = case defs of
 
 
 addModuleFile :: ([Char],SPosition) -> [Char] -> [Char] -> MLoadContext -> IO (MMayFail MLoadContext)
-addModuleFile caller filename modname c = do
+addModuleFile caller filename modname c0 = do
+	let c = (\(MLoadContext loaded curchain) -> MLoadContext (Set.insert ("  "++modname) loaded) curchain) c0
 	hasfile <- doesFileExist filename
 	if (not hasfile) then (return$MFail ("cannot find "++filename) (fst caller) (snd caller)) else do
 		s_mod <- loadModule filename
@@ -73,7 +74,7 @@ addModuleFile caller filename modname c = do
 addImport :: ([Char],SPosition) -> [Char] -> MLoadContext -> IO (MMayFail MLoadContext)
 addImport caller modname c = let
 	(MLoadContext loaded curchain)=c in
-	if (Set.member modname loaded) then (return$return c) else
+	if (Set.member ("  "++modname) loaded) then (return$return c) else
 		addModuleFile caller (modname++".u") modname c
 
 addImports :: ([Char],SPosition) -> [[Char]] -> MLoadContext -> IO (MMayFail MLoadContext)

UParse.hs

@@ -203,6 +203,7 @@ parseSSExp (tree,sp) = case tree of
 	STTList (((STTNode (STAtom "list")),p):r) -> constructListSugar r p
 	STTList (((STTNode (STAtom "run")),p):r) -> constructRunSugar r p
 	STTList (((STTNode (STAtom "do")),p):r) -> constructDoSugar r p
+	STTList (((STTNode (STAtom "let")),p):r) -> constructLetSugar r p
 	STTList [] -> SFail "empty expression" sp
 	STTList (_:[]) -> SFail "extra parenthesis" sp
 	STTList (f:r) -> do
@@ -243,7 +244,15 @@ parseSSExp (tree,sp) = case tree of
 			(e1,p1) <- parseSSExp e
 			(e2,p2) <- constructRunSugar r p
 			return (SSApply (e1,p1) (SSLambda name (e2,p2),p0),p0)
-		constructRunSugar ((_,p1):r) p = SFail "invalid statement in do/run clause" p1
+		constructRunSugar ((_,p1):r) p = SFail "invalid syntax in do/run clause" p1
+		constructLetSugar [] p = SFail "empty let clause" p
+		constructLetSugar (h:[]) p = parseSSExp h
+		constructLetSugar ((STTList [(STTNode (STAtom name),p0),e],_):r) p = do
+			(e1,p1) <- parseSSExp e
+			(e2,p2) <- constructLetSugar r p
+			return (SSApply (SSLambda name (e2,p2),p0) (e1,p1),p0)
+		constructLetSugar ((_,p1):_) _ = SFail "invalid syntax in let clause" p1
+
 
 parseSSModule :: [(STokenTree,SPosition)] -> SMayFail SSModule
 parseSSModule trees = do
@@ -258,10 +267,10 @@ parseSSModule trees = do
 		) where
 		getImportBlock blocks = case blocks of
 			[] -> SSucc ([],[])
-			((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)]),p1):r -> do
+			((STTList [(STTNode (STAtom "import*"),_),(STTNode (STAtom name),_)]),p1):r -> do
 				(sis,remain) <- getImportBlock r
 				return ((((SSImport name SIUnqualified),p1):sis),remain)
-			((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom "qualified"),_),(STTNode (STAtom name),_)]),p1):r -> do
+			((STTList [(STTNode (STAtom "import"),_),(STTNode (STAtom name),_)]),p1):r -> do
 				(sis,remain) <- getImportBlock r
 				return ((((SSImport name SIQualified),p1):sis),remain)
 			_ -> SSucc ([],blocks)

URunTime.hs

@@ -7,7 +7,7 @@ import ULambdaExpression
 import Control.Monad.Trans.Class
 
 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 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 | VSystem | VSystem1 [Int] | VSystem2 [Int] 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
@@ -38,6 +38,9 @@ showVSysCall (VPutChar2 v a) = "(putChar "++(show v)++" "++(show a)++")"
 showVSysCall (VPutChar3 v a _) = "(putChar "++(show v)++" "++(show a)++" ...)"
 showVSysCall (VGetArg) = "getArg"
 showVSysCall (VGetArg1 _) = "(getArg ...)"
+showVSysCall (VSystem) = "system"
+showVSysCall (VSystem1 v) = "(system "++(showBValue (BIntList v))++")"
+showVSysCall (VSystem2 v _) = "(system "++(showBValue (BIntList v))++" ...)"
 
 showValue :: Value -> [Char]
 showValue (VBuiltin b) = showBValue b
@@ -83,7 +86,7 @@ vBuiltInList=[
 	("/=", (VCompFunc (VComp BNEq))),
 	("=", (VCompFunc (VComp BEq))),
 	("exit", (VSys (VExit))),
-	("open", (VSys (VOpen))),
+	("openCmd", (VSys (VOpen))),
 	("close", (VSys (VClose))),
 	("getChar", (VSys (VGetChar1 0))),
 	("getCharF", (VSys (VGetChar))),
@@ -92,6 +95,7 @@ vBuiltInList=[
 	("putChar", (VSys (VPutChar1 1))),
 	("putCharF", (VSys (VPutChar))),
 	("getArg", (VSys (VGetArg))),
+	("systemCmd", (VSys (VSystem))),
 	("consFileName", (VBuiltin (BIntList [])))
 	]
 
@@ -104,7 +108,7 @@ applyFunc :: BoundValue -> VResult -> VResult
 applyFunc ((VBuiltin a),ca) br = (case br of
 	(VException e) -> VException e
 	(VGood (VBuiltin b,_)) -> bValToVResult (applyBVal  a b)
-	(VGood x) -> VException ("cannot feed non-builtin value to builtin value "++(show a))
+	(VGood x) -> VException ("cannot feed non-builtin value to builtin value "++(showBValue a))
 	)where
 		bValToVResult (BException e) = VException e
 		bValToVResult (BClean v) = VGood (VBuiltin v,emptyContext)
@@ -120,48 +124,54 @@ applyFunc (VCompFunc (VComp1 c a),_) br = case br of
 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"
+						_                                         -> 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 b),emptyContext)
-						_                                   -> VException "cannot call Open with non-IntList filename"
+						_                                   -> 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"
+						_                                   -> 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"
+						_                                         -> 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"
+						_                                         -> 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"
+						_                                         -> 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"
+						_                                         -> 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"
+						_                                         -> 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"
+applyFunc (VSys VSystem,_) br = case br of
+						(VException e)                            -> VException e
+						(VGood ((VBuiltin (BIntList a)),_)) -> VGood (VSys (VSystem1 a),emptyContext)
+						_                                         -> VException "cannot call system with non-IntList command"
+applyFunc (VSys (VSystem1 a),_) br = VGood (VSys (VSystem2 a br),emptyContext)
+applyFunc (VSys (VSystem2 _ _),_) _ = VException "too many arguments given to syscall system"
 
 evalExp :: VExpression -> VContext -> VResult
 evalExp (VClean v) context = VGood (v,context)
@@ -196,7 +206,8 @@ executeVResult vr = case vr of
 		(VSys (VGetChar2 f cont)) -> (lift$eGetChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
 		(VSys (VPeekChar2 f cont)) -> (lift$ePeekChar f) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
 		(VSys (VGetArg1 cont)) -> (lift$eGetArg) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
-		(VSys s) -> eException ("insufficient syscall args in "++(show s))
+		(VSys (VSystem2 a cont)) -> (lift$eSystem a) >>= (\retval -> (executeVResult (feedVResult cont (veInt retval))))
+		(VSys s) -> eException ("insufficient syscall args in "++(showVSysCall s))
 		_ -> eReturnResult (val,context)
 
 executeVExp :: (UEnv e) => (Monad e) => VExpression -> UEvalEnv (Value,VContext) e ()

aplusb.u

@@ -0,0 +1,8 @@
+(import* io)
+(import* str)
+(run
+	(a readInt)
+	(b readInt)
+	(_ (putStrLn (itoa (+ a b))))
+	(exit 0)
+)

helloworld.u

@@ -1,5 +1,5 @@
-(import io)
+(import* io)
 (run
-	(_ (io.putStrLn "hello world"))
+	(_ (putStrLn "hello world"))
 	(exit 0)
 )

io.u

@@ -1,4 +1,4 @@
-(import str)
+(import* str)
 ;impl helpers
 (let readIfF (\handle condition
 	(do
@@ -28,16 +28,30 @@
 ; input
 (def readIntF (\handle
 	(do
-		(_ (readWhileF handle str.isSpace))
+		(_ (readWhileF handle isSpace))
 		(sign_m (readIfF handle (= '-')))
 		(let sign (sign_m 1 (neg 1)))
-		(numbers_c (readWhileF handle str.isDigit))
-		(let numbers (str.atoi numbers_c))
+		(numbers_c (readWhileF handle isDigit))
+		(let numbers (atoi numbers_c))
 		(return (* sign numbers))
 	)
 ))
 (def readInt (readIntF 0))
 
+; getArg
+(let getArgStr (recur (\f (do
+	(a getArg)
+	((< a 0) (return "") (run
+		(remain f)
+		(return (cons a remain))
+	))
+))))
+(def getArgs (do
+	(a getArgStr)
+	(return (splitStr 0 a))
+))
+
+
 ; output
 (def putStrF (\handle (recur (\f (\s (do
 	(s (return 0) (\h r (