shithub: MicroHs

Download patch

ref: 3c05ccfe7293328a4f650c0efa8646e382aeada2
parent: f46aa044dc8fce17244821fc9d3c6cd0dc3a91fb
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Nov 10 16:54:26 EST 2023 

Add some more file handling.


--- /dev/null
+++ b/lib/System/Directory.hs
@@ -1,0 +1,12 @@
+module System.Directory(removeFile) where
+import Prelude
+import Foreign.C.String
+import Foreign.Ptr
+
+foreign import ccall "unlink" c_unlink :: CString -> IO Int
+
+removeFile :: FilePath -> IO ()
+removeFile fn = do
+  r <- withCAString fn c_unlink
+  when (r /= 0) $
+    error "removeFile failed"
--- a/lib/System/Environment.hs
+++ b/lib/System/Environment.hs
@@ -12,11 +12,11 @@
 withDropArgs :: forall a . Int -> IO a -> IO a
 withDropArgs = primWithDropArgs
 
-foreign import ccall "getenv" getenvc :: CString -> IO CString
+foreign import ccall "getenv" c_getenv :: CString -> IO CString
 
 lookupEnv :: String -> IO (Maybe String)
 lookupEnv var = do
-  cptr <- withCAString var getenvc
+  cptr <- withCAString var c_getenv
   if cptr == nullPtr then
     return Nothing
    else
--- /dev/null
+++ b/lib/System/IO/Temp.hs
@@ -1,0 +1,23 @@
+module System.IO.Temp(
+  withSystemTempFileSource
+  ) where
+import Prelude
+import System.Directory
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+
+foreign import ccall "tempnam" c_tempnam :: CString -> CString -> IO CString
+
+withSystemTempFileSource :: forall a . String -> (FilePath -> Handle -> IO a) -> IO a
+withSystemTempFileSource tmpl io = do
+  let (pre, post) = span (/= '.') tmpl
+  ctmp <- withCAString pre $ c_tempnam nullPtr
+  tmp <- peekCAString ctmp
+  free ctmp
+  let fn = tmp ++ post
+  h <- openFile fn WriteMode
+  a <- io fn h
+  hClose h
+  removeFile fn
+  return a
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -964,25 +964,28 @@
  *   PI   int    name(void*)
  *   PP   void*  name(void*)
  *   PPI  int    name(void*, void*)
+ *   PPP  void*  name(void*, void*)
  * more can easily be added.
  */
 struct {
   const char *ffi_name;
   const funptr_t ffi_fun;
-  enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III, FFI_DD, FFI_PI, FFI_PPI, FFI_PP } ffi_how;
+  enum { FFI_V, FFI_I, FFI_IV, FFI_II, FFI_IIV, FFI_III, FFI_DD, FFI_PI, FFI_PPI, FFI_PP, FFI_PPP } ffi_how;
 } ffi_table[] = {
-  { "llabs", (funptr_t)llabs, FFI_II },
-  { "log",   (funptr_t)log,   FFI_DD },
-  { "exp",   (funptr_t)exp,   FFI_DD },
-  { "sqrt",  (funptr_t)sqrt,  FFI_DD },
-  { "sin",   (funptr_t)sin,   FFI_DD },
-  { "cos",   (funptr_t)cos,   FFI_DD },
-  { "tan",   (funptr_t)tan,   FFI_DD },
-  { "asin",  (funptr_t)asin,  FFI_DD },
-  { "acos",  (funptr_t)acos,  FFI_DD },
-  { "atan",  (funptr_t)atan,  FFI_DD },
-  { "system",(funptr_t)system,FFI_PI },
-  { "getenv",(funptr_t)getenv,FFI_PP },
+  { "llabs",    (funptr_t)llabs,   FFI_II },
+  { "log",      (funptr_t)log,     FFI_DD },
+  { "exp",      (funptr_t)exp,     FFI_DD },
+  { "sqrt",     (funptr_t)sqrt,    FFI_DD },
+  { "sin",      (funptr_t)sin,     FFI_DD },
+  { "cos",      (funptr_t)cos,     FFI_DD },
+  { "tan",      (funptr_t)tan,     FFI_DD },
+  { "asin",     (funptr_t)asin,    FFI_DD },
+  { "acos",     (funptr_t)acos,    FFI_DD },
+  { "atan",     (funptr_t)atan,    FFI_DD },
+  { "system",   (funptr_t)system,  FFI_PI },
+  { "unlink",   (funptr_t)unlink,  FFI_PI },
+  { "getenv",   (funptr_t)getenv,  FFI_PP },
+  { "tempnam",  (funptr_t)tempnam, FFI_PPP },
 };
 
 /* Look up an FFI function by name */
@@ -2305,6 +2308,7 @@
         case FFI_PI:  FFI (1); xp = PTRARG(1);                 ri = (*(value_t (*)(void*           ))f)(xp);    n = mkInt(ri); RETIO(n);
         case FFI_PP:  FFI (1); xp = PTRARG(1);                 rp = (*(void*   (*)(void*           ))f)(xp);    n = mkPtr(rp); RETIO(n);
         case FFI_PPI: FFI (2); xp = PTRARG(1);yp = PTRARG(2);  ri = (*(value_t (*)(void*, void*    ))f)(xp,yp); n = mkInt(ri); RETIO(n);
+        case FFI_PPP: FFI (2); xp = PTRARG(1);yp = PTRARG(2);  rp = (*(void*   (*)(void*, void*    ))f)(xp,yp); n = mkPtr(rp); RETIO(n);
         default: ERR("T_IO_CCALL");
         }
       }
-- 
⑨