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

support for unbounded integers

Browse Source
This commit is contained in:
krangelov
2021-08-27 11:31:10 +02:00
parent 684f85ff94
commit 8195f8b0cb
10 changed files with 113 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
src/runtime/c/pgf/expr.cxx
View File

@@ -7,10 +7,11 @@ PgfLiteral PgfDBMarshaller::match_lit(PgfUnmarshaller *u, PgfLiteral l)
{
switch (ref<PgfLiteral>::get_tag(l)) {
case PgfLiteralInt::tag: {
return u->lint(ref<PgfLiteralInt>::untagged(l)->val);
auto lint = ref<PgfLiteralInt>::untagged(l);
return u->lint(lint->size, lint->val);
}
case PgfLiteralFlt::tag: {
return u->lflt(ref<PgfLiteralInt>::untagged(l)->val);
return u->lflt(ref<PgfLiteralFlt>::untagged(l)->val);
}
case PgfLiteralStr::tag: {
return u->lstr(&ref<PgfLiteralStr>::untagged(l)->val);
@@ -285,7 +286,10 @@ void PgfExprParser::token()
if (ch == '>') {
ch = getc();
token_tag = PGF_TOKEN_RARROW;
}
} else if (isdigit(ch)) {
putc('-');
goto digit;
}
break;
case ',':
ch = getc();
@@ -329,10 +333,11 @@ void PgfExprParser::token()
} while (pgf_is_ident_rest(ch));
token_tag = PGF_TOKEN_IDENT;
} else if (isdigit(ch)) {
while (isdigit(ch)) {
digit:
do {
putc(ch);
ch = getc();
}
} while (isdigit(ch));
if (ch == '.') {
putc(ch);
@@ -422,8 +427,23 @@ PgfExpr PgfExprParser::parse_term()
return e;
}
case PGF_TOKEN_INT: {
int n = atoi((const char*) &token_value->text);
PgfLiteral lit = u->lint(n);
size_t size = (token_value->size + LINT_BASE_LOG - 1)/LINT_BASE_LOG;
uintmax_t *value = (uintmax_t *) alloca(size*sizeof(uintmax_t));
char *p = token_value->text + token_value->size;
for (size_t i = size; i > 0; i--) {
char tmp = *p; *p = 0;
char *s = p - LINT_BASE_LOG;
if (s < token_value->text)
s = token_value->text;
value[i-1] = (uintmax_t)
(s == token_value->text) ? strtoll(s, NULL, 10)
: strtoull(s, NULL, 10);
*p = tmp;
p = s;
}
PgfLiteral lit = u->lint(size, value);
PgfExpr e = u->elit(lit);
u->free_ref(lit);
token();

3
src/runtime/c/pgf/expr.h
View File

@@ -13,7 +13,8 @@ struct PGF_INTERNAL_DECL PgfLiteralStr {
struct PGF_INTERNAL_DECL PgfLiteralInt {
static const uint8_t tag = 1;
int val;
size_t size;
uintmax_t val[];
} ;
struct PGF_INTERNAL_DECL PgfLiteralFlt {

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

@@ -75,6 +75,25 @@ typedef struct {
PgfType type;
} PgfTypeHypo;
/* Arbitrary size integers are represented as an array of uintmax_t
* values. Each value in the array is at most LINT_BASE-1 big.
* LINT_BASE itself is always 10 ^ LINT_BASE_LOG. */
#if __WORDSIZE == 8
#define LINT_BASE 100
#define LINT_BASE_LOG 2
#elif __WORDSIZE == 16
#define LINT_BASE 10000
#define LINT_BASE_LOG 4
#elif __WORDSIZE == 32
#define LINT_BASE 1000000000
#define LINT_BASE_LOG 9
#elif __WORDSIZE == 64
#define LINT_BASE 10000000000000000000
#define LINT_BASE_LOG 19
#else
#error "Platforms with the current __WORDSIZE are not supported yet"
#endif
/* The PgfUnmarshaller structure tells the runtime how to create
* abstract syntax expressions and types in the heap of
* the host language. For instance, when used from Haskell the runtime
@@ -105,7 +124,7 @@ struct PgfUnmarshaller {
virtual PgfExpr evar(int index)=0;
virtual PgfExpr etyped(PgfExpr expr, PgfType typ)=0;
virtual PgfExpr eimplarg(PgfExpr expr)=0;
virtual PgfLiteral lint(int v)=0;
virtual PgfLiteral lint(size_t size, uintmax_t *v)=0;
virtual PgfLiteral lflt(double v)=0;
virtual PgfLiteral lstr(PgfText *v)=0;
virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,

16
src/runtime/c/pgf/printer.cxx
View File

@@ -249,15 +249,25 @@ PgfExpr PgfPrinter::eimplarg(PgfExpr expr)
return 0;
}
PgfLiteral PgfPrinter::lint(int v)
#define xstr(s) str(s)
#define str(s) #s
PgfLiteral PgfPrinter::lint(size_t size, uintmax_t *v)
{
nprintf(16, "%d", v);
if (size == 0)
puts("0");
else {
nprintf(32, "%jd", v[0]);
for (size_t i = 1; i < size; i++) {
nprintf(32, "%0" xstr(LINT_BASE_LOG) "ju", v[i]);
}
}
return 0;
}
PgfLiteral PgfPrinter::lflt(double v)
{
nprintf(16,"%lg",v);
nprintf(32,"%lg",v);
return 0;
}

2
src/runtime/c/pgf/printer.h
View File

@@ -53,7 +53,7 @@ public:
virtual PgfExpr evar(int index);
virtual PgfExpr etyped(PgfExpr expr, PgfType typ);
virtual PgfExpr eimplarg(PgfExpr expr);
virtual PgfLiteral lint(int v);
virtual PgfLiteral lint(size_t size, uintmax_t *v);
virtual PgfLiteral lflt(double v);
virtual PgfLiteral lstr(PgfText *v);
virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,

5
src/runtime/c/pgf/reader.cxx
View File

@@ -195,8 +195,9 @@ PgfLiteral PgfReader::read_literal()
}
case PgfLiteralInt::tag: {
ref<PgfLiteralInt> lit_int =
DB::malloc<PgfLiteralInt>(tag);
lit_int->val = read_int();
DB::malloc<PgfLiteralInt>(sizeof(PgfLiteralInt)+sizeof(uintmax_t));
lit_int->size = 1;
lit_int->val[0] = read_int();
lit = ref<PgfLiteralInt>::tagged(lit_int);
break;
}

6
src/runtime/haskell/PGF2/Expr.hs
View File

@@ -29,7 +29,7 @@ data BindType =
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LInt Integer -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
@@ -117,11 +117,11 @@ unStr (EImplArg e) = unStr e
unStr _ = Nothing
-- | Constructs an expression from integer literal
mkInt :: Int -> Expr
mkInt :: Integer -> Expr
mkInt i = ELit (LInt i)
-- | Decomposes an expression into integer literal
unInt :: Expr -> Maybe Int
unInt :: Expr -> Maybe Integer
unInt (ELit (LInt i)) = Just i
unInt (ETyped e ty) = unInt e
unInt (EImplArg e) = unInt e

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

@@ -2,6 +2,9 @@
module PGF2.FFI where
import GHC.Exts
import GHC.Prim
import GHC.Integer.Logarithms
import Data.Word
import Foreign
import Foreign.C
@@ -231,7 +234,7 @@ foreign import ccall "dynamic"
foreign import ccall "wrapper"
wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun)
type LIntFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Literal)
type LIntFun = Ptr PgfUnmarshaller -> (#type size_t) -> Ptr (#type uintmax_t) -> IO (StablePtr Literal)
foreign import ccall "dynamic"
callLIntFun :: FunPtr LIntFun -> LIntFun
@@ -291,10 +294,21 @@ marshaller = unsafePerformIO $ do
LStr s -> withText s $ \c_s -> do
fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl
callLStrFun fun u c_s
LInt n -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
callLIntFun fun u (fromIntegral n)
LInt n -> let abs_n = abs n
size = I## (integerLogBase## (#const LINT_BASE) abs_n +## 1##)
in allocaArray size $ \c_v -> do
pokeValue c_v (c_v `plusPtr` ((#size uintmax_t) * (size - 1)))
(fromIntegral (signum n)) abs_n
fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
callLIntFun fun u (fromIntegral size) c_v
LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lflt) vtbl
callLFltFun fun u (realToFrac d)
where
pokeValue c_v p sign abs_n
| c_v == p = poke p (sign * fromIntegral abs_n)
| otherwise = do let (q,r) = quotRem abs_n (#const LINT_BASE)
poke p (fromIntegral r)
pokeValue c_v (p `plusPtr` (- #size uintmax_t)) sign q
matchExpr this u c_expr = do
vtbl <- (#peek PgfUnmarshaller, vtbl) u
@@ -415,8 +429,22 @@ unmarshaller = unsafePerformIO $ do
expr <- deRefStablePtr c_expr
newStablePtr (EImplArg expr)
unmarshalLInt this c_v = do
newStablePtr (LInt (fromIntegral c_v))
unmarshalLInt this c_size c_v = do
n <- if c_size == 0
then return 0
else do v <- peek (castPtr c_v :: Ptr (#type intmax_t))
abs_n <- peekValue (c_size-1)
(c_v `plusPtr` (#size uintmax_t))
(fromIntegral (abs v))
return (fromIntegral (signum v) * abs_n)
newStablePtr (LInt n)
where
peekValue 0 c_v value = return value
peekValue c_size c_v value = do
v <- peek (castPtr c_v :: Ptr (#type uintmax_t))
peekValue (c_size-1)
(c_v `plusPtr` (#size uintmax_t))
(value*(#const LINT_BASE)+fromIntegral v)
unmarshalLFlt this c_v = do
newStablePtr (LFlt (realToFrac c_v))

3
src/runtime/haskell/pgf2.cabal
View File

@@ -30,6 +30,8 @@ library
PGF2.Expr,
PGF2.Type
build-depends:
integer-gmp,
ghc-prim,
base >= 4.3 && < 4.16,
containers,
pretty,
@@ -48,4 +50,5 @@ test-suite basic
build-depends:
base,
HUnit,
random,
pgf2

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

@@ -1,3 +1,4 @@
import System.Random
import Control.Exception
import Test.HUnit
import PGF2
@@ -6,6 +7,11 @@ main = do
x <- testLoadFailure "non-existing.pgf"
y <- testLoadFailure "tests/basic.gf"
gr <- readPGF "tests/basic.pgf"
g <- newStdGen
let limit = 10 ^ 100
ns = take 5000 (randomRs (-limit,limit) g)
runTestTTAndExit $
TestList [TestCase (assertBool "missing file" x)
,TestCase (assertBool "frong file format" y)
@@ -59,6 +65,8 @@ main = do
,TestCase (assertEqual "fresh variables 1" "\\v,v1->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 0)))))
,TestCase (assertEqual "fresh variables 2" "\\v,v1->v" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1)))))
,TestCase (assertEqual "fresh variables 3" "\\v,v1,v2->v1" (showExpr [] (EAbs Explicit "v" (EAbs Explicit "v" (EAbs Explicit "v" (EVar 1))))))
,TestCase (assertBool "large integer 1" (null [n | n <- ns, showExpr [] (ELit (LInt n)) /= show n]))
,TestCase (assertBool "large integer 2" (null [n | n <- ns, readExpr (show n) /= Just (ELit (LInt n))]))
]
testLoadFailure fpath = do