citadelle-devel/C11-FrontEnd/C_Main.thy

179 lines
6.3 KiB
Plaintext

(******************************************************************************
* Generation of Language.C Grammar with ML Interface Binding
*
* Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* * Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above
* copyright notice, this list of conditions and the following
* disclaimer in the documentation and/or other materials provided
* with the distribution.
*
* * Neither the name of the copyright holders nor the names of its
* contributors may be used to endorse or promote products derived
* from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
******************************************************************************)
theory "C_Main"
imports "src/C_Annotation"
keywords "C" :: thy_decl
and "C_import" :: thy_load % "ML"
and "C_export" :: thy_load % "ML"
begin
section \<open>The Global C11-Module State\<close>
ML\<open>
structure C_Context' = struct
fun accept env_lang (_, (res, _, _)) =
(fn context =>
( Context.theory_name (Context.theory_of context)
, (res, #stream_ignored env_lang |> rev))
|> Symtab.update_list (op =)
|> C11_core.map_tab
|> (fn map_tab => C11_core.Data.map map_tab context))
|> C_Env.map_context
val eval_source =
C_Context.eval_source
C_Env.empty_env_lang
(fn _ => fn _ => fn pos => fn _ =>
error ("Parser: No matching grammar rule" ^ Position.here pos))
accept
end
\<close>
section \<open>The Isar Binding to the C11 Interface.\<close>
ML\<open>
structure C_Outer_Syntax =
struct
fun C source =
ML_Context.exec (fn () => C_Context'.eval_source source)
#> Local_Theory.propagate_ml_env
fun C' err env_lang src =
C_Env.empty_env_tree
#> C_Context.eval_source'
env_lang
err
C_Context'.accept
src
#> (fn {context, reports_text} => Stack_Data_Tree.map (append reports_text) context)
val _ =
Outer_Syntax.command @{command_keyword C} ""
(Parse.input (Parse.group (fn () => "C source") Parse.text)
>> (Toplevel.generic_theory o C));
end
\<close>
section \<open>The Command @{command C_import}\<close>
ML\<open>
structure C_File =
struct
fun command0 ({src_path, lines, digest, pos}: Token.file) =
let
val provide = Resources.provide (src_path, digest);
in I
#> C_Outer_Syntax.C (Input.source true (cat_lines lines) (pos, pos))
#> Context.mapping provide (Local_Theory.background_theory provide)
end;
fun command files =
Toplevel.generic_theory
(fn gthy => command0 (hd (files (Context.theory_of gthy))) gthy);
end;
\<close>
section \<open>Reading and Writing C-Files\<close>
ML\<open>
local
val semi = Scan.option @{keyword ";"};
val _ =
Outer_Syntax.command @{command_keyword C_import} "read and evaluate C file"
(Resources.parse_files "C_file" --| semi >> C_File.command);
val _ =
Outer_Syntax.command @{command_keyword C_export} "read and evaluate C file"
(Resources.parse_files "C_file" --| semi >> C_File.command); (* HACK: TO BE DONE *)
in end
\<close>
section \<open>ML-Antiquotations for Debugging\<close>
ML\<open>
fun print_top make_string f _ (_, (value, pos1, pos2)) _ thy =
let
val () = writeln (make_string value)
val () = Position.reports_text [((Position.range (pos1, pos2)
|> Position.range_position, Markup.intensify), "")]
in f thy end
fun print_top' _ f _ (_, (_, pos1, pos2)) env thy =
let
val () = Position.reports_text [((Position.range (pos1, pos2)
|> Position.range_position, Markup.intensify), "")]
val () = writeln ("ENV " ^ C_Env.string_of env)
in f thy end
fun print_stack s make_string stack _ _ thy =
let
val () = warning ("SHIFT " ^ (case s of NONE => "" | SOME s => "\"" ^ s ^ "\" ") ^ Int.toString (length stack - 1) ^ " +1 ")
val () = stack
|> split_list
|> #2
|> map_index I
|> app (fn (i, (value, pos1, pos2)) => writeln (" " ^ Int.toString (length stack - i) ^ " " ^ make_string value ^ " " ^ Position.here pos1 ^ " " ^ Position.here pos2))
in thy end
fun print_stack' s _ stack _ env thy =
let
val () = warning ("SHIFT " ^ (case s of NONE => "" | SOME s => "\"" ^ s ^ "\" ") ^ Int.toString (length stack - 1) ^ " +1 ")
val () = writeln ("ENV " ^ C_Env.string_of env)
in thy end
\<close>
setup \<open>ML_Antiquotation.inline @{binding print_top}
(Args.context >> K ("print_top " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
setup \<open>ML_Antiquotation.inline @{binding print_top'}
(Args.context >> K ("print_top' " ^ ML_Pretty.make_string_fn ^ " I"))\<close>
setup \<open>ML_Antiquotation.inline @{binding print_stack}
(Scan.peek (fn _ => Scan.option Args.text) >> (fn name => ("print_stack " ^ (case name of NONE => "NONE" | SOME s => "(SOME \"" ^ s ^ "\")") ^ " " ^ ML_Pretty.make_string_fn)))\<close>
setup \<open>ML_Antiquotation.inline @{binding print_stack'}
(Scan.peek (fn _ => Scan.option Args.text) >> (fn name => ("print_stack' " ^ (case name of NONE => "NONE" | SOME s => "(SOME \"" ^ s ^ "\")") ^ " " ^ ML_Pretty.make_string_fn)))\<close>
end