#
# 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.libpackage raw_syntax_tree_to_spec {
#
package a= raw_syntax; # raw_syntax is from src/lib/c-kit/src/ast/raw-syntax.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 DIE ("raw_syntax_tree_to_spec: bug: " + m);
fun err m = raise exception DIE ("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 (\\ 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
=>
\\ () = { 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 => {. n = *next;
next := n + 1;
cat [parent_tag, "'", int::to_string n];
}
};
};
tl_context
=
{ next = REF 0;
#
CONTEXT {
anon => TRUE,
gensym => {. 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, \\ t = spec::ENUM (t, FALSE), context);
valty context (a::TYPE_REF tid)
=>
typeref (tid, \\ _ = 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 (\\ (_, 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, \\ _ = 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
};