t

[clean-tests.git] / structs / GenC.icl

diff --git a/structs/GenC.icl b/structs/GenC.icl
index c566d23..19a0652 100644 (file)
--- a/structs/GenC.icl
+++ b/structs/GenC.icl
@@ -5,6 +5,7 @@ import Data.Map => qualified updateAt
 import Data.Func, Data.Tuple
 import Data.Maybe
 import Data.Either
+import Data.List => qualified difference, union, find
 import Text
 
 import scc
@@ -35,7 +36,7 @@ gPotInf{|RECORD of {grd_name}|} f s
 :: CType
        = CTTypeDef String
        | CTEnum [String]
-       | CTStruct [(String, [(String, Bool, String)])]
+       | CTStruct Int [(String, [(String, Bool, String)])]
 
 :: GTSState = {dict :: Map String CType}
 instance zero GTSState where zero = {dict=newMap}
@@ -75,7 +76,8 @@ gToStruct{|PAIR|} fl _ fr _ st
                (a, GTSPair l) = GTSPair [a:l]
                (l, r) = GTSPair [l, r]
        , box st)
-gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st
+import Debug.Trace
+gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
        # (Box isPInf) = i []
        # ty = GTSType isPInf
        = case get gtd_name st.dict of
@@ -92,18 +94,26 @@ gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st
                        # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
                        =
                                ( GTSType isPInf gtd_name
-                               , box $ putst gtd_name (CTStruct (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st
+                               , box $ putst gtd_name
+                                       (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
                                )
        where
+               mkty :: GTSResult -> [GTSResult]
                mkty (GTSEither l) = l
                mkty t = [t]
 
+               mkccons :: GTSResult -> [GTSResult]
                mkccons (GTSType pi t) = [GTSType pi t]
                mkccons (GTSPair t) = t
                mkccons _ = []
-               
-               toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
-gToStruct{|RECORD of {grd_name,grd_fields}|} f i st
+
+               ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
+               ctcons gcd cons
+                       # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
+                       = (gcd_name, toT cons)
+               where
+                       toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
+gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
        # (Box isPInf) = i []
        = case get grd_name st.dict of
                Just n = (GTSType isPInf grd_name, box st)
@@ -112,7 +122,7 @@ gToStruct{|RECORD of {grd_name,grd_fields}|} f i st
                        = case n of
                                GTSPair l =
                                        ( GTSType isPInf grd_name
-                                       , box $ putst grd_name (CTStruct [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
+                                       , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
                                _ = (GTSError, box st)
 
 /**
@@ -123,7 +133,7 @@ toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
 where
        refs (CTTypeDef s) = [s]
        refs (CTEnum _) = []
-       refs (CTStruct cs) = map fst3 (flatten (map snd cs))
+       refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
 
        proc [] c = c
        proc [x] c = ctypedef x (find x m) c
@@ -135,12 +145,12 @@ where
        ctypedef :: String CType [String] -> [String]
        ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
        ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
-       ctypedef name (CTStruct [(_, fs)]) c =
+       ctypedef name (CTStruct _ [(_, fs)]) c =
                [ "struct ", name, " {\n"
                : foldr (uncurry3 (field 1))
                ["};\n":c] fs
                ]
-       ctypedef name (CTStruct cs) c =
+       ctypedef name (CTStruct _ cs) c =
                [ "struct ", name, " {\n"
                : ind 1 ["enum {"
                : enum (map fst cs)
@@ -162,7 +172,7 @@ where
        enum [x:xs] c = [x, ",": enum xs c]
 
 typeName ty m c = [case get ty m of
-               Just (CTStruct _) = "struct "
+               Just (CTStruct _ _) = "struct "
                Just (CTEnum _) = "enum "
                _ = ""
        , ty:c]
@@ -179,24 +189,32 @@ uncurry3 f (x,y,z) = f x y z
 toCParser :: GTSState -> ([String], [String])
 toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
 where
-       funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
+       funsigs = foldr (uncurry funsig) [";\n"] $ toList m
        pfname n c = ["parse_", n:c]
        pfcall n c = pfname n ["(get, alloc, err);":c]
-       funsig n c
-               = typeName n m [" ": pfname n ["(\n"
-               : ind 1 ["uint8_t (*get)(void),\n"
-               : ind 1 ["void *(*alloc)(size_t),\n"
-               : ind 1 ["void (*err)(const char *errmsg, ...))"
-               :c]]]]]
-       funbody (n, ty) c = funsig n
+       funsig n (CTStruct i _) c
+               | i > 0
+                       = typeName n m [" "
+                       : pfname n ["(\n"
+                       : funargs 1
+                       $ foldr (\i c->
+                               [",\n":ind 1 ["void *(*parse_", toString i, ")(\n"
+                               : funargs 2 [")":c]]]) [")":c] [0..i-1]]]
+       funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]]
+       funbody (n, ty) c = funsig n ty
                ["\n{\n"
                :ind 1 $ typeName n m [" r;\n"
                :funb ty $ ind 1 ["return r;\n}\n":c]]]
+       funargs i c
+               = ind i ["uint8_t (*get)(void),\n"
+               : ind i ["void *(*alloc)(size_t size),\n"
+               : ind i ["void (*err)(const char *errmsg, ...)"
+               :c]]]
 
        funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
        funb (CTEnum a) c = ind 1 ["r = get()\n":c]
-       funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
-       funb (CTStruct fs) c
+       funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+       funb (CTStruct _ fs) c
                = ind 1 ["switch(r.cons = get()) {\n"
                :foldr field
                ( ind 1 ["default:\n"
@@ -233,8 +251,8 @@ where
 
        funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
        funb (CTEnum a) c = ind 1 ["put(r)\n":c]
-       funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
-       funb (CTStruct fs) c =
+       funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+       funb (CTStruct _ fs) c =
                ind 1 ["put(r.cons);\n"
                : ind 1 ["switch(r.cons) {\n"
                :foldr field