GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

extend the abstract syntax API

Browse Source
This commit is contained in:
krangelov
2021-08-06 12:43:30 +02:00
parent 87f1e24384
commit dc1644563f
11 changed files with 257 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
src/runtime/c/namespace.h
View File

@@ -187,21 +187,24 @@ public:
};
template <class V>
Namespace<V> namespace_empty() {
Namespace<V> namespace_empty()
{
return 0;
}
template <class V>
Namespace<V> namespace_singleton(ref<V> value) {
Namespace<V> namespace_singleton(ref<V> value)
{
return Node<V>::new_node(value);
}
template <class V>
Namespace<V> namespace_insert(Namespace<V> map, ref<V> value) {
Namespace<V> namespace_insert(Namespace<V> map, ref<V> value)
{
if (map == 0)
return Node<V>::new_node(value);
int cmp = textcmp(value->name,map->value->name);
int cmp = textcmp(&value->name,&map->value->name);
if (cmp < 0) {
Namespace<V> left = namespace_insert(map->left, value);
return Node<V>::balanceL(map->value,left,map->right);
@@ -213,7 +216,8 @@ Namespace<V> namespace_insert(Namespace<V> map, ref<V> value) {
}
template <class V>
ref<V> namespace_lookup(Namespace<V> map, const char *name) {
ref<V> namespace_lookup(Namespace<V> map, const char *name)
{
while (map != 0) {
int cmp = strcmp(name,map->value->name);
if (cmp < 0)
@@ -227,9 +231,21 @@ ref<V> namespace_lookup(Namespace<V> map, const char *name) {
}
template <class V>
size_t namespace_size(Namespace<V> map) {
size_t namespace_size(Namespace<V> map)
{
if (map == 0)
return 0;
return map->sz;
}
template <class V>
void namespace_iter(Namespace<V> 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

37
src/runtime/c/pgf.cxx
View File

@@ -66,3 +66,40 @@ PgfText *pgf_abstract_name(PgfPGF* pgf)
{
return textdup(&(*pgf->get_root<PgfPGFRoot>()->abstract.name));
}
PGF_API
void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor)
{
namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.cats, itor);
}
PGF_API
void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor)
{
namespace_iter(pgf->get_root<PgfPGFRoot>()->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<PgfPGFRoot>()->abstract.funs, &helper);
}

19
src/runtime/c/pgf.h
View File

@@ -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_

54
src/runtime/c/text.cxx
View File

@@ -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;
}
}

2
src/runtime/c/text.h
View File

@@ -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);

68
src/runtime/haskell/PGF2.hsc
View File

@@ -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 <pgf.h>
@@ -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

2
src/runtime/haskell/PGF2/Expr.hsc
View File

@@ -2,3 +2,5 @@
module PGF2.Expr where
type Cat = String -- ^ Name of syntactic category
type Fun = String -- ^ Name of function

56
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -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

8
src/runtime/haskell/tests/basic.gf
View File

@@ -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 ;
}

8
src/runtime/haskell/tests/basic.hs
View File

@@ -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"))
]

BIN
src/runtime/haskell/tests/basic.pgf
View File

Binary file not shown.