codegenbug/Data/GenC.icl

   1 implementation module Data.GenC
   2
   3 import StdEnv
   4 import StdGeneric
   5 import StdDebug
   6
   7 import Data.Map => qualified updateAt
   8 import Data.Func
   9
  10 import Text
  11 import Debug.Trace
  12
  13 //derive class gGenerateC (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
  14
  15 derive bimap Structmaker, Box
  16
  17 toEnumValue :: GenericConsDescriptor -> String
  18 toEnumValue gcd = gcd.gcd_type_def.gtd_name +++ "_" +++ gcd.gcd_name
  19
  20 toEnumType :: GenericTypeDefDescriptor -> String
  21 toEnumType gtd = "enum cleanc_" +++ gtd.gtd_name
  22
  23 class toStructType a :: a -> String
  24 instance toStructType GenericTypeDefDescriptor where
  25         toStructType gtd = "struct clean_" +++ gtd.gtd_name
  26 instance toStructType GenericRecordDescriptor where
  27         toStructType grd = "struct clean_" +++ grd.grd_name
  28
  29 :: CInfo a = {header :: String , toValue :: a -> String}
  30
  31 runStructMaker :: (Structmaker a) -> String
  32 runStructMaker (SM t)
  33 # {defs,imps} = snd $ t {dict=newMap,fresh=0,inRecord=False} []
  34 = end (elems defs) +++ end imps
  35 where
  36         end d = concat [d +++ ";\n"\\d<-d]
  37
  38 generic gToCType a | gPotentialInf a :: Structmaker a
  39 derive gToCType [], [! ], [ !], [!!]
  40 derive gToCType (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
  41 :: Structmaker a = SM (SMInput [String] -> ([String], SMOutput)) | Onzinconstructor a
  42 runSM (SM a) = a
  43 :: SMInput =
  44         { fresh :: Int
  45         , inRecord :: Bool
  46         , dict :: Map String String
  47         }
  48 :: SMOutput =
  49         { defs :: Map String String
  50         , imps :: [String]
  51         }
  52
  53 instance + SMOutput where + a b = {defs=union a.defs b.defs, imps=a.imps++b.imps}
  54 instance zero SMOutput where zero = {defs=newMap, imps=[]}
  55
  56 show :: String -> Structmaker a
  57 show str = SM \st c->([str:c], zero)
  58
  59 gToCType{|Char|} = show "char"
  60 gToCType{|Int|} = show "uint64_t"
  61 gToCType{|Real|} = show "double"
  62 gToCType{|Bool|} = show "bool"
  63 gToCType{|UNIT|} = SM \st c->(c, zero)
  64 gToCType{|EITHER|} fl il fr ir = SM \st c
  65         # (c, oa) = runSM fl st c
  66         # (c, ob) = runSM fr {st & dict=union st.dict oa.defs} c
  67         = (c, oa + ob)
  68 gToCType{|PAIR|} fl il fr ir
  69          = SM \st c
  70                 # (c, oa) = runSM fr st c
  71                 # st & dict = union st.dict oa.defs
  72                 # (c, ob) = if st.inRecord
  73                         (runSM fl st c)
  74                         (runSM fl {st & fresh=st.fresh+1} [" f", toString st.fresh, ";\n":c])
  75                 = (c, oa + ob)
  76 gToCType{|OBJECT of gtd|} f i
  77         //Newtype
  78         | gtd.gtd_num_conses == 0
  79                 = SM $ runSM f
  80         = SM \st c->case get gtd.gtd_name st.dict of
  81                 Just n = ([n:c], zero)
  82                 Nothing
  83                         //Generate the enumeration if necessary
  84                         # box = gtd.gtd_num_conses == 1
  85                         # enums = \c->if box c
  86                                 [concat [toEnumType gtd, " {", join ", " (map toEnumValue gtd.gtd_conses), "}"]:c]
  87                         //If it is just an enumeration, Just an enumeration
  88                         | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses]
  89                                 = ( [toEnumType gtd:c]
  90                                   , {defs=singleton gtd.gtd_name $ toEnumType gtd,imps=enums []}
  91                                 )
  92                         //Only one constructor
  93                         # defs = singleton gtd.gtd_name (toStructType gtd +++ " *")
  94                         # (c`, o) = runSM f {st & dict=union defs st.dict} (if box [] ["} data;\n}"])
  95                         # obj = concat [toStructType gtd, "{\n":if box c` [toEnumType gtd, " cons;\nunion {\n":c`]]
  96                         = ([toStructType gtd:if (isInfinite i) c [" *":c]], {defs=union o.defs defs, imps=enums [obj:o.imps]})
  97 gToCType{|CONS of gcd|} f i
  98         //No data field
  99         | gcd.gcd_arity == 0 = SM \st c->(c, zero)
 100         //Only one data field
 101         | gcd.gcd_arity == 1 = SM \st c->runSM f st [" ", gcd.gcd_name, ";\n":c]
 102         //Multiple data fields
 103         = SM \st c
 104                 # (c, o) = runSM f st [" f", toString (gcd.gcd_arity - 1), ";\n} ", gcd.gcd_name, ";\n":c]
 105                 = (["struct {\n":c], o)
 106 gToCType{|RECORD of grd|} f i
 107         = SM \st c
 108                 # grd = trace_stdout grd
 109                 # defs = singleton grd.grd_name (toStructType grd)
 110                 # (c`, o) = runSM f {st & inRecord=True,dict=union defs st.dict} ["}"]
 111                 # obj = concat [toStructType grd, " {\n":c`]
 112                 = ([toStructType grd:c], {defs=union defs o.defs, imps=[obj:o.imps]})
 113 gToCType{|FIELD of gfd|} f i
 114         = SM \s c->runSM f s [" ", gfd.gfd_name,";\n":c]
 115 gToCType{|{}|} f i = SM \s c->runSM f s ["*":c]
 116 gToCType{|{!}|} f i = SM \s c->runSM f s ["*":c]
 117 gToCType{|{#}|} f i  = SM \s c->runSM f s ["*":c]
 118
 119 unBox (Box b) :== b
 120 box b :== Box b
 121
 122 isInfinite :: ([String] -> Box Bool a) -> Bool
 123 isInfinite f = unBox (f [])
 124
 125 generic gPotentialInf a :: [String] -> Box Bool a
 126 derive gPotentialInf [], [! ], [ !], [!!]
 127 derive gPotentialInf (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
 128 gPotentialInf{|World|} _ = box False
 129 gPotentialInf{|File|} _ = box False
 130 gPotentialInf{|Bool|} _ = box False
 131 gPotentialInf{|Char|} _ = box False
 132 gPotentialInf{|Real|} _ = box False
 133 gPotentialInf{|Int|} _ = box False
 134 gPotentialInf{|Dynamic|} _ = box False
 135 gPotentialInf{|(->)|} _ _ _ = box False
 136 gPotentialInf{|{}|} a m = box (unBox (a m))
 137 gPotentialInf{|{!}|} a m = box (unBox (a m))
 138 gPotentialInf{|{#}|} a m = box (unBox (a m))
 139 gPotentialInf{|UNIT|} _ = box False
 140 gPotentialInf{|EITHER|} l r m = box (unBox (l m) || unBox (r m))
 141 gPotentialInf{|PAIR|} l r m = box (unBox (l m) || unBox (r m))
 142 gPotentialInf{|CONS|} x m = box (unBox (x m))
 143 gPotentialInf{|FIELD|} x m = box (unBox (x m))
 144 gPotentialInf{|RECORD of {grd_name}|} x m
 145         | isMember grd_name m = box True
 146         = box (unBox (x [grd_name:m]))
 147 gPotentialInf{|OBJECT of {gtd_name}|} x m
 148         | isMember gtd_name m = box True
 149         = box (unBox (x [gtd_name:m]))