[project @ 1996-01-08 20:28:12 by partain]

[ghc-hetmet.git] / ghc / lib / hbc / NameSupply.hs

diff --git a/ghc/lib/hbc/NameSupply.hs b/ghc/lib/hbc/NameSupply.hs
new file mode 100644 (file)
index 0000000..6d14d22
--- /dev/null
+++ b/ghc/lib/hbc/NameSupply.hs
@@ -0,0 +1,67 @@
+module NameSupply(NameSupply, initialNameSupply, splitNameSupply, getName, listNameSupply, Name(..)
+#if defined(__YALE_HASKELL__)
+       , Symbol
+#endif
+       ) where
+
+#if defined(__YALE_HASKELL__)
+import Symbol
+type Name = Symbol
+
+#else
+# if defined(__GLASGOW_HASKELL__)
+import PreludeGlaST
+type Name = Int
+
+# else
+import LMLgensym
+type Name = Int
+# endif
+#endif
+
+data NameSupply = NameSupply Name NameSupply NameSupply
+
+splitNameSupply :: NameSupply -> (NameSupply,NameSupply)
+getName                :: NameSupply -> Name
+listNameSupply :: NameSupply -> [NameSupply]
+
+#if defined(__YALE_HASKELL__)
+initialNameSupply :: IO NameSupply
+#else
+initialNameSupply :: NameSupply
+#endif
+
+#if defined(__GLASGOW_HASKELL__)
+initialNameSupply = unsafePerformPrimIO mk_supply# -- GHC-specific
+  where
+    mk_supply#
+      = unsafeInterleavePrimIO (_ccall_ genSymZh)
+                                           `thenPrimIO` \ u  ->
+       unsafeInterleavePrimIO mk_supply#   `thenPrimIO` \ s1 ->
+       unsafeInterleavePrimIO mk_supply#   `thenPrimIO` \ s2 ->
+       returnPrimIO (NameSupply u s1 s2)
+#endif
+
+#if defined(__YALE_HASKELL__)
+initialNameSupply :: IO NameSupply
+initialNameSupply
+ = let
+     mk_supply =
+         unsafeInterleaveIO (genSymbol "NameSupply")   >>= \ sym ->
+         unsafeInterleaveIO mk_supply                  >>= \ supply1 ->
+         unsafeInterleaveIO mk_supply                  >>= \ supply2 ->
+         return (NameSupply sym supply1 supply2)
+   in
+   mk_supply
+#endif
+
+#if defined(__HBC__)
+initialNameSupply = gen ()
+       where gen n = NameSupply (__gensym n) (gen n) (gen n)
+#endif
+
+splitNameSupply (NameSupply _ s1 s2) = (s1, s2)
+
+getName (NameSupply k _ _) = k
+
+listNameSupply (NameSupply _ s1 s2) = s1 : listNameSupply s2