[project @ 2001-01-15 07:33:02 by qrczak]

Implemented #enum construct.

diff --git a/ghc/docs/users_guide/utils.sgml b/ghc/docs/users_guide/utils.sgml
index 88d7aaa..fa4491d 100644 (file)
--- a/ghc/docs/users_guide/utils.sgml
+++ b/ghc/docs/users_guide/utils.sgml
@@ -377,6 +377,28 @@ tags:
             <literal>Ptr a -> Ptr b</literal>.</para>
          </listitem>
        </varlistentry>
+
+       <varlistentry>
+         <term><literal>#enum type, constructor, value, value, ...</literal></term>
+         <listitem>
+           <para>A shortcut for multiple definitions which use
+           <literal>#const</literal>. Each <literal>value</literal>
+           is a name of a C integer constant, e.g. enumeration value.
+           The name will be translated to Haskell by making each
+           letter following an underscore uppercase, making all the rest
+           lowercase, and removing underscores. You can supply a different
+           translation by writing <literal>hs_name = c_value</literal>
+           instead of a <literal>value</literal>, in which case
+           <literal>c_value</literal> may be an arbitrary expression.
+           The <literal>hs_name</literal> will be defined as having the
+           specified <literal>type</literal>. Its definition is the specified
+           <literal>constructor</literal> (which in fact may be an expression
+           or be empty) applied to the appropriate integer value. You can
+           have multiple <literal>#enum</literal> definitions with the same
+           <literal>type</literal>; this construct does not emit the type
+           definition itself.
+         </listitem>
+       </varlistentry>
       </variablelist>
 
     </sect2>

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index fc38ac9..0c99565 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.12 2001/01/13 23:10:45 qrczak Exp $
+-- $Id: Main.hs,v 1.13 2001/01/15 07:33:02 qrczak Exp $
 --
 -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk)
 --
@@ -344,8 +344,30 @@ outTokenHs (Special pos key arg) =
         "def"               -> ""
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         "let"               -> ""
+        "enum"              -> outCLine pos++outEnum arg
         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 
+outEnum :: String -> String
+outEnum arg =
+    case break (== ',') arg of
+        (_, [])        -> ""
+        (t, _:afterT) -> case break (== ',') afterT of
+            (f, afterF) -> let
+                enums []    = ""
+                enums (_:s) = case break (== ',') s of
+                    (enum, rest) -> let
+                        this = case break (== '=') $ dropWhile isSpace enum of
+                            (name, []) ->
+                                "    hsc_enum ("++t++", "++f++", \
+                                \hsc_haskellize (\""++name++"\"), "++
+                                name++");\n"
+                            (hsName, _:cName) ->
+                                "    hsc_enum ("++t++", "++f++", \
+                                \printf (\"%s\", \""++hsName++"\"), "++
+                                cName++");\n"
+                        in this++enums rest
+                in enums afterF
+
 outTokenH :: (SourcePos, String, String) -> String
 outTokenH (pos, key, arg) =
     case key of
@@ -361,7 +383,7 @@ outTokenH (pos, key, arg) =
                 \#endif\n"++
                 arg++"\n"
             _ -> "extern "++header++";\n"
-            where header = takeWhile (\c -> c/='{' && c/='=') arg
+            where header = takeWhile (\c -> c /= '{' && c /= '=') arg
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
@@ -383,7 +405,7 @@ outTokenC (pos, key, arg) =
                 body++
                 "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
-            where (header, body) = span (\c -> c/='{' && c/='=') arg
+            where (header, body) = span (\c -> c /= '{' && c /= '=') arg
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 

diff --git a/ghc/utils/hsc2hs/template-hsc.h b/ghc/utils/hsc2hs/template-hsc.h
index df8747d..a77c253 100644 (file)
--- a/ghc/utils/hsc2hs/template-hsc.h
+++ b/ghc/utils/hsc2hs/template-hsc.h
@@ -6,6 +6,8 @@
 #include <stddef.h>
 #include <string.h>
 #include <stdio.h>
+#include <stdarg.h>
+#include <ctype.h>
 
 #ifndef offsetof
 #define offsetof(t, f) ((size_t) &((t *)0)->f)
@@ -39,7 +41,7 @@
                 printf ("\\%d%s",                                 \
                         (unsigned char) *s,                       \
                         s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \
-            s++;                                                  \
+            ++s;                                                  \
         }                                                         \
         printf ("\"");                                            \
     }
@@ -64,3 +66,34 @@
 #define hsc_ptr(t, f) \
     printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", (long) offsetof (t, f));
 
+#define hsc_enum(t, f, print_name, x)         \
+    print_name;                               \
+    printf (" :: %s\n", #t);                  \
+    print_name;                               \
+    printf (" = %s ", #f);                    \
+    if ((x) < 0)                              \
+        printf ("(%ld)\n", (long)(x));        \
+    else                                      \
+        printf ("%lu\n", (unsigned long)(x));
+
+#define hsc_haskellize(x)                                          \
+    {                                                              \
+        const char *s = (x);                                       \
+        int upper = 0;                                             \
+        if (*s != '\0')                                            \
+        {                                                          \
+            putchar (tolower (*s));                                \
+            ++s;                                                   \
+            while (*s != '\0')                                     \
+            {                                                      \
+                if (*s == '_')                                     \
+                    upper = 1;                                     \
+                else                                               \
+                {                                                  \
+                    putchar (upper ? toupper (*s) : tolower (*s)); \
+                    upper = 0;                                     \
+                }                                                  \
+                ++s;                                               \
+            }                                                      \
+        }                                                          \
+    }