From: qrczak <unknown>
Date: Mon, 15 Jan 2001 07:33:02 +0000 (+0000)
Subject: [project @ 2001-01-15 07:33:02 by qrczak]
X-Git-Tag: Approximately_9120_patches~2911
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0a20cab9d0012a5945318ab4eb56a19464a19873;p=ghc-hetmet.git

[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
--- 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
--- 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
--- 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;                                               \
+            }                                                      \
+        }                                                          \
+    }