bindings-common-1.0: src/bindings.macros.h

#define bindings_initialize(dummy)\
    char conid_buffer[1000] = "C'"; \
    char varid_buffer[1000] = "c'"; \
    char ptr_buffer[1000] = "p'"; \
    char decimal_buffer[1000]; \
    char wrapper_buffer[1000] = "mk'";

#define bc_varid(name) \
    (strcpy(varid_buffer+2,name),varid_buffer)

#define bc_conid(name) \
    (strcpy(conid_buffer+2,name),conid_buffer)

#define bc_ptrid(name) \
    (strcpy(ptr_buffer+2,name),ptr_buffer)

#define bc_decimal(name) \
    (((name)>0) \
        ? sprintf(decimal_buffer,"%llu", \
          (long long unsigned)(name)) \
        : sprintf(decimal_buffer,"%lld", \
          (long long)(name)) \
    , decimal_buffer )

#define bc_wrapper(name) \
    (strcpy(wrapper_buffer+3,name),wrapper_buffer)

#define bc_printtype(name) \
    { \
     char pb[strlen(name)+1]; \
     strcpy (pb,name); \
     char *p = pb; \
     while (p) \
        { \
         char *p1 = strpbrk(p,"<"); \
         char *p2 = strpbrk(p,">"); \
         if (p1 && p2) \
            { \
             printf("%.*s",(int)(p1-p),p); \
             p = p1; \
             if (p1 < p2) \
                { \
                 printf(" %s ",bc_conid(strtok(p1,"<>"))); \
                 p = ++p2; \
                } \
            } \
         else \
             { \
              printf("%s",p); \
              p = NULL; \
             } \
        } \
    }

#define hsc_num(name) \
    { \
     bindings_initialize(); \
     printf("%s = %s ; %s :: (Num a) => a\n", \
       bc_varid(# name),bc_decimal(name),bc_varid(# name)); \
    }

#define hsc_fractional(name) \
    { \
     bindings_initialize(); \
     printf("%s = %Le ; %s :: (Fractional a) => a\n", \
       bc_varid(# name),(long double)(name),bc_varid(# name)); \
    }

#define hsc_pointer(name) \
    { \
     bindings_initialize(); \
     printf("%s = wordPtrToPtr (%zu :: WordPtr) ; %s :: Ptr a\n", \
       bc_varid(# name),(size_t)(name),bc_varid(# name)); \
    }

#define hsc_ccall(name,type) \
    { \
     bindings_initialize(); \
     printf("foreign import ccall \"%s\" %s :: ", \
       # name,bc_varid(# name)); \
     bc_printtype(# type); \
     printf("\n"); \
     printf("foreign import ccall \"&%s\" %s :: FunPtr (", \
       # name,bc_ptrid(# name)); \
     bc_printtype(# type); \
     printf(")\n"); \
    }

#define hsc_cinline(name,type) \
    { \
     bindings_initialize(); \
     printf("foreign import ccall \"%s\" %s :: ", \
       "inline_"# name,bc_varid(# name)); \
     bc_printtype(# type); \
     printf("\n"); \
    }

#define hsc_globalvar(name,type) \
    { \
     bindings_initialize(); \
     printf("foreign import ccall \"&%s\" %s :: %s", \
       # name,bc_ptrid(# name),"Ptr ("); \
     bc_printtype(# type); \
     printf(")\n"); \
    }

#define hsc_integral_t(name) \
    { \
     bindings_initialize(); \
     char fulltype[] = # name; \
     char type[1000]; \
     char *p = strtok(fulltype," "); \
     while (p) {strcpy(type,p); p = strtok(NULL," ");} \
     printf("type %s = %s%zu\n",bc_conid(type), \
       (name)(-1)<(name)(0)?"Int":"Word",sizeof(name)*8) ; \
    }

#define hsc_opaque_t(name) \
    { \
     bindings_initialize(); \
     printf("data %s = %s\n",bc_conid(# name),bc_conid(# name)); \
    }

#define hsc_callback(name,type) \
    { \
     bindings_initialize(); \
     printf("type %s = FunPtr (",bc_conid(# name)); \
     bc_printtype(# type); \
     printf(")\n"); \
     printf("foreign import ccall \"wrapper\" %s\n", \
       bc_wrapper(# name)); \
     printf("  :: ("); \
     bc_printtype(# type); \
     printf(")\n"); \
     printf("  -> IO %s\n",bc_conid(# name)); \
    }

#define hsc_starttype(name) \
    { \
     bindings_initialize(); \
     name *refpointer = 0; \
     char fulltype[] = # name; \
     char type[1000]; \
     char *p = strtok(fulltype," "); \
     while (p) {strcpy(type,p); p = strtok(NULL," ");} \
     int nfields = 0; \
     size_t typesize = sizeof(name); \
     char *fieldnames[1000], *fieldtypes[1000]; \
     size_t fieldoffsets[1000];

#define hsc_field(name,type) \
     fieldnames[nfields] = # name; \
     fieldtypes[nfields] = # type; \
     fieldoffsets[nfields] = (size_t) &(refpointer->name); \
     nfields++;

#define hsc_stoptype(dummy) \
     printf("data %s = %s",bc_conid(type),bc_conid(type)); \
     if (nfields>0) \
        { \
         printf (" {"); \
         int i; \
         for(i=0;i<nfields;i++) \
            { \
             printf("%s'%s :: ",type,fieldnames[i]); \
             bc_printtype(fieldtypes[i]); \
             if (i+1<nfields) printf(" , "); \
            } \
         printf ("}"); \
        } \
     printf("\n"); \
     printf("instance Storable %s where\n",bc_conid(type)); \
     printf(" sizeOf _ = %zu\n",typesize); \
     printf(" alignment = sizeOf\n"); \
     printf(" peek p = do\n"); \
     int i; \
     for(i=0;i<nfields;i++) \
        printf("  v%d <- peekByteOff p %zu\n",i,fieldoffsets[i]); \
     printf("  return $ %s",bc_conid(type)); \
     for(i=0;i<nfields;i++) printf(" v%d",i); \
     printf("\n"); \
     printf(" poke p (%s",bc_conid(type)); \
     for(i=0;i<nfields;i++) printf(" v%d",i); \
     printf("  ) = do\n"); \
     for(i=0;i<nfields;i++) \
        printf("  pokeByteOff p %zu v%d\n",fieldoffsets[i],i); \
     printf("  return ()\n"); \
    }