ref: 62f894ac7766b7b3ed82d94f092b518fb63308ad
parent: 7b7b65af4f276336d06f43a5c541d5597a405916
author: Lennart Augustsson <lennart@augustsson.net>
date: Tue Oct 1 11:52:33 EDT 2024
More BFILE stuff.
--- a/lib/System/Compress.hs
+++ b/lib/System/Compress.hs
@@ -1,5 +1,7 @@
-module System.Compress(compress) where
+module System.Compress {-(compress)-} whereimport Prelude(); import MiniPrelude
+import Data.Function
+import Foreign.Ptr
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
@@ -6,6 +8,8 @@
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
+import System.IO
+import System.IO_Handle
import System.IO.Unsafe
foreign import ccall "lz77c" c_lz77c :: CString -> CSize -> Ptr CString -> IO CSize
@@ -21,3 +25,55 @@
free iptr
free optr
return res
+
+type PBFILE = Ptr BFILE
+foreign import ccall "openb_wr_buf" c_openb_wr_buf :: IO PBFILE
+foreign import ccall "openb_rd_buf" c_openb_rd_buf :: Ptr Char -> Int -> IO PBFILE
+foreign import ccall "add_lz77_compressor" c_add_lz77_compressor :: PBFILE -> IO PBFILE
+foreign import ccall "add_lz77_decompressor" c_add_lz77_decompressor :: PBFILE -> IO PBFILE
+foreign import ccall "putb" c_putb :: Int -> PBFILE -> IO ()
+foreign import ccall "get_buf" c_get_buf :: PBFILE -> Ptr (Ptr Char) -> Ptr Int -> IO ()
+
+withPutTransducer :: (PBFILE -> IO PBFILE) -> [Char] -> [Char]
+withPutTransducer trans file = unsafePerformIO $ do
+ bf <- c_openb_wr_buf
+ cbf <- trans bf
+ mapM_ (flip c_putb cbf . ord) file
+ with nullPtr $ \ bufp ->
+ with 0 $ \ lenp -> do
+ c_get_buf bf bufp lenp
+ buf <- peek bufp
+ len <- peek lenp
+ res <- peekCAStringLen (buf, len)
+ free buf
+ return res
+
+withGetTransducer :: (PBFILE -> IO PBFILE) -> [Char] -> [Char]
+withGetTransducer trans file = unsafePerformIO $ do
+ (ptr, len) <- newCAStringLen file
+ bf <- c_openb_rd_buf ptr len >>= trans
+ h <- mkHandle "withGetTransducer" bf
+ hGetContents h
+
+compress' :: [Char] -> [Char]
+compress' = withPutTransducer c_add_lz77_compressor
+
+decompress :: [Char] -> [Char]
+decompress = withGetTransducer c_add_lz77_decompressor
+
+main :: IO ()
+main = do
+ haa <- openBinaryFile "aa" ReadMode
+ putStrLn "AA"
+ aa <- hGetContents haa
+ putStrLn "BB"
+ let bb = compress' aa
+ putStrLn "CC"
+ hbb <- openBinaryFile "bb" WriteMode
+ putStrLn "DD"
+ hPutStr hbb bb
+ putStrLn "EE"
+ hClose hbb
+ putStrLn "FF"
+ hClose haa
+ putStrLn "GG"
--- a/src/MicroHs/FFI.hs
+++ b/src/MicroHs/FFI.hs
@@ -185,5 +185,6 @@
"peek_ullong", "poke_ullong", "peek_llong", "poke_llong",
"peek_flt", "poke_flt",
"sizeof_int", "sizeof_long", "sizeof_llong",
- "opendir", "closedir", "readdir", "c_d_name", "chdir", "mkdir", "getcwd"
+ "opendir", "closedir", "readdir", "c_d_name", "chdir", "mkdir", "getcwd",
+ "get_buf", "openb_rd_buf", "openb_wr_buf"
]
--- a/src/runtime/bfile.c
+++ b/src/runtime/bfile.c
@@ -23,7 +23,11 @@
*/
/* Sanity checking */
-#define CHECKBFILE(p, f) do { if (p->getb != f) ERR("CHECKBFILE"); } while(0)+void foo(void)
+{+ printf("foo\n");+}
+#define CHECKBFILE(p, f) do { if (p->getb != f) { foo(); ERR("CHECKBFILE"); } } while(0)/* BFILE will have different implementations, they all have these methods */
typedef struct BFILE {@@ -108,7 +112,7 @@
}
}
-/***************** BFILE from static buffer *******************/
+/***************** BFILE from/to memory buffer *******************/
struct BFILE_buffer {BFILE mets;
size_t b_size;
@@ -127,6 +131,20 @@
}
void
+putb_buf(int c, BFILE *bp)
+{+ struct BFILE_buffer *p = (struct BFILE_buffer *)bp;
+ CHECKBFILE(bp, getb_buf);
+ if (p->b_pos >= p->b_size) {+ p->b_size *= 2;
+ p->b_buffer = realloc(p->b_buffer, p->b_size);
+ if (!p->b_buffer)
+ ERR("putb_buf");+ }
+ p->b_buffer[p->b_pos++] = c;
+}
+
+void
ungetb_buf(int c, BFILE *bp)
{struct BFILE_buffer *p = (struct BFILE_buffer *)bp;
@@ -137,17 +155,29 @@
}
void
-closeb_buf(BFILE *bp)
+closeb_rd_buf(BFILE *bp)
{CHECKBFILE(bp, getb_buf);
FREE(bp);
}
-/* There is no open(). Only used with statically allocated buffers. */
+void
+closeb_wr_buf(BFILE *bp)
+{+ CHECKBFILE(bp, getb_buf);
+ FREE(bp);
+}
+
+void
+flushb_buf(BFILE *bp)
+{+ CHECKBFILE(bp, getb_buf);
+}
+
struct BFILE*
-openb_buf(uint8_t *buf, size_t len)
+openb_rd_buf(uint8_t *buf, size_t len)
{- struct BFILE_buffer *p = MALLOC(sizeof(struct BFILE_buffer));;
+ struct BFILE_buffer *p = MALLOC(sizeof(struct BFILE_buffer));
if (!p)
memerr();
p->mets.getb = getb_buf;
@@ -154,11 +184,46 @@
p->mets.ungetb = ungetb_buf;
p->mets.putb = 0;
p->mets.flushb = 0;
- p->mets.closeb = closeb_buf;
+ p->mets.closeb = closeb_rd_buf;
p->b_size = len;
p->b_pos = 0;
p->b_buffer = buf;
return (struct BFILE*)p;
+}
+
+struct BFILE*
+openb_wr_buf(void)
+{+ struct BFILE_buffer *p = MALLOC(sizeof(struct BFILE_buffer));
+ if (!p)
+ memerr();
+ p->mets.getb = getb_buf; /* Just to make CHECKFILE happy */
+ p->mets.ungetb = 0;
+ p->mets.putb = putb_buf;
+ p->mets.flushb = flushb_buf;
+ p->mets.closeb = closeb_wr_buf;
+ p->b_size = 1000;
+ p->b_pos = 0;
+ p->b_buffer = malloc(p->b_size);
+ if (!p->b_buffer)
+ ERR("openb_wr_buf");+ return (struct BFILE*)p;
+}
+
+/*
+ * Get the buffer used by writing.
+ * This should be the last operation before closing,
+ * since the buffer can move when writing.
+ * The caller of openb_wr_buf() and get_buf() owns
+ * the memory and must free it.
+ */
+void
+get_buf(struct BFILE *bp, uint8_t **bufp, size_t *lenp)
+{+ struct BFILE_buffer *p = (struct BFILE_buffer *)bp;
+ CHECKBFILE(bp, getb_buf);
+ *bufp = p->b_buffer;
+ *lenp = p->b_pos;
}
#if WANT_STDIO
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -2434,7 +2434,7 @@
NODEPTR
mkStringU(struct bytestring bs)
{- BFILE *ubuf = add_utf8(openb_buf(bs.string, bs.size));
+ BFILE *ubuf = add_utf8(openb_rd_buf(bs.string, bs.size));
NODEPTR n, *np, nc;
//printf("mkStringU %d %s\n", (int)bs.size, (char*)bs.string);@@ -4082,7 +4082,7 @@
if (combexpr) {int c;
- BFILE *bf = openb_buf(combexpr, combexprlen);
+ BFILE *bf = openb_rd_buf(combexpr, combexprlen);
c = getb(bf);
/* Compressed combinators start with a 'Z' or 'z', otherwise 'v' (for version) */
if (c == 'z') {@@ -4308,6 +4308,9 @@
void mhs_getb(int s) { mhs_from_Int(s, 1, getb(mhs_to_Ptr(s, 0))); } void mhs_putb(int s) { putb(mhs_to_Int(s, 0), mhs_to_Ptr(s, 1)); mhs_from_Unit(s, 2); } void mhs_ungetb(int s) { ungetb(mhs_to_Int(s, 0), mhs_to_Ptr(s, 1)); mhs_from_Unit(s, 2); }+void mhs_openwrbuf(int s) { mhs_from_Ptr(s, 0, openb_wr_buf()); }+void mhs_openrdbuf(int s) { mhs_from_Ptr(s, 2, openb_rd_buf(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); }+void mhs_getbuf(int s) { get_buf(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); mhs_from_Unit(s, 3); } void mhs_system(int s) { mhs_from_Int(s, 1, system(mhs_to_Ptr(s, 0))); } void mhs_tmpname(int s) { mhs_from_Ptr(s, 2, TMPNAME(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); } void mhs_unlink(int s) { mhs_from_Int(s, 1, unlink(mhs_to_Ptr(s, 0))); }@@ -4411,6 +4414,7 @@
#if WANT_STDIO
{ "add_FILE", mhs_add_FILE}, { "add_utf8", mhs_add_utf8},+//{ "add_rle", mhs_add_rle}, { "closeb", mhs_closeb}, { "&closeb", mhs_addr_closeb}, { "flushb", mhs_flushb},@@ -4418,6 +4422,9 @@
{ "getb", mhs_getb}, { "putb", mhs_putb}, { "ungetb", mhs_ungetb},+{ "openb_wr_buf", mhs_openwrbuf},+{ "openn_rd_buf", mhs_openrdbuf},+{ "get_buf", mhs_getbuf}, { "system", mhs_system}, { "tmpname", mhs_tmpname}, { "unlink", mhs_unlink},