114 lines
3.2 KiB
OCaml
114 lines
3.2 KiB
OCaml
(** Compilers. *)
|
|
|
|
open Languages
|
|
|
|
(** A compiler translates programs from a source language
|
|
into programs of a target language. *)
|
|
module type Compiler = sig
|
|
|
|
module Source : Language
|
|
module Target : Language
|
|
|
|
type environment
|
|
val initial_environment : unit -> environment
|
|
|
|
val translate : Source.ast -> environment -> Target.ast * environment
|
|
|
|
end
|
|
|
|
(** Given a compiler from L1 to L2 and a compiler from L2 to L3,
|
|
one can get compiler from L1 to L3. *)
|
|
let compose (module C1 : Compiler) (module C2 : Compiler) : (module Compiler) =
|
|
let c2_source_is_c1_target =
|
|
Obj.magic (* Do not do this at home, kids! *)
|
|
in
|
|
(module struct
|
|
module Source = C1.Source
|
|
|
|
module Target = C2.Target
|
|
|
|
type environment = C1.environment * C2.environment
|
|
|
|
let initial_environment () =
|
|
(C1.initial_environment (), C2.initial_environment ())
|
|
|
|
let translate source (env1, env2) =
|
|
let (intermediate, env1') =
|
|
C1.translate source env1
|
|
in
|
|
let (target, env2') =
|
|
C2.translate (c2_source_is_c1_target intermediate) env2
|
|
in
|
|
(target, (env1', env2'))
|
|
end : Compiler)
|
|
|
|
let rec join = function
|
|
| [x] -> x
|
|
| [x; y] -> compose x y
|
|
| x :: xs -> compose x (join xs)
|
|
| _ -> assert false
|
|
|
|
let string_of_compiler_passes xs =
|
|
String.concat " -> " (
|
|
List.map (fun (module C : Compiler) -> C.Source.extension
|
|
) xs)
|
|
|
|
(** Compiler implementations are stored in the following
|
|
mutable association list. *)
|
|
let compilers : (string * (string * (module Compiler))) list ref =
|
|
ref []
|
|
|
|
let register (module C : Compiler) =
|
|
let source = C.Source.name and target = C.Target.name in
|
|
compilers := (source, (target, (module C))) :: !compilers
|
|
|
|
let compilers_from source =
|
|
List.(
|
|
!compilers
|
|
|> filter (fun (source', _) -> source = source')
|
|
|> map snd
|
|
)
|
|
|
|
let find _ source target using = List.(ExtStd.List.Monad.(
|
|
let rec search seen source target =
|
|
if List.mem source seen then
|
|
fail
|
|
else (
|
|
take_one (compilers_from source) >>= fun (target', m) ->
|
|
if target = target' then
|
|
return [(target', m)]
|
|
else (
|
|
search (source :: seen) target' target >>= fun ms ->
|
|
return ((target', m) :: ms)
|
|
)
|
|
)
|
|
in
|
|
run (search [] source target)
|
|
|> filter (fun p -> for_all (fun u -> exists (fun (l, _) -> l = u) p) using)
|
|
|> map (map snd)
|
|
))
|
|
|
|
let get ?(using=[]) (module Source : Language) (module Target : Language) =
|
|
let using = List.map (fun (module L : Language) -> L.name) using in
|
|
match find compilers Source.name Target.name using with
|
|
| [] ->
|
|
Error.global_error
|
|
"during compilation"
|
|
"Sorry, there is no such compiler in flap."
|
|
| [x] ->
|
|
join x
|
|
| xs ->
|
|
Error.global_error
|
|
"during compilation"
|
|
("Sorry, there are many ways to implement this compiler in flap:\n" ^
|
|
String.concat "\n" (List.map string_of_compiler_passes xs))
|
|
|
|
(** There is an easy way to compile a language into itself:
|
|
just use the identity function :-). *)
|
|
module Identity (L : Language) : Compiler = struct
|
|
module Source = L
|
|
module Target = L
|
|
type environment = unit
|
|
let initial_environment () = ()
|
|
let translate x () = (x, ())
|
|
end
|