/******
* Copyright © 2008–2009 Maurício C. Antunes
* This file is distributed under the BSD license.
* Check LICENSE file in distribution package for
* details.
******/
#ifndef __BINDINGS_DSL_H__
#define __BINDINGS_DSL_H__
#include <inttypes.h>
#define hsc_strict_import(dummy) printf( \
"import Foreign.Ptr (Ptr,FunPtr,plusPtr)\n" \
"import Foreign.Ptr (wordPtrToPtr,castPtrToFunPtr)\n" \
"import Foreign.Storable\n" \
"import Foreign.C.Types\n" \
"import Foreign.C.String (CString,CStringLen,CWString,CWStringLen)\n" \
"import Foreign.Marshal.Alloc (alloca)\n" \
"import Foreign.Marshal.Array (peekArray,pokeArray)\n" \
"import Data.Int\n" \
"import Data.Word\n" \
); \
#define bc_word(name) \
{ \
char *p, *q, buffer_w[strlen(name)+1]; \
strcpy(buffer_w,name); \
for (p=strtok(buffer_w," \t");(q=strtok(NULL," \t"));p=q); \
printf("%s",p); \
} \
#define bc_glue(type,field) \
{ \
bc_word(type); \
printf("'"); \
char *p, buffer_g[strlen(field)+1]; \
strcpy(buffer_g,field); \
for (p=buffer_g;*p;p++) \
*p = *p=='.' ? '\'' : ispunct(*p) ? '_' : *p; \
bc_word(buffer_g); \
} \
#define bc_typemarkup(name) \
{ \
char buffer_t[strlen(name)+1]; \
strcpy(buffer_t,name); \
char *p1,*p2,*p3; \
p1 = buffer_t; \
while (*p1) \
{ \
for (p2=p1;*p2 && *p2!='<';p2++); \
for (p3=p2;*p3 && *p3!='>';p3++); \
if (*p2 == '<') *p2++ = '\0'; \
if (*p3 == '>') *p3++ = '\0'; \
printf("%s",p1); \
if (*p2) bc_conid(p2); \
p1 = p3; \
} \
} \
#define bc_varid(name) {printf("c'");bc_word(name);}; \
#define bc_conid(name) {printf("C'");bc_word(name);}; \
#define bc_ptrid(name) {printf("p'");bc_word(name);}; \
#define bc_wrapper(name) {printf("mk'");bc_word(name);}; \
#define bc_fieldname(type,field) {printf("c'");bc_glue(type,field);}; \
#define bc_unionupdate(type,field) {printf("u'");bc_glue(type,field);}; \
#define bc_famaccess(type,field) {printf("p'");bc_glue(type,field);}; \
#define bc_decimal(name) (name) > 0 \
? printf("%"PRIuMAX,(uintmax_t)(name)) \
: printf("%"PRIdMAX,(intmax_t)(name)) \
#define bc_wordptr(name) printf("%"PRIuPTR,(uintptr_t)(name)) \
#define bc_float(name) printf("%Le",(long double)(name)) \
#define hsc_num(name) \
bc_varid(# name);printf(" = ");bc_decimal(name);printf("\n"); \
bc_varid(# name);printf(" :: (Num a) => a\n"); \
#define hsc_fractional(name) \
bc_varid(# name);printf(" = ");bc_float(name);printf("\n"); \
bc_varid(# name);printf(" :: (Fractional a) => a\n"); \
#define hsc_pointer(name) \
bc_varid(# name);printf(" = wordPtrToPtr "); \
bc_wordptr(name);printf("\n"); \
bc_varid(# name);printf(" :: Ptr a\n"); \
#define hsc_function_pointer(name) \
bc_varid(# name);printf(" = (castPtrToFunPtr . wordPtrToPtr) "); \
bc_wordptr(name);printf("\n"); \
bc_varid(# name);printf(" :: FunPtr a\n"); \
#define hsc_ccall(name,type) \
hsc_callconv(name,ccall,type) \
#define hsc_callconv(name,conv,type) \
printf("foreign import "# conv" \"%s\" ",# name); \
bc_varid(# name);printf("\n"); \
printf(" :: ");bc_typemarkup(# type);printf("\n"); \
printf("foreign import "# conv" \"&%s\" ",# name); \
bc_ptrid(# name);printf("\n"); \
printf(" :: FunPtr (");bc_typemarkup(# type);printf(")\n"); \
#define hsc_cinline(name,type) \
printf("foreign import ccall \"inline_%s\" ",# name); \
bc_varid(# name);printf("\n"); \
printf(" :: ");bc_typemarkup(# type);printf("\n"); \
#define hsc_globalvar(name,type) \
printf("foreign import ccall \"&%s\" ",# name); \
bc_ptrid(# name);printf("\n"); \
printf(" :: Ptr (");bc_typemarkup(# type);printf(")\n"); \
#define hsc_globalarray(name,type) \
printf("foreign import ccall \"array_%s\" ",# name); \
bc_varid(# name);printf("\n"); \
printf(" :: Ptr (");bc_typemarkup(# type);printf(")\n"); \
#define hsc_integral_t(name) \
printf("type ");bc_conid(# name);printf(" = "); \
{ \
int sign = (name)(-1)<0; \
size_t size = sizeof(name); \
if (size==sizeof(int)) printf("%s",sign?"CInt":"CUInt"); \
else if (size==sizeof(char)) printf("%s", \
(char)(-1)<0?(sign?"CChar":"CUChar"):(sign?"CSChar":"CChar")); \
else printf("%s%"PRIuMAX,sign?"Int":"Word",(uintmax_t)(8*size)); \
printf("\n"); \
} \
#define hsc_opaque_t(name) \
printf("data ");bc_conid(# name); \
printf(" = "); \
bc_conid(# name);printf("\n"); \
#define hsc_synonym_t(name,type) \
printf("type ");bc_conid(# name); \
printf(" = "); \
bc_typemarkup(# type); \
printf("\n"); \
#define hsc_callback(name,type) \
printf("type ");bc_conid(# name);printf(" = FunPtr ("); \
bc_typemarkup(# type);printf(")\n"); \
printf("foreign import ccall \"wrapper\" "); \
bc_wrapper(# name);printf("\n"); \
printf(" :: (");bc_typemarkup(# type); \
printf(") -> IO ");bc_conid(# name);printf("\n"); \
static struct {
int n, is_array[500], is_union[500], is_fam[500];
size_t howmany[500], offset[500];
char fname[500][1000], ftype[500][1000];
} bc_fielddata;
#define hsc_starttype(name) \
{ \
name *refpointer = 0; \
bc_fielddata.n = 0; \
printf("data ");bc_conid(# name);printf(" = "); \
bc_conid(# name);printf("{"); \
char typename[] = # name; \
size_t typesize = sizeof(name); \
int index; \
#define hsc_field(name,type) \
index = bc_fielddata.n++; \
if (index > 0) printf(","); \
printf("\n "); \
bc_fieldname(typename,# name); \
printf(" :: ");bc_typemarkup(# type); \
bc_fielddata.offset[index] = (size_t)&(refpointer->name); \
bc_fielddata.is_array[index] = 0; \
bc_fielddata.is_union[index] = 0; \
bc_fielddata.is_fam[index] = 0; \
strcpy(bc_fielddata.fname[index],# name); \
strcpy(bc_fielddata.ftype[index],# type); \
#define hsc_array_field(name,type) \
hsc_field(name,[type]); \
bc_fielddata.howmany[index] = sizeof(refpointer->name) \
/ sizeof(refpointer->name[0]); \
bc_fielddata.is_array[index] = 1; \
#define hsc_union_field(name,type) \
hsc_field(name,type); \
bc_fielddata.is_union[index] = 1; \
#define hsc_union_array_field(name,type) \
hsc_array_field(name,type); \
bc_fielddata.is_union[index] = 1; \
#define hsc_flexible_array_member(name,type) \
hsc_field(name,[type]); \
bc_fielddata.is_fam[index] = 1; \
strcpy(bc_fielddata.ftype[index],# type); \
#define hsc_stoptype(dummy) \
printf("\n } deriving (Eq,Show)\n"); \
int i; \
for (i=0; i < bc_fielddata.n; i++) if (bc_fielddata.is_fam[i]) \
{ \
bc_famaccess(typename,bc_fielddata.fname[i]); \
printf(" p = plusPtr p %d\n",bc_fielddata.offset[i]); \
bc_famaccess(typename,bc_fielddata.fname[i]); \
printf(" :: Ptr (");bc_conid(typename);printf(") -> "); \
printf("Ptr (");bc_typemarkup(bc_fielddata.ftype[i]);printf(")\n"); \
} \
for (i=0; i < bc_fielddata.n; i++) if (bc_fielddata.is_union[i]) \
{ \
bc_unionupdate(typename,bc_fielddata.fname[i]); \
printf(" v vf = alloca $ \\p -> do\n"); \
printf(" poke p v\n"); \
if (bc_fielddata.is_array[i]) \
{ \
printf(" pokeArray (plusPtr p %"PRIuMAX") ", \
(uintmax_t)(bc_fielddata.offset[i])); \
printf("(take %"PRIuMAX" vf)", \
(uintmax_t)(bc_fielddata.howmany[i])); \
} \
else \
printf(" pokeByteOff p %"PRIuMAX" vf", \
(uintmax_t)(bc_fielddata.offset[i])); \
printf("\n"); \
printf(" vu <- peek p\n"); \
printf(" return $ v \n"); \
int j; \
for (j=0; j < bc_fielddata.n; j++) if (bc_fielddata.is_union[j]) \
{ \
printf(" {"); bc_fieldname(typename,bc_fielddata.fname[j]); \
printf(" = "); bc_fieldname(typename,bc_fielddata.fname[j]); \
printf(" vu}\n"); \
} \
bc_unionupdate(typename,bc_fielddata.fname[i]); \
printf(" :: ");bc_conid(typename); \
printf(" -> ");bc_typemarkup(bc_fielddata.ftype[i]) \
printf(" -> IO ");bc_conid(typename); \
printf("\n"); \
} \
printf("instance Storable "); \
bc_conid(typename);printf(" where\n"); \
printf(" sizeOf _ = %"PRIuMAX"\n alignment = sizeOf\n", \
(uintmax_t)(typesize)); \
printf(" peek p = do\n"); \
for (i=0; i < bc_fielddata.n; i++) \
{ \
printf(" v%d <- ",i); \
if (bc_fielddata.is_fam[i]) \
printf("return []"); \
else if (bc_fielddata.is_array[i]) \
printf("peekArray %"PRIuMAX" (plusPtr p %"PRIuMAX")", \
(uintmax_t)(bc_fielddata.howmany[i]), \
(uintmax_t)(bc_fielddata.offset[i])); \
else \
printf("peekByteOff p %"PRIuMAX"", \
(uintmax_t)(bc_fielddata.offset[i])); \
printf("\n"); \
} \
printf(" return $ ");bc_conid(typename); \
for (i=0; i < bc_fielddata.n; i++) printf(" v%d",i); printf("\n"); \
printf(" poke p (");bc_conid(typename); \
for (i=0; i < bc_fielddata.n; i++) printf(" v%d",i); printf(") = do\n"); \
for (i=0; i < bc_fielddata.n; i++) \
{ \
printf(" "); \
if (bc_fielddata.is_fam[i]) \
printf("pokeArray (plusPtr p %"PRIuMAX") v%d", \
(uintmax_t)(bc_fielddata.offset[i]),i); \
else if (bc_fielddata.is_array[i]) \
printf("pokeArray (plusPtr p %"PRIuMAX") " \
"(take %"PRIuMAX" v%d)",(uintmax_t)(bc_fielddata.offset[i]), \
(uintmax_t)(bc_fielddata.howmany[i]),i); \
else \
printf("pokeByteOff p %"PRIuMAX" v%d", \
(uintmax_t)(bc_fielddata.offset[i]),i); \
printf("\n"); \
} \
printf(" return ()\n"); \
} \
#endif /* __BINDINGS_DSL_H__ */