diff --git a/src/runtime/c/namespace.h b/src/runtime/c/namespace.h index 18495f07f..f89008fd0 100644 --- a/src/runtime/c/namespace.h +++ b/src/runtime/c/namespace.h @@ -187,21 +187,24 @@ public: }; template -Namespace namespace_empty() { +Namespace namespace_empty() +{ return 0; } template -Namespace namespace_singleton(ref value) { +Namespace namespace_singleton(ref value) +{ return Node::new_node(value); } template -Namespace namespace_insert(Namespace map, ref value) { +Namespace namespace_insert(Namespace map, ref value) +{ if (map == 0) return Node::new_node(value); - int cmp = textcmp(value->name,map->value->name); + int cmp = textcmp(&value->name,&map->value->name); if (cmp < 0) { Namespace left = namespace_insert(map->left, value); return Node::balanceL(map->value,left,map->right); @@ -213,7 +216,8 @@ Namespace namespace_insert(Namespace map, ref value) { } template -ref namespace_lookup(Namespace map, const char *name) { +ref namespace_lookup(Namespace map, const char *name) +{ while (map != 0) { int cmp = strcmp(name,map->value->name); if (cmp < 0) @@ -227,9 +231,21 @@ ref namespace_lookup(Namespace map, const char *name) { } template -size_t namespace_size(Namespace map) { +size_t namespace_size(Namespace map) +{ if (map == 0) return 0; return map->sz; } + +template +void namespace_iter(Namespace map, PgfItor* itor) +{ + if (map == 0) + return; + + namespace_iter(map->left, itor); + itor->fn(itor, &map->value->name, &(*map->value)); + namespace_iter(map->right, itor); +} #endif diff --git a/src/runtime/c/pgf.cxx b/src/runtime/c/pgf.cxx index 9eed30a02..a722b6c7f 100644 --- a/src/runtime/c/pgf.cxx +++ b/src/runtime/c/pgf.cxx @@ -66,3 +66,40 @@ PgfText *pgf_abstract_name(PgfPGF* pgf) { return textdup(&(*pgf->get_root()->abstract.name)); } + +PGF_API +void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor) +{ + namespace_iter(pgf->get_root()->abstract.cats, itor); +} + +PGF_API +void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor) +{ + namespace_iter(pgf->get_root()->abstract.funs, itor); +} + +struct PgfItorHelper : PgfItor +{ + PgfText *cat; + PgfItor *itor; +}; + +static +void iter_by_cat_helper(PgfItor* itor, PgfText* key, void* value) +{ + PgfItorHelper* helper = (PgfItorHelper*) itor; + PgfAbsFun* absfun = (PgfAbsFun*) value; + if (textcmp(helper->cat, &absfun->type->name) == 0) + helper->itor->fn(helper->itor, key, value); +} + +PGF_API +void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor) +{ + PgfItorHelper helper; + helper.fn = iter_by_cat_helper; + helper.cat = cat; + helper.itor = itor; + namespace_iter(pgf->get_root()->abstract.funs, &helper); +} diff --git a/src/runtime/c/pgf.h b/src/runtime/c/pgf.h index c71a032de..21eccabb3 100644 --- a/src/runtime/c/pgf.h +++ b/src/runtime/c/pgf.h @@ -43,6 +43,13 @@ typedef struct { char text[]; } PgfText; +/* A generic structure to pass a callback for iteration over a collection */ +typedef struct PgfItor PgfItor; + +struct PgfItor { + void (*fn)(PgfItor* self, PgfText* key, void *value); +}; + typedef struct PgfPGF PgfPGF; /* All functions that may fail take a reference to a PgfExn structure. @@ -79,4 +86,16 @@ PgfPGF *pgf_read(const char* fpath, PgfExn* err); PGF_API_DECL void pgf_free(PgfPGF *pgf); +PGF_API_DECL +PgfText *pgf_abstract_name(PgfPGF* pgf); + +PGF_API_DECL +void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor); + +PGF_API_DECL +void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor); + +PGF_API +void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor); + #endif // PGF_H_ diff --git a/src/runtime/c/text.cxx b/src/runtime/c/text.cxx index 6e3b9804b..ecee1e083 100644 --- a/src/runtime/c/text.cxx +++ b/src/runtime/c/text.cxx @@ -1,20 +1,18 @@ #include "data.h" PGF_INTERNAL -int textcmp(PgfText &t1, PgfText &t2) +int textcmp(PgfText *t1, PgfText *t2) { for (size_t i = 0; ; i++) { - if (i >= t1.size) - return (i - t2.size); - if (i >= t2.size) + if (i >= t1->size) + return (i - t2->size); + if (i >= t2->size) return 1; - if (t1.text[i] > t2.text[i]) + if (t1->text[i] > t2->text[i]) return 1; - else if (t1.text[i] < t2.text[i]) + else if (t1->text[i] < t2->text[i]) return -1; - - i++; } } @@ -52,4 +50,42 @@ pgf_utf8_decode(const uint8_t** src_inout) return u; } - +PGF_API void +pgf_utf8_encode(uint32_t ucs, uint8_t** buf) +{ + uint8_t* p = *buf; + if (ucs < 0x80) { + p[0] = (uint8_t) ucs; + *buf = p+1; + } else if (ucs < 0x800) { + p[0] = 0xc0 | (ucs >> 6); + p[1] = 0x80 | (ucs & 0x3f); + *buf = p+2; + } else if (ucs < 0x10000) { + p[0] = 0xe0 | (ucs >> 12); + p[1] = 0x80 | ((ucs >> 6) & 0x3f); + p[2] = 0x80 | (ucs & 0x3f); + *buf = p+3; + } else if (ucs < 0x200000) { + p[0] = 0xf0 | (ucs >> 18); + p[1] = 0x80 | ((ucs >> 12) & 0x3f); + p[2] = 0x80 | ((ucs >> 6) & 0x3f); + p[3] = 0x80 | (ucs & 0x3f); + *buf = p+4; + } else if (ucs < 0x4000000) { + p[0] = 0xf8 | (ucs >> 24); + p[1] = 0x80 | ((ucs >> 18) & 0x3f); + p[2] = 0x80 | ((ucs >> 12) & 0x3f); + p[3] = 0x80 | ((ucs >> 6) & 0x3f); + p[4] = 0x80 | (ucs & 0x3f); + *buf = p+5; + } else { + p[0] = 0xfc | (ucs >> 30); + p[1] = 0x80 | ((ucs >> 24) & 0x3f); + p[2] = 0x80 | ((ucs >> 18) & 0x3f); + p[3] = 0x80 | ((ucs >> 12) & 0x3f); + p[4] = 0x80 | ((ucs >> 6) & 0x3f); + p[5] = 0x80 | (ucs & 0x3f); + *buf = p+6; + } +} diff --git a/src/runtime/c/text.h b/src/runtime/c/text.h index 88b4266b5..7442cce0d 100644 --- a/src/runtime/c/text.h +++ b/src/runtime/c/text.h @@ -2,7 +2,7 @@ #define TEXT_H PGF_INTERNAL_DECL -int textcmp(PgfText &t1, PgfText &t2); +int textcmp(PgfText *t1, PgfText *t2); PGF_INTERNAL_DECL PgfText* textdup(PgfText *t1); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index ac24d3b42..0f434533e 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -18,6 +18,10 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, + -- ** Categories + Cat,categories, + -- ** Functions + Fun, functions, functionsByCat, -- * Concrete syntax ConcName @@ -25,12 +29,14 @@ module PGF2 (-- * PGF import Control.Exception(Exception,throwIO,mask_,bracket) import System.IO.Unsafe(unsafePerformIO) +import PGF2.Expr import PGF2.FFI import Foreign import Foreign.C import Data.Typeable import qualified Data.Map as Map +import Data.IORef #include @@ -60,10 +66,68 @@ readPGF fpath = abstractName :: PGF -> AbsName abstractName p = unsafePerformIO $ - withForeignPtr (a_pgf p) $ \c_pgf -> - bracket (pgf_abstract_name c_pgf) free $ \c_text -> + withForeignPtr (a_pgf p) $ \p_pgf -> + bracket (pgf_abstract_name p_pgf) free $ \c_text -> peekText c_text +-- | List of all functions defined in the abstract syntax +categories :: PGF -> [Fun] +categories p = + unsafePerformIO $ do + ref <- newIORef [] + (allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (a_pgf p) $ \p_pgf -> do + (#poke PgfItor, fn) itor fptr + pgf_iter_categories p_pgf itor + cs <- readIORef ref + return (reverse cs)) + where + getCategories :: IORef [String] -> ItorCallback + getCategories ref itor key = do + names <- readIORef ref + name <- peekText key + writeIORef ref $ (name : names) + +-- | List of all functions defined in the abstract syntax +functions :: PGF -> [Fun] +functions p = + unsafePerformIO $ do + ref <- newIORef [] + (allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (a_pgf p) $ \p_pgf -> do + (#poke PgfItor, fn) itor fptr + pgf_iter_functions p_pgf itor + fs <- readIORef ref + return (reverse fs)) + where + getFunctions :: IORef [String] -> ItorCallback + getFunctions ref itor key = do + names <- readIORef ref + name <- peekText key + writeIORef ref $ (name : names) + +-- | List of all functions defined in the abstract syntax +functionsByCat :: PGF -> Cat -> [Fun] +functionsByCat p cat = + unsafePerformIO $ do + ref <- newIORef [] + (withText cat $ \c_cat -> + allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (a_pgf p) $ \p_pgf -> do + (#poke PgfItor, fn) itor fptr + pgf_iter_functions_by_cat p_pgf c_cat itor + fs <- readIORef ref + return (reverse fs)) + where + getFunctions :: IORef [String] -> ItorCallback + getFunctions ref itor key = do + names <- readIORef ref + name <- peekText key + writeIORef ref $ (name : names) + ----------------------------------------------------------------------- -- Exceptions diff --git a/src/runtime/haskell/PGF2/Expr.hsc b/src/runtime/haskell/PGF2/Expr.hsc index 786794725..0f24d0699 100644 --- a/src/runtime/haskell/PGF2/Expr.hsc +++ b/src/runtime/haskell/PGF2/Expr.hsc @@ -2,3 +2,5 @@ module PGF2.Expr where +type Cat = String -- ^ Name of syntactic category +type Fun = String -- ^ Name of function diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index e462dd571..22583f655 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -3,7 +3,7 @@ module PGF2.FFI where import Data.Word -import Foreign ( alloca, peek, poke, peekByteOff ) +import Foreign import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr @@ -21,21 +21,39 @@ data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr} data PgfExn data PgfText +data PgfItor data PgfPGF data PgfConcr foreign import ccall unsafe "pgf_utf8_decode" pgf_utf8_decode :: Ptr CString -> IO Word32 -foreign import ccall "pgf.h pgf_read" +foreign import ccall unsafe "pgf_utf8_encode" + pgf_utf8_encode :: Word32 -> Ptr CString -> IO () + +foreign import ccall "pgf_read" pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF) foreign import ccall "&pgf_free" pgf_free_fptr :: FinalizerPtr PgfPGF -foreign import ccall "pgf/pgf.h pgf_abstract_name" +foreign import ccall "pgf_abstract_name" pgf_abstract_name :: Ptr PgfPGF -> IO (Ptr PgfText) +type ItorCallback = Ptr PgfItor -> Ptr PgfText -> IO () + +foreign import ccall "wrapper" + wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback) + +foreign import ccall "pgf_iter_categories" + pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> IO () + +foreign import ccall "pgf_iter_functions" + pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> IO () + +foreign import ccall "pgf_iter_functions_by_cat" + pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO () + peekText :: Ptr PgfText -> IO String peekText ptr = alloca $ \pptr -> do @@ -51,3 +69,35 @@ peekText ptr = else do x <- pgf_utf8_decode pptr cs <- decode pptr end return (((toEnum . fromEnum) x) : cs) + +withText :: String -> (Ptr PgfText -> IO a) -> IO a +withText s fn = + allocaBytes ((#size PgfText) + size + 1) $ \ptr -> do + (#poke PgfText, size) ptr (fromIntegral size :: CSize) + pokeUtf8CString s (ptr `plusPtr` (#const offsetof(PgfText, text))) + fn ptr + where + size = utf8Length s + + pokeUtf8CString s ptr = + alloca $ \pptr -> + poke pptr ptr >> encode s pptr + where + encode [] pptr = do + pgf_utf8_encode 0 pptr + encode (c:cs) pptr = do + pgf_utf8_encode ((toEnum . fromEnum) c) pptr + encode cs pptr + + utf8Length s = count 0 s + where + count !c [] = c + count !c (x:xs) + | ucs < 0x80 = count (c+1) xs + | ucs < 0x800 = count (c+2) xs + | ucs < 0x10000 = count (c+3) xs + | ucs < 0x200000 = count (c+4) xs + | ucs < 0x4000000 = count (c+5) xs + | otherwise = count (c+6) xs + where + ucs = fromEnum x diff --git a/src/runtime/haskell/tests/basic.gf b/src/runtime/haskell/tests/basic.gf index e54b628cc..534c1be2d 100644 --- a/src/runtime/haskell/tests/basic.gf +++ b/src/runtime/haskell/tests/basic.gf @@ -1,8 +1,10 @@ abstract basic = { -cat N ; +cat N; S ; -fun Z : N ; - S : N -> N ; +fun z : N ; + s : N -> N ; + +fun c : N -> S ; } diff --git a/src/runtime/haskell/tests/basic.hs b/src/runtime/haskell/tests/basic.hs index bbb7b6c69..b8cefd9f0 100644 --- a/src/runtime/haskell/tests/basic.hs +++ b/src/runtime/haskell/tests/basic.hs @@ -3,4 +3,10 @@ import PGF2 main = do gr <- readPGF "tests/basic.pgf" - runTestTTAndExit (TestCase (assertEqual "abstract names" "basic" (abstractName gr))) + runTestTTAndExit $ + TestList [TestCase (assertEqual "abstract names" "basic" (abstractName gr)) + ,TestCase (assertEqual "abstract categories" ["Float","Int","N","S","String"] (categories gr)) + ,TestCase (assertEqual "abstract functions" ["c","s","z"] (functions gr)) + ,TestCase (assertEqual "abstract functions by cat 1" ["s","z"] (functionsByCat gr "N")) + ,TestCase (assertEqual "abstract functions by cat 2" ["c"] (functionsByCat gr "S")) + ] diff --git a/src/runtime/haskell/tests/basic.pgf b/src/runtime/haskell/tests/basic.pgf index 410358375..d897827e8 100644 Binary files a/src/runtime/haskell/tests/basic.pgf and b/src/runtime/haskell/tests/basic.pgf differ