diff options
Diffstat (limited to 'VM.hs')
| -rw-r--r-- | VM.hs | 25 |
1 files changed, 13 insertions, 12 deletions
@@ -10,6 +10,7 @@ import qualified System.IO.Error as IO -- import Debug.Trace import AST +import qualified DString as DS import Intermediate @@ -33,7 +34,7 @@ data RunValue = RVClosure Name [RunValue] | RVList [RunValue] | RVNum Int - | RVString String + | RVString DS.DString | RVQuoted RunValue | RVName Name deriving Show @@ -142,7 +143,7 @@ vmRunBuiltin state "cons" [val, RVList l] = return (RVList (val : l), state) vmRunBuiltin state "sys-open-file" [RVNum modenum, RVString path] = do let mode = [ReadMode, WriteMode] !! modenum fid = sUniq state - handle <- openFile path mode + handle <- openFile (DS.unpack path) mode return (RVNum fid, state { sHandles = Map.insert fid handle (sHandles state), sUniq = fid + 1 }) vmRunBuiltin state "sys-close-file" [RVNum fid] = do hClose (sHandles state ! fid) @@ -152,9 +153,9 @@ vmRunBuiltin state "sys-get-char" [RVNum fid] = do eof <- hIsEOF h if eof then return (RVList [], state) - else hGetChar h >>= \ch -> return (RVString [ch], state) + else hGetChar h >>= \ch -> return (RVString (DS.singleton ch), state) vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do - hPutStr (sHandles state ! fid) str + DS.hPutStr (sHandles state ! fid) str return (RVList [], state) vmRunBuiltin state "sys-flush" [RVNum fid] = do hFlush (sHandles state ! fid) @@ -162,14 +163,14 @@ vmRunBuiltin state "sys-flush" [RVNum fid] = do vmRunBuiltin state "sys-stdin" [] = return (RVNum (-1), state) vmRunBuiltin state "sys-stdout" [] = return (RVNum (-2), state) vmRunBuiltin state "sys-stderr" [] = return (RVNum (-3), state) -vmRunBuiltin state "length" [RVString str] = return (RVNum (length str), state) +vmRunBuiltin state "length" [RVString str] = return (RVNum (DS.length str), state) vmRunBuiltin state "substr" [RVNum idx, RVNum len, RVString str] = - let s = (if len >= 0 then take len else id) (drop idx str) + let s = (if len >= 0 then DS.take len else id) (DS.drop idx str) in return (RVString s, state) -vmRunBuiltin state "ord" [RVString str] = return (RVNum (case str of { "" -> 0; c:_ -> ord c }), state) -vmRunBuiltin state "chr" [RVNum num] = return (RVString [chr num], state) +vmRunBuiltin state "ord" [RVString str] = return (RVNum (if DS.null str then 0 else ord (DS.head str)), state) +vmRunBuiltin state "chr" [RVNum num] = return (RVString (DS.singleton (chr num)), state) vmRunBuiltin state "concat" values - | Just strings <- sequence (map fromRVString values) = return (RVString (concat strings), state) + | Just strings <- sequence (map fromRVString values) = return (RVString ({-# SCC builtin_string_concat #-} DS.concat strings), state) | otherwise = throw "Non-string arguments to 'concat'" vmRunBuiltin state "type-list?" [value] = return (RVNum (case value of { RVList _ -> 1; _ -> 0 }), state) vmRunBuiltin state "type-number?" [value] = return (RVNum (case value of { RVNum _ -> 1; _ -> 0 }), state) @@ -192,7 +193,7 @@ equalOp (RVName n) (RVName m) = Right (n == m) equalOp _ _ = Right False printshow :: RunValue -> String -printshow (RVString str) = str +printshow (RVString str) = DS.unpack str printshow (RVList values) = "[" ++ intercalate "," (map printshow values) ++ "]" printshow (RVNum i) = show i printshow (RVQuoted value) = '\'' : printshow value @@ -206,7 +207,7 @@ truthy _ = True toRunValue :: Value -> RunValue toRunValue (VList values) = RVList (map toRunValue values) toRunValue (VNum i) = RVNum i -toRunValue (VString s) = RVString s +toRunValue (VString s) = RVString (DS.pack s) toRunValue (VQuoted value) = RVQuoted (toRunValue value) toRunValue (VName name) = RVName name toRunValue _ = undefined @@ -214,6 +215,6 @@ toRunValue _ = undefined throw :: String -> IO a throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit) -fromRVString :: RunValue -> Maybe String +fromRVString :: RunValue -> Maybe DS.DString fromRVString (RVString str) = Just str fromRVString _ = Nothing |