adbrucker
/
lh-l4v
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Refactoring as a prelude to handling static/extern 

This is work for both of JIRA VER-439 and VER-440.

Test-suite passes.
This commit is contained in:
Michael Norrish 2015-03-17 16:42:46 +11:00
parent 5c3f79ff3b
commit 94d8a918f2
7 changed files with 9759 additions and 9401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
tools/c-parser/Absyn-StmtDecl.ML
View File

@ -25,8 +25,14 @@ datatype fnspec = fnspec of string wrap
| didnt_translate | didnt_translate
| gcc_attribs of gcc_attribute list | gcc_attribs of gcc_attribute list
datatype storage_class =
SC_EXTERN | SC_STATIC | SC_AUTO | SC_REGISTER | SC_THRD_LOCAL
datatype declaration = datatype declaration =
VarDecl of (expr ctype * string wrap * bool * initializer option * VarDecl of (expr ctype *
string wrap *
storage_class list *
initializer option *
gcc_attribute list) gcc_attribute list)
(* VarDecl's bool is true if the declaration is not an extern; (* VarDecl's bool is true if the declaration is not an extern;
if the declaration is "genuine". if the declaration is "genuine".
@ -90,6 +96,7 @@ end
signature STMT_DECL = signature STMT_DECL =
sig sig
datatype gcc_attribute = datatype StmtDeclDatatype.gcc_attribute datatype gcc_attribute = datatype StmtDeclDatatype.gcc_attribute
datatype storage_class = datatype StmtDeclDatatype.storage_class
datatype fnspec = datatype StmtDeclDatatype.fnspec datatype fnspec = datatype StmtDeclDatatype.fnspec
datatype declaration = datatype StmtDeclDatatype.declaration datatype declaration = datatype StmtDeclDatatype.declaration
datatype trappable = datatype StmtDeclDatatype.trappable datatype trappable = datatype StmtDeclDatatype.trappable
@ -116,6 +123,8 @@ sig
val stmt_fail : statement * string -> exn val stmt_fail : statement * string -> exn
val is_extern : storage_class list -> bool
end end
structure StmtDecl : STMT_DECL = structure StmtDecl : STMT_DECL =
@ -227,4 +236,7 @@ fun stmt_type s =
fun stmt_fail (Stmt w, msg) = fun stmt_fail (Stmt w, msg) =
Fail (Region.toString (Region.Wrap.region w) ^ ": " ^ msg) Fail (Region.toString (Region.Wrap.region w) ^ ": " ^ msg)
val is_extern = List.exists (fn x => x = SC_EXTERN)
val is_static = List.exists (fn x => x = SC_STATIC)
end end

23
tools/c-parser/StrictC.grm
View File

@ -165,7 +165,7 @@ fun gen_struct_id () =
NameGeneration.internalAnonStructPfx^Int.toString (!scount)) NameGeneration.internalAnonStructPfx^Int.toString (!scount))
end end
datatype storage_class_specifier = TypeDef | Extern | Static | Auto | Register datatype storage_class_specifier = TypeDef | Extern | Static | Auto | Register | Thread_Local
datatype type_qualifier = Const | Volatile | Restrict datatype type_qualifier = Const | Volatile | Restrict
datatype typespectok = ts_unsigned datatype typespectok = ts_unsigned
| ts_signed | ts_signed
@ -197,6 +197,19 @@ datatype decl_specifier = Storage of storage_class_specifier wrap
| TypeSpec of type_specifier | TypeSpec of type_specifier
| FunSpec of Absyn.fnspec wrap | FunSpec of Absyn.fnspec wrap
fun scs_to_SC scs =
case scs of
Extern => SOME SC_EXTERN
| Static => SOME SC_STATIC
| Thread_Local => SOME SC_THRD_LOCAL
| Register => SOME SC_REGISTER
| Auto => SOME SC_AUTO
| TypeDef => NONE
val extract_storage_specs =
List.mapPartial (fn Storage scs_w => scs_to_SC (node scs_w)
| _ => NONE)
fun dslleft [] = raise Fail "dslleft: nil" fun dslleft [] = raise Fail "dslleft: nil"
| dslleft (h :: t) = | dslleft (h :: t) =
case h of case h of
@ -502,6 +515,7 @@ let
NONE => [] NONE => []
| SOME es => [wrap(EnumDecl (node es), left es, right es)] | SOME es => [wrap(EnumDecl (node es), left es, right es)]
val fnspecs = extract_fnspecs (node dsl) val fnspecs = extract_fnspecs (node dsl)
val storage_specs = extract_storage_specs (node dsl)
fun handle_declarator idw = let fun handle_declarator idw = let
val (d : addecl wrap, iopt : initializer option) = node idw val (d : addecl wrap, iopt : initializer option) = node idw
@ -535,7 +549,7 @@ let
errorStr'(left idw, right idw, "Don't initialise externs") errorStr'(left idw, right idw, "Don't initialise externs")
else () else ()
in in
wrap(VarDecl(finaltype, nm, not is_extern, iopt, attrs), wrap(VarDecl(finaltype, nm, storage_specs, iopt, attrs),
left idw, right idw) left idw, right idw)
end end
end end
@ -808,7 +822,7 @@ end
| NUMERIC_CONSTANT of Absyn.numliteral_info | NUMERIC_CONSTANT of Absyn.numliteral_info
| STRUCT | UNION | TYPEDEF | EXTERN | CONST | VOLATILE | RESTRICT | STRUCT | UNION | TYPEDEF | EXTERN | CONST | VOLATILE | RESTRICT
| INVARIANT | INVARIANT
| INLINE | STATIC | NORETURN | INLINE | STATIC | NORETURN | THREAD_LOCAL | AUTO
| FNSPEC | FNSPEC
| RELSPEC | RELSPEC
| AUXUPD | AUXUPD
@ -853,6 +867,9 @@ storage_class_specifier : TYPEDEF (wrap(TypeDef, TYPEDEFleft, TYPEDEFright))
| EXTERN (wrap(Extern, EXTERNleft, EXTERNright)) | EXTERN (wrap(Extern, EXTERNleft, EXTERNright))
| STATIC (wrap(Static, STATICleft, STATICright)) | STATIC (wrap(Static, STATICleft, STATICright))
| YREGISTER (wrap(Register, YREGISTERleft, YREGISTERright)) | YREGISTER (wrap(Register, YREGISTERleft, YREGISTERright))
| AUTO (wrap(Auto, AUTOleft, AUTOright))
| THREAD_LOCAL (wrap(Thread_Local, THREAD_LOCALleft,
THREAD_LOCALright))
function_specifiers function_specifiers
: INLINE (wrap([], INLINEleft, INLINEright)) (* totally ignored by us *) : INLINE (wrap([], INLINEleft, INLINEright)) (* totally ignored by us *)

2
tools/c-parser/StrictC.grm.sig
View File

@ -17,6 +17,8 @@ val GHOSTUPD: 'a * 'a -> (svalue,'a) token
val AUXUPD: 'a * 'a -> (svalue,'a) token val AUXUPD: 'a * 'a -> (svalue,'a) token
val RELSPEC: 'a * 'a -> (svalue,'a) token val RELSPEC: 'a * 'a -> (svalue,'a) token
val FNSPEC: 'a * 'a -> (svalue,'a) token val FNSPEC: 'a * 'a -> (svalue,'a) token
val AUTO: 'a * 'a -> (svalue,'a) token
val THREAD_LOCAL: 'a * 'a -> (svalue,'a) token
val NORETURN: 'a * 'a -> (svalue,'a) token val NORETURN: 'a * 'a -> (svalue,'a) token
val STATIC: 'a * 'a -> (svalue,'a) token val STATIC: 'a * 'a -> (svalue,'a) token
val INLINE: 'a * 'a -> (svalue,'a) token val INLINE: 'a * 'a -> (svalue,'a) token

4933
tools/c-parser/StrictC.grm.sml
View File

File diff suppressed because it is too large Load Diff

4
tools/c-parser/StrictC.lex
View File

@ -193,7 +193,9 @@ attr_start = "__attribute__"{ws}*"((";
getPos(source, yypos + 6)); getPos(source, yypos + 6));
continue()); continue());
<INITIAL>"register"=> (tok(Tokens.YREGISTER,source,yypos,yypos+size yytext-1)); <INITIAL>"register"=> (tok(Tokens.YREGISTER,source,yypos,yypos+size yytext-1));
<INITIAL>"_Thread_local" =>
(tok(Tokens.THREAD_LOCAL,source,yypos,yypos+size yytext-1));
<INITIAL>"auto" => (tok(Tokens.AUTO,source,yypos,yypos+size yytext-1));
<TDEF>"/*" => (YYBEGIN TRADCOMMENT; in_comment := true; <TDEF>"/*" => (YYBEGIN TRADCOMMENT; in_comment := true;
return := STDEF; return := STDEF;

14141
tools/c-parser/StrictC.lex.sml
View File

File diff suppressed because it is too large Load Diff

43
tools/c-parser/program_analysis.ML
View File

@ -122,7 +122,6 @@ datatype var_info =
fname : string option, fname : string option,
proto_param : bool, proto_param : bool,
munged_name : string, munged_name : string,
is_genuine : bool,
declared_at : Region.t, declared_at : Region.t,
attrs : gcc_attribute list} attrs : gcc_attribute list}
fun viToString (VI {name, fname,...}) = fun viToString (VI {name, fname,...}) =
@ -137,7 +136,6 @@ fun get_vi_fname (VI {fname,...}) = fname
fun get_vi_type (VI {vtype,...}) = vtype fun get_vi_type (VI {vtype,...}) = vtype
fun get_vi_senv (VI {struct_env,...}) = struct_env fun get_vi_senv (VI {struct_env,...}) = struct_env
fun declpos (VI {declared_at,...}) = declared_at fun declpos (VI {declared_at,...}) = declared_at
fun is_genuine (VI {is_genuine, ...}) = is_genuine
fun vi_compare(VI vi1, VI vi2) = let fun vi_compare(VI vi1, VI vi2) = let
val ocmp = option_compare and pcmp = pair_compare and scmp = String.compare val ocmp = option_compare and pcmp = pair_compare and scmp = String.compare
@ -395,24 +393,24 @@ local
cse_makeUpdate (from, from', to) cse_makeUpdate (from, from', to)
end z end z
fun vi_makeUpdate z = makeUpdate10 z fun vi_makeUpdate z = makeUpdate9 z
fun update_VI z = let fun update_VI z = let
fun from name return_var vtype struct_env fname proto_param fun from name return_var vtype struct_env fname proto_param
munged_name is_genuine declared_at attrs = munged_name declared_at attrs =
{name = name, return_var = return_var, vtype = vtype, {name = name, return_var = return_var, vtype = vtype,
struct_env = struct_env, fname = fname, declared_at = declared_at, struct_env = struct_env, fname = fname, declared_at = declared_at,
proto_param = proto_param, munged_name = munged_name, proto_param = proto_param, munged_name = munged_name,
is_genuine = is_genuine, attrs = attrs} attrs = attrs}
fun from' attrs declared_at is_genuine munged_name proto_param fname struct_env fun from' attrs declared_at munged_name proto_param fname struct_env
vtype return_var name = vtype return_var name =
{name = name, return_var = return_var, vtype = vtype, {name = name, return_var = return_var, vtype = vtype,
struct_env = struct_env, fname = fname, declared_at = declared_at, struct_env = struct_env, fname = fname, declared_at = declared_at,
proto_param = proto_param, munged_name = munged_name, proto_param = proto_param, munged_name = munged_name,
is_genuine = is_genuine, attrs = attrs} attrs = attrs}
fun to f {name, return_var, vtype, struct_env, fname, proto_param, fun to f {name, return_var, vtype, struct_env, fname, proto_param,
munged_name, is_genuine, declared_at, attrs} = munged_name, declared_at, attrs} =
f name return_var vtype struct_env fname proto_param f name return_var vtype struct_env fname proto_param
munged_name is_genuine declared_at attrs munged_name declared_at attrs
in in
vi_makeUpdate (from, from', to) vi_makeUpdate (from, from', to)
end z end z
@ -460,8 +458,6 @@ fun cse_fupdglobinits f (CSE cse) =
fun upd_mname mname (VI vi) = fun upd_mname mname (VI vi) =
VI (update_VI vi (U #munged_name mname) $$) VI (update_VI vi (U #munged_name mname) $$)
fun vi_upd_genuine b (VI vi) =
VI (update_VI vi (U #is_genuine b) $$)
fun vi_upd_type ty (VI vi) = fun vi_upd_type ty (VI vi) =
VI (update_VI vi (U #vtype ty) $$) VI (update_VI vi (U #vtype ty) $$)
@ -874,10 +870,8 @@ fun munge_insert (v as VI vrec) cse = let
fun merge_vis v1 v2 = let fun merge_vis v1 v2 = let
val ty1 = get_vi_type v1 val ty1 = get_vi_type v1
val ty2 = get_vi_type v2 val ty2 = get_vi_type v2
val g1 = is_genuine v1
val g2 = is_genuine v2
in in
vi_upd_type (max_type ty1 ty2) (vi_upd_genuine (g1 orelse g2) v1) vi_upd_type (max_type ty1 ty2) v1
end end
fun vars_add v1 vlist = fun vars_add v1 vlist =
@ -1195,7 +1189,7 @@ fun process_expr lvstate fname (env as CSE {senv, ...}) e = let
val retvar = VI {name = nm, munged_name = nm, vtype = rettype, val retvar = VI {name = nm, munged_name = nm, vtype = rettype,
struct_env = senv, proto_param = false, struct_env = senv, proto_param = false,
fname = SOME "", return_var = true, attrs = [], fname = SOME "", return_var = true, attrs = [],
is_genuine = true, declared_at = Region.bogus} declared_at = Region.bogus}
in in
foldthis (rettype, count - 1) (#2 (insert_var(retvar, acc))) foldthis (rettype, count - 1) (#2 (insert_var(retvar, acc)))
end end
@ -1277,7 +1271,7 @@ fun process_decl fname (d:declaration wrap) (e as CSE {senv,...}) = let
val ecenv = cse2ecenv e val ecenv = cse2ecenv e
in in
case node d of case node d of
VarDecl (ty,s,is_genuine,iopt,attrs) => let VarDecl (ty,s,storage_specs,iopt,attrs) => let
val s = if node s = phantom_state_name then val s = if node s = phantom_state_name then
(Feedback.errorStr' (Feedback.errorStr'
(left s, right s, (left s, right s,
@ -1305,7 +1299,7 @@ in
NONE => let NONE => let
in in
case fname of case fname of
SOME fnm => if is_genuine then SOME fnm => if not (is_extern storage_specs) then
raise Fail ("Array "^str^" in function "^fnm^ raise Fail ("Array "^str^" in function "^fnm^
" must be given a size or an \ " must be given a size or an \
\initialiser") \initialiser")
@ -1330,7 +1324,7 @@ in
val vi = VI {name = str, vtype = vty, attrs = attrs, val vi = VI {name = str, vtype = vty, attrs = attrs,
munged_name = str, struct_env = senv, proto_param = false, munged_name = str, struct_env = senv, proto_param = false,
fname = fname, return_var = false, is_genuine = is_genuine, fname = fname, return_var = false,
declared_at = Region.make{left = left s, right = right s}} declared_at = Region.make{left = left s, right = right s}}
val (vi, e) = insert_var (vi, e) val (vi, e) = insert_var (vi, e)
val bogus = SourcePos.bogus val bogus = SourcePos.bogus
@ -1401,7 +1395,7 @@ in
in in
(w (Assign(var_e, exp)), SOME exp, e) (w (Assign(var_e, exp)), SOME exp, e)
end end
val d' = wrap(VarDecl(ty,s,is_genuine,NONE,attrs), left d, right d) val d' = wrap(VarDecl(ty,s,storage_specs,NONE,attrs), left d, right d)
val e = val e =
case proc_expr_opt of case proc_expr_opt of
NONE => e NONE => e
@ -1431,7 +1425,7 @@ in
else let else let
val retvar = VI {name = ret_vname, munged_name = ret_vname, val retvar = VI {name = ret_vname, munged_name = ret_vname,
vtype = rettype, proto_param = false, vtype = rettype, proto_param = false,
struct_env = senv, is_genuine = true, struct_env = senv,
fname = SOME fname, return_var = true, fname = SOME fname, return_var = true,
attrs = [], declared_at = Region.bogus} attrs = [], declared_at = Region.bogus}
in in
@ -1443,7 +1437,7 @@ in
| SOME s => s | SOME s => s
val var = val var =
VI {name = name, vtype = param_norm (constify_abtype ecenv ty), VI {name = name, vtype = param_norm (constify_abtype ecenv ty),
munged_name = name, is_genuine = true, attrs = [], munged_name = name, attrs = [],
struct_env = senv, proto_param = true, struct_env = senv, proto_param = true,
fname = SOME fname, return_var = false, fname = SOME fname, return_var = false,
declared_at = Region.bogus} declared_at = Region.bogus}
@ -1454,7 +1448,7 @@ in
val paramtypes = map (param_norm o constify_abtype ecenv o #1) params val paramtypes = map (param_norm o constify_abtype ecenv o #1) params
val ftype = Function(rettype, paramtypes) val ftype = Function(rettype, paramtypes)
val fvi = VI {name = fname, vtype = ftype, munged_name = fname, val fvi = VI {name = fname, vtype = ftype, munged_name = fname,
proto_param = false, struct_env = senv, is_genuine = true, proto_param = false, struct_env = senv,
fname = NONE, return_var = false, attrs = [], fname = NONE, return_var = false, attrs = [],
declared_at = Region.Wrap.region d} declared_at = Region.Wrap.region d}
val (_, e) = insert_var (fvi, e) val (_, e) = insert_var (fvi, e)
@ -1729,13 +1723,13 @@ fun process_one_extdecl (env0 : csenv) edec =
val rv_nm = return_var_name rettype val rv_nm = return_var_name rettype
val retvar = VI {name = rv_nm, munged_name = rv_nm, attrs = [], val retvar = VI {name = rv_nm, munged_name = rv_nm, attrs = [],
vtype = rettype, proto_param = false, vtype = rettype, proto_param = false,
struct_env = senv, is_genuine = true, struct_env = senv,
fname = SOME (node s), return_var = true, fname = SOME (node s), return_var = true,
declared_at = Region.bogus} declared_at = Region.bogus}
val paramtypes = map (param_norm o constify_abtype ecenv o #1) params val paramtypes = map (param_norm o constify_abtype ecenv o #1) params
val ftype = Function(rettype, paramtypes) val ftype = Function(rettype, paramtypes)
val fvi = VI {name = node s, vtype = ftype, munged_name = node s, val fvi = VI {name = node s, vtype = ftype, munged_name = node s,
proto_param = false, struct_env = senv, is_genuine = true, proto_param = false, struct_env = senv,
fname = NONE, return_var = false, attrs = [], fname = NONE, return_var = false, attrs = [],
declared_at = Region.Wrap.region s} declared_at = Region.Wrap.region s}
val (_, env) = insert_var(fvi,env) val (_, env) = insert_var(fvi,env)
@ -1744,7 +1738,6 @@ fun process_one_extdecl (env0 : csenv) edec =
vtype = param_norm (constify_abtype ecenv ty), vtype = param_norm (constify_abtype ecenv ty),
struct_env = senv, proto_param = false, struct_env = senv, proto_param = false,
fname = fname, return_var = false, fname = fname, return_var = false,
is_genuine = true,
declared_at = declared_at =
Region.make{left = left pname, right = right pname}} Region.make{left = left pname, right = right pname}}
val env = new_scope env (* new scope for parameters and body *) val env = new_scope env (* new scope for parameters and body *)