PreviousUpNext

15.4.8  src/app/c-glue-maker/ast-to-spec.pkg

#
# ast-to-spec.pkg - Conversion from CKIT "raw_syntax_tree" to a "spec" (see spec.pkg).
#
#  (C) 2001, Lucent Technologies, Bell Labs
#
# author: Matthias Blume (blume@research.bell-labs.com)

# Compiled by:
#     src/app/c-glue-maker/c-glue-maker.lib



package raw_syntax_tree_to_spec {
    #
    package a= raw_syntax;      # raw_syntax    is from   src/lib/c-kit/src/ast/ast.pkg
    package b= namings;         # namings       is from   src/lib/c-kit/src/ast/bindings.pkg

    package ss= string_set;     # string_set    is from   src/lib/src/string-set.pkg
    package sm= string_map;     # string_map    is from   src/lib/src/string-map.pkg

    Context = CONTEXT  { gensym: Void -> String,
                         anon:   Bool
                       };

    exception VOID_TYPE;
    exception ELLIPSIS;
    exception DUPLICATE String;

    #
    fun bug m =   raise exception FAIL ("raw_syntax_tree_to_spec: bug: "   + m);
    fun err m =   raise exception FAIL ("raw_syntax_tree_to_spec: error: " + m);

    #
    fun warn m
        =
        file__premicrothread::write (file__premicrothread::stderr, "raw_syntax_tree_to_spec: warning: " + m);

    #
    fun build { bundle,                 # From c-kit parser: raw syntax trees plus matching symbol tables.
                sizes: sizes::Sizes,    # Target machine word lengths etc.
                collect_enums,          # Boolean recording commandline '-nocollect' setting.  See ./README.
                cfiles,                 # List of strings:  The actual commandline .h filenames being processed.
                match,                  # Regex from commandline '-match' switch.  See ./README.
                all_su,                 # "all_su" == "all structures and unions"
                eshift,                 # Function generating shift need to extract a bitfield. (Depends on endian-ness etc.)
                gensym_suffix           # From '-gensym' commandline switch.  See ./README.
              }
        =
        {   cur_loc =   REF "?";

            #
            fun warn_loc m
                =
                warn (cat [*cur_loc, ": ", m]);

            bundle
                ->
                { raw_syntax_tree,      # Actually a list of syntax trees, one per C external declaration.
                  tidtab,               # Maps tids (integer "type identifiers") to types.
                  error_count,
                  warning_count,
                  auxiliary_info => { aidtab, implicits, dictionary }
                };

            #
            fun real_function_def_coming   symbol
                =
                list::exists   is_the_def   raw_syntax_tree
                where
                    fun is_the_def (a::DECL (a::FUN (id, _, _), _, _))
                            =>
                            symbol::equal (id.name, symbol);    # symbol        is from   src/lib/c-kit/src/ast/symbol.pkg

                        is_the_def _
                            =>
                            FALSE;
                    end;
                end;

            src_of =   line_number_db::loc_to_string;           # line_number_db        is from   src/lib/c-kit/src/parser/stuff/line-number-db.pkg

            #
            fun is_this_file   line_number_db::UNKNOWN
                    =>
                    FALSE;

                is_this_file (  line_number_db::LOC { src_file, ... } )
                    =>
                    list::exists   (fn f =   f == src_file)   cfiles
                    or
                    match src_file;
            end;

            #
            fun included_su   (tag, loc) = (all_su   or   is_this_file   loc);
            fun included_enum (tag, loc) =                is_this_file   loc;
            fun included_type (n,   loc) =                is_this_file   loc;

            #
            fun is_function   t =  type_util::is_function    tidtab  t;
            fun get_function  t =  type_util::get_function   tidtab  t;
            fun get_core_type t =  type_util::get_core_type  tidtab  t;

            #
            fun constness type
                =
                if  (type_util::is_const  tidtab  type)
                     spec::RO;
                else
                     case (get_core_type type)
                       
                          a::ARRAY (_, array_type) =>   constness array_type;
                          _                        =>   spec::RW;
                     esac;
                fi;

            sizerec =   { sizes, err, warn, bug };

            #
            fun size_of  t
                =
                .bytes  (sizeof::byte_size_of  sizerec  tidtab  t);

            bytebits =  sizes.char.bits;
            intbits  =  sizes.int.bits ;
            intalign =  sizes.int.align;

            #
            fun get_field (m, l)
                =
                sizeof::get_field sizerec (m, l);

            #
            fun field_offsets t
                =
                case  (sizeof::field_offsets   sizerec   tidtab   t)
                  
                      NULL  =>   bug "no field offsets";
                      THE l =>   l;
                esac;

            structs          =  REF [];
            unions           =  REF [];

            global_types     =  REF sm::empty;
            global_variables =  REF sm::empty;
            global_functions =  REF sm::empty;

            named_enums      =  REF sm::empty;
            anon_enums       =  REF sm::empty;

            seen_structs     =  REF ss::empty;
            seen_unions      =  REF ss::empty;

            nexttag          =  REF 0;

            tags =   tidtab::uidtab () :  tidtab::Uidtab ((String, Bool));

            #
            fun make_context_td tdname                          # "td" is probably "typedef"
                =
                {   next =   REF 0;

                    CONTEXT {
                        anon => FALSE,

                        gensym
                            =>
                            fn () =  {   n = *next;

                                         next := n + 1;

                                         cat [ "'",
                                                  if  (n == 0  )  "";  else  int::to_string n;  fi,
                                                  tdname
                                                ];
                                     }
                    };
                };

            #
            fun make_context_su (parent_tag, anon)
                =
                {   next =   REF 0;

                    CONTEXT {
                        anon,

                        gensym
                            =>
                            fn () =  {   n = *next;
                                         next := n + 1;
                                         cat [parent_tag, "'", int::to_string n];
                                     }
                    };
                };

            tl_context
                =
                {   next =   REF 0;

                    CONTEXT {
                        anon => TRUE,

                        gensym
                            =>
                            fn () =  {   n = *next;
                                         next := n + 1;
                                         int::to_string n;
                                     }
                    };
                };

            #
            fun tagname (THE t, _, _)
                    =>
                    (t, FALSE);

               tagname (NULL, CONTEXT { gensym, anon }, tid)
                    =>
                    case (tidtab::find (tags, tid))
                      
                        THE ta => ta;

                        NULL => {   t =   gensym ();
                                    tidtab::insert (tags, tid, (t, anon));
                                    (t, anon);
                                };
                    esac;
            end;

            #
            fun reported_tagname (t, FALSE) =>  t;
                reported_tagname (t, TRUE)  =>  t + gensym_suffix;
            end;

            #
            fun valty context a::VOID     => raise exception  VOID_TYPE;
                valty context a::ELLIPSES => raise exception  ELLIPSIS;

                valty context (a::QUAL (q, t)) =>  valty context t;

                valty context (a::NUMERIC (_, _, a::SIGNED,   a::CHAR,     _)) =>   spec::SCHAR;
                valty context (a::NUMERIC (_, _, a::UNSIGNED, a::CHAR,     _)) =>   spec::UCHAR;
                valty context (a::NUMERIC (_, _, a::SIGNED,   a::INT,      _)) =>   spec::SINT;
                valty context (a::NUMERIC (_, _, a::UNSIGNED, a::INT,      _)) =>   spec::UINT;
                valty context (a::NUMERIC (_, _, a::SIGNED,   a::SHORT,    _)) =>   spec::SSHORT;
                valty context (a::NUMERIC (_, _, a::UNSIGNED, a::SHORT,    _)) =>   spec::USHORT;
                valty context (a::NUMERIC (_, _, a::SIGNED,   a::LONG,     _)) =>   spec::SLONG;
                valty context (a::NUMERIC (_, _, a::UNSIGNED, a::LONG,     _)) =>   spec::ULONG;
                valty context (a::NUMERIC (_, _, _,           a::FLOAT,    _)) =>   spec::FLOAT;
                valty context (a::NUMERIC (_, _, _,           a::DOUBLE,   _)) =>   spec::DOUBLE;
                valty context (a::NUMERIC (_, _, a::SIGNED,   a::LONGLONG, _)) =>   spec::SLONGLONG;
                valty context (a::NUMERIC (_, _, a::UNSIGNED, a::LONGLONG, _)) =>   spec::ULONGLONG;
                valty context (a::NUMERIC (_, _, _, a::LONGDOUBLE,         _)) =>   spec::UNIMPLEMENTED "long double";

                valty context (a::ARRAY (NULL, t))
                    =>
                    valty context (a::POINTER t);

                valty context (a::ARRAY (THE (n, _), t))
                    =>
                    {   d =  int::from_multiword_int  n;
                        #
                        if  (d < 0)   err "negative dimension";
                        else          spec::ARR { t => valty context t, d, esz => size_of t };
                        fi;
                    };

                valty context (a::POINTER t)
                    =>
                    case (get_core_type  t)
                        #
                        a::VOID       =>  spec::VOIDPTR;
                        a::FUNCTION f =>  fptrty context f;
                        _             =>  spec::PTR (cchunk context t);
                    esac;

                valty context (a::FUNCTION f    ) =>   fptrty context f;

                valty context (a::STRUCT_REF tid) =>   typeref (tid, spec::STRUCT, context);
                valty context (a::UNION_REF  tid) =>   typeref (tid, spec::UNION, context);
                valty context (a::ENUM_REF   tid) =>   typeref (tid, fn t =  spec::ENUM (t, FALSE),   context);

                valty context (a::TYPE_REF tid)
                    =>
                    typeref   (tid,   fn _ = bug "missing typedef info",   context);

                valty context a::ERROR => err "Error type";
            end 

            also
            fun valty_nonvoid context t
                 =
                 valty context t
                 except
                     VOID_TYPE =  err "void variable type"

            also
            fun typeref (tid, otherwise, context)
                =
                case (tidtab::find (tidtab, tid))
                  
                    NULL
                        =>
                        bug "tid not bound in tidtab";

                    THE { name => THE n, ntype => NULL, ... }
                        =>
                        otherwise n;

                    THE { name => NULL, ntype => NULL, ... }
                        =>
                        bug "both name and ntype missing in tidtab naming";

                    THE { name, ntype => THE nct, location, ... }
                         =>
                         case nct
                           
                             b::STRUCT (tid, members)
                                  =>
                                  structty (tid, name, context, members, location);

                             b::UNION (tid, members)
                                  =>
                                  unionty (tid, name, context, members, location);

                             b::ENUM (tid, edefs)
                                  =>
                                  enumty (tid, name, context, edefs, location);

                             b::TYPEDEFX (_, t)
                                  =>
                                  {   n = case name
                                            
                                               NULL  =>  bug "missing name in typedef";
                                               THE n =>  n;
                                          esac;

                                      context' = make_context_td n;

                                      result = valty context' t;

#                                     fun same_name { src, name, spec }
#                                         =
#                                         name == n;

                                      if  (included_type (n, location) and
                                           not (sm::contains_key (*global_types, n)))

                                           global_types
                                               :=
                                               sm::set (*global_types, n,
                                                             { src    => src_of location,
                                                               c_name => n,
                                                               spec   => result } );
                                      fi;

                                      result;
                                  };
                         esac;
                 esac

            also
            fun enumty (tid, name, context, edefs, location)
                 = 
                 {   my (tag_stem, anon)
                         =
                         tagname (name, context, tid);

                     c_name =   reported_tagname (tag_stem, anon);

                     fun one ( { name, uid, location, ctype, kind }, i)
                         =
                         {   name =>  symbol::name name,
                             spec =>  i
                         };

                     enums =   if   anon      anon_enums;
                                           else   named_enums;   fi;

                     enums := sm::set ( *enums,
                                           c_name,
                                           { src     => src_of location,
                                             c_name,
                                             anon,
                                             descr   =>  c_name,
                                             exclude =>  not (included_enum (c_name, location)),
                                             spec    =>  map one edefs
                                           }
                                         );

                     spec::ENUM (c_name, anon);
                 }

           also
            fun structty (tid, name, context, members, location)
                = 
                {   my (tag_stem, anon)
                        =
                        tagname (name, context, tid);

                    c_name   =   reported_tagname (tag_stem, anon);
                    type     =   spec::STRUCT c_name;
                    context' =   make_context_su (tag_stem, anon);

                    if (not (ss::member (*seen_structs, c_name)))
                        #
                        seen_structs :=  ss::add (*seen_structs, c_name);

                        fol   =   field_offsets (a::STRUCT_REF tid);            # "fol" maybe == "field offset list"
                        ssize =   size_of (a::STRUCT_REF tid);

                        #
                        fun bfspec (offset, bits, shift, (c, t))
                            =
                            {   offset =  offset;
                                #
                                bits   =  unt::from_multiword_int  bits;
                                #
                                shift  =  eshift (shift, intbits, bits);

                                r = { offset,
                                      constness => c,
                                      bits,
                                      shift
                                    };

                                case t

                                    spec::UINT =>   spec::UNSIGNED_BITFIELD r;
                                    spec::SINT =>   spec::SIGNED_BITFIELD   r;
                                    _          =>   err "non-int bitfield";
                                esac;
                            };

                        #
                        fun synthetic (synth, (_, FALSE), _)
                                =>
                                ([], synth);

                           synthetic (synth, (endp, TRUE), startp)
                                =>
                                if  (endp == startp)
                                     ([], synth);
                                else
                                     ([{ name => int::to_string synth,
                                         spec => spec::OFIELD {
                                                    offset => endp,
                                                    spec => (spec::RW,
                                                            spec::ARR { t => spec::UCHAR,
                                                                       d => startp - endp,
                                                                       esz => 1 } ),
                                                    synthetic => TRUE
                                                }
                                       }
                                      ],
                                      synth+1
                                     );
                                fi;
                        end;

                        #
                        fun build ([], synth, gap)
                                =>
                                #1 (synthetic (synth, gap, ssize));

                            build ((t, THE m, NULL) ! rest, synth, gap)
                                =>
                                {   bitoff =   .bit_offset (get_field (m, fol));
                                    bytoff =   bitoff / bytebits;

                                    my (filler, synth)
                                        =
                                        synthetic (synth, gap, bytoff);

                                    endp = bytoff + size_of t;

                                    if  (bitoff % bytebits != 0)

                                         bug "non-bitfield not on byte boundary";
                                    else
                                         filler
                                         @
                                         { name => symbol::name m.name,
                                           spec => spec::OFIELD
                                                      { offset    =>  bytoff,
                                                        spec      =>  cchunk context' t,
                                                        synthetic =>  FALSE
                                                      }
                                         }
                                         !
                                         build (rest, synth, (endp, FALSE));
                                    fi;
                                };

                            build ((t, THE m, THE b) ! rest, synth, gap)
                                =>
                                {   bitoff =  .bit_offset (get_field (m, fol));

                                    bytoff
                                        =
                                        (intalign * (bitoff / intalign))
                                        /
                                        bytebits;

                                    gap =   (#1 gap, TRUE);

                                    {   name => symbol::name m.name,
                                        spec => bfspec (  bytoff,
                                                          b,
                                                          bitoff % intalign,
                                                          cchunk context' t
                                                      )
                                    }
                                    !
                                    build (rest, synth, gap);
                                };

                            build ((t, NULL, THE _) ! rest, synth, gap)
                                =>
                                build (rest, synth, (#1 gap, TRUE));

                            build ((_, NULL, NULL) ! _, _, _)
                                =>
                                bug "unnamed struct member (not bitfield)";
                        end;

                        fields = build (members, 0, (0, FALSE));

                        structs := { src => src_of location,
                                     c_name, 
                                     anon,
                                     size => unt::from_int ssize,
                                     exclude => not (included_su (c_name, location)),
                                     fields
                                   }
                                   ! *structs;

                    fi;

                    type;
                }

           also
            fun unionty (tid, name, context, members, location)
                = 
                {   my  (tag_stem, anon)
                        =
                        tagname (name, context, tid);

                    c_name   =   reported_tagname (tag_stem, anon);
                    context' =   make_context_su  (tag_stem, anon);
                    type     =   spec::UNION c_name;
                    lsz      =   REF 0;

                    fun make_field (t, m: a::Member)
                        =
                        {   size = size_of t;

                            { name => symbol::name m.name,
                              spec => spec::OFIELD { offset    => 0,
                                                     spec      => cchunk context' t,
                                                     synthetic => FALSE
                                                   }
                            };
                        };

                    if  (not (ss::member (*seen_unions, c_name)))

                         seen_unions := ss::add (*seen_unions, c_name);

                         all  = map make_field members;

                         unions := { c_name,
                                     anon,
                                     all,
                                     src     => src_of location,
                                     size    => unt::from_int (size_of (a::UNION_REF tid)),
                                     exclude => not (included_su (c_name, location))
                                   }
                                   !
                                   *unions;

                    fi;

                    type;
                }

            also
            fun cchunk context t
                =
                (constness t, valty_nonvoid context t)

            also
            fun fptrty context f
                =
                spec::FPTR (cft context f)

            also
            fun cft context (result, args)                              # "cft" is maybe "core function type"?
                =
                { result => case (get_core_type  result)
                              
                                 a::VOID =>  NULL;
                                 _       =>  THE (valty_nonvoid context result);
                            esac,

                  args => case args
                            
                               [(arg, _)] => case (get_core_type  arg)
                                               
                                                  a::VOID => [];
                                                  _ => [valty_nonvoid context arg];
                                             esac;

                              _ => build args
                                   where
                                       fun build []
                                               =>
                                               [];

                                           build [(x, _)]
                                               =>
                                               (   [valty_nonvoid context x]
                                                   except
                                                       ELLIPSIS
                                                           =
                                                           {   warn_loc
                                                                  "varargs not supported:  Ignoring the ellipsis.\n";

                                                               [];
                                                           }
                                               );

                                           build ((x, _) ! xs)
                                               =>
                                               valty_nonvoid context x ! build xs;
                                       end;
                                   end;
                          esac
                };

            #
            fun ft_argnames (result, args)
                =
                {   optids =   map' args  (fn (_, optid) =  optid);
                    #
                    if (list::exists (not o not_null) optids)   NULL;
                    else                                        THE (map the optids);
                    fi;
                };

            #
            fun function_name (  f:      a::Id,
                                 ailo:   Null_Or(  List(  a::Id ) )     # "ailo": "a"="arg", "i"="id", "l"="list", "o"="optional"...?
                              )
                =
                {   name =   symbol::name f.name;
                    anlo =   null_or::map (map (symbol::name o .name)) ailo;    # "anlo"="argument name list, optional"?

                    if  (name != "_init"   and
                         name != "_fini"   and
                         not (sm::contains_key (*global_functions, name))
                        )

                         case f.st_ilk
                           
                             (a::EXTERN | a::DEFAULT)
                                 =>
                                 case (get_function f.ctype)
                                   
                                      THE fs
                                          =>
                                          global_functions
                                              :=
                                              sm::set (
                                                       *global_functions,
                                                       name,
                                                       { src       => *cur_loc,
                                                         c_name    => name,
                                                         spec      => cft tl_context fs,
                                                         arg_names => anlo
                                                       }
                                                   );

                                      NULL
                                          => bug "function without function type";
                                 esac;

                            (a::AUTO | a::REGISTER | a::STATIC)
                                =>
                                ();
                         esac;
                    fi;
                };

            #
            fun var_decl (v: a::Id)
                =
                case v.st_ilk                           # "st_ilk" is likely "storage class"
                  
                     (a::EXTERN | a::DEFAULT)
                         =>
                         case (get_function  v.ctype)
                           
                              THE fs => if  (not (real_function_def_coming   v.name))
                                            function_name (v, ft_argnames fs);
                                        fi;
                              NULL
                                  =>
                                  {   n =   symbol::name v.name;

                                      if  (not (sm::contains_key (*global_variables, n)))

                                          global_variables
                                              :=
                                              sm::set (
                                                         *global_variables,
                                                         n,
                                                         { src    =>  *cur_loc,
                                                           c_name =>  n,
                                                           spec   =>  cchunk  tl_context  v.ctype
                                                         }
                                                     );
                                      fi;
                                  };
                         esac;

                     (a::AUTO | a::REGISTER | a::STATIC)
                         => ();
                esac;

            #
            fun do_tid tid
                =
                # Spec::SINT is an arbitrary choice;
                # The value gets ignored anyway:
                (   ignore (typeref (tid, fn _ = spec::SINT, tl_context))
                    except
                        VOID_TYPE = ()          # Ignore type aliases for void.
                );

            #
            fun declaration (a::TYPE_DECL { tid, ... } ) =>   do_tid  tid;
                declaration (a::VAR_DECL (v, _)        ) =>   var_decl  v;
            end;

            #
            fun core_external_decl (a::EXTERNAL_DECL decl)
                    =>
                    declaration decl;

                core_external_decl (a::FUN (function, argids, _))
                    =>
                    function_name (function, THE argids);

                core_external_decl (a::EXTERNAL_DECL_EXT _)
                    =>
                    ();
            end;

            #
            fun external_decl (a::DECL (decl, _, loc))
                =
                if  (is_this_file loc)

                    cur_loc :=   line_number_db::loc_to_string  loc;

                    core_external_decl  decl;
                fi;

            #
            fun do_ast l
                =
                apply  external_decl  l;

            #
            fun gen_enums ()
                =
                {   ael =   sm::vals_list  *anon_enums;         # So "ael" == "anonymous enum list"
                    nel =   sm::vals_list *named_enums;         # So "nel" == "named enum list"

                    infix my @@@;

                    fun x @@@ [] =>  [x];
                        x @@@ y  =>  x ! ", " ! y;
                    end;

                    fun onev (v as { name, spec }, m)
                        =
                        if  (sm::contains_key (m, name))
                             raise exception DUPLICATE name;
                        else
                             sm::set (m, name, v);
                        fi;

                    fun onee ( { src, c_name, anon, spec, descr, exclude }, (m, sl))
                        =
                        ( fold_forward onev m spec,
                          src @@@ sl
                        );

                    if  (not collect_enums)
                         ael @ nel;
                    else
                         {   my (m, sl)
                                 =
                                 fold_forward onee (sm::empty, []) ael;

                             if  (sm::is_empty m)
                                  nel;
                             else
                                  { src     => cat (reverse sl),
                                    c_name  => "'",
                                    anon    => FALSE,
                                    descr   => "collected from unnamed enumerations",
                                    exclude => FALSE,
                                    spec    => sm::vals_list m
                                  }
                                  !
                                  nel;
                             fi;
                         }
                         except
                             DUPLICATE name
                                 =
                                 {   warn (cat ["constant ", name,
                                                   " defined more than once;\
                                                   \ disabling `-collect'\n"]);

                                     ael @ nel;
                                 };
                    fi;
                };

            do_ast raw_syntax_tree;

            apply  (do_tid o #1)  (tidtab::keyvals_list tidtab);

            { structs            =>   *structs,
              unions             =>   *unions,

              global_types       =>   sm::vals_list *global_types,
              global_variables   =>   sm::vals_list *global_variables,
              global_functions   =>   sm::vals_list *global_functions,

              enums              =>   gen_enums ()

            }: spec::Spec;
        };                      # fun build
};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext