Publication du jalon 1

flap/AUTEURS

@@ -0,0 +1,2 @@
+nom1,prenom1,email1
+nom2,prenom2,email2

flap/README.md

@@ -0,0 +1,31 @@
+# The Flap Compiler
+
+## Prerequisites
+
+Flap requires **OCaml 4.10+**, as well as the tools and libraries listed
+below. They should be installed prior to attempting to build Flap.
+
+- The **dune** build system.
+- The **utop** enhanced interactive toplevel.
+- The **pprint** library.
+- The **menhir** parser generator and library.
+- The **sexplib** library.
+- The **ppx_sexp_conv** syntax extension.
+
+The easiest way to install them is via OPAM.
+
+``
+opam install dune utop pprint menhir sexplib ppx_sexp_conv
+``
+
+In addition, running the test requires the [cram](https://bitheap.org/cram/)
+tool. It is probably provided by your Linux distribution.
+
+## Build instructions
+
+To compile the compiler, run `dune build` from this directory.
+
+To run the compiler, run `dune exec ./src/flap.exe -- OPTIONS file` from this
+directory. Alternatively, `flap.exe` can be found in `_build/default/src/`.
+
+The test suite can be found in the `tests` directory. See the README there.

flap/dune-project

@@ -0,0 +1,3 @@
+(lang dune 2.7)
+(using menhir 2.1)
+(cram enable)

flap/runtime/runtime.c

@@ -0,0 +1,37 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+int equal_string(const char* s1, const char* s2) {
+  return (strcmp (s1, s2) == 0 ? 1 : 0);
+}
+
+int equal_char(char c1, char c2) {
+  return (c1 == c2 ? 1 : 0);
+}
+
+void print_string(const char* s) {
+  printf("%s", s);
+}
+
+void print_int(int64_t n) {
+    fprintf(stderr, "Students! This is your job!\n");
+}
+
+void observe_int(int64_t n) {
+  print_int(n);
+}
+
+intptr_t* allocate_block (int64_t n) {
+  return (intptr_t*)malloc (n * sizeof (int64_t));
+}
+
+intptr_t read_block (intptr_t* block, int64_t n) {
+  return block[n];
+}
+
+int64_t write_block (intptr_t* block, int64_t n, intptr_t v) {
+  block[n] = v;
+  return 0;
+}

flap/src/commandLineOptions.ml

@@ -0,0 +1,162 @@
+(** Command line arguments analysis. *)
+
+let options_list =
+  ref []
+
+let push local_options =
+  options_list := !options_list @ local_options
+
+let options names kind doc =
+  let first_shot =
+    let state = ref true in
+    fun s ->
+      if !state then (state := false; s)
+      else
+        (List.hd (Str.(split (regexp " ") doc)))
+  in
+  List.map (fun n -> (n, kind, first_shot doc)) names
+
+let optimizers_options () =
+  List.map (fun (module O : Optimizers.Optimizer) -> Arg.(
+      options
+        ["--" ^ O.shortname]
+        (Set O.activated)
+        (Printf.sprintf " Activate optimization `%s'." O.longname)
+    )) !Optimizers.optimizers
+
+let show_version_and_exits () =
+  Printf.printf "flap %s\n%!" Version.number;
+  exit 0
+
+let generic_options () = Arg.(align (List.flatten [
+  options
+    ["--version"; "-v"]
+    (Unit show_version_and_exits)
+    " Show the version number and exits.";
+
+  options
+    ["--source"; "-s"]
+    (String Options.set_source_language)
+    (" Set the source programming language");
+
+  options
+    ["--target"; "-t"]
+    (String Options.set_target_language)
+    (" Set the target programming language");
+
+  options
+    ["--interactive"; "-i"]
+    (Bool Options.set_interactive_mode)
+    ("(true|false) Set the compiler mode");
+
+  options
+    ["--run"; "-r"]
+    (Bool Options.set_running_mode)
+    ("(true|false) Ask the compiler to run the compiled code");
+
+  options
+    ["--verbose"; "-V"]
+    (Bool Options.set_verbose_mode)
+    ("(true|false) Ask the compiler to be verbose");
+
+  options
+    ["--verbose-eval"; "-VV"]
+    (Bool Options.set_verbose_eval)
+    ("(true|false) Ask the compiler to be show the result of evaluation");
+
+  options
+    ["--dry"; "-d"]
+    (Bool Options.set_dry_mode)
+    ("(true|false) Ask the compiler not to produce compiled file");
+
+  options
+    ["--unsafe"; "-u"]
+    (Bool Options.set_unsafe)
+    ("(true|false) Ask the compiler not to typecheck");
+
+  options
+    ["--bench"; "-B"]
+    (Bool Options.set_benchmark)
+    ("(true|false) Ask the compiler to show evaluation time.");
+
+  options
+    ["--using"; "-!" ]
+    (String Options.insert_using)
+    (" Force the compilation to use this intermediate language");
+
+  options
+    ["--types"; "-T"]
+    (Bool Options.set_show_types)
+    ("(true|false) Ask the compiler to show types for toplevel values.");
+
+  options
+    ["--infer"; "-I"]
+    (Bool Options.set_infer_types)
+    ("(true|false) Ask the compiler to infer types for toplevel values.");
+
+  options
+    ["--typechecking"; "-C"]
+    (Bool Options.set_check_types)
+    ("(true|false) Ask the compiler to check types for toplevel values.");
+
+  options
+    ["--sexp-in"]
+    (Bool Options.set_use_sexp_in)
+    ("(true|false) Activate sexp parsing.");
+
+  options
+    ["--sexp-out"]
+    (Bool Options.set_use_sexp_out)
+    ("(true|false) Activate sexp printing.");
+
+  options
+  ["--scripts-dir"; "-IS"]
+  (String Options.set_scripts_dir)
+  ("[dirname] Set the directory where compiler scripts are located.");
+
+  options
+  ["--include-dir"; "-II"]
+  (String Options.set_include_dir)
+  ("[dirname] Set the directory where runtime.c is located.");
+
+  options
+  ["--output-file"; "-o"]
+  (String Options.set_output_file)
+  "[filename] Set the output file.";
+
+  options
+  ["--fast-pattern-matching"; "-fpm"]
+  (Bool Options.set_fast_match)
+  " Enable efficient pattern-matching compilation.";
+
+  options
+  ["--backend"; "-b"]
+  (String Options.set_backend)
+  "[architecture] Set the architecture backend, default is x86-64.";
+
+  options
+  ["--regalloc-strategy"; "-R"]
+  (String Options.set_regalloc)
+  "[strategy] Set the register allocation strategy, default is naive \
+   (alternatives: advanced).";
+
+  options
+    ["--debug"; "-D"]
+    (Bool Options.set_debug_mode)
+    ("(true|false) Ask the compiler to dump internal information");
+
+  options
+    ["--loc"; "-l"]
+    (Bool Options.set_print_locs)
+    ("(true|false) Ask the compiler to print locations in error messages");
+
+] @ (List.flatten (optimizers_options ()))))
+
+let usage_msg =
+  "flap [options] input_filename"
+
+let parse () =
+  Arg.parse !options_list Options.set_input_filename usage_msg
+
+let initialize () =
+  push (generic_options ())

flap/src/common/architecture.mli

@@ -0,0 +1,26 @@
+(** This module defines a common interface to specify target architectures. *)
+
+module type S = sig
+
+  (** The type of hardware registers. *)
+  type register
+
+  (** Hardware registers that can be used by register allocation. *)
+  val allocable_registers : register list
+
+  (** Registers used as effective arguments for functions. *)
+  val argument_passing_registers : register list
+
+  (** Registers that must be preserved through function calls. *)
+  val callee_saved_registers : register list
+
+  (** Registers that are *not* preserved by function calls. *)
+  val caller_saved_registers : register list
+
+  (** The register that holds the value returned by a function. *)
+  val return_register : register
+
+  (** A human representation of register identifier. *)
+  val string_of_register : register -> string
+
+end

flap/src/common/compilers.ml

@@ -0,0 +1,114 @@
+(** 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

flap/src/common/compilers.mli

@@ -0,0 +1,45 @@
+(** Compilers
+
+    A compiler is a translator from a source language to a target
+    language.
+
+*)
+open Languages
+
+module type Compiler = sig
+
+  module Source : Language
+  module Target : Language
+
+  (** It is convenient to maintain some information about a program
+      along its compilation: an environment is meant to store that
+      kind of information. *)
+  type environment
+  val initial_environment : unit -> environment
+
+  (** [translate source env] returns a [target] program semantically
+      equivalent to [source] as a well as an enriched environment
+      [env] that contains information related to the compilation of
+      [source]. *)
+  val translate : Source.ast -> environment -> Target.ast * environment
+
+end
+
+(** [register compiler] integrates [compiler] is the set of flap's compilers. *)
+val register : (module Compiler) -> unit
+
+(** [get ?using source target] returns a compiler from [source] to
+    [target] built by composing flap's compilers. [using] is empty if
+    not specified.
+
+    [using] represents a list of languages that must appear in the
+    compilation chain. It is useful to disambiguate between several
+    choices when distinct compilation chains exist between two
+    languages. If [using] is not precise enough to kill the
+    ambiguity, flap issues a global error. *)
+val get : ?using:(module Language) list
+  -> (module Language) -> (module Language) -> (module Compiler)
+
+(** There is an easy way to compile a language into itself:
+    just use the identity function :-). *)
+module Identity (L : Language) : Compiler

flap/src/common/languages.ml

@@ -0,0 +1,95 @@
+module type Language = sig
+
+  (** A language as a [name]. *)
+  val name : string
+
+  (** {1 Syntax} *)
+
+  (** A syntax is defined by the type of abstract syntax trees. *)
+  type ast
+
+  (** [parse_filename f] turns the content of file [f] into an
+      abstract syntax tree if that content is a syntactically valid
+      input. *)
+  val parse_filename : string -> ast
+
+  (** Each language has its own extension for source code filenames. *)
+  val extension : string
+
+  (** [executable_format] should true when programs of the language are directly
+      executable when dumped on disk as files.  *)
+  val executable_format : bool
+
+  (** [parse_string c] is the same as [parse_filename] except that the
+      source code is directly given as a string. *)
+  val parse_string : string -> ast
+
+  (** [print ast] turns an abstract syntax tree into a human-readable
+      form. *)
+  val print_ast : ast -> string
+
+  (** {2 Semantic} *)
+
+  (** A runtime environment contains all the information necessary
+      to evaluate a program. *)
+  type runtime
+
+  (** In the interactive loop, we will display some observable
+      feedback about the evaluation. *)
+  type observable
+
+  (** The evaluation starts with an initial runtime. *)
+  val initial_runtime : unit -> runtime
+
+  (** [evaluate runtime p] executes the program [p] and
+      produces a new runtime as well as an observation
+      of this runtime. *)
+  val evaluate : runtime -> ast -> runtime * observable
+
+  (** [print_observable o] returns a human-readable
+      representation of an observable. *)
+  val print_observable : runtime -> observable -> string
+
+  (** {3 Static semantic} *)
+
+  (** During type checking, static information (aka types)
+      are stored in the typing environment. *)
+  type typing_environment
+
+  (** A typing environment to start with. *)
+  val initial_typing_environment : unit -> typing_environment
+
+  (** [typecheck tenv p] checks if [p] is a well-typed program
+      and returns an extension of the typing environment [tenv]
+      with the values defined in the program. *)
+  val typecheck : typing_environment -> ast -> typing_environment
+
+  (** [print_typing_environment tenv] returns a human-readable
+      representation of [tenv]. *)
+  val print_typing_environment : typing_environment -> string
+
+end
+
+(** We store all the language implementations in the following
+    hashing table. *)
+let languages : (string, (module Language)) Hashtbl.t =
+  Hashtbl.create 13
+
+let extensions : (string, (module Language)) Hashtbl.t =
+  Hashtbl.create 13
+
+let get (l : string) : (module Language) =
+  try
+    Hashtbl.find languages l
+  with Not_found ->
+    Error.global_error "initialization" "There is no such language."
+
+let get_from_extension (l : string) : (module Language) =
+  try
+    Hashtbl.find extensions l
+  with Not_found ->
+    Error.global_error "initialization" "This extension is not supported."
+
+let register (module L : Language) =
+  Hashtbl.add languages L.name (module L);
+  Hashtbl.add extensions L.extension (module L)

flap/src/common/languages.mli

@@ -0,0 +1,80 @@
+module type Language = sig
+  (** A language has a [name]. *)
+  val name : string
+
+  (** {1 Syntax} *)
+
+  (** The syntax of a language is defined by its Abstract Syntax Trees. *)
+  type ast
+
+  (** [parse_filename f] turns the content of file [f] into an
+      abstract syntax tree if that content is a syntactically valid
+      input. *)
+  val parse_filename : string -> ast
+
+  (** Each language has its own extension for source code filenames. *)
+  val extension : string
+
+  (** [executable_format] should true when programs of the language are directly
+      executable when dumped on disk as files.  *)
+  val executable_format : bool
+
+  (** [parse_string c] is the same as [parse_filename] except that the
+      source code is directly given as a string. *)
+  val parse_string : string -> ast
+
+  (** [print ast] turns an abstract syntax tree into a human-readable
+      form. *)
+  val print_ast : ast -> string
+
+  (** {2 Semantics} *)
+
+  (** A runtime environment contains all the information necessary
+      to evaluate a program. *)
+  type runtime
+
+  (** In the interactive loop, we will display some observable
+      feedback about the evaluation. *)
+  type observable
+
+  (** The evaluation starts with an initial runtime. *)
+  val initial_runtime : unit -> runtime
+
+  (** [evaluate runtime p] executes the program [p] and
+      produces a new runtime as well as an observation
+      of this runtime. *)
+  val evaluate : runtime -> ast -> runtime * observable
+
+  (** [print_observable o] returns a human-readable
+      representation of an observable. *)
+  val print_observable : runtime -> observable -> string
+
+  (** {3 Type Checking} *)
+
+  (** A typing environment stores static information about the program. *)
+  type typing_environment
+
+  (** The initial typing environment contains predefined static information,
+      like the type for constants. *)
+  val initial_typing_environment : unit -> typing_environment
+
+  (** [typecheck env p] checks if the program [p] is well-formed
+      and enriches the typing environment accordingly. If [p] is
+      not well-formed an {!Error} is issued. *)
+  val typecheck : typing_environment -> ast -> typing_environment
+
+  (** [print_typing_environment] returns a human-readable
+      representation of a typing environment. *)
+  val print_typing_environment : typing_environment -> string
+end
+
+(** [get name] returns a language of flap called [name] if it exists. *)
+val get : string -> (module Language)
+
+(** [get_from_extension ext] returns a language of flap whose extension
+    is [ext] if it exists. *)
+val get_from_extension : string -> (module Language)
+
+
+(** [register l] inserts [l] in the set of flap's languages. *)
+val register : (module Language) -> unit

flap/src/common/memory.ml

@@ -0,0 +1,49 @@
+type location = int
+
+type 'a block = 'a array
+
+type 'a memory = {
+  mutable bound : int;
+  data          : 'a block option array;
+}
+
+type 'a t = 'a memory
+
+let create size = {
+  bound = 0;
+  data  = Array.make size None
+}
+
+exception OutOfMemory
+
+let allocate mem size init =
+  let size = Mint.to_int size in
+  if mem.bound >= Array.length mem.data then
+    raise OutOfMemory
+  else (
+    let location = mem.bound in
+    mem.data.(location) <- Some (Array.make size init);
+    mem.bound <- mem.bound + 1;
+    location
+  )
+
+exception InvalidDereference of location
+
+let dereference mem location =
+  match mem.data.(location) with
+    | None -> raise (InvalidDereference location)
+    | Some b -> b
+
+let size block =
+  Mint.of_int (Array.length block)
+
+let read block i =
+  block.(Mint.to_int i)
+
+let write block i x =
+  block.(Mint.to_int i) <- x
+
+let array_of_block block =
+  block
+
+let print_location x = "#" ^ string_of_int x

flap/src/common/memory.mli

@@ -0,0 +1,39 @@
+(** This module defines a memory model. *)
+
+(** A memory is data structure... *)
+type 'a t
+
+(** that maps locations... *)
+type location
+
+(** to blocks of data of type ['a]. *)
+type 'a block
+
+(** [create size] produces a fresh memory of [size] potential blocks. *)
+val create : int -> 'a t
+
+(** [allocate mem size init] produces a location that points to a fresh block
+    of size cells. These cells are initialized with [init]. *)
+val allocate : 'a t -> Mint.t -> 'a -> location
+
+(** The following exception is raised if no new block can be allocated in the
+    memory. *)
+exception OutOfMemory
+
+(** [dereference mem location] returns the block pointed by [location]. *)
+val dereference : 'a t -> location -> 'a block
+
+(** [size block] returns the length of a block. *)
+val size : 'a block -> Mint.t
+
+(** [read block i] returns the content of the i-th cell of the block *)
+val read : 'a block -> Mint.t -> 'a
+
+(** [write block i x] sets the content of the i-th cell of the block to [x]. *)
+val write : 'a block -> Mint.t -> 'a -> unit
+
+(** [array_of_block b] returns the cells of [b] packed in an array. *)
+val array_of_block : 'a block -> 'a array
+
+(** [print_location l] returns a human-readable representation of [l]. *)
+val print_location : location -> string

flap/src/common/mint.ml

@@ -0,0 +1,17 @@
+include Int64
+
+exception DoesNotFit
+
+let to_int n =
+  if n < of_int Stdlib.min_int || n > of_int Stdlib.max_int
+  then raise DoesNotFit
+  else to_int n
+
+let t_of_sexp s =
+  of_string @@ Int64.to_string @@ Sexplib.Conv.int64_of_sexp s
+
+let sexp_of_t n =
+  Sexplib.Conv.sexp_of_int64 @@ Int64.of_string @@ to_string n
+
+let size_in_bytes =
+  8

flap/src/common/mint.mli

@@ -0,0 +1,34 @@
+(** This module defines the integer type used in all languages. *)
+
+type t = Int64.t
+
+(** {2 Basic Values} *)
+
+val zero : t
+val one : t
+
+(** {2 Arithmetic Operations} *)
+
+val add : t -> t -> t
+val sub : t -> t -> t
+val mul : t -> t -> t
+val div : t -> t -> t
+
+(** {2 Conversions} *)
+
+exception DoesNotFit
+
+val of_int : int -> t
+val to_int : t -> int
+
+val of_string : string -> t
+val to_string : t -> string
+
+(** {2 Serialization} *)
+
+val t_of_sexp : Sexplib.Sexp.t -> t
+val sexp_of_t : t -> Sexplib.Sexp.t
+
+(** {2 Low-level information} *)
+
+val size_in_bytes : int

flap/src/common/optimizers.ml

@@ -0,0 +1,57 @@
+(** Optimizers. *)
+
+open Languages
+open Compilers
+
+(** An optimizer rewrites programs from a language to try
+    to improve their efficiency.
+
+    An optimizer has a name and its application is optional.
+*)
+module type Optimizer = sig
+
+  val shortname : string
+
+  val longname : string
+
+  val activated : bool ref
+
+  module Source : Language
+
+  val translate : Source.ast -> Source.ast
+
+end
+
+let optimizers : (module Optimizer) list ref =
+  ref []
+
+let register (module O : Optimizer) =
+  optimizers := (module O) :: !optimizers
+
+let find_optimizers source =
+  List.filter (fun (module O : Optimizer) ->
+      !O.activated && O.Source.name = source
+    ) !optimizers
+
+let optimize
+      (type t)
+      (module Source : Language with type ast = t) (ast : t) =
+  List.fold_left (fun ast (module O : Optimizer) ->
+      (* Kids, do not do that at home. *)
+      Obj.magic (O.translate (Obj.magic ast))
+    ) ast (find_optimizers Source.name)
+
+let optimizing_compiler (module C : Compiler) =
+  (module struct
+
+    module Source = C.Source
+    module Target = C.Target
+
+    type environment = C.environment
+    let initial_environment = C.initial_environment
+
+    let translate source env =
+      let source = optimize (module Source) source in
+      C.translate source env
+
+  end : Compiler)

flap/src/common/syntacticAnalysis.ml

@@ -0,0 +1,12 @@
+let parsing_step = "during parsing"
+
+let process ~lexer_init ~lexer_fun ~parser_fun ~input =
+  parser_fun lexer_fun (lexer_init input)
+
+let process ~lexer_init ~lexer_fun ~parser_fun ~input  = try
+  process ~lexer_init ~lexer_fun ~parser_fun ~input
+with
+  | Sys_error msg ->
+    Error.global_error parsing_step msg
+  | _ ->
+    Error.global_error parsing_step "Syntax error."

flap/src/common/syntacticAnalysis.mli

@@ -0,0 +1,11 @@
+(** This module helps combining {!Lexer} and {!Parser}. *)
+
+(** [process lexer_init lexer_fun parser_fun input] initializes a lexer,
+    and composes it with a parser in order to transform an input text into
+    an abstract syntax tree. *)
+val process :
+  lexer_init : ('a -> 'lexbuf) ->
+  lexer_fun  : ('lexbuf -> 'token) ->
+  parser_fun : (('lexbuf -> 'token) -> 'lexbuf -> 'ast) ->
+  input      : 'a ->
+  'ast

flap/src/dune

@@ -0,0 +1,29 @@
+(copy_files# common/*.{ml,mli})
+(copy_files# elf/*.{ml,mli})
+(copy_files# fopix/*.{ml,mli})
+(copy_files# hopix/*.{ml,mli})
+(copy_files# hobix/*.{ml,mli})
+(copy_files# retrolix/*.{ml,mli})
+(copy_files# utilities/*.{ml,mli})
+(copy_files# x86-64/*.{ml,mli})
+(copy_files fopix/*.{mll,mly})
+(copy_files hopix/*.{mll,mly})
+(copy_files hobix/*.{mll,mly})
+(copy_files retrolix/*.{mll,mly})
+(copy_files# ../runtime/runtime.c)
+
+(executable
+  (name flap)
+  (libraries str unix pprint menhirLib sexplib)
+  (modules_without_implementation architecture hopixSyntacticSugar)
+  (preprocess (pps ppx_sexp_conv))
+  (promote (until-clean))
+)
+
+(ocamllex fopixLexer hopixLexer hobixLexer retrolixLexer)
+(menhir
+  (modules fopixParser hopixParser hobixParser retrolixParser)
+  (infer true)
+  (flags --explain --table))
+
+(env (dev (flags (:standard -warn-error -A -w -9 -w -32))))

flap/src/elf/elf.ml

@@ -0,0 +1,37 @@
+(** The ELF binary format. *)
+
+module AST = ElfAST
+
+let name = "elf"
+
+type ast = AST.t
+
+let parse lexer_init input =
+  SyntacticAnalysis.process
+    ~lexer_init
+    ~lexer_fun:RetrolixLexer.token
+    ~parser_fun:RetrolixParser.program
+    ~input
+
+let no_parser () =
+  Error.global_error
+    "during source analysis"
+    "There is no parser for ELF in flap."
+
+let parse_filename _ =
+  no_parser ()
+
+let extension =
+  ".elf"
+
+let executable_format =
+  true
+
+let parse_string _ =
+  no_parser ()
+
+let print_ast (buf : ast) =
+  Buffer.contents buf
+
+include ElfInterpreter
+include ElfTypechecker

flap/src/elf/elfAST.ml

@@ -0,0 +1 @@
+type t = Buffer.t

flap/src/elf/elfInitialization.ml

@@ -0,0 +1,7 @@
+open Optimizers
+
+(** Register some compilers that have ELF as a target or source language. *)
+let initialize () =
+  Languages.register (module Elf);
+  Compilers.register (optimizing_compiler (module X86_64toElf));
+  ()

flap/src/elf/elfInterpreter.ml

@@ -0,0 +1,37 @@
+(** This module implements the interpreter for X86-64 programs. *)
+
+open ElfAST
+
+type runtime = unit
+
+type observable = {
+    exit_status : Unix.process_status;
+    stdout      : string;
+    stderr      : string;
+}
+
+let initial_runtime () = ()
+
+let show_runtime _ = ()
+
+let evaluate (_ : runtime) (buf : t) =
+  (* 1. Generate a temporary .s file.
+     2. Call gcc to generate an executable linked with runtime.o
+     3. Execute this program, capturing its stdout/stderr
+   *)
+  let fn = Filename.chop_extension (Options.get_input_filename ()) ^ ".elf" in
+  let oc = open_out fn in
+  Buffer.output_buffer oc buf;
+  close_out oc;
+  ExtStd.Unix.add_exec_bits fn;
+  let exit_status, stdout, stderr =
+    ExtStd.Unix.output_and_error_of_command ("./" ^ fn)
+  in
+  (), { exit_status; stdout; stderr; }
+
+let print_observable (_ : runtime) (obs : observable) =
+  Printf.sprintf
+    "Process exited with status %s.\nSTDOUT:\n%s\nSTDERR:\n%s\n\n"
+    (ExtStd.Unix.string_of_process_status obs.exit_status)
+    obs.stdout
+    obs.stderr

flap/src/elf/elfTypechecker.ml

@@ -0,0 +1,9 @@
+(** There is no typechecker for ELF programs in flap. *)
+
+type typing_environment = unit
+
+let initial_typing_environment () = ()
+
+let typecheck () _ast = ()
+
+let print_typing_environment () = ""

flap/src/elf/x86_64toElf.ml

@@ -0,0 +1,48 @@
+module Source = X86_64
+module Target = Elf
+
+type environment = unit
+
+let initial_environment () =
+  ()
+
+let installation_directory () =
+  Filename.dirname Sys.argv.(0)
+
+let gcc ~src ~tgt =
+  let open Filename in
+  let runtime =
+    concat (installation_directory ()) "runtime.c"
+  in
+  Printf.sprintf
+    "gcc -no-pie -g %s %s -o %s"
+    src
+    runtime
+    tgt
+
+let translate (p : X86_64.ast) _env =
+  (* 1. Generate a temporary .s file.
+     2. Call gcc to generate an executable linked with runtime.o
+     3. Execute this program, capturing its stdout/stderr
+   *)
+  let asmf = Filename.temp_file "flap" ".s" in
+  let elff = Filename.temp_file "flap" ".elf" in
+  let oc = open_out asmf in
+  PPrint.ToChannel.compact oc (X86_64_PrettyPrinter.program p);
+  close_out oc;
+  let exit_status, _, stderr =
+    ExtStd.Unix.output_and_error_of_command (gcc ~src:asmf ~tgt:elff)
+  in
+  if exit_status <> Unix.WEXITED 0
+  then
+    Error.error
+      "ELF"
+      Position.dummy
+      (Printf.sprintf "Could not assemble or link file \"%s\":\n%s" asmf stderr)
+  else
+    let ic = open_in elff in
+    let b = ExtStd.Buffer.slurp ic in
+    close_in ic;
+    List.iter Sys.remove [asmf; elff];
+    b,
+    ()

flap/src/flap.ml

@@ -0,0 +1,236 @@
+(** The main driver module.
+
+    The role of this module is to have [flap] behave as the command
+    line options say. In particular, these options determine:
+
+    - if the compiler is run in interactive or batch mode.
+    - what is the source language of the compiler.
+    - what is the target language of the compiler.
+
+*)
+
+(* -------------------------- *)
+(*   Initialization process   *)
+(* -------------------------- *)
+
+open Options
+
+let rec initialize () =
+  initialize_languages ();
+  initialize_options ();
+  initialize_prompt ()
+
+and initialize_prompt () =
+  UserInput.set_prompt "flap> "
+
+and initialize_options () =
+  CommandLineOptions.initialize ();
+  if not (!Sys.interactive) then CommandLineOptions.parse ()
+
+and initialize_languages () =
+  HopixInitialization.initialize ();
+  ElfInitialization.initialize ();
+  X86_64_Initialization.initialize ();
+  RetrolixInitialization.initialize ();
+  FopixInitialization.initialize ();
+  HobixInitialization.initialize ()
+
+(** Infer source language from the extension of the input file or from the
+    related command line option. *)
+let infer_source_language () =
+  if Options.is_source_language_set ()
+  then Languages.get @@ Options.get_source_language ()
+  else
+    Options.get_input_filename ()
+    |> Filename.extension
+    |> Languages.get_from_extension
+
+(** Given the source language and the target language returns
+    the right compiler (as a first-class module). *)
+let get_compiler () : (module Compilers.Compiler) =
+  let source_language =
+    infer_source_language ()
+  in
+  let target_language =
+    if is_target_language_set () then
+      Languages.get (get_target_language ())
+    else
+      source_language
+  in
+  let using = List.map Languages.get (Options.get_using ()) in
+  Compilers.get ~using source_language target_language
+
+(** The evaluation function evaluates some code and prints the results
+    into the standard output. It also benchmarks the time taken to
+    evaluates the code, if asked. *)
+let eval runtime eval print =
+  let now = Unix.gettimeofday () in
+  let runtime, observation = eval runtime in
+  let elapsed_time = Unix.gettimeofday () -. now in
+  if Options.get_benchmark () then
+    Printf.eprintf "[%fs]\n" elapsed_time;
+  if Options.get_verbose_eval () then
+    print_endline (print runtime observation);
+  runtime
+
+(* -------------------- **)
+(*   Interactive mode    *)
+(* -------------------- **)
+(**
+
+   The interactive mode is a basic read-compile-eval-print loop.
+
+*)
+let interactive_loop () =
+
+  Printf.printf "        Flap version %s\n\n%!" Version.number;
+
+  let module Compiler = (val get_compiler () : Compilers.Compiler) in
+  let open Compiler in
+
+  let read () =
+    initialize_prompt ();
+    let b = Buffer.create 13 in
+    let rec read prev =
+      let c = UserInput.input_char stdin in
+      if c = "\n" then
+        if prev <> "\\" then (
+          Buffer.add_string b prev;
+          Buffer.contents b
+        ) else (
+          UserInput.set_prompt "....> ";
+          read c
+        )
+      else (
+        Buffer.add_string b prev;
+        read c
+      )
+    in
+    read ""
+  in
+
+  let rec step
+    : Target.runtime -> Compiler.environment -> Source.typing_environment
+    -> Target.runtime * Compiler.environment * Source.typing_environment =
+    fun runtime cenvironment tenvironment ->
+      try
+        match read () with
+          | "+debug" ->
+            Options.set_verbose_mode true;
+            step runtime cenvironment tenvironment
+
+          | "-debug" ->
+            Options.set_verbose_mode false;
+            step runtime cenvironment tenvironment
+
+          | input ->
+            let ast = Compiler.Source.parse_string input in
+            let tenvironment =
+              if Options.get_unsafe () then
+                tenvironment
+              else
+                Compiler.Source.typecheck tenvironment ast
+            in
+            let cast, cenvironment = Compiler.translate ast cenvironment in
+            if Options.get_verbose_mode () then
+              print_endline (Target.print_ast cast);
+            let runtime = Compiler.Target.(
+              eval runtime (fun r -> evaluate r cast) print_observable
+            )
+            in
+            step runtime cenvironment tenvironment
+      with
+        | e when !Sys.interactive -> raise e (* display exception at toplevel *)
+        | Error.Error (positions, msg) ->
+          output_string stdout (Error.print_error positions msg);
+          step runtime cenvironment tenvironment
+        | End_of_file ->
+          (runtime, cenvironment, tenvironment)
+        | e ->
+          print_endline (Printexc.get_backtrace ());
+          print_endline (Printexc.to_string e);
+          step runtime cenvironment tenvironment
+  in
+  Error.resume_on_error ();
+  ignore (step
+            (Target.initial_runtime ())
+            (Compiler.initial_environment ())
+            (Source.initial_typing_environment ())
+  )
+
+(* ------------- **)
+(*   Batch mode   *)
+(* ------------- **)
+(**
+
+   In batch mode, the compiler loads a file written in the source
+   language and produces a file written in the target language.
+
+   The filename of the output file is determined by the basename
+   of the input filename concatenated with the extension of the
+   target language.
+
+   If the running mode is set, the compiler will also interpret
+   the compiled code.
+
+*)
+let batch_compilation () =
+  Error.exit_on_error ();
+  let module Compiler = (val get_compiler () : Compilers.Compiler) in
+  let open Compiler in
+  let input_filename = Options.get_input_filename () in
+  let module_name = Filename.chop_extension input_filename in
+  let ast = Source.parse_filename input_filename in
+  if not (Options.get_unsafe ()) then
+    Compiler.Source.(
+      let tenv = typecheck (initial_typing_environment ()) ast in
+      if Options.get_show_types () then (
+        print_endline (print_typing_environment tenv)
+      )
+    );
+  let cast, _ = Compiler.(translate ast (initial_environment ())) in
+  let output_filename =
+    if Options.get_output_file () = "" then
+      let output_filename = module_name ^ Target.extension in
+      if output_filename = input_filename then
+        module_name ^ Target.extension ^ "-optimized"
+      else
+        output_filename
+    else
+      Options.get_output_file ()
+  in
+  if Options.get_verbose_mode () then
+    output_string stdout (Target.print_ast cast ^ "\n");
+  if not (Options.get_dry_mode () || output_filename = input_filename) then (
+    let cout = open_out output_filename in
+    output_string cout (Target.print_ast cast);
+    close_out cout;
+    if Target.executable_format then ExtStd.Unix.add_exec_bits output_filename;
+  );
+  if Options.get_running_mode () then Compiler.Target.(
+    ignore (
+      try
+        let print =
+          if Options.get_verbose_eval () then
+            print_observable
+          else
+            fun _ _ -> ""
+        in
+        eval (initial_runtime ()) (fun r -> evaluate r cast) print
+      with
+        | e ->
+          print_endline (Printexc.get_backtrace ());
+          print_endline (Printexc.to_string e);
+          exit 1
+    )
+  )
+
+(** -------------- **)
+(**   Entry point   *)
+(** -------------- **)
+let main =
+  initialize ();
+  match get_mode () with
+    | _ when !Sys.interactive -> ()
+    | Interactive -> interactive_loop ()
+    | Batch -> batch_compilation ()

flap/src/fopix/fopix.ml

@@ -0,0 +1,32 @@
+(** The fopix programming language. *)
+
+module AST = FopixAST
+
+let name = "fopix"
+
+type ast = FopixAST.t
+
+let parse lexer_init input =
+  SyntacticAnalysis.process
+    ~lexer_init
+    ~lexer_fun:FopixLexer.token
+    ~parser_fun:FopixParser.program
+    ~input
+
+let parse_filename filename =
+  parse Lexing.from_channel (open_in filename)
+
+let extension =
+  ".fopix"
+
+let executable_format =
+  false
+
+let parse_string =
+  parse Lexing.from_string
+
+let print_ast ast =
+  FopixPrettyPrinter.(to_string program ast)
+
+include FopixInterpreter
+include FopixTypechecker

flap/src/fopix/fopixAST.ml

@@ -0,0 +1,65 @@
+(** The abstract syntax tree for Fopix programs. *)
+
+(**
+
+   Fopix is a first order language.
+
+   Like the C language, Fopix only allows toplevel functions. These
+   functions can be called directly by using their names in the source
+   code or indirectly by means of (dynamically computed) function
+   pointers. Toplevel functions are mutually recursive.
+
+   As in C, the control-flow can be structured by loops,
+   conditionals and switchs.
+
+   Contrary to C, Fopix does not make a distinction between statements
+   and expressions. Besides, the notion of variable is similar to the
+   one of functional language: variables are immutable.
+
+*)
+
+type program = definition list
+
+and definition =
+  (** [val x = e]  *)
+  | DefineValue      of identifier * expression
+  (** [def f (x1, ..., xN) = e] *)
+  | DefineFunction   of function_identifier * formals * expression
+  (** [external f : arity] *)
+  | ExternalFunction of function_identifier * int
+
+and expression =
+  (** [0, 1, 2, ], ['a', 'b', ...], ["Dalek", "Master", ...] *)
+  | Literal of literal
+  (** [x, y, z, ginette] *)
+  | Variable of identifier
+  (** [val x = e1; e2] *)
+  | Define of identifier * expression * expression
+  (** [f (e1, .., eN)] *)
+  | FunCall of function_identifier * expression list
+  (** [call e with (e1, .., eN)] *)
+  | UnknownFunCall of expression * expression list
+  (** [while e do e' end] *)
+  | While of expression * expression
+  (** [if e then e1 else e2 end] *)
+  | IfThenElse of expression * expression * expression
+  (** [switch e in c1 | c2 | .. | cN orelse e_default end]
+      where [ci := ! | e]. *)
+  | Switch of expression * expression option array * expression option
+
+and literal =
+  | LInt    of Mint.t
+  | LString of string
+  | LChar   of char
+  | LFun    of function_identifier
+
+and identifier =
+  | Id of string
+
+and formals =
+    identifier list
+
+and function_identifier =
+  | FunId of string
+
+and t = program

flap/src/fopix/fopixInitialization.ml

@@ -0,0 +1,4 @@
+let initialize () =
+  Languages.register (module Fopix);
+  Compilers.register (module Compilers.Identity (Fopix));
+  Compilers.register (module HobixToFopix)

flap/src/fopix/fopixInterpreter.ml

@@ -0,0 +1,395 @@
+open Error
+open FopixAST
+
+(** [error pos msg] reports runtime error messages. *)
+let error positions msg =
+  errorN "execution" positions msg
+
+(** Every expression of fopi evaluates into a [value]. *)
+type value =
+  | VUnit
+  | VInt       of Mint.t
+  | VBool      of bool
+  | VChar      of char
+  | VString    of string
+  | VAddress   of Memory.location
+  | VFun       of function_identifier
+
+type 'a coercion = value -> 'a option
+let value_as_int      = function VInt x -> Some x | _ -> None
+let value_as_bool     = function VBool x -> Some x | _ -> None
+let value_as_address  = function VAddress x -> Some x | _ -> None
+let value_as_unit     = function VUnit -> Some () | _ -> None
+
+type 'a wrapper = 'a -> value
+let int_as_value x  = VInt x
+let bool_as_value x = VBool x
+let address_as_value x = VAddress x
+let unit_as_value () = VUnit
+
+let print_value m v =
+  let max_depth = 5 in
+
+  let rec print_value d v =
+    if d >= max_depth then "..." else
+      match v with
+        | VInt x ->
+          Mint.to_string x
+        | VBool true ->
+          "true"
+        | VBool false ->
+          "false"
+        | VChar c ->
+          "'" ^ Char.escaped c ^ "'"
+        | VString s ->
+          "\"" ^ String.escaped s ^ "\""
+        | VUnit ->
+          "()"
+        | VAddress a ->
+          print_block m d a
+        | VFun _ ->
+          "<fun>"
+  and print_block m d a =
+    let b = Memory.dereference m a in
+    let vs = Array.to_list (Memory.array_of_block b) in
+    "[ " ^ String.concat "; " (List.map (print_value (d + 1)) vs) ^ " ]"
+  in
+  print_value 0 v
+
+module Environment : sig
+  type t
+  val initial : t
+  val bind    : t -> identifier -> value -> t
+  exception UnboundIdentifier of identifier
+  val lookup  : identifier -> t -> value
+  val last    : t -> (identifier * value * t) option
+  val print   : value Memory.t -> t -> string
+end = struct
+  type t = (identifier * value) list
+
+  let initial = []
+
+  let bind e x v = (x, v) :: e
+
+  exception UnboundIdentifier of identifier
+
+  let _ =
+    Printexc.register_printer (function
+        | UnboundIdentifier (Id x) ->
+           Some (Printf.sprintf "Unbound identifier %s" x)
+        | _ ->
+           None
+      )
+
+  let lookup x e =
+    try
+      List.assoc x e
+    with Not_found ->
+      raise (UnboundIdentifier x)
+
+  let last = function
+    | [] -> None
+    | (x, v) :: e -> Some (x, v, e)
+
+  let print_binding memory (Id x, v) =
+    (* Identifiers starting with '_' are reserved for the compiler.
+       Their values must not be observable by users. *)
+    if x.[0] = '_' then
+      ""
+    else
+      x ^ " = " ^ print_value memory v
+
+  let print memory env =
+    String.concat "\n" (
+      List.(filter (fun s -> s <> "") (map (print_binding memory) env))
+    )
+
+end
+
+type runtime = {
+    memory : value Memory.t;
+    environment : Environment.t;
+    functions   : (function_identifier * (formals * expression)) list;
+}
+
+type observable = {
+    new_environment : Environment.t;
+  }
+
+let initial_runtime () =
+  let bind_bool s b env = Environment.bind env (Id s) (VBool b) in
+  let bind_unit s env = Environment.bind env (Id s) VUnit in
+  {
+    memory = Memory.create (640 * 1024);
+    environment =
+      Environment.initial
+      |> bind_bool "true"  true
+      |> bind_bool "false" false
+      |> bind_unit "nothing";
+    functions  = [];
+  }
+
+let rec evaluate runtime ast =
+  let runtime = List.fold_left bind_function runtime ast in
+  let runtime' = List.fold_left declaration runtime ast in
+  (runtime', extract_observable runtime runtime')
+
+and bind_function runtime = function
+  | DefineValue _ ->
+    runtime
+
+  | DefineFunction (f, xs, e) ->
+    { runtime with
+      functions = (f, (xs, e)) :: runtime.functions
+    }
+
+  | ExternalFunction _ ->
+    runtime
+
+and declaration runtime = function
+  | DefineValue (i, e) ->
+    let v = expression runtime e in
+    { runtime with environment = Environment.bind runtime.environment i v }
+  | DefineFunction _ ->
+    runtime
+  | ExternalFunction _ ->
+    runtime
+
+and arith_operator_of_symbol = function
+  | "`+`" -> Mint.add
+  | "`-`" -> Mint.sub
+  | "`/`" -> Mint.div
+  | "`*`" -> Mint.mul
+  | _ -> assert false
+
+and cmp_operator_of_symbol = function
+  | "`<?`" -> ( < )
+  | "`>?`" -> ( > )
+  | "`<=?`" -> ( <= )
+  | "`>=?`" -> ( >= )
+  | "`=?`" -> ( = )
+  | _ -> assert false
+
+and boolean_operator_of_symbol = function
+  | "`&&`" -> ( && )
+  | "`||`" -> ( || )
+  | _ -> assert false
+
+and evaluation_of_binary_symbol environment = function
+  | ("`+`" | "`-`" | "`*`" | "`/`") as s ->
+    arith_binop environment (arith_operator_of_symbol s)
+  | ("`<?`" | "`>?`" | "`<=?`" | "`>=?`" | "`=?`") as s ->
+    arith_cmpop environment (cmp_operator_of_symbol s)
+  | _ -> assert false
+
+and is_binary_primitive = function
+  | "`+`" | "`-`" | "`*`" | "`/`" | "`<?`"
+  | "`>?`" | "`<=?`" | "`>=?`" | "`=?`"
+  | "`&&`" | "`||`" -> true
+  | _ -> false
+
+and expression runtime = function
+  | Literal l ->
+    literal l
+
+  | Variable (Id "true") ->
+     VBool true
+
+  | Variable (Id "false") ->
+     VBool false
+
+  | Variable x ->
+    Environment.lookup x runtime.environment
+
+  | While (cond, e) ->
+     let rec loop () =
+       match expression runtime cond with
+       | VBool true ->
+          ignore (expression runtime e);
+          loop ()
+       | VBool false ->
+          ()
+       | _ ->
+          assert false (* By typing. *)
+     in
+     loop ();
+     VUnit
+
+  | Switch (e, bs, default) ->
+    begin match value_as_int (expression runtime e) with
+      | None -> error [] "Switch on integers only."
+      | Some i ->
+        let i = Mint.to_int i in
+        if i < Array.length bs && bs.(i) <> None then
+          match bs.(i) with
+          | None -> assert false (* By condition. *)
+          | Some t -> expression runtime t
+        else match default with
+          | Some t -> expression runtime t
+          | None -> error [] "No default case in switch."
+    end
+
+  | IfThenElse (c, t, f) ->
+    begin match value_as_bool (expression runtime c) with
+      | Some true -> expression runtime t
+      | Some false -> expression runtime f
+      | None -> error [] "Condition is not a boolean."
+    end
+
+  | Define (x, ex, e) ->
+    let v = expression runtime ex in
+    let runtime = { runtime with
+      environment = Environment.bind runtime.environment x v
+    }
+    in
+    expression runtime e
+
+  | FunCall (FunId "allocate_block", [size]) ->
+    begin match value_as_int (expression runtime size) with
+      | Some size ->
+        let a = Memory.allocate runtime.memory size VUnit in
+        VAddress a
+      | None ->
+        error [] "A block size should be an integer."
+    end
+
+  | (FunCall (FunId "read_block", [location; index])) as e ->
+    begin match
+        (value_as_address (expression runtime location),
+         value_as_int (expression runtime index))
+      with
+        | Some location, Some index ->
+           let block = Memory.dereference runtime.memory location in
+           Memory.read block index
+        | None, _ ->
+          error [] (Printf.sprintf "Expecting a block while evaluating %s" (FopixPrettyPrinter.(to_string expression e)))
+        | _, None ->
+          error [] "Expecting an integer."
+    end
+
+  | FunCall (FunId "equal_string", [e1; e2]) ->
+     begin match expression runtime e1, expression runtime e2 with
+     | VString s1, VString s2 -> VBool (String.compare s1 s2 = 0)
+     | _ -> assert false (* By typing. *)
+     end
+
+  | FunCall (FunId "equal_char", [e1; e2]) ->
+     begin match expression runtime e1, expression runtime e2 with
+     | VChar s1, VChar s2 -> VBool (Char.compare s1 s2 = 0)
+     | _ -> assert false (* By typing. *)
+     end
+
+  | FunCall (FunId ("observe_int" | "print_int"), [e]) ->
+     begin match expression runtime e with
+     | VInt x ->
+        ignore (print_string (Mint.to_string x));
+        VUnit
+     | _ -> assert false (* By typing. *)
+     end
+
+  | FunCall (FunId "print_string", [e]) ->
+     begin match expression runtime e with
+     | VString s -> print_string s
+     | _ -> assert false (* By typing. *)
+     end
+
+  | FunCall (FunId "write_block", [location; index; e]) ->
+    begin match
+        (value_as_address (expression runtime location),
+         value_as_int (expression runtime index))
+      with
+        | Some location, Some index ->
+          let v = expression runtime e in
+          let block = Memory.dereference runtime.memory location in
+          Memory.write block index v;
+          VUnit
+        | None, _ ->
+          error [] "Expecting a block."
+        | _, None ->
+          error [] "Expecting an integer."
+    end
+
+  | FunCall (FunId (("`&&`" | "`||`") as binop), [e1; e2]) ->
+     begin match expression runtime e1, binop with
+     | VBool true, "`&&`" | VBool false, "`||`" -> expression runtime e2
+     | VBool false, "`&&`" -> VBool false
+     | VBool true, "`||`" -> VBool true
+     | _, _ -> assert false (* By typing. *)
+     end
+
+  | FunCall (FunId s, [e1; e2]) when is_binary_primitive s ->
+    evaluation_of_binary_symbol runtime s e1 e2
+
+  | FunCall (f, arguments) ->
+    let vs = List.map (expression runtime) arguments in
+    let (formals, body) = try
+        List.assoc f runtime.functions
+      with Not_found ->
+        let FunId f = f in
+        error [] (Printf.sprintf "Unbound function `%s'." f)
+    in
+    let runtime =
+      { runtime with
+        environment =
+          Environment.(List.fold_left2 bind runtime.environment formals vs)
+      }
+    in
+    expression runtime body
+
+  | UnknownFunCall (e, arguments) ->
+    begin match expression runtime e with
+      | VFun f ->
+        expression runtime (FunCall (f, arguments))
+      | _ ->
+        assert false (* By construction. *)
+    end
+
+and binop
+: type a b.
+  _ -> string ->
+  a coercion -> b wrapper -> _ -> (a -> a -> b) -> _ -> _ -> value
+= fun m kind coerce wrap runtime op l r ->
+  let lv = expression runtime l
+  and rv = expression runtime r in
+  match coerce lv, coerce rv with
+    | Some li, Some ri ->
+      wrap (op li ri)
+    | _, _ ->
+      error [] (Printf.sprintf "Invalid %s binary operation between %s and %s."
+                  kind (print_value m lv) (print_value m rv))
+
+and arith_binop env =
+  binop env.memory "arithmetic" value_as_int int_as_value env
+and arith_cmpop env =
+  binop env.memory "comparison" value_as_int bool_as_value env
+and boolean_binop env =
+  binop env.memory "boolean" value_as_bool bool_as_value env
+
+and literal = function
+  | LInt x -> VInt x
+  | LString s -> VString s
+  | LChar c -> VChar c
+  | LFun f -> VFun f
+
+and print_string s =
+  output_string stdout s;
+  flush stdout;
+  VUnit
+
+and extract_observable runtime runtime' =
+  let rec substract new_environment env env' =
+    if env == env' then new_environment
+    else
+      match Environment.last env' with
+        | None -> assert false (* Absurd. *)
+        | Some (x, v, env') ->
+          let new_environment = Environment.bind new_environment x v in
+          substract new_environment env env'
+  in
+  {
+    new_environment =
+      substract Environment.initial runtime.environment runtime'.environment
+  }
+
+let print_observable runtime observation =
+  Environment.print runtime.memory observation.new_environment

flap/src/fopix/fopixLexer.mll

@@ -0,0 +1,111 @@
+{ (* Emacs, be a -*- tuareg -*- to open this file. *)
+  open Lexing
+  open Error
+  open Position
+  open FopixParser
+
+  let next_line_and f lexbuf  =
+    Lexing.new_line lexbuf;
+    f lexbuf
+
+  let error lexbuf =
+    error "during lexing" (lex_join lexbuf.lex_start_p lexbuf.lex_curr_p)
+
+}
+
+let newline = ('\010' | '\013' | "\013\010")
+
+let blank   = [' ' '\009' '\012']
+
+let digit = ['0'-'9']
+
+let lowercase_alpha = ['a'-'z' '_']
+
+let uppercase_alpha = ['A'-'Z' '_']
+
+let alpha = lowercase_alpha | uppercase_alpha
+
+let alphanum = alpha | digit | '_'
+
+let identifier = alpha alphanum*
+
+rule token = parse
+  (** Layout *)
+  | newline         { next_line_and token lexbuf }
+  | blank+          { token lexbuf               }
+  | "/*"            { comment 1 lexbuf           }
+
+  (** Keywords *)
+  | "val"           { VAL  }
+  | "in"            { IN   }
+  | "def"           { DEF  }
+  | "end"           { END  }
+  | "if"            { IF   }
+  | "then"          { THEN }
+  | "else"          { ELSE }
+  | "eval"          { EVAL }
+  | "external"      { EXTERNAL }
+  | "switch"	    { SWITCH }
+  | "call"          { CALL }
+  | "with"          { WITH }
+  | "orelse"	    { ORELSE }
+  | "while"         { WHILE }
+  | "do"            { DO }
+
+  (** Literals *)
+  | digit+ as d     { INT (Mint.of_string d) }
+
+  (** Identifiers *)
+  | identifier as i { ID i }
+
+  (** Infix operators *)
+  | "="             { EQUAL     }
+  | ":"             { COLON     }
+  | "+"             { PLUS      }
+  | "*"             { STAR      }
+  | "/"             { SLASH     }
+  | "-"             { MINUS     }
+  | "=?"            { EQ        }
+  | ">?"            { GT        }
+  | ">=?"           { GTE       }
+  | "<?"            { LT        }
+  | "<=?"           { LTE       }
+  | ":="            { ASSIGNS   }
+  | "&&"            { LAND      }
+  | "&"             { UPPERSAND }
+  | "||"            { LOR       }
+  | "|"		    { PIPE      }
+
+  (** Punctuation *)
+  | ","             { COMMA     }
+  | ";"             { SEMICOLON }
+  | "("             { LPAREN    }
+  | ")"             { RPAREN    }
+  | "["             { LBRACKET  }
+  | "]"             { RBRACKET  }
+  | "."             { END       }
+  | "!"             { BANG      }
+  | eof             { EOF       }
+
+  (** Lexing error. *)
+  | _               { error lexbuf "unexpected character." }
+
+and comment level = parse
+  | "*/" {
+    if level = 1 then
+      token lexbuf
+    else
+      comment (pred level) lexbuf
+  }
+  | "/*" {
+    comment (succ level) lexbuf
+  }
+  | eof {
+    error lexbuf "unterminated comment."
+  }
+  | newline {
+    next_line_and (comment level) lexbuf
+  }
+  | _ {
+    comment level lexbuf
+  }

flap/src/fopix/fopixParser.mly

@@ -0,0 +1,164 @@
+%{ (* Emacs, be a -*- tuareg -*- to open this file. *)
+
+  open FopixAST
+
+%}
+
+%token VAL DEF IN END IF THEN ELSE EVAL LAND LOR EXTERNAL SWITCH DO WHILE WITH
+%token PLUS MINUS STAR SLASH GT GTE LT LTE EQUAL EQ UPPERSAND ORELSE CALL COLON
+%token LPAREN RPAREN LBRACKET RBRACKET ASSIGNS COMMA SEMICOLON EOF PIPE BANG
+%token<Mint.t> INT
+%token<string> ID
+
+%right SEMICOLON
+%nonassoc ASSIGNS
+%left LOR
+%left LAND
+%nonassoc GT GTE LT LTE EQ
+%left PLUS MINUS
+%left STAR SLASH
+%nonassoc LBRACKET
+
+%start<FopixAST.t> program
+
+%%
+
+program: ds=definition* EOF
+{
+  ds
+}
+| error {
+  let pos = Position.lex_join $startpos $endpos in
+  Error.error "parsing" pos "Syntax error."
+}
+
+definition: VAL x=located(identifier) EQUAL e=located(expression)
+{
+  DefineValue (x, e)
+}
+| DEF f=located(function_identifier)
+  LPAREN xs=separated_list(COMMA, identifier) RPAREN
+  EQUAL e=located(expression)
+{
+  DefineFunction (f, xs, e)
+}
+| EVAL e=located(expression)
+{
+  DefineValue (Id "_", e)
+}
+| EXTERNAL f=located(function_identifier) COLON n=INT
+{
+  ExternalFunction (f, Int64.to_int n)
+}
+
+expression:
+  l=literal
+{
+  Literal l
+}
+| x=identifier
+{
+  Variable x
+}
+| VAL x=located(identifier)
+  EQUAL
+    e1=located(expression)
+  SEMICOLON
+    e2=located(expression)
+{
+  Define (x, e1, e2)
+}
+| IF
+  c=located(expression)
+  THEN t=located(expression)
+  ELSE f=located(expression)
+  END
+{
+  IfThenElse (c, t, f)
+}
+| f=function_identifier
+  LPAREN es=separated_list(COMMA, located(expression)) RPAREN
+{
+  FunCall (f, es)
+}
+| l=located(expression) b=binop r=located(expression) {
+  FunCall (FunId b, [l; r])
+}
+| CALL f=located(expression) WITH LPAREN es=separated_list(COMMA, located(expression)) RPAREN
+{
+  UnknownFunCall (f, es)
+}
+| e=located(expression) LBRACKET i=located(expression) RBRACKET {
+  FunCall (FunId "read_block", [e; i])
+}
+| e=located(expression)
+  LBRACKET i=located(expression) RBRACKET
+  ASSIGNS v=located(expression) {
+  FunCall (FunId "write_block", [e; i; v])
+}
+| e1=located(expression) SEMICOLON e2=located(expression) {
+  Define (Id "_", e1, e2)
+}
+| WHILE e=expression DO b=expression END
+{
+  While (e, b)
+}
+| SWITCH e=expression IN
+  bs=separated_list(PIPE, optional_case)
+  ORELSE d=expression
+  END
+{
+  Switch (e, Array.of_list bs, Some d)
+}
+| SWITCH e=expression IN bs=separated_list(PIPE, optional_case) END
+{
+  Switch (e, Array.of_list bs, None)
+}
+| LPAREN e=expression RPAREN {
+  e
+}
+
+optional_case:
+  BANG
+{
+  None
+}
+| e=expression
+{
+  Some e
+}
+
+%inline binop:
+  PLUS  { "`+`"  }
+| MINUS { "`-`"  }
+| STAR  { "`*`"  }
+| SLASH { "`/`"  }
+| GT    { "`>?`"  }
+| GTE   { "`>=?`" }
+| LT    { "`<?`"  }
+| LTE   { "`<=?`" }
+| EQ    { "`=?`"  }
+| LAND  { "`&&`" }
+| LOR   { "`||`" }
+
+%inline literal:
+  x=INT
+{
+  LInt x
+}
+| UPPERSAND f=function_identifier
+{
+  LFun f
+}
+
+%inline identifier: x=ID {
+  Id x
+}
+
+%inline function_identifier: x=ID {
+  FunId x
+}
+
+%inline located(X): x=X {
+  x
+}

flap/src/fopix/fopixPrettyPrinter.ml

@@ -0,0 +1,131 @@
+open PPrint
+
+open FopixAST
+
+let ( ++ ) x y =
+  x ^^ break 1 ^^ y
+
+let located f x = f (Position.value x)
+
+let rec program p =
+  separate_map hardline definition p
+
+and definition = function
+  | DefineValue (x, e) ->
+    nest 2 (
+      group (string "val" ++ identifier x ++ string "=")
+      ++ group (expression e)
+    )
+
+  | DefineFunction (f, xs, e) ->
+    nest 2 (
+      group (string "def" ++ function_identifier f
+             ++ PPrint.OCaml.tuple (List.map identifier xs)
+             ++ string "=")
+      ++ group (expression e)
+    )
+
+  | ExternalFunction (f, n) ->
+    group (string "external" ++ function_identifier f
+           ++ string ":" ++ string (string_of_int n))
+
+and identifier (Id x) =
+  string x
+
+and function_identifier (FunId x) =
+  string x
+
+and expression = function
+  | Literal l ->
+    literal l
+  | Variable x ->
+    identifier x
+  | FunCall (FunId f, es) ->
+    funcall f es
+  | While (cond, e) ->
+     nest 2 (
+         group (string "while"
+                ++ group (expression cond)
+                ++ string "do"
+                ++ group (expression e)
+                ++ string "done")
+       )
+  | IfThenElse (c, t, f) ->
+    nest 2 (
+      group (string "if"
+             ++ group (expression c)
+             ++ string "then"
+      )
+      ++ group (expression t))
+    ++ nest 2 (
+      group (string "else"
+                ++ group (expression f))
+         )
+    ++ string "end"
+  | Define (x, e1, e2) ->
+    nest 2 (
+      group (
+        group (string "val"
+               ++ identifier x
+               ++ string "="
+        )
+        ++ group (expression e1)
+        ++ string ";"
+      )
+    )
+    ++ group (expression e2)
+  | UnknownFunCall (e, es) ->
+    string "call" ++ parens (expression e) ++ string "with"
+    ++ PPrint.OCaml.tuple (List.map expression es)
+  | Switch (e, bs, default) ->
+    group (string "switch" ++ expression e ++ string "in")
+    ++ group (
+      branches bs
+    ) ^^ begin match default with
+      | None -> empty
+      | Some t -> break 1 ^^ group (string "orelse" ++ expression t)
+    end ++ string "end"
+
+and branches bs =
+  let bs = List.mapi (fun i x -> (i, x)) (Array.to_list bs) in
+  separate_map (string "|" ^^ break 1) (fun (i, t) ->
+      group (
+          string (string_of_int i) ^^  match t with
+                                     | None -> string "!"
+                                     | Some t -> expression t)
+    ) bs
+
+and funcall f es =
+  match f, es with
+    | ("`=?`" | "`*`" | "`/`" | "`+`" | "`-`" | "`%`"
+       | "`<?`" | "`>?`" | "`<=?`" | "`>=?`"),
+      [ lhs; rhs ] ->
+      let op = String.(sub f 1 (length f - 2)) in
+      group (parens (expression lhs ++ string op ++ expression rhs))
+    | _, _ ->
+      let ts = PPrint.OCaml.tuple (List.map expression es) in
+      group (string f ++ ts)
+
+and literal = function
+  | LInt x ->
+    int x
+  | LChar c ->
+    char c
+  | LString s ->
+    string_literal s
+  | LFun (FunId f) ->
+    string ("&" ^ f)
+
+and char c =
+  group (string "'" ^^ string (Char.escaped c) ^^ string "'")
+
+and string_literal s =
+  group (string "\"" ^^ string (String.escaped s) ^^ string "\"")
+
+and int x =
+  string (Mint.to_string x)
+
+let to_string f x =
+  let b = Buffer.create 13 in
+  ToBuffer.pretty 0.7 80 b (f x);
+  Buffer.contents b

flap/src/fopix/fopixTypechecker.ml

@@ -0,0 +1,7 @@
+type typing_environment = unit
+
+let initial_typing_environment () = ()
+
+let typecheck () _ = ()
+
+let print_typing_environment () = ""

flap/src/fopix/hobixToFopix.ml

@@ -0,0 +1,297 @@
+(** This module implements a compiler from Hobix to Fopix. *)
+
+(** As in any module that implements {!Compilers.Compiler}, the source
+    language and the target language must be specified. *)
+
+module Source = Hobix
+module S = Source.AST
+module Target = Fopix
+module T = Target.AST
+
+(**
+
+   The translation from Hobix to Fopix turns anonymous
+   lambda-abstractions into toplevel functions and applications into
+   function calls. In other words, it translates a high-level language
+   (like OCaml) into a first order language (like C).
+
+   To do so, we follow the closure conversion technique.
+
+   The idea is to make explicit the construction of closures, which
+   represent functions as first-class objects. A closure is a block
+   that contains a code pointer to a toplevel function [f] followed by all
+   the values needed to execute the body of [f]. For instance, consider
+   the following OCaml code:
+
+   let f =
+     let x = 6 * 7 in
+     let z = x + 1 in
+     fun y -> x + y * z
+
+   The values needed to execute the function "fun y -> x + y * z" are
+   its free variables "x" and "z". The same program with explicit usage
+   of closure can be written like this:
+
+   let g y env = env[1] + y * env[2]
+   let f =
+      let x = 6 * 7 in
+      let z = x + 1 in
+      [| g; x; z |]
+
+   (in an imaginary OCaml in which arrays are untyped.)
+
+   Once closures are explicited, there are no more anonymous functions!
+
+   But, wait, how to we call such a function? Let us see that on an
+   example:
+
+   let f = ... (* As in the previous example *)
+   let u = f 0
+
+   The application "f 0" must be turned into an expression in which
+   "f" is a closure and the call to "f" is replaced to a call to "g"
+   with the proper arguments. The argument "y" of "g" is known from
+   the application: it is "0". Now, where is "env"? Easy! It is the
+   closure itself! We get:
+
+   let g y env = env[1] + y * env[2]
+   let f =
+      let x = 6 * 7 in
+      let z = x + 1 in
+      [| g; x; z |]
+   let u = f[0] 0 f
+
+   (Remark: Did you notice that this form of "auto-application" is
+   very similar to the way "this" is defined in object-oriented
+   programming languages?)
+
+*)
+
+(**
+   Helpers functions.
+*)
+
+let error pos msg =
+  Error.error "compilation" pos msg
+
+let make_fresh_variable =
+  let r = ref 0 in
+  fun () -> incr r; T.Id (Printf.sprintf "_%d" !r)
+
+
+let make_fresh_function_identifier =
+  let r = ref 0 in
+  fun () -> incr r; T.FunId (Printf.sprintf "_%d" !r)
+
+let define e f =
+  let x = make_fresh_variable () in
+  T.Define (x, e, f x)
+
+let rec defines ds e =
+  match ds with
+    | [] ->
+      e
+    | (x, d) :: ds ->
+      T.Define (x, d, defines ds e)
+
+let seq a b =
+  define a (fun _ -> b)
+
+let rec seqs = function
+  | [] -> assert false
+  | [x] -> x
+  | x :: xs -> seq x (seqs xs)
+
+let allocate_block e =
+  T.(FunCall (FunId "allocate_block", [e]))
+
+let write_block e i v =
+  T.(FunCall (FunId "write_block", [e; i; v]))
+
+let read_block e i =
+  T.(FunCall (FunId "read_block", [e; i]))
+
+let lint i =
+  T.(Literal (LInt (Int64.of_int i)))
+
+
+(** [free_variables e] returns the list of free variables that
+     occur in [e].*)
+let free_variables =
+  let module M =
+    Set.Make (struct type t = S.identifier let compare = compare end)
+  in
+  let rec unions f = function
+    | [] -> M.empty
+    | [s] -> f s
+    | s :: xs -> M.union (f s) (unions f xs)
+  in
+  let rec fvs = function
+    | S.Literal _ ->
+       M.empty
+    | S.Variable x ->
+       M.singleton x
+    | S.While (cond, e) ->
+       failwith "Students! This is your job!"
+    | S.Define (vd, a) ->
+       failwith "Students! This is your job!"
+    | S.ReadBlock (a, b) ->
+       unions fvs [a; b]
+    | S.Apply (a, b) ->
+       unions fvs (a :: b)
+    | S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) ->
+       unions fvs [a; b; c]
+    | S.AllocateBlock a ->
+       fvs a
+    | S.Fun (xs, e) ->
+       failwith "Students! This is your job!"
+    | S.Switch (a, b, c) ->
+       let c = match c with None -> [] | Some c -> [c] in
+       unions fvs (a :: ExtStd.Array.present_to_list b @ c)
+  in
+  fun e -> M.elements (fvs e)
+
+(**
+
+    A closure compilation environment relates an identifier to the way
+    it is accessed in the compiled version of the function's
+    body.
+
+    Indeed, consider the following example. Imagine that the following
+    function is to be compiled:
+
+    fun x -> x + y
+
+    In that case, the closure compilation environment will contain:
+
+    x -> x
+    y -> "the code that extract the value of y from the closure environment"
+
+    Indeed, "x" is a local variable that can be accessed directly in
+    the compiled version of this function's body whereas "y" is a free
+    variable whose value must be retrieved from the closure's
+    environment.
+
+*)
+type environment = {
+    vars : (HobixAST.identifier, FopixAST.expression) Dict.t;
+    externals : (HobixAST.identifier, int) Dict.t;
+}
+
+let initial_environment () =
+  { vars = Dict.empty; externals = Dict.empty }
+
+let bind_external id n env =
+  { env with externals = Dict.insert id n env.externals }
+
+let is_external id env =
+  Dict.lookup id env.externals <> None
+
+let reset_vars env =
+   { env with vars = Dict.empty }
+
+(** Precondition: [is_external id env = true]. *)
+let arity_of_external id env =
+  match Dict.lookup id env.externals with
+    | Some n -> n
+    | None -> assert false (* By is_external. *)
+
+
+(** [translate p env] turns an Hobix program [p] into a Fopix program
+    using [env] to retrieve contextual information. *)
+let translate (p : S.t) env =
+  let rec program env defs =
+    let env, defs = ExtStd.List.foldmap definition env defs in
+    (List.flatten defs, env)
+  and definition env = function
+    | S.DeclareExtern (id, n) ->
+       let env = bind_external id n env in
+       (env, [T.ExternalFunction (function_identifier id, n)])
+    | S.DefineValue vd ->
+       (env, value_definition env vd)
+  and value_definition env = function
+    | S.SimpleValue (x, e) ->
+       let fs, e = expression (reset_vars env) e in
+       fs @ [T.DefineValue (identifier x, e)]
+    | S.RecFunctions fdefs ->
+       let fs, defs = define_recursive_functions fdefs in
+       fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs
+
+  and define_recursive_functions rdefs =
+       failwith "Students! This is your job!"
+  and expression env = function
+    | S.Literal l ->
+      [], T.Literal (literal l)
+    | S.While (cond, e) ->
+       let cfs, cond = expression env cond in
+       let efs, e = expression env e in
+       cfs @ efs, T.While (cond, e)
+    | S.Variable x ->
+      let xc =
+        match Dict.lookup x env.vars with
+          | None -> T.Variable (identifier x)
+          | Some e -> e
+      in
+      ([], xc)
+    | S.Define (vdef, a) ->
+         failwith "Students! This is your job!"
+    | S.Apply (a, bs) ->
+         failwith "Students! This is your job!"
+    | S.IfThenElse (a, b, c) ->
+      let afs, a = expression env a in
+      let bfs, b = expression env b in
+      let cfs, c = expression env c in
+      afs @ bfs @ cfs, T.IfThenElse (a, b, c)
+
+    | S.Fun (x, e) ->
+         failwith "Students! This is your job!"
+    | S.AllocateBlock a ->
+      let afs, a = expression env a in
+      (afs, allocate_block a)
+    | S.WriteBlock (a, b, c) ->
+      let afs, a = expression env a in
+      let bfs, b = expression env b in
+      let cfs, c = expression env c in
+      afs @ bfs @ cfs,
+      T.FunCall (T.FunId "write_block", [a; b; c])
+    | S.ReadBlock (a, b) ->
+      let afs, a = expression env a in
+      let bfs, b = expression env b in
+      afs @ bfs,
+      T.FunCall (T.FunId "read_block", [a; b])
+    | S.Switch (a, bs, default) ->
+      let afs, a = expression env a in
+      let bsfs, bs =
+        ExtStd.List.foldmap (fun bs t ->
+                    match ExtStd.Option.map (expression env) t with
+                    | None -> (bs, None)
+                    | Some (bs', t') -> (bs @ bs', Some t')
+                  ) [] (Array.to_list bs)
+      in
+      let dfs, default = match default with
+        | None -> [], None
+        | Some e -> let bs, e = expression env e in bs, Some e
+      in
+      afs @ bsfs @ dfs,
+      T.Switch (a, Array.of_list bs, default)
+
+
+  and expressions env = function
+    | [] ->
+       [], []
+    | e :: es ->
+       let efs, es = expressions env es in
+       let fs, e = expression env e in
+       fs @ efs, e :: es
+
+  and literal = function
+    | S.LInt x -> T.LInt x
+    | S.LString s -> T.LString s
+    | S.LChar c -> T.LChar c
+
+  and identifier (S.Id x) = T.Id x
+
+  and function_identifier (S.Id x) = T.FunId x
+
+  in
+  program env p

flap/src/hobix/HobixParser.mly

@@ -0,0 +1,21 @@
+%{
+
+  open HopixAST
+
+
+%}
+
+%token EOF
+%token<Int32.t> INT
+
+
+%start<HopixAST.t> program
+
+%%
+
+program: EOF
+{
+   []
+}
+
+

flap/src/hobix/hobix.ml

@@ -0,0 +1,35 @@
+(** The hobix programming language. *)
+
+let name = "hobix"
+
+module AST = HobixAST
+
+type ast = HobixAST.t
+
+let executable_format = false
+
+let parse lexer_init input =
+  SyntacticAnalysis.process
+    ~lexer_init
+    ~lexer_fun:HobixLexer.token
+    ~parser_fun:HobixParser.program
+    ~input
+
+let parse_filename filename =
+  parse Lexing.from_channel (open_in filename)
+
+let extension =
+  ".hobix"
+
+let parse_string s =
+  parse Lexing.from_string s
+
+let print_ast ast =
+  HobixPrettyPrinter.(to_string program ast)
+
+let print_expression e =
+  HobixPrettyPrinter.(to_string expression e)
+
+include HobixInterpreter
+
+include HobixTypechecker

flap/src/hobix/hobixAST.ml

@@ -0,0 +1,51 @@
+(** The abstract syntax tree for hobix programs. *)
+
+(** A program is a list of definitions. *)
+type program = definition list
+
+and definition =
+  (** A toplevel declaration for an external value of arity n. *)
+  | DeclareExtern of identifier * int
+  (** A toplevel definition for a value. *)
+  | DefineValue of value_definition
+
+and value_definition =
+  (** A simple (non recursive) value definition. *)
+  | SimpleValue of identifier * expression
+  (** A definition for mutually recursive functions. *)
+  | RecFunctions of (identifier * expression) list
+
+and expression =
+  (** A literal is a constant written "as is". *)
+  | Literal of literal
+  (** A variable identifies a value. *)
+  | Variable of identifier
+  (** A local definition [val x₁ := e₁ ; e₂]. *)
+  | Define of value_definition * expression
+  (** A function application [a (b_1, ..., b_N)]. *)
+  | Apply of expression * expression list
+  (** A conditional expression of the form [if ... then ... else ... fi]. *)
+  | IfThenElse of expression * expression * expression
+  (** An anonymous function [ \ x => e ]. *)
+  | Fun of identifier list * expression
+  (** Allocate a block of size n [ alloc_block n ]. *)
+  | AllocateBlock of expression
+  (** Write a value v at offset i of block b [ alloc_write b i v ]. *)
+  | WriteBlock of expression * expression * expression
+  (** Read a value at offset i of block b [ alloc_read b i ]. *)
+  | ReadBlock of expression * expression
+  (** Jump to the i-th branch if i < |bs|, jump to default otherwise
+      if it is present. [switch i in bs orelse default] *)
+  | Switch of expression * expression option array * expression option
+  (** While-loop *)
+  | While of expression * expression
+
+and literal =
+  | LInt    of Int64.t
+  | LString of string
+  | LChar   of char
+
+and identifier =
+  | Id of string
+
+and t = program

flap/src/hobix/hobixInitialization.ml

@@ -0,0 +1,4 @@
+let initialize () =
+  Languages.register (module Hobix);
+  Compilers.register (module HopixToHobix);
+  Compilers.register (module Compilers.Identity (Hobix))

flap/src/hobix/hobixInterpreter.ml

@@ -0,0 +1,418 @@
+open Error
+open HobixAST
+
+(** [error pos msg] reports runtime error messages. *)
+let error positions msg =
+  errorN "execution" positions msg
+
+(** Every expression of hobix evaluates into a [value]. *)
+type 'e gvalue =
+  | VInt          of Int64.t
+  | VChar         of char
+  | VString       of string
+  | VUnit
+  | VAddress      of Memory.location
+  | VPrimitive    of string * ('e gvalue list -> 'e gvalue)
+  | VBool         of bool
+  | VFun          of identifier list * expression * 'e
+
+type ('a, 'e) coercion = 'e gvalue -> 'a option
+let value_as_int      = function VInt x -> Some x | _ -> None
+let value_as_bool     = function VBool x -> Some x | _ -> None
+let value_as_char     = function VChar c -> Some c | _ -> None
+let value_as_addr     = function VAddress a -> Some a | _ -> None
+
+let ( >>= ) m f =
+  match m with
+    | None -> None
+    | Some x -> f x
+
+let return x =
+  Some x
+
+let trust_me = function
+  | None -> assert false (* Impossible. *)
+  | Some x -> x
+
+type ('a, 'e) wrapper = 'a -> 'e gvalue
+let int_as_value x  = VInt x
+let bool_as_value x = VBool x
+
+let primitive name ?(error = fun () -> assert false) coercion wrapper f =
+  VPrimitive (name, fun x ->
+    match coercion x with
+      | None -> error ()
+      | Some x -> wrapper (f x)
+  )
+
+let print_value m v =
+  let max_depth = 5 in
+
+  let rec print_value d v =
+    if d >= max_depth then "..." else
+      match v with
+        | VInt x ->
+          Int64.to_string x
+        | VBool true ->
+          "true"
+        | VBool false ->
+          "false"
+        | VChar c ->
+          "'" ^ Char.escaped c ^ "'"
+        | VString s ->
+          "\"" ^ String.escaped s ^ "\""
+        | VUnit ->
+          "()"
+        | VAddress a ->
+          print_block m d a
+        | VFun _ ->
+          "<fun>"
+        | VPrimitive (s, _) ->
+          Printf.sprintf "<primitive: %s>" s
+  and print_block m d a =
+    let b = Memory.dereference m a in
+    let vs = Array.to_list (Memory.array_of_block b) in
+    "[ " ^ String.concat "; " (List.map (print_value d) vs) ^ " ]"
+  in
+  print_value 0 v
+
+module Environment : sig
+  type t
+  val empty : t
+  val bind    : t -> identifier -> t gvalue -> t
+  val update  : identifier -> t -> t gvalue -> unit
+  exception UnboundIdentifier of identifier
+  val lookup  : identifier -> t -> t gvalue
+  val last    : t -> (identifier * t gvalue * t) option
+  val print   : t gvalue Memory.t -> t -> string
+end = struct
+
+  type t =
+    | EEmpty
+    | EBind of identifier * t gvalue ref * t
+
+  let empty = EEmpty
+
+  let bind e x v =
+    EBind (x, ref v, e)
+
+  exception UnboundIdentifier of identifier
+
+  let lookup' x =
+    let rec aux = function
+      | EEmpty -> raise (UnboundIdentifier x)
+      | EBind (y, v, e) ->
+        if x = y then v else aux e
+    in
+    aux
+
+  let lookup x e = !(lookup' x e)
+
+  let update x e v =
+    lookup' x e := v
+
+  let last = function
+    | EBind (x, v, e) -> Some (x, !v, e)
+    | EEmpty -> None
+
+  let print_binding m (Id x, v) =
+    x ^ " = " ^ print_value m !v
+
+  let print m e =
+    let b = Buffer.create 13 in
+    let push x v = Buffer.add_string b (print_binding m (x, v)) in
+    let rec aux = function
+      | EEmpty -> Buffer.contents b
+      | EBind (x, v, EEmpty) -> push x v; aux EEmpty
+      | EBind (x, v, e) -> push x v; Buffer.add_string b "\n"; aux e
+    in
+    aux e
+
+end
+
+type value = Environment.t gvalue
+
+type formals = identifier list
+
+type runtime = {
+  memory      : value Memory.t;
+  environment : Environment.t;
+}
+
+type observable = {
+  new_memory      : value Memory.t;
+  new_environment : Environment.t;
+}
+
+(** [primitives] is an environment that contains the implementation
+    of all primitives (+, <, ...). *)
+let primitives =
+  let intbin name out op =
+    VPrimitive (name, function [VInt x; VInt y] -> out (op x y)
+        | _ -> 
+           Printf.printf "%s\n" name;
+           assert false (* By typing. *)
+    )
+  in
+  let bind_all what l x =
+    List.fold_left (fun env (x, v) -> Environment.bind env (Id x) (what x v)) x l
+  in
+  (* Define arithmetic binary operators. *)
+  let binarith name =
+    intbin name (fun x -> VInt x) in
+  let binarithops = Int64.(
+    [ ("`+`", add); ("`-`", sub); ("`*`", mul); ("`/`", div) ]
+  ) in
+  (* Define arithmetic comparison operators. *)
+  let cmparith name = intbin name (fun x -> VBool x) in
+  let cmparithops =
+    [ ("`=?`", ( = )); ("`<?`", ( < )); ("`>?`", ( > ));
+      ("`>=?`", ( >= )); ("`<=?`", ( <= )) ]
+  in
+  let boolbin name out op =
+    VPrimitive (name, function [VBool x; VBool y] -> out (op x y)
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let boolarith name = boolbin name (fun x -> VBool x) in
+  let boolarithops =
+    [ ("`||`", ( || )); ("`&&`", ( && )) ]
+  in
+  let print s =
+    output_string stdout s;
+    flush stdout;
+    VUnit
+  in
+  let print_int =
+    VPrimitive  ("print_int", function
+      | [ VInt x ] -> print (Int64.to_string x)
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let print_string =
+    VPrimitive  ("print_string", function
+      | [ VString x ] -> print x
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let equal_string =
+    VPrimitive  ("equal_string", function
+      | [ VString x; VString y ] -> VBool (String.compare x y = 0)
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let equal_char =
+    VPrimitive  ("equal_char", function
+      | [ VChar x; VChar y ] -> VBool (Char.compare x y = 0)
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let bind' x w env = Environment.bind env (Id x) w in
+  Environment.empty
+  |> bind_all binarith binarithops
+  |> bind_all cmparith cmparithops
+  |> bind_all boolarith boolarithops
+  |> bind' "print_int" print_int
+  |> bind' "print_string" print_string
+  |> bind' "equal_string" equal_string
+  |> bind' "equal_char"   equal_char
+  |> bind' "true"         (VBool true)
+  |> bind' "false"        (VBool false)
+  |> bind' "nothing"      VUnit
+
+let initial_runtime () = {
+  memory      = Memory.create (640 * 1024);
+  environment = primitives;
+}
+
+let rec evaluate runtime ast =
+  try
+    let runtime' = List.fold_left definition runtime ast in
+    (runtime', extract_observable runtime runtime')
+  with Environment.UnboundIdentifier (Id x) ->
+    Error.error "interpretation" Position.dummy (Printf.sprintf "`%s' is unbound." x)
+
+(* [definition pos runtime d] evaluates the new definition [d]
+   into a new runtime [runtime']. In the specification, this
+   is the judgment:
+
+                        E, M ⊢ dᵥ ⇒ E', M'
+
+*)
+and definition runtime d =
+  match d with
+  | DefineValue vd ->
+     value_definition runtime vd
+
+  | DeclareExtern _ ->
+     runtime
+
+and value_definition runtime = function
+  | SimpleValue (x, e) ->
+     let v = expression runtime.environment runtime.memory e in
+     { runtime with environment =
+                      bind_identifier runtime.environment x v
+     }
+  | RecFunctions rdefs ->
+     { runtime with environment =
+                      define_recvalues runtime.environment runtime.memory rdefs
+     }
+
+and define_recvalues environment memory rdefs =
+  let environment =
+    List.fold_left (fun env (x, _) ->
+        bind_identifier env x VUnit) environment rdefs
+  in
+  let vs = expressions environment memory (snd (List.split rdefs)) in
+  List.iter2 (fun (x, _) v ->
+    Environment.update x environment v
+  ) rdefs vs;
+  environment
+
+(* [expression pos runtime e] evaluates into a value [v] if
+
+                          E, M ⊢ e ⇓ v, M'
+
+   and E = [runtime.environment], M = [runtime.memory].
+*)
+and expression environment memory = function
+  | Apply (a, b) ->
+    let vbs () = expressions environment memory b in
+    begin match expression environment memory a with
+    | VPrimitive ("`||", _) ->
+       begin match expression environment memory (List.nth b 0) with
+       | VBool true -> VBool true
+       | _ -> expression environment memory (List.nth b 1)
+       end
+    | VPrimitive ("`&&", _) ->
+       begin match expression environment memory (List.nth b 0) with
+       | VBool false -> VBool false
+       | _ -> expression environment memory (List.nth b 1)
+       end
+
+    | VPrimitive (_, f) ->
+       f (vbs ())
+
+    | VFun (xs, e, environment) ->
+       expression (List.fold_left2 bind_identifier environment xs (vbs ())) memory e
+
+    | _ ->
+       assert false (* By typing. *)
+    end
+
+  | While (c, e) ->
+    let rec aux () =
+      match expression environment memory c with
+        | VBool true ->
+          ignore (expression environment memory e);
+          aux ()
+        | VBool false ->
+          VUnit
+        | _ ->
+          assert false (* By typing. *)
+    in
+    aux ()
+
+  | Switch (e, branches, default) ->
+    begin match expression environment memory e with
+      | VInt i ->
+        let i = Int64.to_int i in
+        if i < 0 then assert false; (* By typing. *)
+        if i < Array.length branches && branches.(i) <> None then
+          match branches.(i) with
+          | None -> assert false (* By condition. *)
+          | Some t -> expression environment memory t
+        else begin match default with
+          | None -> assert false; (* By typing. *)
+          | Some t -> expression environment memory t
+        end
+      | _ -> assert false (* By typing. *)
+    end
+
+  | Fun (p, e) ->
+    VFun (p, e, environment)
+
+  | Literal l ->
+    literal l
+
+  | Variable x ->
+    Environment.lookup x environment
+
+  | Define (vd, e) ->
+    let runtime = value_definition { environment; memory } vd in
+    expression runtime.environment runtime.memory e
+
+  | IfThenElse (c, t, f) ->
+    let v = expression environment memory c in
+    begin match value_as_bool v with
+      | None -> assert false (* By typing. *)
+      | Some true -> expression environment memory t
+      | Some false -> expression environment memory f
+    end
+
+  | AllocateBlock e ->
+    begin match expression environment memory e with
+      | VInt x ->
+        let a = Memory.allocate memory x (VInt Int64.zero) in
+        VAddress a
+      | _ ->
+        assert false (* By typing. *)
+    end
+
+  | WriteBlock (b, i, v) ->
+    let bv = expression environment memory b in
+    (value_as_addr bv >>= fun a ->
+    let bi = expression environment memory i in
+    value_as_int bi >>= fun i ->
+    let bb = expression environment memory v in
+    let b = Memory.dereference memory a in
+    Memory.write b i bb;
+    return (VUnit)
+    ) |> trust_me (* By typing. *)
+
+  | ReadBlock (b, i) ->
+    let bv = expression environment memory b in
+    (value_as_addr bv >>= fun a ->
+     let bi = expression environment memory i in
+     value_as_int bi >>= fun i ->
+     let b = Memory.dereference memory a in
+     return (Memory.read b i)
+    ) |> trust_me (* By typing. *)
+
+and expressions environment memory es =
+  let rec aux vs = function
+    | [] ->
+      List.rev vs
+    | e :: es ->
+      let v = expression environment memory e in
+      aux (v :: vs) es
+  in
+  aux [] es
+
+and bind_identifier environment (x : identifier) v =
+  Environment.bind environment x v
+
+and literal = function
+  | LInt x -> VInt x
+  | LChar c -> VChar c
+  | LString s -> VString s
+
+and extract_observable runtime runtime' =
+  let rec substract new_environment env env' =
+    if env == env' then new_environment
+    else
+      match Environment.last env' with
+        | None -> assert false (* Absurd. *)
+        | Some (x, v, env') ->
+          let new_environment = Environment.bind new_environment x v in
+          substract new_environment env env'
+  in
+  {
+    new_environment =
+      substract Environment.empty runtime.environment runtime'.environment;
+    new_memory =
+      runtime'.memory
+  }
+
+let print_observable _ observation =
+  Environment.print observation.new_memory observation.new_environment

flap/src/hobix/hobixLexer.mll

@@ -0,0 +1,206 @@
+{
+  open Lexing
+  open Error
+  open Position
+  open HobixParser
+
+  let next_line_and f lexbuf  =
+    Lexing.new_line lexbuf;
+    f lexbuf
+
+  let error lexbuf =
+    error "during lexing" (lex_join lexbuf.lex_start_p lexbuf.lex_curr_p)
+
+  let string_buffer =
+    Buffer.create 13
+
+}
+
+let newline = ('\010' | '\013' | "\013\010")
+
+let blank   = [' ' '\009' '\012']
+
+let symbol = [ '+' '-' '*' '/' '<' '=' '>' '?' '&' ]
+
+let digit = ['0'-'9']
+
+let lowercase_alpha = ['a'-'z' '_']
+
+let uppercase_alpha = ['A'-'Z']
+
+let alpha = lowercase_alpha | uppercase_alpha
+
+let alphanum = alpha | digit | '_'
+
+let basic_identifier = lowercase_alpha alphanum*
+
+let prefix_alien_identifier = "`" (alpha | symbol | digit)+
+
+let infix_alien_identifier = "`" (alpha | symbol | digit)+ "`"
+
+let identifier = basic_identifier | prefix_alien_identifier | infix_alien_identifier
+
+let uidentifier = uppercase_alpha alphanum*
+let hexa   = [ '0'-'9' 'a'-'f' 'A'-'F']
+
+rule token = parse
+  (** Layout *)
+  | newline         { next_line_and token lexbuf }
+  | blank+          { token lexbuf               }
+  | "{*"            { comment 1 lexbuf           }
+  | "**"            { commentline lexbuf         }
+
+  (** Keywords *)
+  | "val"           { VAL  }
+  | "if"            { IF }
+  | "fi"            { FI }
+  | "while"         { WHILE }
+  | "then"          { THEN }
+  | "else"          { ELSE }
+  | "and"           { AND }
+  | "or"            { OR }
+  | "nothing"       { NOTHING }
+  | "extern"        { EXTERN }
+  | "newblock"      { NEWBLOCK }
+  | "fun"           { FUN }
+  | "switch"        { SWITCH }
+  | "in"            { IN }
+
+  (** Identifiers *)
+  | identifier as i  { ID i  }
+  | infix_alien_identifier as i { INFIXID i }
+
+  (** Literals *)
+  | digit+ as d     { INT (Int64.of_string d) }
+  | ("0x" |"0X") hexa+                    { INT (Int64.of_string (lexeme lexbuf)) }
+  | ("0b" |"0B") ['0'-'1']+               { INT (Int64.of_string (lexeme lexbuf)) }
+  | '"'                                   { string lexbuf }
+  | "'\\n'"                               { LCHAR '\n' }
+  | "'\\t'"                               { LCHAR '\t' }
+  | "'\\b'"                               { LCHAR '\b' }
+  | "'\\r'"                               { LCHAR '\r' }
+  | "'\\\\'"                              { LCHAR '\\' }
+  | "'\\''"                               { LCHAR '\'' }
+  | '\'' ([^ '\\' '\''] as c) '\''        {
+    if (Char.code c < 32) then
+      error lexbuf (
+        Printf.sprintf
+          "The ASCII character %d is not printable." (Char.code c)
+      );
+    LCHAR c
+  }
+  | "'\\" (digit digit digit as i) "'" {
+    let c = int_of_string i in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  | "'\\0" ("x" | "X") (hexa hexa as i) "'" {
+    let c = int_of_string ("0x" ^ i) in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  | "'\\0" ("b" | "B") (['0'-'1']+ as i) "'" {
+    let c = int_of_string ("0b" ^ i) in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  (* </corrige> *)
+
+  (** Infix operators *)
+  | "="             { EQUAL       }
+  | ":"             { COLON       }
+  | "=>"            { DRARROW     }
+  | "=?"            { EQ          }
+  | ">?"            { GT          }
+  | ">=?"           { GTE         }
+  | "<?"            { LT          }
+  | "<=?"           { LTE         }
+  | "=>?"           { DRARROW     }
+  | "&&"            { LAND        }
+  | "||"            { LOR         }
+  | "-"             { MINUS       }
+  | "+"             { PLUS        }
+  | "*"             { STAR        }
+  | "/"             { SLASH       }
+
+  (** Punctuation *)
+  | ":="            { DEQUAL    }
+  | "|"             { PIPE      }
+  | ";"             { SEMICOLON }
+  | "("             { LPAREN    }
+  | ")"             { RPAREN    }
+  | "["             { LBRACKET  }
+  | "]"             { RBRACKET  }
+  | "{"             { LBRACE    }
+  | "}"             { RBRACE    }
+  | ","             { COMMA     }
+  | "\\"            { BACKSLASH }
+  | eof             { EOF       }
+
+  (** Lexing error. *)
+  | _               { error lexbuf "unexpected character." }
+
+and comment level = parse
+  | "*}" {
+    if level = 1 then
+      token lexbuf
+    else
+      comment (pred level) lexbuf
+  }
+  | "{*" {
+    comment (succ level) lexbuf
+  }
+  | eof {
+    error lexbuf "unterminated comment."
+  }
+  | newline {
+    next_line_and (comment level) lexbuf
+  }
+  | _ {
+    comment level lexbuf
+  }
+
+and commentline = parse
+  | newline { next_line_and token lexbuf }
+  | eof { EOF }
+  | _ { commentline lexbuf }
+
+and string = parse
+| "\\n"                                 { Buffer.add_char string_buffer '\n'; string lexbuf }
+| "\\t"                                 { Buffer.add_char string_buffer '\t'; string lexbuf }
+| "\\b"                                 { Buffer.add_char string_buffer '\b'; string lexbuf }
+| "\\r"                                 { Buffer.add_char string_buffer '\r'; string lexbuf }
+| '\\' '\''                              { Buffer.add_char string_buffer '\''; string lexbuf }
+| '\\' '"'                              { Buffer.add_char string_buffer '"'; string lexbuf }
+| "\\\\"                                { Buffer.add_char string_buffer '\\'; string lexbuf }
+
+| '\\' (_ as c)                 { error lexbuf
+                                    (Printf.sprintf "Bad escape sequence in string '\\%c'" c)
+                                }
+| "\\" (digit digit digit as i) {
+   let c = int_of_string i in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| "\\0" ("x" | "X") (hexa hexa as i) {
+   let c = int_of_string ("0x" ^ i) in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| "\\0" ("b" | "B") (['0'-'1']+ as i) {
+   let c = int_of_string ("0b" ^ i) in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| '"'                                   {
+  let s = Buffer.contents string_buffer in
+  Buffer.clear string_buffer;
+  LSTRING s
+}
+| _ as c                                {
+  Buffer.add_char string_buffer c;
+  string lexbuf
+}
+| eof                                   {
+  error lexbuf "Unterminated string."
+}

flap/src/hobix/hobixParser.mly

@@ -0,0 +1,204 @@
+%{
+
+  open HobixAST
+
+%}
+
+%token VAL
+%token PLUS MINUS STAR SLASH
+%token FUN WHILE
+%token LTE LT GT GTE EQUAL EQ LAND LOR
+%token IF THEN ELSE FI NEWBLOCK
+%token AND OR EXTERN NOTHING IN SWITCH PIPE
+%token LBRACKET RBRACKET COMMA BACKSLASH DRARROW
+%token LBRACE RBRACE COLON
+%token<string> LSTRING
+%token<char> LCHAR
+%token LPAREN RPAREN
+%token SEMICOLON DEQUAL EOF
+%token<Int64.t> INT
+%token<string> ID INFIXID
+%type <HobixAST.expression> expression
+
+%right SEMICOLON
+%nonassoc FUN AND ELSE
+%nonassoc DEQUAL
+%nonassoc DRARROW
+%left LOR
+%left LAND
+%nonassoc LTE LT GT GTE EQ
+%left INFIXID
+%left PLUS MINUS
+%left STAR SLASH
+
+%start<HobixAST.t> program
+
+%%
+
+program: ds=definition* EOF
+{
+  ds
+}
+
+definition:
+VAL d=value_def
+{
+  let (x, e) = d in
+  DefineValue (SimpleValue (x, e))
+}
+| FUN d=function_definition ds=mutfun
+{
+  DefineValue (RecFunctions (d :: ds))
+}
+| EXTERN x=identifier COLON n=INT
+{
+  DeclareExtern (x, Int64.to_int n)
+}
+| error {
+  let pos = Position.lex_join $startpos $endpos in
+  Error.error "parsing" pos "Syntax error."
+}
+
+%inline value_def:
+x=identifier EQUAL e=expression
+{
+  (x, e)
+}
+
+%inline function_definition:
+x=identifier
+LPAREN xs=separated_list(COMMA, identifier) RPAREN
+EQUAL e=expression
+{
+  (x, Fun (xs, e))
+}
+
+mutfun:
+/* empty */ %prec AND { [] }
+| AND d=function_definition ds=mutfun
+{ d::ds }
+
+expression:
+s=simple_expression
+{
+  s
+}
+| e1=expression SEMICOLON e2=expression
+{
+  Define (SimpleValue (Id "__nothing__", e1), e2)
+}
+| VAL vdef=value_def SEMICOLON e2=expression
+{
+  let (id,e1) = vdef in Define (SimpleValue (id, e1),e2)
+}
+| FUN d=function_definition ds=mutfun SEMICOLON e=expression %prec FUN
+{
+  Define (RecFunctions (d::ds), e)
+}
+| WHILE e=expression LBRACE b=expression RBRACE
+{
+  While (e, b)
+}
+| NEWBLOCK LPAREN e=expression RPAREN
+{
+  AllocateBlock e
+}
+| b=simple_expression LBRACKET i=expression RBRACKET DEQUAL rhs=expression
+{
+  WriteBlock (b, i, rhs)
+}
+| lhs=expression b=binop rhs=expression
+{
+  Apply (Variable (Id b), [lhs; rhs])
+}
+| IF c=expression THEN t=expression ELSE e=expression FI
+{
+  IfThenElse (c, t, e)
+}
+| BACKSLASH
+    LPAREN xs=separated_list(COMMA, identifier) RPAREN
+    DRARROW e=expression
+{
+  Fun (xs, e)
+}
+| SWITCH e=expression IN bs=list(branch) OR ELSE d=default
+{
+  let i = List.fold_left (fun i (j, _) -> max i j) 0 bs in
+  let abs = Array.make i None in
+  List.iter (fun (i, e) -> abs.(i) <- Some e) bs;
+  Switch (e, abs, d)
+}
+
+%inline default: NOTHING { None }
+| e=expression { Some e }
+
+branch: PIPE x=INT DRARROW e=expression
+{
+  (Int64.to_int x, e)
+}
+
+simple_expression:
+| a=simple_expression
+  LPAREN bs=separated_list(COMMA, expression) RPAREN
+{
+  Apply (a, bs)
+}
+| b=simple_expression LBRACKET i=expression RBRACKET
+{
+  ReadBlock (b, i)
+}
+
+| e=very_simple_expression
+{
+  e
+}
+
+very_simple_expression:
+  l=literal
+{
+  Literal l
+}
+| x=identifier
+{
+  HobixAST.Variable x
+}
+| LPAREN e=expression RPAREN
+{
+  e
+}
+
+%inline binop:
+  x=INFIXID { String.(sub x 0 (length x - 1)) }
+| PLUS  { "`+`"  }
+| MINUS { "`-`"  }
+| STAR  { "`*`"  }
+| SLASH { "`/`"  }
+| GT    { "`>?`"  }
+| GTE   { "`>=?`" }
+| LT    { "`<?`"  }
+| LTE   { "`<=?`" }
+| EQ    { "`=?`"  }
+| LAND  { "`&&`" }
+| LOR   { "`||`" }
+
+%inline literal:
+  x=INT
+{
+  LInt x
+}
+| MINUS x=INT
+{
+  LInt (Int64.neg x)
+}
+| s=LSTRING
+{
+  LString s
+}
+| c=LCHAR
+{
+  LChar c
+}
+
+%inline identifier: x=ID {
+  Id x
+}

flap/src/hobix/hobixPrettyPrinter.ml

@@ -0,0 +1,155 @@
+open PPrint
+open ExtPPrint
+open HobixAST
+
+let int i = string (Int64.to_string i)
+
+let rec program p =
+  separate_map hardline (definition) p
+
+and definition = function
+  | DefineValue vd ->
+     value_definition "val" vd
+  | DeclareExtern (x, n) ->
+    group (string "extern" ++ identifier x
+           ++ string ":" ++ string (string_of_int n))
+
+and value_definition ?(parens=false) what = function
+  | SimpleValue (x, e) ->
+     let pe =
+       if parens then may_paren_expression e else expression e
+     in
+     nest 2 (group (group (string what ++ identifier x ++ string "=")
+                    ++ group pe))
+  | RecFunctions rv ->
+     group (
+         string "fun"
+         ++ separate_map
+              (hardline ^^ string "and" ^^ break 1)
+              function_definition
+              rv
+       )
+
+and function_definition (f, e) =
+  match e with
+    | Fun (xs, e) ->
+       group (
+           identifier f
+           ++ group (string "(" ++ separate_map (string "," ^^ break 1) identifier xs ++ string ")")
+           ++ string "="
+       ) ++ group (expression e)
+    | _ ->
+       assert false
+
+and identifier (Id x) =
+  string x
+
+and expression = function
+  | Literal l ->
+    literal l
+
+  | While (c, b) ->
+    nest 2 (group (string "while" ++ may_paren_expression c
+                   ++ string "{" ^^ break 1
+                   ++ expression b
+                   ++ break 1 ^^ string "}"))
+
+  | Variable x ->
+    identifier x
+
+  | Define (vd, e2) ->
+    nest 2 (
+      group (value_definition ~parens:true "val" vd ^^ string ";"
+    ))
+    ++ group (expression e2)
+
+  | Fun (p, e) ->
+    nest 2 (group (
+      group (string "\\" ^^ function_parameters p ++ string "=>") ++
+        group (expression e)
+    ))
+
+  | Apply (a, bs) ->
+    group (
+      parens_at_left_of_application a (expression a)
+      ++ parens (separate_map (string "," ^^ break 1) expression bs)
+    )
+
+  | IfThenElse (c, t, f) ->
+    nest 2 (group (
+      group (string "if"
+             ++ group (may_paren_expression c)
+             ++ string "then"
+      )
+      ++ group (may_paren_expression t)
+    ))
+    ++ nest 2 (group (
+      string "else"
+      ++ group (may_paren_expression f)
+      ++ string "fi"
+    ))
+
+  | WriteBlock (e1, e2, e3) ->
+    parens (expression e1) ^^ string "[" ^^ expression e2
+    ^^ string "] := " ^^ may_paren_expression e3
+
+  | ReadBlock (e1, e2) ->
+    parens (expression e1) ^^ string "[" ^^ expression e2 ^^ string "]"
+
+  | AllocateBlock e1 ->
+    expression (Apply (Variable (Id "newblock"), [e1]))
+
+  | Switch (i, bs, default) ->
+    group (string "switch" ++ expression i ++ string "in")
+    ++ group (
+      branches bs
+    ) ++ string "or else" ++ begin match default with
+      | None -> string "nothing"
+      | Some t -> expression t
+    end
+and branches bs =
+  let bs = List.mapi (fun i x -> (i, x)) (Array.to_list bs) in
+  separate_map (string "|" ^^ break 1) (fun (i, t) ->
+      nest 2 (group (
+                  string (string_of_int i)
+                  ++ string "=>"
+                  ++ match t with
+                     | None -> string "!"
+                     | Some t -> expression t)
+    )) bs
+
+and function_parameters xs =
+  parens (separate_map (string "," ^^ break 1) identifier xs)
+
+and may_paren_expression e = match e with
+  | Fun _ | Define _ -> parens (expression e)
+  | _ -> expression e
+
+and literal = function
+  | LInt x ->
+    int x
+  | LChar c ->
+    char c
+  | LString s ->
+    string_literal s
+
+and char c =
+  group (string "'" ^^ string (Char.escaped c) ^^ string "'")
+
+and string_literal s =
+  group (string "\"" ^^ string (String.escaped s) ^^ string "\"")
+
+and parens_at_left_of_application e =
+  match e with
+  | Apply _ | Variable _ | Literal _ -> fun x -> x
+  | _ -> parens
+
+and parens_at_right_of_application e =
+  match e with
+  | Variable _ | Literal _ -> fun x -> x
+  | _ -> parens
+
+let to_string f x =
+  let b = Buffer.create 13 in
+  ToBuffer.pretty 0.8 80 b (f x);
+  Buffer.contents b

flap/src/hobix/hobixTypechecker.ml

@@ -0,0 +1,11 @@
+(** This module implements a type checker for Hopix. *)
+
+let initial_typing_environment = HopixTypes.initial_typing_environment
+
+type typing_environment = HopixTypes.typing_environment
+
+let typecheck tenv _ =
+  tenv
+
+let print_typing_environment =
+  HopixTypes.string_of_typing_environment

flap/src/hobix/hobixTypes.ml

@@ -0,0 +1,5 @@
+type typing_environment = unit
+
+let initial_typing_environment () = ()
+
+let print_typing_environment _ = ""

flap/src/hobix/hopixToHobix.ml

@@ -0,0 +1,312 @@
+(** From Hopix to Hobix *)
+
+module Source = Hopix
+module Target = Hobix
+
+(** The compilation environment.
+    ———————————————————————————–
+
+    To translate a program written in a source language into another
+    semantically equivalent program written in a target language, it
+    is convenient to carry some information about the correspondence
+    between the two programs along the process. The compilation
+    environment is meant to that.
+
+    In this particular pass, we want to remember an assignment of
+    integers to constructor and label identifiers. Therefore, the
+    compilation environment is composed of two maps representing these
+    assignments. The environment is populated each time we cross a
+    type definitions while it is read each time we translate language
+    constructions related to record and tagged values.
+*)
+
+module ConstructorMap = Map.Make (struct
+  type t = HopixAST.constructor
+  let compare = compare
+end)
+
+module LabelMap = Map.Make (struct
+  type t = HopixAST.label
+  let compare = compare
+end)
+
+type environment = {
+  constructor_tags : Int64.t ConstructorMap.t;
+  label_positions  : Int64.t LabelMap.t;
+}
+
+let initial_environment () = {
+  constructor_tags = ConstructorMap.empty;
+  label_positions  = LabelMap.empty;
+}
+
+let index_of_constructor env k =
+  ConstructorMap.find k env.constructor_tags
+
+let position_of_label env l =
+  LabelMap.find l env.label_positions
+
+(** Code generation
+    ———————————————
+
+    A compilation pass produces code. We could directly
+    write down caml expressions made of applications of
+    HobixAST constructors. Yet, the resulting code would
+    be ugly...
+
+    A better way consists in defining functions that build
+    Hobix AST terms and are convenient to use. Here are a
+    list of functions that may be convenient to you when
+    you will implement this pass.
+
+*)
+
+(** [fresh_identifier ()] returns a fresh identifier, that is
+    an identifier that has never been seen before. *)
+let fresh_identifier =
+  let r = ref 0 in
+  fun () -> incr r; HobixAST.Id ("_h2h_" ^ string_of_int !r)
+
+(** [def w (fun x -> e)] returns an abstract syntax tree of
+    the form:
+
+    val x = w; e
+
+    where [x] is chosen fresh.
+*)
+let def w f =
+  let x = fresh_identifier () in
+  HobixAST.(Define (SimpleValue (x, w), f x))
+
+(** [defines [d1; ..; dN] e] returns an abstract syntax tree of
+    the form:
+
+    val d1;
+    ..
+    val dN;
+    e
+
+*)
+let defines =
+  List.fold_right (fun (x, xe) e ->
+      HobixAST.(Define (SimpleValue (x, xe), e)))
+
+(** [seq s1 s2] is
+
+    val _ = s1;
+    s2
+
+*)
+let seq s1 s2 =
+  HobixAST.(Define (SimpleValue (fresh_identifier (), s1), s2))
+
+(** [htrue] represents the primitive true in Hobix. *)
+let htrue =
+  HobixAST.(Variable (Id "true"))
+
+(** [seqs [s1; ...; sN] is
+
+    val _ = s1;
+    ...
+    val _ = s(N - 1);
+    sN
+*)
+let rec seqs = function
+  | [] -> assert false
+  | [e] -> e
+  | e :: es -> seq e (seqs es)
+
+(** [is_equal e1 e2] is the boolean expression [e1 = e2]. *)
+let is_equal l e1 e2 =
+  let equality = HobixAST.(match l with
+    | LInt _ -> "`=?`"
+    | LString _ -> "equal_string"
+    | LChar _ -> "equal_char"
+  ) in
+  HobixAST.(Apply (Variable (Id equality), [e1; e2]))
+
+(** [conj e1 e2] is the boolean expression [e1 && e2]. *)
+let conj e1 e2 =
+  HobixAST.(Apply (Variable (Id "`&&`"), [ e1; e2 ]))
+
+(** [conjs [e1; ..; eN]] is the boolean expression [e1 && .. && eN]. *)
+let rec conjs = function
+  | [] -> htrue
+  | [c] -> c
+  | c :: cs -> conj c (conjs cs)
+
+(** [component x i] returns [x[i]] where x is an Hobix expression
+    denoting a block. *)
+let component x i =
+  failwith "Students! This is your job!"
+
+
+let located  f x = f (Position.value x)
+let located' f x = Position.map f x
+
+let is_binop = function
+  | "`+`" | "`-`" | "`*`" | "`/`"
+  | "`=?`" | "`>=?`" | "`<=?`" | "`>?`" | "`<?`"
+  | "`||`" | "`&&`" ->
+     true
+  | _ ->
+     false
+
+let arity_of_type = HopixAST.(function
+  | TyVar _           -> 0
+  | TyCon (_, _)     -> 0
+  | TyArrow (_, _) -> 1
+  | TyTuple _ -> 0
+)
+
+let eta2 f =
+     failwith "Students! This is your job!"
+
+(** [program env p] turns an Hopix program into an equivalent
+    Hobix program. *)
+let rec program env p =
+  let env, defs = ExtStd.List.foldmap definition' env p in
+  (List.flatten defs, env)
+
+(** Compilation of Hopix toplevel definitions. *)
+and definition' env p =
+  definition env (Position.value p)
+
+and definition env = HobixAST.(function
+  | HopixAST.DeclareExtern (x, s) ->
+    let { Position.value = HopixAST.ForallTy (_, ty); _ } = s in
+    let ty = Position.value ty in
+    env, [DeclareExtern (located identifier x, arity_of_type ty)]
+
+  | HopixAST.DefineValue vd ->
+     let vd = value_definition env vd in
+     env, [DefineValue vd]
+
+  | HopixAST.DefineType (_, _, tydef) ->
+    type_definition env tydef, []
+)
+
+and value_definition env = function
+  | HopixAST.SimpleValue (x, _, e) ->
+     HobixAST.SimpleValue (located identifier x, located (expression env) e)
+  | HopixAST.RecFunctions fs ->
+     HobixAST.RecFunctions (List.map (function_binding env) fs)
+
+and function_binding env (f, _, fdef) =
+  (located identifier f, function_definition env fdef)
+
+and function_definition env (HopixAST.FunctionDefinition (x, e)) =
+  let y = HopixASTHelper.fresh_identifier () in
+  let wpos t = Position.(with_pos (position x) t) in
+  let e = HopixAST.(
+      Case (wpos (Variable (wpos y, None)),
+            [
+              wpos (Branch (x, e))
+            ])
+  )
+  in
+  (HobixAST.Fun ([identifier y], expression env e))
+
+and identifier (HopixAST.Id x) =
+  HobixAST.Id x
+
+(** Compilation of Hopix expressions. *)
+and expression env = HobixAST.(function
+  | HopixAST.Variable ({ value = HopixAST.Id x }, _) when is_binop x ->
+     eta2 (HobixAST.Id x)
+
+  | HopixAST.Variable (x, _) ->
+    Variable (located identifier x)
+
+  | HopixAST.Tagged (k, _, es) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Case (e, bs) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Ref e ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Read r ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Assign (r, v) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.While (c, b) ->
+    HobixAST.While (located (expression env) c,
+                    located (expression env) b)
+
+  | HopixAST.Apply (a, b) ->
+    Apply (located (expression env) a,
+           [located (expression env) b])
+
+  | HopixAST.Literal l ->
+    Literal (located literal l)
+
+  | HopixAST.Define (vd, e) ->
+    Define (value_definition env vd, located (expression env) e)
+
+  | HopixAST.TypeAnnotation (e, _) ->
+    located (expression env) e
+
+  | HopixAST.IfThenElse (c, t, f) ->
+     let f = located (expression env) f in
+     HobixAST.IfThenElse (located (expression env) c,
+                          located (expression env) t,
+                          f)
+
+  | HopixAST.Record (fs, _) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Tuple ts ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Field (e, l, _) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Sequence es ->
+     seqs (List.map (located (expression env)) es)
+
+  | HopixAST.For (x, start, stop, e) ->
+    failwith "Students! This is your job!"
+
+  | HopixAST.Fun fdef ->
+    failwith "Students! This is your job!"
+)
+
+
+(** [expands_or_patterns branches] returns a sequence of branches
+    equivalent to [branches] except that their patterns do not contain
+    any disjunction. {ListMonad} can be useful to implement this
+    transformation. *)
+and expands_or_patterns branches =
+ failwith "Students! This is your job!"
+
+
+(** [pattern env scrutinee p] returns an HopixAST expression
+    representing a boolean condition [c] and a list of definitions
+    [ds] such that:
+
+    - [c = true] if and only if [p] matches the [scrutinee] ;
+    - [ds] binds all the variables that appear in [p].
+
+    Precondition: p does not contain any POr.
+ *)
+and pattern env scrutinee p = HobixAST.(
+    failwith "Students! This is your job!"
+)
+
+and literal = HobixAST.(function
+  | HopixAST.LInt x -> LInt x
+  | HopixAST.LString s -> LString s
+  | HopixAST.LChar c -> LChar c
+)
+
+(** Compilation of type definitions. *)
+and type_definition env t =
+  failwith "Students! This is your job!"
+
+(** Here is the compiler! *)
+let translate source env =
+  program env source

flap/src/hobix/patternMatchingCompiler.ml

@@ -0,0 +1,182 @@
+(** This module implements an optimized compilation of pattern-matching.
+
+    It is based on the article
+
+    "Compiling Pattern Matching to Good Decision Trees"
+
+    written by Luc Maranget
+    and published in the proceedings of the ML workshop 2005.
+
+*)
+open Position
+
+module S = HopixAST
+module T = HobixAST
+
+(** A path is a sequence of indices which allow for accessing
+    a component which may be deeply nested inside a block. *)
+type path = int list
+
+(** Each identifier bound by the pattern will finally be associated to
+    a path. *)
+type binding = T.identifier * path
+
+(** A pattern-matching matrix has a row for each possible
+    case and as many columns as the number of components of
+    the matched value. *)
+type matrix = row list
+
+and row = S.pattern list * binding list * T.expression
+
+(** [nb_columns m] returns the number of columns of [m]. *)
+let nb_columns = function
+  | [] ->
+     0
+  | (ps, _, _) :: rows ->
+     let n = List.length ps in
+     assert (List.for_all (fun (ps, _, _) -> List.length ps = n) rows);
+     n
+
+(** [string_of_path occ] produces a human-readable version of [occ]. *)
+let string_of_path occ =
+  String.concat "." (List.rev_map string_of_int occ)
+
+(** [string_of_bindings bs] produces a human-readable version of [bs]. *)
+let string_of_bindings bs =
+  String.concat ", " (
+      List.map (fun (T.Id x, p) ->
+          Printf.sprintf "%s = %s" x (string_of_path p)
+        ) bs)
+
+(** [string_of_matrix m] produces a human-readable version of [m]. *)
+let string_of_matrix m =
+  let csizes = Array.make (nb_columns m) 0 in
+  let string_of_pattern i p =
+    let s = HopixPrettyPrinter.(to_string pattern p) in
+    csizes.(i) <- max csizes.(i) (String.length s);
+    s
+  in
+  let complete_pattern i p =
+    p ^ String.make (csizes.(i) - String.length p) ' '
+  in
+  let string_of_expression e =
+    HobixPrettyPrinter.(to_string expression e)
+  in
+  let b = Buffer.create 13 in
+  List.map (fun (ps, bs, e) ->
+      (List.mapi string_of_pattern ps,
+       string_of_bindings bs,
+       string_of_expression e)) m
+  |> List.iter (fun (ps, bs, e) ->
+         Buffer.add_string b (
+             String.concat " " (List.mapi complete_pattern ps)
+             ^ " -> " ^ bs ^ " in " ^ e ^ "\n"
+           )
+       );
+  Buffer.contents b
+
+(** We may observe if a value is a tagged value with a specific
+    constructor or is equal to a given literal. *)
+type observation =
+  | CTag of S.constructor
+  | CLit of S.literal
+
+(** [head_constructors m] returns the list of observations of the
+   first column of [m] without repetition. Each observation comes with
+   its arity. A literal has an arity of 0 and constructor has for arity
+   the number of arguments it is applied to. This function assumes
+   that the patterns in the matrix are well-typed, hence we can deduce
+   the arity of the constructors directly from their application. *)
+let head_constructors : matrix -> (observation * int) list =
+  failwith "Students! This is your job!"
+
+(** [specialize occ c arity m] returns the matrix [m] in which rows that
+    do not match the observation [c] are removed and the others
+    have new columns to match the subcomponents of [c].
+    - [m] must have at least one row and one column.
+    - [arity] is the arity of [c].
+    - [occ] is the path to the scrutinee's component matched by the
+      first column of [m].
+*)
+let specialize occ c arity (m : matrix) =
+  failwith "Students! This is your job!"
+
+(** [default occ m] returns the default matrix of [m], that is the matrix
+    corresponding to the remaining tests to do if the default case of the
+    first column of [m] has been chosen. *)
+let default occ (m : matrix) =
+  failwith "Students! This is your job!"
+
+(** [split n] returns the list of occurrences [occ.0; occ.1; ..;
+    occ.(n - 1)]. *)
+let split n occ =
+  failwith "Students! This is your job!"
+
+(** [swap_columns i m] returns a new matrix which is [m] in which
+    column 0 and column i have been exchanged. *)
+let swap_columns i m =
+  failwith "Students! This is your job!"
+
+(** [swap_occurences i occs] returns a new list of occurrences in
+    which the occ numbered 0 and the occ numbered i have been
+    exchanged. *)
+let swap_occurences i occs =
+  failwith "Students! This is your job!"
+
+type decision_tree =
+  | Fail
+  | Leaf   of binding list * T.expression
+  | Switch of path * (observation * decision_tree) list * decision_tree option
+  | Swap   of int * decision_tree
+
+let string_of_constructor = function
+  | CTag (S.KId s) -> s
+  | CLit l -> HopixPrettyPrinter.(to_string literal l)
+
+(** [string_of_decision_tree t] produces a human-readable version of [t]. *)
+let string_of_decision_tree t =
+  let b = Buffer.create 13 in
+  let offset = 2 in
+  let show indent s =
+    Buffer.add_string b (String.make (offset * indent) ' ' ^ s ^ "\n")
+  in
+  let rec aux prefix indent = function
+  | Fail ->
+     show indent (prefix ^ "fail")
+  | Leaf (bs, e) ->
+     show indent (
+         prefix
+         ^ string_of_bindings bs
+         ^ HobixPrettyPrinter.(to_string expression e))
+  | Switch (occ, ts, default) ->
+     show indent (prefix ^ string_of_path occ ^ "?");
+     List.iter (fun (c, t) -> aux (string_of_constructor c) (indent + 1) t) ts;
+     begin match default with
+     | None -> ()
+     | Some t -> aux "default: " (indent + 1) t
+     end
+  | Swap (i, t) ->
+     aux ("swap" ^ string_of_int i ^ ":") (indent + 1) t
+  in
+  aux "" 0 t;
+  Buffer.contents b
+
+
+(** [decision_tree_of_matrix m] returns a decision tree that
+    implements [m] efficiently. *)
+let decision_tree_of_matrix (m : matrix) : decision_tree =
+  failwith "Students! This is your job!"
+
+(** [compile_decision_tree index_of_constructor x t] returns an
+    expression in Hobix which corresponds to the application of [t] to
+    [x]. [index_of_constructor k] returns the integer which represents
+    the constructor k in Hobix. *)
+let compile_decision_tree (index_of_constructor : S.constructor -> int) x t =
+  failwith "Students! This is your job!"
+
+(** [translate branches x] returns an [Hobix] expression which implements
+    an efficient pattern matching of [x] with the [branches]. *)
+let translate (index_of_constructor : S.constructor -> int) bs x =
+  let matrix = List.map (fun (p, e) -> ([p.value], [], e)) bs in
+  let decision_tree = decision_tree_of_matrix matrix in
+  compile_decision_tree index_of_constructor x decision_tree

flap/src/hopix/hopix.ml

@@ -0,0 +1,44 @@
+(** The Hopix programming language. *)
+
+let name = "hopix"
+
+module AST = HopixAST
+
+type ast = HopixAST.t
+
+let parse lexer_init input =
+  SyntacticAnalysis.process
+    ~lexer_init
+    ~lexer_fun:HopixLexer.token
+    ~parser_fun:HopixParser.program
+    ~input
+
+let parse_filename filename =
+  if Options.get_use_sexp_in () then
+    ExtStd.Stdlib.file_content filename
+    |> Sexplib.Sexp.of_string
+    |> HopixAST.program_of_sexp
+  else
+    parse Lexing.from_channel (open_in filename)
+
+let extension =
+  ".hopix"
+
+let executable_format =
+  false
+
+let parse_string =
+  parse Lexing.from_string
+
+let print_ast ast =
+  if Options.get_use_sexp_out () then
+    HopixAST.sexp_of_program ast |> Sexplib.Sexp.to_string
+  else
+    HopixPrettyPrinter.(to_string program ast)
+
+let print_expression e =
+  HopixPrettyPrinter.(to_string expression e)
+
+include HopixInterpreter
+
+include HopixTypechecker

flap/src/hopix/hopixAST.ml

@@ -0,0 +1,150 @@
+(** The abstract syntax tree for hopix programs. *)
+
+open Sexplib.Std
+open Position
+
+(** A program is a list of definitions. *)
+type program = definition located list
+[@@deriving sexp]
+
+and definition =
+  (** A type definition. *)
+  | DefineType of
+      type_constructor located * type_variable located list * type_definition
+  (** A toplevel declaration for an external value. *)
+  | DeclareExtern of identifier located * type_scheme located
+  (** A toplevel definition of value(s). *)
+  | DefineValue of value_definition
+
+and type_definition =
+  (** A sum type for tagged values
+      [K₁ (ty₁₁, ..., ty₁ₙ) | ... | Kₙ (tyₙ₁, ..., tyₘₖ)].
+  *)
+  | DefineSumType of (constructor located * ty located list) list
+  (** A record type { l₁ : ty₁, ..., lₙ : tyₙ}. *)
+  | DefineRecordType of (label located * ty located) list
+  (** A type with no visible definition. *)
+  | Abstract
+
+and expression =
+  (** A literal is a constant written "as is". *)
+  | Literal of literal located
+  (** A variable identifies a value. If this value is polymorphic, it can be
+      instantiated using a list of types.*)
+  | Variable of identifier located * ty located list option
+  (** A tagged value [K <ty_1, ..., ty_m> (e₁, ..., eₙ)]. *)
+  | Tagged of
+      constructor located * ty located list option * expression located list
+  (** A record [{l₁ = e₁, ..., lₙ = eₙ} <ty₁, ..., tyₘ>]. *)
+  | Record of (label located * expression located) list * ty located list option
+  (** A record field access [e.l]. *)
+  | Field of expression located * label located * ty located list option
+  (** A tuple [(e₁, ..., en)]. *)
+  | Tuple of expression located list
+  (** A sequence [e₁ ; ... ; eₙ] *)
+  | Sequence of expression located list
+  (** A local definition of value(s) [value_definition; e₂]. *)
+  | Define of value_definition * expression located
+  (** An anonymous function [ pattern -> e ]. *)
+  | Fun of function_definition
+  (** A function application [a₁ (a₂))]. *)
+  | Apply of expression located * expression located
+  (** A reference allocation. *)
+  | Ref of expression located
+  (** An assignment. *)
+  | Assign of expression located * expression located
+  (** A dereference. *)
+  | Read of expression located
+  (** A pattern matching [match (e) { p₁ -> e₁ | ... | pₙ -> eₙ }]. *)
+  | Case of expression located * branch located list
+  (** A conditional expression of the form [if (...) ... else ...]. *)
+  | IfThenElse of expression located * expression located * expression located
+  (** An unbounded loop of the form [while (...) { ... }]. *)
+  | While of expression located * expression located
+  (** A bounded loop of the form [for x in (e₁ to e₂) { ... }]. *)
+  | For of
+      identifier located
+      * expression located * expression located
+      * expression located
+  (** A type annotation [(e : ty)]. *)
+  | TypeAnnotation of expression located * ty located
+
+and value_definition =
+  (** A toplevel definition for a value. *)
+  | SimpleValue of expression located polymorphic_definition
+  (** A toplevel definition for mutually recursive functions. *)
+  | RecFunctions of function_definition polymorphic_definition list
+
+and 'a polymorphic_definition =
+  identifier located * type_scheme located option * 'a
+
+and function_definition =
+  | FunctionDefinition of pattern located * expression located
+
+and type_arguments =
+  type_variable located list
+
+and pattern =
+  (** A pattern which is simply an identifier. *)
+  | PVariable of identifier located
+  (** A wildcard pattern [_]. *)
+  | PWildcard
+  (** A pattern with a type annotation of type form [p : ty] *)
+  | PTypeAnnotation of pattern located * ty located
+  (** A literal pattern. *)
+  | PLiteral of literal located
+  (** A pattern for a tagged value K <ty₁, ..., tyₙ> (p₁, ..., pₙ). *)
+  | PTaggedValue of
+      constructor located * ty located list option * pattern located list
+  (** A pattern for a record {l₁ = p₁, ..., lₙ = pₙ }  < ty₁, ..., tyₘ >. *)
+  | PRecord of (label located * pattern located) list * ty located list option
+  (** A pattern for a tuple (p₁, ..., pₙ). *)
+  | PTuple of pattern located list
+  (** A disjunctive pattern [ p₁ | ... | pₙ ]. *)
+  | POr of pattern located list
+  (** A conjunctive pattern [ p₁ & ... & pₙ ]. *)
+  | PAnd of pattern located list
+
+and branch =
+  (** A branch in a pattern matching [p => e]. *)
+  | Branch of pattern located * expression located
+
+and ty =
+  (** An instantiated type constructor [t <ty₁, .., tyₙ>]. *)
+  | TyCon of type_constructor * ty located list
+  (** A function type [ty₁ → ty₂]. *)
+  | TyArrow of ty located * ty located
+  (** A tuple type [ty₁ * ... * tyₙ]. *)
+  | TyTuple of ty located list
+  (** A type variable ['a]. *)
+  | TyVar of type_variable
+
+and type_scheme =
+  ForallTy of type_variable located list * ty located
+
+and literal =
+  | LInt    of Mint.t
+  | LString of string
+  | LChar   of char
+
+and identifier =
+  | Id of string
+
+and type_constructor =
+  | TCon of string
+
+and type_variable =
+  | TId of string
+
+and constructor =
+  | KId of string
+
+and label =
+  | LId of string
+
+[@@deriving sexp]
+
+type t = program
+
+[@@deriving sexp]
+

flap/src/hopix/hopixASTHelper.ml

@@ -0,0 +1,15 @@
+open HopixAST
+
+module LabelSet = Set.Make (struct
+  type t = label
+  let compare = compare
+end)
+
+module TypeVariableSet = Set.Make (struct
+  type t = type_variable
+  let compare = compare
+end)
+
+let fresh_identifier =
+  let count = ref (-1) in
+  fun () -> incr count; Id ("id" ^ string_of_int !count)

flap/src/hopix/hopixInitialization.ml

@@ -0,0 +1,4 @@
+let initialize () =
+  Languages.register (module Hopix);
+  Compilers.register (module Compilers.Identity (Hopix))
+

flap/src/hopix/hopixInterpreter.ml

@@ -0,0 +1,356 @@
+open Position
+open Error
+open HopixAST
+
+(** [error pos msg] reports execution error messages. *)
+let error positions msg =
+  errorN "execution" positions msg
+
+(** Every expression of Hopix evaluates into a [value].
+
+   The [value] type is not defined here. Instead, it will be defined
+   by instantiation of following ['e gvalue] with ['e = environment].
+   Why? The value type and the environment type are mutually recursive
+   and since we do not want to define them simultaneously, this
+   parameterization is a way to describe how the value type will use
+   the environment type without an actual definition of this type.
+
+*)
+type 'e gvalue =
+  | VInt       of Mint.t
+  | VChar      of char
+  | VString    of string
+  | VUnit
+  | VTagged    of constructor * 'e gvalue list
+  | VTuple     of 'e gvalue list
+  | VRecord    of (label * 'e gvalue) list
+  | VLocation  of Memory.location
+  | VClosure   of 'e * pattern located * expression located
+  | VPrimitive of string * ('e gvalue Memory.t -> 'e gvalue -> 'e gvalue)
+
+(** Two values for booleans. *)
+let ptrue  = VTagged (KId "True", [])
+let pfalse = VTagged (KId "False", [])
+
+(**
+    We often need to check that a value has a specific shape.
+    To that end, we introduce the following coercions. A
+    coercion of type [('a, 'e)] coercion tries to convert an
+    Hopix value into a OCaml value of type ['a]. If this conversion
+    fails, it returns [None].
+*)
+
+type ('a, 'e) coercion = 'e gvalue -> 'a option
+let fail = None
+let ret x = Some x
+let value_as_int      = function VInt x -> ret x | _ -> fail
+let value_as_char     = function VChar c -> ret c | _ -> fail
+let value_as_string   = function VString s -> ret s | _ -> fail
+let value_as_tagged   = function VTagged (k, vs) -> ret (k, vs) | _ -> fail
+let value_as_record   = function VRecord fs -> ret fs | _ -> fail
+let value_as_location = function VLocation l -> ret l | _ -> fail
+let value_as_closure  = function VClosure (e, p, b) -> ret (e, p, b) | _ -> fail
+let value_as_primitive = function VPrimitive (p, f) -> ret (p, f) | _ -> fail
+let value_as_bool = function
+  | VTagged (KId "True", []) -> true
+  | VTagged (KId "False", []) -> false
+  | _ -> assert false
+
+(**
+   It is also very common to have to inject an OCaml value into
+   the types of Hopix values. That is the purpose of a wrapper.
+ *)
+type ('a, 'e) wrapper = 'a -> 'e gvalue
+let int_as_value x  = VInt x
+let bool_as_value b = if b then ptrue else pfalse
+
+(**
+
+  The flap toplevel needs to print the result of evaluations. This is
+   especially useful for debugging and testing purpose. Do not modify
+   the code of this function since it is used by the testsuite.
+
+*)
+let print_value m v =
+  (** To avoid to print large (or infinite) values, we stop at depth 5. *)
+  let max_depth = 5 in
+
+  let rec print_value d v =
+    if d >= max_depth then "..." else
+      match v with
+        | VInt x ->
+          Mint.to_string x
+        | VChar c ->
+          "'" ^ Char.escaped c ^ "'"
+        | VString s ->
+          "\"" ^ String.escaped s ^ "\""
+        | VUnit ->
+          "()"
+        | VLocation a ->
+          print_array_value d (Memory.dereference m a)
+        | VTagged (KId k, []) ->
+          k
+        | VTagged (KId k, vs) ->
+          k ^ print_tuple d vs
+        | VTuple (vs) ->
+           print_tuple d vs
+        | VRecord fs ->
+           "{"
+           ^ String.concat ", " (
+                 List.map (fun (LId f, v) -> f ^ " = " ^ print_value (d + 1) v
+           ) fs) ^ "}"
+        | VClosure _ ->
+          "<fun>"
+        | VPrimitive (s, _) ->
+          Printf.sprintf "<primitive: %s>" s
+    and print_tuple d vs =
+      "(" ^ String.concat ", " (List.map (print_value (d + 1)) vs) ^ ")"
+    and print_array_value d block =
+      let r = Memory.read block in
+      let n = Mint.to_int (Memory.size block) in
+      "[ " ^ String.concat ", " (
+                 List.(map (fun i -> print_value (d + 1) (r (Mint.of_int i)))
+                         (ExtStd.List.range 0 (n - 1))
+               )) ^ " ]"
+  in
+  print_value 0 v
+
+let print_values m vs =
+  String.concat "; " (List.map (print_value m) vs)
+
+module Environment : sig
+  (** Evaluation environments map identifiers to values. *)
+  type t
+
+  (** The empty environment. *)
+  val empty : t
+
+  (** [bind env x v] extends [env] with a binding from [x] to [v]. *)
+  val bind    : t -> identifier -> t gvalue -> t
+
+  (** [update pos x env v] modifies the binding of [x] in [env] so
+      that [x ↦ v] ∈ [env]. *)
+  val update  : Position.t -> identifier -> t -> t gvalue -> unit
+
+  (** [lookup pos x env] returns [v] such that [x ↦ v] ∈ env. *)
+  val lookup  : Position.t -> identifier -> t -> t gvalue
+
+  (** [UnboundIdentifier (x, pos)] is raised when [update] or
+      [lookup] assume that there is a binding for [x] in [env],
+      where there is no such binding. *)
+  exception UnboundIdentifier of identifier * Position.t
+
+  (** [last env] returns the latest binding in [env] if it exists. *)
+  val last    : t -> (identifier * t gvalue * t) option
+
+  (** [print env] returns a human readable representation of [env]. *)
+  val print   : t gvalue Memory.t -> t -> string
+end = struct
+
+  type t =
+    | EEmpty
+    | EBind of identifier * t gvalue ref * t
+
+  let empty = EEmpty
+
+  let bind e x v =
+    EBind (x, ref v, e)
+
+  exception UnboundIdentifier of identifier * Position.t
+
+  let lookup' pos x =
+    let rec aux = function
+      | EEmpty -> raise (UnboundIdentifier (x, pos))
+      | EBind (y, v, e) ->
+        if x = y then v else aux e
+    in
+    aux
+
+  let lookup pos x e = !(lookup' pos x e)
+
+  let update pos x e v =
+    lookup' pos x e := v
+
+  let last = function
+    | EBind (x, v, e) -> Some (x, !v, e)
+    | EEmpty -> None
+
+  let print_binding m (Id x, v) =
+    x ^ " = " ^ print_value m !v
+
+  let print m e =
+    let b = Buffer.create 13 in
+    let push x v = Buffer.add_string b (print_binding m (x, v)) in
+    let rec aux = function
+      | EEmpty -> Buffer.contents b
+      | EBind (x, v, EEmpty) -> push x v; aux EEmpty
+      | EBind (x, v, e) -> push x v; Buffer.add_string b "\n"; aux e
+    in
+    aux e
+
+end
+
+(**
+    We have everything we need now to define [value] as an instantiation
+    of ['e gvalue] with ['e = Environment.t], as promised.
+*)
+type value = Environment.t gvalue
+
+(**
+   The following higher-order function lifts a function [f] of type
+   ['a -> 'b] as a [name]d Hopix primitive function, that is, an
+   OCaml function of type [value -> value].
+*)
+let primitive name ?(error = fun () -> assert false) coercion wrapper f
+: value
+= VPrimitive (name, fun x ->
+    match coercion x with
+      | None -> error ()
+      | Some x -> wrapper (f x)
+  )
+
+type runtime = {
+  memory      : value Memory.t;
+  environment : Environment.t;
+}
+
+type observable = {
+  new_memory      : value Memory.t;
+  new_environment : Environment.t;
+}
+
+(** [primitives] is an environment that contains the implementation
+    of all primitives (+, <, ...). *)
+let primitives =
+  let intbin name out op =
+    let error m v =
+      Printf.eprintf
+        "Invalid arguments for `%s': %s\n"
+        name (print_value m v);
+      assert false (* By typing. *)
+    in
+    VPrimitive (name, fun m -> function
+      | VInt x ->
+         VPrimitive (name, fun m -> function
+         | VInt y -> out (op x y)
+         | v -> error m v)
+      | v -> error m v)
+  in
+  let bind_all what l x =
+    List.fold_left (fun env (x, v) -> Environment.bind env (Id x) (what x v))
+      x l
+  in
+  (* Define arithmetic binary operators. *)
+  let binarith name =
+    intbin name (fun x -> VInt x) in
+  let binarithops = Mint.(
+    [ ("`+`", add); ("`-`", sub); ("`*`", mul); ("`/`", div) ]
+  ) in
+  (* Define arithmetic comparison operators. *)
+  let cmparith name = intbin name bool_as_value in
+  let cmparithops =
+    [ ("`=?`", ( = ));
+      ("`<?`", ( < ));
+      ("`>?`", ( > ));
+      ("`>=?`", ( >= ));
+      ("`<=?`", ( <= )) ]
+  in
+  let boolbin name out op =
+    VPrimitive (name, fun _ x -> VPrimitive (name, fun _ y ->
+        out (op (value_as_bool x) (value_as_bool y))))
+  in
+  let boolarith name = boolbin name (fun x -> if x then ptrue else pfalse) in
+  let boolarithops =
+    [ ("`||`", ( || )); ("`&&`", ( && )) ]
+  in
+  let generic_printer =
+    VPrimitive ("print", fun m v ->
+      output_string stdout (print_value m v);
+      flush stdout;
+      VUnit
+    )
+  in
+  let print s =
+    output_string stdout s;
+    flush stdout;
+    VUnit
+  in
+  let print_int =
+    VPrimitive  ("print_int", fun _ -> function
+      | VInt x -> print (Mint.to_string x)
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let print_string =
+    VPrimitive  ("print_string", fun _ -> function
+      | VString x -> print x
+      | _ -> assert false (* By typing. *)
+    )
+  in
+  let bind' x w env = Environment.bind env (Id x) w in
+  Environment.empty
+  |> bind_all binarith binarithops
+  |> bind_all cmparith cmparithops
+  |> bind_all boolarith boolarithops
+  |> bind' "print"        generic_printer
+  |> bind' "print_int"    print_int
+  |> bind' "print_string" print_string
+  |> bind' "true"         ptrue
+  |> bind' "false"        pfalse
+  |> bind' "nothing"      VUnit
+
+let initial_runtime () = {
+  memory      = Memory.create (640 * 1024 (* should be enough. -- B.Gates *));
+  environment = primitives;
+}
+
+let rec evaluate runtime ast =
+  try
+    let runtime' = List.fold_left definition runtime ast in
+    (runtime', extract_observable runtime runtime')
+  with Environment.UnboundIdentifier (Id x, pos) ->
+    Error.error "interpretation" pos (Printf.sprintf "`%s' is unbound." x)
+
+(** [definition pos runtime d] evaluates the new definition [d]
+    into a new runtime [runtime']. In the specification, this
+    is the judgment:
+
+                        E, M ⊢ dv ⇒ E', M'
+
+*)
+and definition runtime d =
+failwith "Students! This is your job!"
+
+and expression' environment memory e =
+  expression (position e) environment memory (value e)
+
+(** [expression pos runtime e] evaluates into a value [v] if
+
+                          E, M ⊢ e ⇓ v, M'
+
+   and E = [runtime.environment], M = [runtime.memory].
+*)
+and expression _ environment memory =
+failwith "Students! This is your job!"
+
+(** This function returns the difference between two runtimes. *)
+and extract_observable runtime runtime' =
+  let rec substract new_environment env env' =
+    if env == env' then new_environment
+    else
+      match Environment.last env' with
+        | None -> assert false (* Absurd. *)
+        | Some (x, v, env') ->
+          let new_environment = Environment.bind new_environment x v in
+          substract new_environment env env'
+  in
+  {
+    new_environment =
+      substract Environment.empty runtime.environment runtime'.environment;
+    new_memory =
+      runtime'.memory
+  }
+
+(** This function displays a difference between two runtimes. *)
+let print_observable (_ : runtime) observation =
+  Environment.print observation.new_memory observation.new_environment

flap/src/hopix/hopixLexer.mll

@@ -0,0 +1,32 @@
+{ (* -*- tuareg -*- *)
+  open Lexing
+  open Error
+  open Position
+  open HopixParser
+
+  let next_line_and f lexbuf  =
+    Lexing.new_line lexbuf;
+    f lexbuf
+
+  let error lexbuf =
+    error "during lexing" (lex_join lexbuf.lex_start_p lexbuf.lex_curr_p)
+
+
+}
+
+let newline = ('\010' | '\013' | "\013\010")
+
+let blank   = [' ' '\009' '\012']
+
+let digit = ['0'-'9']
+
+
+rule token = parse
+  (** Layout *)
+  | newline         { next_line_and token lexbuf }
+  | blank+          { token lexbuf               }
+  | eof             { EOF       }
+
+  (** Lexing error. *)
+  | _               { error lexbuf "unexpected character." }
+

flap/src/hopix/hopixParser.mly

@@ -0,0 +1,23 @@
+%{ (* -*- tuareg -*- *)
+
+  open HopixAST
+  open Position
+
+
+%}
+
+%token EOF
+
+
+%start<HopixAST.t> program
+
+%%
+
+program: EOF
+{
+   []
+}
+
+%inline located(X): x=X {
+  Position.with_poss $startpos $endpos x
+}

flap/src/hopix/hopixPrettyPrinter.ml

@@ -0,0 +1,394 @@
+open PPrint
+open ExtPPrint
+open HopixAST
+open Position
+
+let int i = string (Mint.to_string i)
+
+let colon = string ","
+
+let semicolon = string ";"
+
+let sqbrackets d = string "[" ^^ d ^^ string "]"
+
+let angles d = string "<" ^^ d ^^ string ">"
+
+let separate_postgrouped_map sep f xs =
+  let rec aux = function
+  | [] -> empty
+  | x :: xs -> group (sep ^^ f x) ^^ break 1 ^^ aux xs
+  in
+  match xs with
+  | [] -> empty
+  | x :: xs -> f x ^^ break 1 ^^ aux xs
+
+let gtype_definition sep what around ks =
+  around (break 1 ^^ group (
+     separate_postgrouped_map (break 1 ^^ string sep ^^ break 1) what ks
+    ))
+
+let rec program p =
+  separate_map hardline (located definition) p
+
+and definition = function
+  | DefineType (t, ts, tdef) ->
+    nest 2 (
+      group (group (string "type"
+                    ++ located type_constructor t
+                    ^^ group (type_parameters_angles ts))
+             ++ string "=")
+      ++ type_definition tdef)
+  | DeclareExtern (x, t) ->
+    group (string "extern" ++ located identifier x
+           ++ string ":" ++ located type_scheme t)
+  | DefineValue vdef ->
+    group (value_definition false vdef)
+
+and rec_function_definition paren rv =
+  group (string "fun"
+         ^^ space
+         ^^ separate_map (hardline ^^ string "and" ^^ space)
+             (fun (x, d) ->
+               nest 2 (
+                 group (located identifier x ^^ break 1 ^^
+                        let sep = space ^^ string "=" ^^ break 1 in
+                        located (function_definition paren sep) d)))
+             rv)
+
+and function_definition paren sep = function
+  | FunctionDefinition (p, e) ->
+    group (located pattern p)
+    ^^ sep ^^ group (located (if_paren_expression paren) e)
+
+and type_parameters ts =
+  separate_map (comma ^^ break 1) (located type_variable) ts
+
+and type_parameters_angles = function
+  | [] ->
+     empty
+  | ts ->
+     angles (type_parameters ts)
+
+and type_parameters_bracketed = function
+  | [] ->
+     empty
+  | ts ->
+     sqbrackets (type_parameters ts)
+
+and type_definition = function
+  | DefineSumType ks ->
+    gtype_definition "|" dataconstructor_definition (fun x -> x) ks
+  | DefineRecordType ls ->
+    gtype_definition "," label_definition braces ls
+  | Abstract ->
+    empty
+
+and label (LId s) =
+  string s
+
+and dataconstructor_definition (k, tys) =
+  match tys with
+    | [] ->
+      located dataconstructor k
+    | _ ->
+       group (located dataconstructor k
+              ++ parens (
+                     separate_map (string "," ^^ break 1) (located ty) tys
+                   ))
+
+and label_definition (l, t) =
+  group (located label l ++ string ":" ++ located ty t)
+
+and dataconstructor (KId k) =
+  string k
+
+and value_definition paren = function
+  | SimpleValue (x, ot, e) ->
+    nest 2 (group (group (
+        string "let" ++ located identifier x
+        ^^ optional_type_scheme_annotation ot
+        ++ string "=")
+        ++ group (located (if_paren_expression paren) e
+    )))
+  | RecFunctions (f :: fs) ->
+    rec_function "fun" f ++
+    separate_map (break 1) (rec_function "and") fs
+  | RecFunctions [] ->
+    assert false (* By parsing. *)
+
+and rec_function prefix (f, ot, fdef) =
+  group (nest 2 (
+      group (string prefix
+             ^^ optional_type_scheme_annotation ot
+             ++ located identifier f)
+      ++ function_definition true (space ^^ string "=" ^^ break 1) fdef
+  ))
+
+and optional_type_annotation = function
+  | None -> empty
+  | Some t -> type_annotation t
+
+and type_annotation t =
+  group (break 1 ^^ string ":" ++ located ty t)
+
+and optional_type_scheme_annotation = function
+  | None -> empty
+  | Some t -> type_scheme_annotation t
+
+and type_scheme_annotation t =
+  group (break 1 ^^ string ":" ++ located type_scheme t)
+
+and type_scheme (ForallTy (ts, t)) =
+  type_parameters_bracketed ts ^^ located ty t
+
+and ty t = match t with
+  | TyCon (tcon, []) ->
+    type_constructor tcon
+  | TyCon (tcon, tys) ->
+    group (type_constructor tcon
+           ^^ angles (
+             separate_map (string "," ^^ break 1) (located ty) tys
+           ))
+  | TyVar tvar ->
+    type_variable tvar
+  | TyTuple tys ->
+     parens (separate_map (break 1 ^^ string "*" ^^ break 1) (located ty) tys)
+  | TyArrow (in_, out) ->
+     group (
+         ((located may_paren_ty) in_
+         ++ string "->") ++ located may_paren_ty out)
+
+and may_paren_ty t =
+  match t with
+  | TyArrow _ -> parens (ty t)
+  | _ -> ty t
+
+and type_constructor (TCon s) =
+  string s
+
+and type_variable (TId x) =
+  string x
+
+and identifier (Id x) =
+  string x
+
+and is_infix s =
+  String.length s >= 2 && s.[0] = '`' && s.[String.length s - 1] = '`'
+
+and infix_operator s =
+  string (String.(sub s 1 (length s - 2)))
+
+and expression = function
+  | Literal l ->
+    located literal l
+
+  | Variable (x, tys) ->
+    located identifier x ^^ optional_type_instantiation tys
+
+  | TypeAnnotation (e, t) ->
+    parens (located expression e ++ group (string ":" ++ located ty t))
+
+  | Define (vdef, e2) ->
+    nest 2 (
+      group (value_definition true vdef ++ string ";"
+    ))
+    ^^ break 1 ^^ group (located expression e2)
+
+  | Fun (fdef) ->
+     string "\\"
+     ++ function_definition true (space ^^ string "->" ^^ break 1) fdef
+
+  | Record (ls, tys) ->
+    braces (separate_map (comma ^^ break 1) make_label ls)
+    ^^ optional_type_instantiation tys
+
+  | Apply ({ value = Apply ({ value = Variable ({ value = Id x; _ }, _); _ }, lhs); _ }, rhs)
+    when is_infix x ->
+     parens (located expression lhs ++ infix_operator x ++ located expression rhs)
+
+  | Apply (a, b) ->
+    group (
+      located may_paren_expression a
+      ++ located may_paren_expression b
+    )
+
+  | IfThenElse (c, t, e) ->
+    group (string "if" ++ guarded_expression (c, t))
+    ^^ else_expression e
+
+  | Tagged (k, ts, es) ->
+    group (
+        located dataconstructor k
+        ^^ optional_type_instantiation ts
+        ^^ (match es with
+            | [] ->
+               empty
+            | es ->
+               parens (
+                 separate_map (colon ^^ break 1) (located expression) es
+               ))
+      )
+
+  | Tuple es ->
+    group (
+        parens (
+            separate_map (colon ^^ break 1) (located expression) es
+      ))
+
+  | Case (e, bs) ->
+    group (
+      group (group (
+                 string "match"
+                 ++ parens (located expression e)) ++ string "{"
+             )
+      ++ group (separate_map (break 1) (located branch) bs)
+      ++ string "}"
+      )
+
+  | Field (e, l, ts) ->
+     located may_paren_expression e ^^ string "." ^^ located label l
+     ^^ optional_type_instantiation ts
+
+  | Sequence es ->
+     separate_map (semicolon ^^ break 1) (located may_paren_expression) es
+
+  | Ref e ->
+    string "ref" ++ located may_paren_expression e
+
+  | Assign (lhs, rhs) ->
+    group (located may_paren_expression lhs
+    ++ string ":="
+    ++ located expression rhs)
+
+  | Read e ->
+    group (parens (string "!" ++ located may_paren_expression e))
+
+  | While (e, b) ->
+    nest 2 (group (string "while" ++ parens (located expression e)
+                   ++ braces' (located expression b)))
+
+  | For (x, start, stop, e) ->
+     nest 2 (group (
+                 string "for"
+                 ++ located identifier x
+                 ++ string "from"
+                 ++ parens (located expression start)
+                 ++ string "to"
+                 ++ parens (located expression stop)
+                 ++ braces' (located expression e)))
+
+
+and delimit l r d =
+  surround 2 1 (!^ l) d (!^ r)
+
+and braces' d =
+  delimit "{" "}" d
+
+and make_label (l, e) =
+  located label l ++ string "=" ++ located expression e
+
+and guarded_expression (c, t) =
+  nest 2 (
+      parens (located expression c)
+      ^^ (break 1)
+      ^^ prefix 2 1 (!^ "then") (braces' (located expression t))
+  )
+
+and optional_type_instantiation = function
+  | None ->
+     empty
+  | Some tys ->
+     space
+     ^^ string "<"
+     ++ separate_map (comma ^^ break 1) (located may_paren_ty) tys
+     ++ string ">"
+
+and else_expression e =
+  break 1 ^^ prefix 2 1 (!^ "else") (braces' (located expression e))
+
+and function_type_arguments = function
+  | None ->
+    empty
+  | Some ts ->
+    angles (separate_map (break 1) (located ty) ts)
+
+and may_paren_under_if e = match e with
+  | IfThenElse _ ->
+    parens (expression e)
+  | _ ->
+    expression e
+
+and delimited = function
+  | Record _ | For _ | Variable _ | Tagged _ | Literal _
+  | While _ | Tuple _ | TypeAnnotation _ ->
+    (* Delimited expressions, no need to put parenthesis around.
+       Some inner sub-expressions may need parens, though *)
+    true
+  | Define _ | IfThenElse _ | Fun _ | Apply _ | Field _
+  | Ref _ | Read _ | Assign _ | Case _ | Sequence _ ->
+    false
+
+and may_paren_expression e =
+  if delimited e then expression e else parens (expression e)
+
+and if_paren_expression b e =
+  if b && not (delimited e) then parens (expression e) else expression e
+
+and branch (Branch (p, e)) =
+  group (nest 2 (group (string "|" ++ located pattern p ++ string "->")
+                 ++ located may_paren_expression e))
+
+and patterns ps =
+  parens (separate_map (comma ^^ break 1) (located pattern) ps)
+
+and pattern = function
+  | PWildcard ->
+    string "_"
+  | PVariable x ->
+    located identifier x
+  | PTypeAnnotation (p, t) ->
+    parens (located pattern p ++ string ":" ++ located ty t)
+  | PTaggedValue (k, tys, ps) ->
+     located dataconstructor k
+     ^^ optional_type_instantiation tys
+     ^^ (match ps with
+         | [] ->
+            empty
+         | ps ->
+            parens (separate_map (comma ^^ break 1) (located pattern) ps)
+         )
+  | PTuple ps ->
+     parens (separate_map (comma ^^ break 1) (located pattern) ps)
+  | PRecord (ls, tys) ->
+    braces (separate_map (comma ^^ break 1) label_pattern ls)
+    ++ optional_type_instantiation tys
+  | PAnd ps ->
+    parens
+      (separate_map (break 1 ^^ string "&" ^^ break 1) (located pattern) ps)
+  | POr ps ->
+    parens
+      (separate_map (break 1 ^^ string "|" ^^ break 1) (located pattern) ps)
+  | PLiteral l ->
+    located literal l
+
+and label_pattern (f, p) =
+  located label f ++ string "=" ++ located pattern p
+
+and literal = function
+  | LInt x ->
+    int x
+  | LChar c ->
+    char c
+  | LString s ->
+    string_literal s
+
+and char c =
+  group (string "'" ^^ string (Char.escaped c) ^^ string "'")
+
+and string_literal s =
+  group (string "\"" ^^ string (String.escaped s) ^^ string "\"")
+
+let to_string f x =
+  let b = Buffer.create 13 in
+  ToBuffer.pretty 0.8 80 b (group (f x));
+  Buffer.contents b

flap/src/hopix/hopixSyntacticSugar.mli

@@ -0,0 +1,26 @@
+open Position
+open HopixAST
+
+(** [fresh_identifier ()] returns a new fresh identifier each time it
+    is called. *)
+val fresh_identifier : unit -> identifier
+
+(** [make_multi_assignments [e1; ...; eN] [f1; ...; fN]] returns
+    an expression of the form:
+    [
+    let x_1 = f1 in
+    ...
+    let x_N = fN in
+    e1 := x1;
+    ...
+    eN := xN
+    ] *)
+val make_multi_assignments
+  : expression located list -> expression located list -> expression
+
+(** [make_delayed_computation e] returns an expression of the form:
+
+    [ \() => e ]
+
+*)
+val make_delayed_computation : expression located -> expression

flap/src/hopix/hopixTypechecker.ml

@@ -0,0 +1,102 @@
+(** This module implements a bidirectional type checker for Hopix. *)
+
+open HopixAST
+
+(** Error messages *)
+
+let invalid_instantiation pos given expected =
+  HopixTypes.type_error pos (
+      Printf.sprintf
+        "Invalid number of types in instantiation: \
+         %d given while %d were expected." given expected
+    )
+
+let check_equal_types pos ~expected ~given =
+  if expected <> given
+  then
+    HopixTypes.(type_error pos
+                  Printf.(sprintf
+                            "Type mismatch.\nExpected:\n  %s\nGiven:\n  %s"
+                            (string_of_aty expected)
+                            (string_of_aty given)))
+
+(** Linearity-checking code for patterns *)
+
+let rec check_pattern_linearity
+        : identifier list -> pattern Position.located -> identifier list
+  = fun vars Position.{ value; position; } ->
+  failwith "Students! This is your job!"
+
+(** Type-checking code *)
+
+let check_type_scheme :
+      HopixTypes.typing_environment ->
+      Position.t ->
+      HopixAST.type_scheme ->
+      HopixTypes.aty_scheme * HopixTypes.typing_environment
+  = fun env pos (ForallTy (ts, ty)) ->
+  failwith "Students! This is your job!"
+
+let synth_literal : HopixAST.literal -> HopixTypes.aty =
+  fun l ->
+  failwith "Students! This is your job!"
+
+let rec check_pattern :
+          HopixTypes.typing_environment ->
+          HopixAST.pattern Position.located ->
+          HopixTypes.aty ->
+          HopixTypes.typing_environment
+  = fun env Position.({ value = p; position = pos; } as pat) expected ->
+  failwith "Students! This is your job!"
+
+and synth_pattern :
+      HopixTypes.typing_environment ->
+      HopixAST.pattern Position.located ->
+      HopixTypes.aty * HopixTypes.typing_environment
+  = fun env Position.{ value = p; position = pos; } ->
+  failwith "Students! This is your job!"
+
+let rec synth_expression :
+      HopixTypes.typing_environment ->
+      HopixAST.expression Position.located ->
+      HopixTypes.aty
+  = fun env Position.{ value = e; position = pos; } ->
+  failwith "Students! This is your job!"
+
+and check_expression :
+      HopixTypes.typing_environment ->
+      HopixAST.expression Position.located ->
+      HopixTypes.aty ->
+      unit
+  = fun env (Position.{ value = e; position = pos; } as exp) expected ->
+  failwith "Students! This is your job!"
+
+and check_value_definition :
+      HopixTypes.typing_environment ->
+      HopixAST.value_definition ->
+      HopixTypes.typing_environment
+  = fun env def ->
+  failwith "Students! This is your job!"
+
+let check_definition env = function
+  | DefineValue vdef ->
+     check_value_definition env vdef
+
+  | DefineType (t, ts, tdef) ->
+     let ts = List.map Position.value ts in
+     HopixTypes.bind_type_definition (Position.value t) ts tdef env
+
+  | DeclareExtern (x, tys) ->
+     let tys, _ = Position.located_pos (check_type_scheme env) tys in
+     HopixTypes.bind_value (Position.value x) tys env
+
+let typecheck env program =
+  List.fold_left
+    (fun env d -> Position.located (check_definition env) d)
+    env program
+
+type typing_environment = HopixTypes.typing_environment
+
+let initial_typing_environment = HopixTypes.initial_typing_environment
+
+let print_typing_environment = HopixTypes.string_of_typing_environment

flap/src/hopix/hopixTypes.ml

@@ -0,0 +1,493 @@
+open HopixAST
+open HopixASTHelper
+
+let type_error = Error.error "typechecking"
+
+type variable = type_variable
+
+type aty =
+  | ATyVar   of type_variable
+  | ATyCon   of type_constructor * aty list
+  | ATyTuple of aty list
+  | ATyArrow of aty * aty
+
+let make_fresh_name_generator () =
+  let r = ref (-1) in
+  let mangle () =
+    if !r > 26 then
+      "a" ^ string_of_int !r
+    else
+      String.make 1 (Char.(chr (code 'a' + !r)))
+  in
+  fun () ->
+  incr r; TId ("`" ^ mangle ())
+
+let fresh = make_fresh_name_generator ()
+
+let rec hprod_destruct = function
+  | ATyTuple tys -> List.(flatten (map hprod_destruct tys))
+  | ty -> [ty]
+
+let hprod tys =
+  ATyTuple (List.(flatten (map hprod_destruct tys)))
+
+let rec aty_of_ty = function
+  | TyVar x            -> ATyVar x
+  | TyCon (t, ts)      -> ATyCon (t, List.map aty_of_ty' ts)
+  | TyArrow (ins, out) -> ATyArrow (aty_of_ty' ins, aty_of_ty' out)
+  | TyTuple ins        -> hprod (List.map aty_of_ty' ins)
+
+and aty_of_ty' x = aty_of_ty (Position.value x)
+
+let pretty_print_aty bound_vars aty =
+  let fresh = make_fresh_name_generator () in
+  let r = ref [] in
+  let print_var =
+    fun x ->
+    (if not (List.mem x bound_vars) then
+       x
+     else try
+         List.assoc x !r
+       with Not_found ->
+         let y = fresh () in
+         r := (x, y) :: !r;
+         y
+    ) |> function (TId x) -> x
+  in
+  let rec print_aty = function
+    | ATyVar x ->
+       print_var x
+    | ATyArrow (ins, out) ->
+       let ins = print_aty' ins in
+       let out = print_aty' out in
+       ins ^ " -> " ^ out
+    | ATyTuple tys ->
+       String.concat " * " (List.map print_aty' tys)
+    | ATyCon (TCon x, []) ->
+       x
+    | ATyCon (TCon x, ts) ->
+       x ^ "<" ^ String.concat ", " (List.map print_aty' ts) ^ ">"
+  and print_aty' = function
+    | (ATyArrow (_, _)) as t -> "(" ^ print_aty t ^ ")"
+    | x -> print_aty x
+  in
+  let s = print_aty aty in
+  (s, !r)
+
+let string_of_aty aty = fst (pretty_print_aty [] aty)
+
+let tvar x =
+  ATyVar (TId x)
+
+let ( --> ) tys ty =
+  List.fold_left (fun ty aty -> ATyArrow (aty, ty)) ty (List.rev tys)
+
+exception NotAFunction
+
+let output_type_of_function = function
+  | ATyArrow (_, ty) -> ty
+  | _ -> raise NotAFunction
+
+let constant x = TCon x, ATyCon (TCon x, [])
+let tcunit,   hunit    = constant "unit"
+let tcbool,   hbool    = constant "bool"
+let tcint,    hint     = constant "int"
+let tcstring, hstring  = constant "string"
+let tcchar,   hchar    = constant "char"
+
+let tcref = TCon "mut"
+let href ty = ATyCon (tcref, [ty])
+
+exception NotAReference
+
+let type_error_wrong_shape shape pos given =
+  type_error pos
+    (Printf.sprintf
+       "This expression has type %s which should be a %s type."
+       (string_of_aty given)
+       shape)
+
+type 'res destruction_fun = Position.t -> aty -> 'res
+
+let destruct_function_type pos ty =
+  match ty with
+  | ATyArrow (dom, cod) ->
+     dom, cod
+  | given ->
+     type_error_wrong_shape "function" pos given
+
+let rec destruct_function_type_maximally pos = function
+  | ATyArrow (ins, out) ->
+     let ins', out = destruct_function_type_maximally pos out in
+     (ins :: ins', out)
+  | ty ->
+     ([], ty)
+
+let destruct_product_type pos ty =
+  match ty with
+  | ATyTuple tys ->
+     tys
+  | given ->
+     type_error_wrong_shape "product" pos given
+
+let destruct_constructed_type pos ty =
+  match ty with
+  | ATyCon (tc, tys) ->
+     tc, tys
+  | given ->
+     type_error_wrong_shape "constructed" pos given
+
+let destruct_reference_type pos ty =
+  match ty with
+  | ATyCon (tc, [ty]) when tc = tcref ->
+     ty
+  | given ->
+     type_error_wrong_shape "reference" pos given
+
+let rec occurs x = function
+  | ATyVar tv -> x = tv
+  | ATyCon (_, tys) -> List.exists (occurs x) tys
+  | ATyArrow (ins, out) -> List.exists (occurs x) [out; ins]
+  | ATyTuple tys -> List.exists (occurs x) tys
+
+let free_type_variables ty =
+  let rec aux accu = function
+    | ATyVar tv -> TypeVariableSet.add tv accu
+    | ATyCon (_, tys) -> aux' accu tys
+    | ATyArrow (ins, out) -> aux (aux accu out) ins
+    | ATyTuple tys -> aux' accu tys
+  and aux' accu tys = List.fold_left aux accu tys
+  in
+  aux TypeVariableSet.empty ty
+
+type aty_scheme = Scheme of type_variable list * aty
+
+let rec ty_of_aty' = function
+  | ATyVar tv ->
+     TyVar tv
+  | ATyCon (tycon, atys) ->
+     TyCon (tycon, List.map ty_of_aty atys)
+  | ATyArrow (atydom, atycod) ->
+     TyArrow (ty_of_aty atydom, ty_of_aty atycod)
+  | ATyTuple atys ->
+     TyTuple (List.map ty_of_aty atys)
+
+and ty_of_aty aty = Position.unknown_pos (ty_of_aty' aty)
+
+let type_scheme_of_aty_scheme (Scheme (bound, aty)) =
+  ForallTy (List.map Position.unknown_pos bound, ty_of_aty aty)
+
+let pp_aty_scheme atys =
+  HopixPrettyPrinter.type_scheme @@ type_scheme_of_aty_scheme atys
+
+let free_type_variables_scheme (Scheme (bound, aty)) =
+  let open TypeVariableSet in
+  diff (free_type_variables aty) (of_list bound)
+
+let mk_type_scheme ty =
+  Scheme (TypeVariableSet.elements @@ free_type_variables ty, ty)
+
+let monomorphic_type_scheme ty =
+  Scheme ([], ty)
+
+exception NotAMonotype
+
+let type_of_monotype = function
+  | Scheme ([], ty) -> ty
+  | _ -> raise NotAMonotype
+
+exception InvalidInstantiation of { expected : int; given : int; }
+
+let rec substitute phi = function
+  | ATyVar tv ->
+    (try List.assoc tv phi with Not_found -> ATyVar tv)
+  | ATyArrow (ins, out) ->
+    ATyArrow (substitute phi ins, substitute phi out)
+  | ATyCon (t, tys) ->
+    ATyCon (t, List.map (substitute phi) tys)
+  | ATyTuple tys ->
+     hprod (List.map (substitute phi) tys)
+
+let instantiate_type_scheme (Scheme (ts, ty)) types =
+  if List.(length ts <> length types) then
+    raise (InvalidInstantiation { expected = List.length ts;
+                                  given = List.length types; });
+  let substitution = List.combine ts types in
+  substitute substitution ty
+
+let refresh_type_scheme (Scheme (ts, ty)) =
+  let ts' = List.map (fun _ -> fresh ()) ts in
+  let phi = List.(map (fun (x, y) -> (x, ATyVar y)) (combine ts ts')) in
+  Scheme (ts', substitute phi ty)
+
+type type_information =
+  | Abstract
+  | Sum of constructor list
+  | Record of label list
+
+type typing_environment = {
+  values            : (identifier * aty_scheme) list;
+  constructors      : (constructor * aty_scheme) list;
+  destructors       : (label * aty_scheme) list;
+  type_constructors : (type_constructor * (int * type_information)) list;
+  type_variables    : type_variable list;
+}
+
+let pp_typing_environment env =
+  let open PPrint in
+  let pp_binding pp_id (x, tys) =
+    group (pp_id x ^^ space ^^ colon ^/^ pp_aty_scheme tys)
+  in
+  group @@ separate_map
+             (semi ^^ break 1)
+             (pp_binding HopixPrettyPrinter.identifier) env.values
+
+let free_type_variables_env_values { values; _ } =
+  List.fold_left
+    (fun free (_, tys) ->
+      TypeVariableSet.union free @@ free_type_variables_scheme tys)
+    TypeVariableSet.empty
+    values
+
+let generalize_type_scheme env aty =
+  let open TypeVariableSet in
+  let free_aty = free_type_variables aty in
+  let free_env = free_type_variables_env_values env in
+  Scheme (elements @@ diff free_aty free_env, aty)
+
+let diffdomain tenv tenv' =
+  let d =
+    List.fold_left (fun s (x, _) ->
+        if not (List.mem_assoc x tenv.values) then x :: s else s
+      ) [] tenv'.values
+  in
+  List.sort compare d
+
+type binding =
+  | Identifier of identifier
+  | TypeConstructor of type_constructor
+  | Constructor of constructor
+  | Label of label
+
+exception Unbound of Position.position * binding
+
+let string_of_binding = function
+  | Identifier (Id x) -> Printf.sprintf "identifier `%s'" x
+  | TypeConstructor (TCon t) -> Printf.sprintf "type constructor `%s'" t
+  | Constructor (KId k) -> Printf.sprintf "constructor `%s'" k
+  | Label (LId l) -> Printf.sprintf "label `%s'" l
+
+let check_well_formed_type pos env ty =
+  let rec aux = function
+    | ATyVar ((TId a) as x) ->
+       if not (List.mem x env.type_variables) then
+         type_error pos (
+             Printf.sprintf "Ill-formed type: unbound type variable %s." a
+           )
+    | ATyCon (tcon, atys) ->
+       (try
+          let (arity, _) = List.assoc tcon env.type_constructors in
+          List.iter aux atys;
+          if List.length atys <> arity then
+            type_error pos "Ill-formed type: invalid arity."
+        with Not_found ->
+             type_error pos "Ill-formed type: unbound type constructor.")
+
+    | ATyTuple tys ->
+       List.iter aux tys
+
+    | ATyArrow (ins, out) ->
+       aux ins;
+       aux out
+  in
+  aux ty
+
+let internalize_ty env ty =
+  let pos = Position.position ty in
+  let ty = Position.value ty in
+  let aty = aty_of_ty ty in
+  check_well_formed_type pos env aty;
+  aty
+
+let empty_typing_environment = {
+  values = [];
+  constructors = [];
+  type_constructors = [];
+  destructors = [];
+  type_variables = []
+}
+
+let print_tenv env =
+  Printf.sprintf "tvs: %s\n" (
+    String.concat ", " (List.map (fun (TId x) -> x) env.type_variables)
+  )
+
+let bind_type_variable pos env tv =
+  if List.mem tv env.type_variables then
+    type_error pos (
+        Printf.sprintf
+          "The type variable `%s' is already bound in the environment."
+          (HopixPrettyPrinter.(to_string type_variable tv))
+      );
+  { env with type_variables = tv :: env.type_variables }
+
+let bind_type_variables pos env ts =
+  List.fold_left (fun env t ->
+      bind_type_variable pos env t
+    ) env ts
+
+let is_type_variable_defined _ env tv =
+  List.mem tv env.type_variables
+
+let bind_value x scheme env = {
+  env with values = (x, scheme) :: env.values
+}
+
+type 'key type_scheme_lookup_fun =
+  Position.t -> 'key -> typing_environment -> aty_scheme
+
+let lookup_type_scheme_of_identifier pos x env =
+  try
+    List.assoc x env.values
+  with Not_found ->
+    raise (Unbound (pos, Identifier x))
+
+let make_pre_type_environment env ts x arity tdef =
+  let env = bind_type_variables Position.dummy env ts in
+  let type_constructors = (x, (arity, tdef)) :: env.type_constructors in
+  { env with type_constructors; constructors = [] }
+
+let bind_abstract_type x ts env =
+  let arity = List.length ts in
+  let type_constructors = (x, (arity, Abstract)) :: env.type_constructors in
+  { env with type_constructors }
+
+let bind_sum_type_definition x ts ds env =
+  let arity = List.length ts in
+  let constructors = List.map (fun (k, _) -> Position.value k) ds in
+  let pre_env = make_pre_type_environment env ts x arity (Sum constructors) in
+  let constructor_definition (k, tys) =
+    let atys = List.map (internalize_ty pre_env) tys in
+    let scheme =
+      Scheme (ts, atys --> ATyCon (x, List.map (fun v -> ATyVar v) ts))
+    in
+    (Position.value k, scheme)
+  in
+  let constructors = List.map constructor_definition ds @ env.constructors in
+  let type_constructors =
+    (x, (arity, Sum (List.map fst constructors))) :: env.type_constructors
+  in
+  { env with type_constructors; constructors }
+
+let bind_record_type_definition x ts fs env =
+  let arity = List.length ts in
+  let labels = List.map (fun (l, _) -> Position.value l) fs in
+  let pre_env = make_pre_type_environment env ts x arity (Record labels) in
+  let destructor_definition (l, ty) =
+    let aty = internalize_ty pre_env ty in
+    let scheme =
+      Scheme (ts, [ATyCon (x, List.map (fun v -> ATyVar v) ts)] --> aty)
+    in
+    (Position.value l, scheme)
+  in
+  let destructors = List.map destructor_definition fs @ env.destructors in
+  let type_constructors =
+    (x, (arity, Record labels)) :: env.type_constructors
+  in
+  { env with type_constructors; destructors }
+
+let bind_type_definition x ts td tenv =
+  match td with
+  | DefineSumType ks ->
+     bind_sum_type_definition x ts ks tenv
+  | DefineRecordType fs ->
+     bind_record_type_definition x ts fs tenv
+  | Abstract ->
+     bind_abstract_type x ts tenv
+
+let lookup_type_scheme_of_constructor pos k env =
+  try
+    List.assoc k env.constructors
+  with Not_found ->
+    raise (Unbound (pos, Constructor k))
+
+let lookup_type_scheme_of_label pos l env =
+  try
+    List.assoc l env.destructors
+  with Not_found ->
+    raise (Unbound (pos, Label l))
+
+let lookup_information_of_type_constructor pos ((TCon t) as tc) env =
+  try let _, info = List.assoc tc env.type_constructors in info
+  with Not_found ->
+    type_error pos Printf.(sprintf "Unbound type constructor %s." t)
+
+let lookup_fields_of_type_constructor pos ((TCon t) as tc) env =
+  match lookup_information_of_type_constructor pos tc env with
+  | Record fields -> fields
+  | _ -> type_error pos Printf.(sprintf "Type %s is not a record type." t)
+
+let lookup_type_constructor_of_label pos l env =
+  try
+    let label_type_definition (_, (_, d)) =
+      match d with
+      | Record labels -> List.mem l labels
+      | _ -> false
+    in
+    let (tycon, (arity, labels)) =
+      List.find label_type_definition env.type_constructors
+    in
+    let labels = match labels with Record ls -> ls | _ -> assert false in
+    (tycon, arity, labels)
+  with Not_found ->
+       raise (Unbound (pos, Label l))
+
+let initial_typing_environment () =
+  empty_typing_environment |>
+  List.fold_right (fun ti env -> bind_abstract_type ti [] env) [
+    tcunit; tcstring; tcchar; tcint; tcbool
+  ] |>
+  bind_abstract_type (TCon "mut") [TId "'a"]
+  |> List.fold_right (fun (x, s) env ->
+         bind_value (Id x) (mk_type_scheme s) env
+  ) [
+    "true",         hbool;
+    "false",        hbool;
+    "nothing"  ,    hunit;
+    "print_int",    [hint] --> hunit;
+    "print_string", [hstring] --> hunit;
+    "print",        [tvar "'a"] --> hunit;
+    "`||`",         [hbool; hbool] --> hbool;
+    "`&&`",         [hbool; hbool] --> hbool;
+    "`=?`",         [hint; hint] --> hbool;
+    "`<=?`",        [hint; hint] --> hbool;
+    "`>=?`",        [hint; hint] --> hbool;
+    "`<?`",         [hint; hint] --> hbool;
+    "`>?`",         [hint; hint] --> hbool;
+    "`+`",          [hint; hint] --> hint;
+    "`*`",          [hint; hint] --> hint;
+    "`-`",          [hint; hint] --> hint;
+    "`/`",          [hint; hint] --> hint;
+  ]
+
+let print_type_scheme (Scheme (ts, aty)) =
+  let sty, subst = pretty_print_aty ts aty in
+  let ts = List.(map (fun x -> assoc x subst) ts) in
+  let forall =
+    let type_variable (TId s) = s in
+    match ts with
+    | [] -> ""
+    | ts -> "[" ^ String.concat ", " (List.map type_variable ts) ^ "] "
+  in
+  forall ^ sty
+
+let string_of_declaration (Id x, s) =
+  x ^ " : " ^ print_type_scheme s
+
+let string_of_typing_environment tenv =
+  let excluded = initial_typing_environment () in
+  let values = List.filter (fun (x, _) ->
+    not (List.mem_assoc x excluded.values)
+  ) (List.rev tenv.values)
+  in
+  String.concat "\n" (List.map string_of_declaration values)

flap/src/hopix/hopixTypes.mli

@@ -0,0 +1,97 @@
+open HopixAST
+
+(** Abstract syntax for types.
+
+    The following internal syntax for types is the same as the one for
+    the types [ty] defined in {!HopixAST} except that all positions
+    have been erased.
+
+ *)
+type aty =
+  | ATyVar   of type_variable
+  | ATyCon   of type_constructor * aty list
+  | ATyTuple of aty list
+  | ATyArrow of aty * aty
+
+type aty_scheme = Scheme of type_variable list * aty
+
+val string_of_aty : aty -> string
+
+val monomorphic_type_scheme : aty -> aty_scheme
+
+val instantiate_type_scheme : aty_scheme -> aty list -> aty
+
+type 'res destruction_fun = Position.t -> aty -> 'res
+
+val destruct_function_type : (aty * aty) destruction_fun
+
+val destruct_function_type_maximally : (aty list * aty) destruction_fun
+
+val destruct_product_type : aty list destruction_fun
+
+val destruct_constructed_type : (type_constructor * aty list) destruction_fun
+
+val destruct_reference_type : aty destruction_fun
+
+type typing_environment
+
+val initial_typing_environment : unit -> typing_environment
+
+val string_of_typing_environment : typing_environment -> string
+
+val bind_type_variable :
+  Position.t -> typing_environment -> type_variable -> typing_environment
+
+val bind_type_variables :
+  Position.t -> typing_environment -> type_variable list -> typing_environment
+
+val internalize_ty : typing_environment -> ty Position.located -> aty
+
+type binding =
+  | Identifier of identifier
+  | TypeConstructor of type_constructor
+  | Constructor of constructor
+  | Label of label
+
+val string_of_binding : binding -> string
+
+exception Unbound of Position.position * binding
+
+exception InvalidInstantiation of { expected : int; given : int; }
+
+type 'key type_scheme_lookup_fun =
+  Position.t -> 'key -> typing_environment -> aty_scheme
+
+val lookup_type_scheme_of_constructor : constructor type_scheme_lookup_fun
+
+val lookup_type_scheme_of_label : label type_scheme_lookup_fun
+
+val lookup_type_scheme_of_identifier : identifier type_scheme_lookup_fun
+
+val lookup_type_constructor_of_label
+    : Position.t -> label -> typing_environment ->
+      type_constructor * int * label list
+
+val lookup_fields_of_type_constructor
+    : Position.t -> type_constructor -> typing_environment -> label list
+
+val bind_value
+    : identifier -> aty_scheme -> typing_environment -> typing_environment
+
+val bind_type_definition
+    : type_constructor -> type_variable list -> type_definition
+      -> typing_environment -> typing_environment
+
+val type_error : Position.t -> string -> 'a
+
+val hunit : aty
+val hint : aty
+val hbool : aty
+val hstring : aty
+val hchar : aty
+val hprod : aty list -> aty
+val href : aty -> aty
+
+val generalize_type_scheme : typing_environment -> aty -> aty_scheme
+
+val string_of_typing_environment : typing_environment -> string

flap/src/options.ml

@@ -0,0 +1,80 @@
+(** Options *)
+
+open ExtStd
+
+let error msg =
+  Error.global_error
+    "during analysis of options"
+    msg
+
+let make_string_option what kind =
+  let language = ref "" in
+  let get () =
+    if !language = "" then
+      error (Printf.sprintf "You should specify the %s %s using '--%s'."
+               kind what kind);
+    !language
+  in
+  let set = ( := ) language in
+  let is_set () = !language <> "" in
+  get, set, is_set
+
+let (get_source_language, set_source_language, is_source_language_set) =
+  make_string_option "language" "source"
+
+let (get_target_language, set_target_language, is_target_language_set) =
+  make_string_option "language" "target"
+
+type mode = Interactive | Batch
+
+let mode = ref Batch
+
+let set_mode = ( := ) mode
+
+let get_mode () = !mode
+
+let (get_input_filename, set_input_filename, is_input_filename_set) =
+  make_string_option "filename" "input"
+
+let using : string list ref = ref []
+let insert_using x = using := x :: !using
+let get_using () = !using
+
+let set_interactive_mode = function
+  | true -> set_mode Interactive
+  | false -> set_mode Batch
+
+let set_running_mode, get_running_mode = Ref.as_functions false
+let set_verbose_mode, get_verbose_mode = Ref.as_functions false
+let set_dry_mode, get_dry_mode         = Ref.as_functions false
+let set_benchmark, get_benchmark       = Ref.as_functions false
+let set_unsafe, get_unsafe             = Ref.as_functions false
+let set_show_types, get_show_types     = Ref.as_functions false
+let set_infer_types, get_infer_types   = Ref.as_functions false
+let set_check_types, get_check_types   = Ref.as_functions true
+let set_verbose_eval, get_verbose_eval = Ref.as_functions false
+let set_use_sexp_in, get_use_sexp_in   = Ref.as_functions false
+let set_use_sexp_out, get_use_sexp_out = Ref.as_functions false
+let set_scripts_dir, get_scripts_dir   = Ref.as_functions "/bin"
+let set_include_dir, get_include_dir   = Ref.as_functions "/usr/include"
+let set_output_file, get_output_file   = Ref.as_functions ""
+let set_fast_match, get_fast_match     = Ref.as_functions false
+let set_backend, get_backend           = Ref.as_functions "x86-64"
+let set_regalloc, get_regalloc         = Ref.as_functions "naive"
+let set_debug_mode, get_debug_mode     = Ref.as_functions false
+let set_print_locs, get_print_locs     = Ref.functions_of_ref Error.print_locs
+
+let get_architecture () : (module Architecture.S) =
+  match get_backend () with
+  | "x86-64" -> (module X86_64_Architecture)
+  | s -> error (Printf.sprintf "`%s' is not a valid architecture." s)
+
+type regalloc_variant = Naive | Realistic
+
+let get_regalloc_variant () =
+  match get_regalloc () with
+    | "naive" -> Naive
+    | "realistic"  -> Realistic
+    | s -> error (
+      Printf.sprintf "`%s' is not a valid register allocation strategy." s
+    )

flap/src/retrolix/fopixToRetrolix.ml

@@ -0,0 +1,404 @@
+(** This module implements a compiler from Fopix to Retrolix. *)
+
+(**
+
+    Here are the two main problems to be solved.
+
+    1. Fopix has complex expressions while Retrolix has only atomic
+   instructions. In addition, in Fopix, scopes can arbitrarily nested
+   while Retrolix has only one scope per function.
+
+    2. Fopix is independent from the calling conventions of the target
+   architecture while Retrolix is not. In particular, hardware registers
+   are used in Retrolix to pass the first arguments to a function while
+   in Fopix there is no such mechanism.
+
+*)
+
+let error pos msg =
+  Error.error "compilation" pos msg
+
+(** As in any module that implements {!Compilers.Compiler}, the source
+    language and the target language must be specified. *)
+module Source = Fopix
+module Target = Retrolix
+module S = Source.AST
+module T = Target.AST
+
+(** We are targetting the X86_64_Architecture. *)
+module Arch = X86_64_Architecture
+
+(** The compilation environment stores the list of global
+    variables (to compute local variables) and a table
+    representing a renaming (for alpha-conversion). *)
+type environment = T.IdSet.t * (S.identifier * S.identifier) list
+
+(** Initially, the environment is empty. *)
+let initial_environment () = (T.IdSet.empty, [])
+
+(** [fresh_label ()] returns a new identifier for a label. *)
+let fresh_label =
+  let c = ref 0 in
+  fun () -> incr c; T.Label ("l" ^ string_of_int !c)
+
+(** [fresh_label ()] returns a new identifier for a variable. *)
+let fresh_variable =
+  let c = ref 0 in
+  fun () -> incr c; T.(Id ("X" ^ string_of_int !c))
+
+(** [translate' p env] turns a Fopix program [p] into a Retrolix
+    program using [env] to retrieve contextual information. *)
+let rec translate' p env =
+  (** The global variables are extracted in a first pass. *)
+  let (globals, renaming) = env in
+  let globals = List.fold_left get_globals globals p in
+  let env = (globals, renaming) in
+  (** Then, we translate Fopix declarations into Retrolix declarations. *)
+  let defs = List.map (declaration globals) p in
+  (defs, env)
+
+and identifier (S.Id x) =
+  T.Id x
+
+and register r =
+  T.((`Register (RId (Arch.string_of_register r)) : lvalue))
+
+and get_globals env = function
+  | S.DefineValue (x, _) ->
+    push env x
+  | _ ->
+    env
+
+and push env x =
+  T.IdSet.add (identifier x) env
+
+and declaration env = T.(function
+  | S.DefineValue (S.Id x, e) ->
+    let x = Id x in
+    let ec = expression (`Variable x) e in
+    let locals = locals env ec in
+    DValues ([x], (locals, ec @ [labelled T.Ret]))
+
+  | S.DefineFunction (S.FunId f, xs, e) ->
+    Target.AST.(
+      let in_registers_arguments, _, remaining = Arch.(
+        ExtStd.List.asymmetric_map2
+          (fun r x ->
+            labelled (Assign (`Variable (identifier x),
+                              Copy,
+                              [(register r :> rvalue)])))
+          argument_passing_registers
+          xs
+      )
+      in
+      let save_registers, restore_registers = List.(
+          if Options.(get_regalloc_variant () = Realistic) then
+            split (
+                List.map (fun r ->
+                    let x = `Variable (fresh_variable ()) in
+                    let r = register r in
+                    labelled (Assign (x, Copy, [(r :> rvalue)])),
+                    (fun () -> labelled (Assign (r, Copy, [x])))
+                  ) Arch.allocable_callee_saved_registers)
+          else ([], []))
+      in
+      let return =
+        labelled Ret
+      in
+      let prolog =
+        in_registers_arguments
+        @ save_registers
+      in
+      let postlog =
+        (List.map (fun f -> f ()) restore_registers) @
+        [return]
+      in
+      let function_body =
+        let x = `Variable (fresh_variable ()) in
+        expression x e @ [
+          labelled (Assign (register Arch.return_register, Copy, [x]))
+        ]
+      in
+      let ec = prolog @ function_body @ postlog in
+      let remaining = List.map identifier remaining in
+      let locals = locals env ec in
+      let locals = List.filter (fun x -> not (List.mem x remaining)) locals in
+      DFunction (FId f, remaining, (locals, ec))
+    )
+
+  | S.ExternalFunction (S.FunId f, _) ->
+    DExternalFunction (FId f)
+)
+(** [expression out e] compiles [e] into a block of Retrolix
+    instructions that stores the evaluation of [e] into [out]. *)
+and expression out = T.(function
+  | S.Literal l ->
+    [labelled (Assign (out, Copy, [ `Immediate (literal l) ]))]
+
+  | S.Variable (S.Id "true") ->
+     expression out (S.(Literal (LInt (Mint.one))))
+
+  | S.Variable (S.Id "false") ->
+     expression out (S.(Literal (LInt (Mint.zero))))
+
+  | S.Variable (S.Id x) ->
+    [labelled (Assign (out, Copy, [ `Variable (Id x) ]))]
+
+  | S.Define (S.Id x, e1, e2) ->
+    (** Hey student! The following code is wrong in general,
+        hopefully, you will implement [preprocess] in such a way that
+        it will work, right? *)
+    expression (`Variable (Id x)) e1 @ expression out e2
+
+  | S.While (c, e) ->
+     let tc = expression out e in
+     let l = fresh_label () in
+     let cc = condition (first_label tc) l c in
+     cc @ tc @ [labelled (Jump (first_label cc))]
+     @ [l, Comment "Exit of while loop"]
+
+  | S.IfThenElse (c, t, f) ->
+    let tc = expression out t
+    and fc = expression out f in
+    let l = fresh_label () in
+    condition (first_label tc) (first_label fc) c
+    @ tc
+    @ [labelled (Jump l) ]
+    @ fc
+    @ [l, Comment "Join control point"]
+
+  | S.FunCall (S.FunId "`&&`", [e1; e2]) ->
+     expression out (S.(IfThenElse (e1, e2, Variable (Id "false"))))
+
+  | S.FunCall (S.FunId "`||`", [e1; e2]) ->
+     expression out (S.(IfThenElse (e1, Variable (Id "true"), e2)))
+
+  | S.FunCall (S.FunId f, es) when is_binop f ->
+    assign out (binop f) es
+
+  | S.FunCall (S.FunId f, _) as e when is_condition f ->
+    expression out (S.(
+      IfThenElse (e, Literal (LInt Mint.one), Literal (LInt Mint.zero)))
+    )
+
+  | S.FunCall (S.FunId f, actuals) ->
+    call None (`Immediate (LFun (FId f))) actuals out
+
+  | S.UnknownFunCall (ef, actuals) ->
+    let f, ef = as_rvalue ef in
+    ef @ (call None f actuals out)
+
+  | S.Switch (e, cases, default) ->
+    let f, ef = as_rvalue e in
+    let l = fresh_label () in
+    let cases = Array.to_list cases in
+    let ldefault, cdefault =
+      match default with
+      | None -> None, []
+      | Some e -> let l, le = expression_block l out e in (Some l, le)
+    in
+    let branch lces = function
+      | None -> (match ldefault with
+                 | None -> assert false (* By exhaustiveness. *)
+                 | Some l -> (lces, l))
+      | Some e ->
+         let (l, lces') = expression_block l out e in
+         (lces @ lces', l)
+    in
+    let lces, lcases = ExtStd.List.foldmap branch cdefault cases in
+    ef @ [
+      labelled (T.Switch (f, Array.of_list lcases, ldefault))
+    ]
+    @ lces
+    @ [(l, Comment "Join control point")]
+)
+
+and expression_block l out (e : S.expression) =
+  let lstart = fresh_label () in
+  let ec = expression out e in
+  (lstart, [(lstart, T.Comment "Start block")] @ ec @ [labelled (T.Jump l)])
+
+and call tail =
+  match tail with
+    | None ->
+      normal_call
+    | Some _ ->
+      failwith "Not implemented yet"
+
+and push_input_arguments actuals =
+  let xs, es = List.(split (map as_rvalue actuals)) in
+  (** The first four arguments are passed to a0 ... a3. *)
+  let in_registers_arguments, _, remaining = Arch.(
+    ExtStd.List.asymmetric_map2
+      (fun r x ->
+        labelled (Target.AST.(Assign (`Register (RId (string_of_register r)),
+                                      Copy,
+                                      [x]))))
+      argument_passing_registers
+      xs
+  )
+  in
+  (List.flatten es @ in_registers_arguments, remaining)
+
+and normal_call f actuals out = Target.AST.(
+  (** Implementing calling conventions. *)
+  let _save_registers, _restore_registers = List.(
+      map (fun r ->
+          let x = `Variable (fresh_variable ()) in
+          let r = register r in
+          labelled (Assign (x, Copy, [(r :> rvalue)])),
+          (fun () -> labelled (Assign (r, Copy, [x])))
+      ) Arch.caller_saved_registers |> split)
+  in
+  let in_registers_arguments, remaining = push_input_arguments actuals in
+  let result_register = register Arch.return_register in
+  let get_result =
+    labelled (
+      Assign (out, Copy, [ (result_register :> rvalue)])
+    )
+  in
+  in_registers_arguments
+  @ [(labelled (Target.AST.Call (f, remaining, false)))]
+  @ [get_result]
+)
+
+and as_rvalue e =
+  let x = `Variable (fresh_variable ()) in
+  (x, expression x e)
+
+and as_rvalues rs f =
+  let xs, es = List.(split (map as_rvalue rs)) in
+  List.flatten es @ f xs
+
+and assign out op rs =
+  as_rvalues rs (fun xs ->
+    [labelled (T.Assign (out, op, xs))]
+  )
+
+and condition lt lf c =
+T.(match c with
+  | S.FunCall (S.FunId "`&&`", [a; b]) ->
+     let lta = fresh_label () in
+     condition lta lf a
+     @ [ (lta, Comment "Left-hand-side of conjunction is true.") ]
+     @ condition lt lf b
+
+  | S.FunCall (S.FunId "`||`", [a; b]) ->
+     let lfa = fresh_label () in
+     condition lt lfa a
+     @ [ (lfa, Comment "Left-hand-side of disjunction is false.") ]
+     @ condition lt lf b
+
+  | S.FunCall (S.FunId f, [a; b]) when is_condition f ->
+     as_rvalues [a; b] @@ fun args -> [
+       labelled (ConditionalJump (condition_op f, args, lt, lf))
+     ]
+  | c ->
+     let x = fresh_variable () in
+     expression (`Variable x) c
+     @ [ labelled (ConditionalJump (EQ, [ `Variable x;
+                                          `Immediate (LInt (Mint.of_int 0)) ],
+                                    lf,
+                                    lt))]
+)
+
+and first_label = function
+  | [] -> assert false
+  | (l, _) :: _ -> l
+
+and labelled i =
+  (fresh_label (), i)
+
+and literal = T.(function
+  | S.LInt x ->
+    LInt x
+  | S.LFun (S.FunId f) ->
+    LFun (FId f)
+  | S.LChar c ->
+    LChar c
+  | S.LString s ->
+    LString s
+)
+
+and is_binop = function
+  | "`+`" | "`-`" | "`*`" | "`/`" -> true
+  | _ -> false
+
+and binop = T.(function
+  | "`+`" -> Add
+  | "`-`" -> Sub
+  | "`*`" -> Mul
+  | "`/`" -> Div
+  | _ -> assert false (* By [is_binop] *)
+)
+
+and is_condition = function
+  | "`<?`" | "`>?`" | "`=?`" | "`<=?`" | "`>=?`" -> true
+  | _ -> false
+
+and condition_op = T.(function
+  | "`<?`" -> LT
+  | "`>?`" -> GT
+  | "`<=?`" -> LTE
+  | "`>=?`" -> GTE
+  | "`=?`" -> EQ
+  | _ -> assert false
+)
+
+let fresh_name =
+  let c = ref 0 in
+  fun (S.Id x) -> incr c; S.Id (x ^ string_of_int !c)
+
+let rec preprocess p (globals, renaming) =
+  let renaming, p = ExtStd.List.foldmap declaration renaming p in
+  (p, (globals, renaming))
+
+and rename renaming x =
+  let y = fresh_name x in
+  ((x, y) :: renaming, y)
+
+and declaration renaming = S.(function
+  | DefineValue (x, e) ->
+    let renaming, x' = rename renaming x in
+    (renaming, DefineValue (x', expression renaming e))
+
+  | DefineFunction (f, xs, e) ->
+    let renaming', xs = ExtStd.List.foldmap rename renaming xs in
+    (renaming, DefineFunction (f, xs, expression renaming' e))
+
+  | ExternalFunction (f, n) ->
+    (renaming, ExternalFunction (f, n))
+)
+and expression renaming = S.(function
+  | Variable x ->
+    Variable (try List.assoc x renaming with Not_found -> x)
+  | Define (x, e1, e2) ->
+    let renaming, x' = rename renaming x in
+    Define (x',
+            expression renaming e1,
+            expression renaming e2)
+  | FunCall (f, es) ->
+    FunCall (f, List.map (expression renaming) es)
+  | IfThenElse (e1, e2, e3) ->
+    IfThenElse (expression renaming e1,
+                expression renaming e2,
+                expression renaming e3)
+  | UnknownFunCall (f, es) ->
+    UnknownFunCall (expression renaming f,
+                    List.map (expression renaming) es)
+  | Literal l ->
+     Literal l
+  | While (e, s) ->
+     While (expression renaming e, expression renaming s)
+  | Switch (e, es, d) ->
+     Switch (expression renaming e,
+             Array.map (Option.map (expression renaming)) es,
+             Option.map (expression renaming) d)
+)
+
+(** [translate p env] turns the fopix program [p] into a semantically
+    equivalent retrolix program. *)
+let translate p env =
+  let p, env = preprocess p env in
+  let p, env = translate' p env in
+  (p, env)

flap/src/retrolix/retrolix.ml

@@ -0,0 +1,33 @@
+(** The retrolix programming language. *)
+
+module AST = RetrolixAST
+
+let name = "retrolix"
+
+type ast =
+    RetrolixAST.t
+
+let parse lexer_init input =
+  SyntacticAnalysis.process
+    ~lexer_init
+    ~lexer_fun:RetrolixLexer.token
+    ~parser_fun:RetrolixParser.program
+    ~input
+
+let parse_filename filename =
+  parse Lexing.from_channel (open_in filename)
+
+let extension =
+  ".retrolix"
+
+let executable_format =
+  false
+
+let parse_string =
+  parse Lexing.from_string
+
+let print_ast ast =
+  ExtPPrint.to_string RetrolixPrettyPrinter.program ast
+
+include RetrolixInterpreter
+include RetrolixTypechecker

flap/src/retrolix/retrolixAST.ml

@@ -0,0 +1,180 @@
+(** The abstract syntax tree for retrolix programs. *)
+
+(**
+
+   Retrolix is a "Register-Transfer-Language" inspired by one of the
+   intermediate languages of Compcert, a certified compiler for C.
+
+   Retrolix is an idealized low-level language for the target
+   architecture.
+
+   Contrary to standard assembly code, a program in Retrolix can
+   - define and call functions ;
+   - use an arbitrary number of local variables (also named pseudo-registers) ;
+   - refer to literals directly in instructions (no data segment).
+
+   Like assembly code, a program in Retrolix:
+   - has only access to very basic instructions ;
+   - can use hardware registers ;
+   - must follow the target architecture calling conventions regarding register
+     usage to pass function arguments and return ; and register values
+     preservation through function calls.
+
+   Retrolix is designed to express low-level optimizations in a
+   target-agnostic way. It is similar to LLVM's IR or GCC's GIMPLE
+   except that it is simplified for pedagogical purpose.
+
+*)
+
+type literal =
+  | LInt of Mint.t
+  | LFun of function_identifier
+  | LChar of char
+  | LString of string
+
+and identifier = Id of string
+
+and label = Label of string
+
+and function_identifier = FId of string
+
+type register = RId of string
+
+type lvalue = [ `Variable of identifier | `Register of register ]
+
+type rvalue = [ lvalue | `Immediate of literal ]
+
+type t = definition list
+
+and definition =
+  (** DValues (xs, b) is a block [b] that defines global variables [xs]. *)
+  | DValues    of identifier list * block
+  (** DFunction (f, xs, ys, b) is a function definition with formal
+      parameters [xs], and block [b]. *)
+  | DFunction  of function_identifier * identifier list * block
+  | DExternalFunction of function_identifier
+
+and block =
+    (** a block consists in a list of local variables and a list of
+        instructions. *)
+    identifier list * labelled_instruction list
+
+and labelled_instruction =
+    label * instruction
+
+and instruction =
+  (** call r (r1, ⋯, rN) tail *)
+  | Call of rvalue * rvalue list * bool
+  (** ret r *)
+  | Ret
+  (** l ← op r1, ⋯, rN *)
+  | Assign of lvalue * op * rvalue list
+  (** jump ℓ *)
+  | Jump of label
+  (** jumpif condition r1, r2 → ℓ1, ℓ2 *)
+  | ConditionalJump of condition * rvalue list * label * label
+  (** switch r -> l1, ..., lN orelse l. *)
+  | Switch of rvalue * label array * label option
+  (** ;; comment *)
+  | Comment of string
+  (** exit *)
+  | Exit
+
+and op =
+  | Copy
+  | Add | Mul | Div | Sub
+  | And | Or
+
+and condition =
+  | GT | LT | GTE | LTE | EQ
+
+(** We will need the following pieces of information to be carrying
+    along the translation: *)
+module IdCmp = struct
+  type t = identifier
+  let equal = (=)
+  let compare = compare
+  let print (Id s) = PPrint.string s
+  let hash = Hashtbl.hash
+end
+module IdSet = ExtStd.Set (IdCmp)
+module IdMap = ExtStd.Map (IdCmp)
+module IdHT = Hashtbl.Make (IdCmp)
+module FIdCmp = struct
+  type t = function_identifier
+  let compare = compare
+end
+module FIdSet = Set.Make (FIdCmp)
+module FIdMap = Map.Make (FIdCmp)
+module LabelCmp = struct
+  type t = label
+  let equal = (=)
+  let hash = Hashtbl.hash
+  let compare = compare
+  let print (Label s) = PPrint.string s
+end
+module LabelSet = ExtStd.Set (LabelCmp)
+module LabelMap = ExtStd.Map (LabelCmp)
+module LabelTab = Hashtbl.Make (LabelCmp)
+
+(**
+
+  In Retrolix, the toplevel value declarations define global
+  variables. The identifiers of these variables must be distinct.
+
+*)
+exception GlobalIdentifiersMustBeUnique of identifier
+
+(** [globals p] returns the global variables of the program [p]. It
+    checks that each definition is unique. *)
+let globals =
+  List.fold_left (fun globals -> function
+      | DValues (xs, _) ->
+         let add globals x =
+           if IdSet.mem x globals then
+             raise (GlobalIdentifiersMustBeUnique x);
+           IdSet.add x globals
+         in
+         List.fold_left add globals xs
+      | _ ->
+         globals
+  ) IdSet.empty
+
+(** [externals p] returns the extern functions of the program [p]. *)
+let externals =
+  List.fold_left (fun externals -> function
+      | DExternalFunction f ->
+         FIdSet.add f externals
+      | _ ->
+         externals
+  ) FIdSet.empty
+
+(**
+   Every function in Retrolix starts with a declaration
+   of local variables. So we need a way to compute the
+   local variables of some generated code. This is the
+   purpose of the next function.
+*)
+
+(** [locals globals b] takes a set of variables [globals] and returns
+    the variables use in the list of instructions [b] which are not
+    in [globals]. *)
+let locals globals b =
+IdSet.(
+  let unions = List.fold_left union empty in
+  let rec locals (_, i) =
+    match i with
+      | Call (r, rs, _) ->
+        unions ([rvalue r] @ List.map rvalue rs)
+      | Assign (l, _, rs) ->
+        unions (rvalue (l :> rvalue) :: List.map rvalue rs)
+      | ConditionalJump (_, rs, _, _) ->
+        unions (List.map rvalue rs)
+      | _ ->
+        empty
+  and rvalue = function
+    | `Variable x when not (IdSet.mem x globals) -> singleton x
+    | _ -> empty
+  in
+  elements (unions (List.map locals b))
+)

flap/src/retrolix/retrolixConstantFolding.ml

@@ -0,0 +1,83 @@
+open RetrolixAST
+open RetrolixUtils
+
+let activated = ref false
+
+module Source = Retrolix
+
+let shortname = "cf"
+
+let longname = "constant folding"
+
+(** {2 The Analysis Itself} *)
+
+module ConstantDomain =
+  struct
+    let global_variables = ref []
+
+    module D =
+      struct
+        type t =
+          | Bot
+          | Const of RetrolixAST.literal
+          | Top
+
+        let print x =
+          match x with
+          | Bot ->
+             PPrint.string "Bot"
+          | Const l ->
+             RetrolixPrettyPrinter.literal l
+          | Top ->
+             PPrint.string "Top"
+
+        let equal =
+          Stdlib.(=)
+
+        let compare =
+          Stdlib.compare
+
+        let le x y =
+             failwith "Student! This is your job!"
+
+        let bot =
+             failwith "Student! This is your job!"
+
+        let lub x y =
+             failwith "Student! This is your job!"
+      end
+
+    module DV = RetrolixDataflowUtils.PerLValueProperty(D)
+    include DV
+
+    (* This function sets to [Top] every lvalue that may have been modified by
+       an opaque function call: caller-saved registers, global variables. *)
+    let clobber_registers_and_globals x =
+         failwith "Student! This is your job!"
+
+
+    let transfer (lab, insn) x =
+       failwith "Student! This is your job!"
+  end
+
+module ConstantAnalysis = RetrolixDataflowEngines.Default(ConstantDomain)
+
+(** {2 Putting Everything Together} *)
+
+let error lab msg =
+  Printf.eprintf "%sundefined behavior (%s)\n"
+    (ExtPPrint.to_string (RetrolixPrettyPrinter.label 0) lab)
+    msg;
+  exit 1
+
+let analyze ((locals, _) as block) =
+     failwith "Student! This is your job!"
+
+
+let rewrite sol (lab, insn) =
+  let _, r = sol lab in
+     failwith "Students! This is your job!"
+
+let translate p =
+  ConstantDomain.global_variables := RetrolixUtils.global_variables p;
+  RetrolixUtils.transform_blocks analyze rewrite p

flap/src/retrolix/retrolixDataflowEngines.ml

@@ -0,0 +1,130 @@
+open RetrolixDataflowSigs
+
+open AST
+
+(** This module implements a slow and inefficient dataflow engine using a very
+    naive iteration strategy, with no acceleration at all. *)
+module Naive : ENGINE =
+  functor (D : DOMAIN) ->
+  struct
+    module D = D
+
+    module Edge = struct
+      type t = unit
+      let compare = Stdlib.compare
+      let print () = PPrint.empty
+    end
+
+    module FG = RetrolixDataflowUtils.FlowGraph(Edge)
+    open FG
+
+    type result = label -> (D.t * D.t)
+
+    let same_solution s1 s2 =
+      LabelMap.equal
+        (fun (x1, x2) (y1, y2) -> D.equal x1 y1 && D.equal x2 y2)
+        s1
+        s2
+
+    let input_of, output_of =
+      let get f sol v = f (LabelMap.find v.FG.Vertex.label sol) in
+      get fst, get snd
+
+    let join_input x v sol =
+      let x', y = LabelMap.find v.FG.Vertex.label sol in
+      LabelMap.add v.FG.Vertex.label (D.lub x x', y) sol
+
+    let join_output y v sol =
+      let (x, _) = LabelMap.find v.FG.Vertex.label sol in
+      LabelMap.add v.FG.Vertex.label (x, y) sol
+
+    let transfer dir gr sol =
+      let is_fwd = dir = `Forward in
+      let fold_outputs =
+        if is_fwd then G.fold_successors else G.fold_predecessors
+      in
+      let transfer_vertex v sol =
+        let y = D.transfer (v.Vertex.label, v.Vertex.insn) (input_of sol v) in
+        let sol = join_output y v sol in
+        fold_outputs
+          v.FG.Vertex.label
+          (fun out () -> join_input y out)
+          sol
+          gr.graph
+      in
+      G.fold_vertices transfer_vertex gr.graph sol
+
+    let analyze ?(init = `Input D.bot) ~direction block =
+      let gr = FG.flow_graph_of_block (fun () -> ()) block in
+      if Options.get_debug_mode () then
+        (
+          let fn = Filename.temp_file "cfg" ".dot" in
+          let oc = open_out fn in
+          FG.G.dump_graphviz gr.graph oc;
+          close_out oc;
+          Printf.printf "[dataflow] CFG stored in %s.\n" fn
+        );
+      let start =
+        let input_vertices =
+          LabelSet.of_list
+          @@ List.map FG.Vertex.label
+          @@ match direction with
+             | `Forward -> FG.G.initial_vertices gr.graph
+             | `Backward -> FG.G.terminal_vertices gr.graph
+        in
+        FG.G.fold_vertices
+          (fun v init_sol ->
+            let vl = FG.Vertex.label v in
+            let x =
+              match init with
+              | `Input x ->
+                 if LabelSet.mem vl input_vertices then x else D.bot
+              | `All f ->
+                 f vl
+            in
+            LabelMap.add vl (x, D.bot) init_sol)
+          gr.FG.graph
+          LabelMap.empty
+      in
+      let rec fix i current =
+        if Options.get_debug_mode () then
+          (
+            Printf.printf "[dataflow] Solution at iteration %d:\n" i;
+            ExtPPrint.to_channel
+              (LabelMap.print
+                 (fun (i, o) -> PPrint.OCaml.tuple [D.print i; D.print o])
+                 current)
+        );
+        let next = transfer direction gr current in
+        if same_solution current next then current else fix (i + 1) next
+      in
+      let res = fix 0 start in
+      fun lab -> LabelMap.find lab res
+  end
+
+(** This module implements a more efficient strategy involving a worklist and
+    iterative computation of the solution. *)
+module Worklist : ENGINE =
+  functor (D : DOMAIN) ->
+  struct
+    module D = D
+
+    module Edge = struct
+      type t = unit
+      let compare () () = 0
+      let print () = PPrint.empty
+    end
+
+    module FG = RetrolixDataflowUtils.FlowGraph(Edge)
+    open FG
+
+    type result = label -> (D.t * D.t)
+
+    let analyze ?(init = `Input D.bot) ~direction block =
+      let work = Queue.create () in
+      let dirty = LabelTab.create 100 in
+
+      failwith "Students! This is your job!"
+  end
+
+module Default : ENGINE = Naive

flap/src/retrolix/retrolixDataflowSigs.ml

@@ -0,0 +1,48 @@
+module AST = RetrolixAST
+
+(** A property is the result of a dataflow analysis. The set of properties
+   should form a semilattice, that is, be ordered, have a least element, and a
+   least upper bound operator. *)
+module type PROPERTY =
+  sig
+    (** The type of properties. *)
+    type t
+
+    val print : t -> PPrint.document
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+
+    (** The ordering relation of the semilattice. *)
+    val le : t -> t -> bool
+    (** The smallest element of the semilattice. *)
+    val bot : t
+    (** The least upper bound (or "join") of the semilattice. *)
+    val lub : t -> t -> t
+  end
+
+(** A domain provides a space of properties together with a transfer function
+   that specifies the semantics of an instruction w.r.t. to properties. *)
+module type DOMAIN =
+  sig
+    include PROPERTY
+    val transfer : AST.labelled_instruction -> t -> t
+  end
+
+(** An analysis provides a way to compute the result of a dataflow analysis for
+   the specified domain D. *)
+module type ANALYSIS =
+  sig
+    module D : DOMAIN
+
+    type result = AST.label -> (D.t * D.t)
+
+    val analyze :
+      ?init:[ `Input of D.t | `All of AST.label -> D.t ] ->
+      direction:[ `Forward | `Backward ] ->
+      AST.block ->
+      result
+  end
+
+(** An engine implements an algorithm turning a domain into an analysis for this
+   domain. *)
+module type ENGINE = functor (D : DOMAIN) -> ANALYSIS with module D = D

flap/src/retrolix/retrolixDataflowUtils.ml

@@ -0,0 +1,105 @@
+open RetrolixDataflowSigs
+
+module AST = RetrolixAST
+module Utils = RetrolixUtils
+module PP = RetrolixPrettyPrinter
+
+module PerLValueProperty (P : PROPERTY)
+       : PROPERTY with type t = P.t Utils.LValueMap.t = struct
+  type t = P.t Utils.LValueMap.t
+
+  let print m =
+    Utils.LValueMap.print P.print m
+
+  let equal =
+    Utils.LValueMap.equal P.equal
+
+  let compare =
+    Utils.LValueMap.compare P.compare
+
+  let le m1 m2 =
+    Utils.LValueMap.for_all
+      (fun k x ->
+        let y = try Utils.LValueMap.find k m2 with Not_found -> P.bot in
+        P.le x y)
+      m1
+
+  let bot =
+    Utils.LValueMap.empty
+
+  let lub m1 m2 =
+    let p_of_opt xo = match xo with None -> P.bot | Some x -> x in
+    let merge _ xo yo = Some (P.lub (p_of_opt xo) (p_of_opt yo)) in
+    Utils.LValueMap.merge merge m1 m2
+
+  let bot_lvalues lvs =
+    List.fold_left
+      (fun m lv -> Utils.LValueMap.add lv P.bot m)
+      Utils.LValueMap.empty
+      (lvs @ List.map RetrolixUtils.register X86_64_Architecture.all_registers)
+end
+
+module FlowGraph (Edge : Digraph.EDGE) = struct
+  open RetrolixAST
+
+  module Vertex = struct
+    type t =
+      {
+        label : label;
+        insn : instruction;
+      }
+
+    let print { label; insn; } =
+      RetrolixPrettyPrinter.labelled_instruction
+        RetrolixPrettyPrinter.nodecorations
+        0
+        (label, insn)
+
+    module Label = struct
+      type t = label
+      let compare = Stdlib.compare
+      let print = RetrolixPrettyPrinter.label 0
+    end
+
+    let label { label; _ } = label
+  end
+
+  module G = Digraph.Make(Edge)(Vertex)
+
+  type t =
+    {
+      initial : label;
+      locals : IdSet.t;
+      graph : G.t;
+    }
+
+  let flow_graph_of_block make_default_edge ((locals, insns) : block) =
+    let initial =
+      match insns with
+      | [] ->
+         failwith "flow_graph_of_block: empty block"
+      | (initial, _) :: _ ->
+         initial
+    in
+    let locals =
+      List.fold_left (fun locals id -> IdSet.add id locals) IdSet.empty locals
+    in
+    let graph =
+      List.fold_left
+        (fun graph (label, insn) -> G.add_vertex graph { label; insn; })
+        G.empty
+        insns
+    in
+    let graph =
+      let targets = RetrolixUtils.instruction_targets insns in
+      List.fold_left
+        (fun graph (src, _, ldsts) ->
+          List.fold_left
+            (fun graph dst -> G.add_edge graph ~src ~dst (make_default_edge ()))
+            graph
+            ldsts)
+        graph
+        targets
+    in
+    { initial; locals; graph; }
+end

flap/src/retrolix/retrolixDeadCodeElimination.ml

@@ -0,0 +1,63 @@
+open RetrolixAST
+open RetrolixUtils
+
+let activated = ref false
+
+module Source = Retrolix
+
+let shortname = "dce"
+
+let longname = "dead-code elimination"
+
+(** {2 The Analysis Itself} *)
+
+module LivenessDomain =
+  struct
+    type t = LValueSet.t
+
+    let print = LValueSet.print
+
+    let equal = LValueSet.equal
+
+    let compare = LValueSet.compare
+
+    let bot =
+         failwith "Students! This is your job!"
+
+    let le =
+         failwith "Students! This is your job!"
+
+    let lub =
+         failwith "Students! This is your job!"
+
+    let global_variables =
+      ref bot
+
+
+
+    let gen insn =
+      failwith "Students! This is your job!"
+
+    let kill insn =
+      failwith "Students! This is your job!"
+
+    let transfer (_, insn) liveout =
+      failwith "Students! This is your job!"
+  end
+
+module LivenessAnalysis = RetrolixDataflowEngines.Default(LivenessDomain)
+
+(** {2 Putting Everything Together} *)
+
+let analyze block =
+  failwith "Students! This is your job!"
+
+let rewrite sol (lab, insn) =
+     failwith "Students! This is your job!"
+
+let translate p =
+  LivenessDomain.global_variables :=
+    LValueSet.of_list
+    @@ List.map (fun v -> `Variable v)
+    @@ RetrolixUtils.global_variables p;
+  RetrolixUtils.transform_blocks analyze rewrite p

flap/src/retrolix/retrolixInitialization.ml

@@ -0,0 +1,7 @@
+open Optimizers
+
+(** Register some compilers that process Retrolix programs. *)
+let initialize () =
+  Languages.register (module Retrolix);
+  Compilers.(register (optimizing_compiler (module Identity (Retrolix))));
+  Compilers.(register (optimizing_compiler (module FopixToRetrolix)))

flap/src/retrolix/retrolixInterferenceGraph.ml

@@ -0,0 +1,79 @@
+open RetrolixAST
+open RetrolixLivenessAnalysis
+open RetrolixUtils
+
+(** Interference graph. *)
+
+(** In the interference graph, there will be two kinds of edges: *)
+type relation =
+  (** If two variables cannot be represented in the same register
+      because their liveness ranges intersect, we say that they are in
+      a conflict relation. *)
+  | Conflict
+
+  (** If two variables are related by a MOVE instruction, we will try
+      to put them in the same register, we say that they are in
+      a preference relation. *)
+  | Preference
+
+(** Interference graph. *)
+
+module EdgeLabel = struct
+  type t = relation
+  let compare = compare
+  let all = [Conflict; Preference]
+  let to_string = function Conflict -> "c" | Preference -> "p"
+end
+
+module NodeLabel = struct
+  type t = RetrolixAST.lvalue
+  let compare = compare
+  let to_string = RetrolixUtils.string_of_lvalue
+end
+
+module InterferenceGraph = Graph.Make (EdgeLabel) (NodeLabel)
+
+type t = InterferenceGraph.t
+
+(** [add_node g n] inserts [n] in [g] if it is not already there. *)
+let add_node g n =
+  try InterferenceGraph.add_node g [n]
+  with InterferenceGraph.InvalidNode -> g
+
+(** [add_relation g c n1 n2] creates an edge of kind [c] between [n1]
+   and [n2]. This function inserts [n1] and [n2] in [g] if needed.*)
+let add_relation g c n1 n2 =
+  assert (n1 <> n2);
+  let g = add_node g n1 in
+  let g = add_node g n2 in
+  InterferenceGraph.add_edge g n1 c n2
+
+(** [are_in_relation g c] is a predicate returning [true] if [n1]
+    and [n2] are in relation [c] in [g]. *)
+let are_in_relation g c n1 n2 =
+  InterferenceGraph.are_connected g n1 c n2
+
+(** The empty graph. *)
+let empty_graph = InterferenceGraph.empty
+
+(**
+
+   To construct the interference graph:
+
+   1. At any non-move instruction that defines variable a (where
+   live-out variables are b1, ..., bj) add interference edges (a, b1),
+   ..., (a, bj).
+
+   2. At a move instruction a ← c (where variables b1, ..., bj are
+   live-out) add interference edges (a, b1), ..., (a, bj) for any bi
+   that is not the same as c. Besides, add an preference edge (a, c)
+   if a and c are not in interference. Notice that interference
+   overrides preference: if a subsequel instruction implies an
+   interference between a and c, the preference relation is removed.
+
+   [forbidden] represents the list of global variables: they must not be
+   colorized. Hence, they more or less behave as the hardware registers.
+
+*)
+let interference_graph forbidden b liveness : t =
+   failwith "Student! This is your job!"

flap/src/retrolix/retrolixInterpreter.ml

@@ -0,0 +1,383 @@
+(** This module implements the interpreter of the Retrolix programming
+    language. *)
+
+open Error
+open RetrolixAST
+
+let error msg =
+  global_error "retrolix execution" msg
+
+(** ----------------------- *)
+(** {1 Runtime definition } *)
+(** ----------------------- *)
+
+(** This exception is raised to stop the machine. *)
+exception ExitNow
+
+type data =
+  | DUnit
+  | DInt   of Mint.t
+  | DBool of bool
+  | DString of string
+  | DChar of char
+  | DLocation of Memory.location
+  | DFun of function_identifier
+
+let print_data m data =
+  let max_depth = 5 in
+  let rec print_value d v =
+    if d >= max_depth then "..."
+    else match v with
+      | DUnit -> "()"
+      | DInt x -> Mint.to_string x
+      | DLocation l -> print_block (d + 1) l
+      | DFun (FId f) -> "@" ^ f
+      | DBool true -> "true"
+      | DBool false -> "false"
+      | DChar c -> "'" ^ Char.escaped c ^ "'"
+      | DString s -> "\"" ^ String.escaped s ^ "\""
+  and print_block d a =
+    let b = Memory.dereference m a in
+    let vs = Array.to_list (Memory.array_of_block b) in
+    "[ " ^ String.concat "; " (List.map (print_value d) vs) ^ " ]"
+  in
+  print_value 0 data
+
+let type_of = function
+  | DUnit -> "unit"
+  | DInt _ -> "int"
+  | DLocation _ -> "location"
+  | DFun _ -> "function_ptr"
+  | DChar _ -> "char"
+  | DString _ -> "string"
+  | DBool _ -> "bool"
+
+let coercion_error expectation v =
+  error ("Expecting " ^ expectation ^ " get " ^ type_of v)
+
+let as_int  = function DInt x -> x   | v -> coercion_error "int" v
+let as_loc  = function DLocation x -> x | v -> coercion_error "location" v
+let as_fun  = function DFun f -> f | v -> coercion_error "function_ptr" v
+
+let from_unit ()    = DUnit
+let from_int x      = DInt x
+let from_location x = DLocation x
+let from_fid x      = DFun x
+
+let is_intermediate (Id x) = (x.[0] = 'X')
+
+module IdMap = Map.Make (struct
+    type t = identifier
+    let compare = compare
+end)
+
+module RIdMap = Map.Make (struct
+    type t = register
+    let compare = compare
+end)
+
+module FIdMap = Map.Make (struct
+    type t = function_identifier
+    let compare = compare
+end)
+
+type runtime = {
+  gvariables     : data IdMap.t;
+  lvariables     : data IdMap.t;
+  registers      : data RIdMap.t;
+  mutable memory : data Memory.t;
+  functions      : function_definition FIdMap.t
+}
+
+and function_definition = {
+  formals : identifier list;
+  body : block;
+}
+
+type observable = {
+  new_variables : data IdMap.t
+}
+
+let initial_runtime () = {
+  gvariables = IdMap.empty;
+  lvariables = IdMap.empty;
+  registers  = RIdMap.empty;
+  memory     = Memory.create (640 * 1024);
+  functions  = FIdMap.empty;
+}
+
+let print_runtime runtime =
+  let idmap m =
+    String.concat "," (List.map (fun (Id s, v) ->
+      Printf.sprintf "%s = %s" s (print_data runtime.memory v)
+    ) (IdMap.bindings m))
+  in
+  let ridmap m =
+    String.concat "," (List.map (fun (RId s, v) ->
+      Printf.sprintf "%s = %s" s (print_data runtime.memory v)
+    ) (RIdMap.bindings m))
+  in
+  let gvariables = idmap
+  and lvariables = idmap
+  and registers = ridmap
+  in
+  Printf.sprintf "\
+  gvariables = %s\n\
+  lvariables = %s\n\
+  registers = %s\n\
+"
+    (gvariables runtime.gvariables)
+    (lvariables runtime.lvariables)
+    (registers runtime.registers)
+
+(** -------------------------- *)
+(** {1 Instruction execution } *)
+(** -------------------------- *)
+
+let evaluate runtime0 (ast : t) =
+  let extract_function_definition runtime = function
+    | DValues _ -> runtime
+    | DFunction (f, formals, body) ->
+      { runtime with functions =
+          FIdMap.add f { formals; body } runtime.functions
+      }
+    | DExternalFunction _ ->
+      runtime
+  in
+  let rec program runtime ds =
+    let runtime = List.fold_left extract_function_definition runtime ds in
+    List.fold_left definition runtime ds
+  and definition runtime = function
+    | DValues (xs, b) ->
+       let runtime =
+         { runtime with
+           gvariables = List.fold_left
+                          (fun gvariables x -> IdMap.add x DUnit gvariables)
+                          runtime.gvariables
+                          xs;
+         }
+       in
+       block runtime b
+    | DFunction _ ->
+      runtime
+    | DExternalFunction _ ->
+      runtime
+  and block runtime b =
+    let jump_table = Hashtbl.create 13 in
+    let rec make = function
+      | [(l, i)] ->
+        Hashtbl.add jump_table l (i, None)
+      | (l, i) :: ((l', _) :: _ as is) ->
+        Hashtbl.add jump_table l (i, Some l');
+        make is
+      | [] -> assert false
+    in
+    make (snd b);
+    let locals0 = runtime.lvariables in
+    let locals = fst b in
+    let start_label = fst (List.hd (snd b)) in
+    let start = Hashtbl.find jump_table start_label in
+    let runtime =
+      List.fold_left (fun r x ->
+          bind_local r x (DInt Mint.zero)
+        ) runtime locals
+    in
+    let runtime = instruction runtime jump_table start_label start in
+    { runtime with lvariables = locals0 }
+
+  and instruction runtime jump_table l (i, next) =
+    let jump l runtime =
+      if not (Hashtbl.mem jump_table l) then
+        let Label l = l in
+        failwith (Printf.sprintf "Label %s not found" l)
+      else
+        instruction runtime jump_table l (Hashtbl.find jump_table l)
+    in
+    let continue runtime =
+      match next with
+        | None -> runtime
+        | Some l -> jump l runtime
+    in
+    match i with
+      | Call (f, rs, _) ->
+         call runtime (rvalue runtime f) (List.map (rvalue runtime) rs)
+         |> continue
+      | Ret ->
+        runtime
+      | Assign (x, o, rs) ->
+        assign runtime x (op l runtime o (List.map (rvalue runtime) rs))
+        |> continue
+      | Jump l ->
+        jump l runtime
+      | ConditionalJump (c, rs, l1, l2) ->
+        if condition l c (List.map (rvalue runtime) rs) then
+          jump l1 runtime
+        else
+          jump l2 runtime
+      | Comment _ ->
+        continue runtime
+      | Switch (r, ls, default) ->
+        begin match rvalue runtime r with
+          | DInt x ->
+            let x = Mint.to_int x in
+            if  x < Array.length ls then
+              jump ls.(x) runtime
+            else
+              begin match default with
+                | None -> failwith "Non exhaustive switch."
+                | Some l -> jump l runtime
+              end
+          | _ ->
+            assert false (* By typing. *)
+        end
+      | Exit ->
+        runtime
+  and rvalue runtime = function
+    | `Variable x ->
+      (try
+         IdMap.find x runtime.lvariables
+       with Not_found ->
+         (try
+            IdMap.find x runtime.gvariables
+          with Not_found ->
+            let Id x = x in
+            failwith (Printf.sprintf "Variable %s not found" x)
+         )
+      )
+    | `Register x ->
+      (try
+         RIdMap.find x runtime.registers
+       with Not_found ->
+         DInt Mint.zero
+      )
+    | `Immediate l ->
+      literal l
+  and op _ _ o vs =
+    match o, vs with
+      | Copy, [ v ] -> v
+      | Add, [ DInt x; DInt y ] ->
+        DInt (Mint.add x y)
+      | Mul, [ DInt x; DInt y ] ->
+        DInt (Mint.mul x y)
+      | Div, [ DInt x; DInt y ] ->
+        DInt (Mint.div x y)
+      | Sub, [ DInt x; DInt y ] ->
+        DInt (Mint.sub x y)
+      | _, _ ->
+        assert false
+
+  and condition (Label l) op vs =
+    match op, vs with
+    | GT, [ DInt x1; DInt x2 ] -> x1 > x2
+    | LT, [ DInt x1; DInt x2 ] -> x1 < x2
+    | GTE, [ DInt x1; DInt x2 ] -> x1 >= x2
+    | LTE, [ DInt x1; DInt x2 ] -> x1 <= x2
+    | EQ, [ DInt x1; DInt x2 ] -> x1 = x2
+    | _,  vs ->
+       failwith (
+           Printf.sprintf "Line %s: Invalid comparison with %s\n"
+             l
+             (String.concat " " (List.map type_of vs))
+         )
+
+  and literal = function
+    | LInt x -> DInt x
+    | LFun f -> DFun f
+    | LString s -> DString s
+    | LChar c -> DChar c
+
+  and assign runtime lvalue v =
+    match lvalue with
+      | `Variable x ->
+        if IdMap.mem x runtime.lvariables then
+          { runtime with lvariables = IdMap.add x v runtime.lvariables }
+        else if IdMap.mem x runtime.gvariables then
+          { runtime with gvariables = IdMap.add x v runtime.gvariables }
+        else failwith "Assignment to an unbound variable."
+      | `Register x ->
+        { runtime with registers = RIdMap.add x v runtime.registers }
+
+  and call runtime fv vs =
+    match fv with
+      | DFun f ->
+         (try
+            let fdef = FIdMap.find f runtime.functions in
+            let runtime = List.fold_left2 bind_local runtime fdef.formals vs in
+            block runtime fdef.body
+          with Not_found ->
+            external_function runtime vs f
+         )
+      | _ ->
+        assert false
+
+  and external_function runtime vs (FId f) =
+    let module Arch : Architecture.S = (val Options.get_architecture ()) in
+    let mk_reg r = `Register (RId (Arch.string_of_register r)) in
+    let return value runtime = Arch.(
+      assign runtime (mk_reg return_register) value
+    )
+    in
+    let vs = Arch.(
+      List.(map (rvalue runtime) (map mk_reg argument_passing_registers))
+    ) @ vs
+    in
+    match f, vs with
+      | "allocate_block", (DInt size :: _) ->
+         let addr = Memory.allocate runtime.memory size (DInt Mint.zero) in
+         return (DLocation addr) runtime
+      | "write_block", (DLocation location :: DInt i :: v :: _) ->
+         let block = Memory.dereference runtime.memory location in
+         Memory.write block i v;
+         return DUnit runtime
+      | "read_block", (DLocation location :: DInt i :: _) ->
+         let block = Memory.dereference runtime.memory location in
+         return (Memory.read block i) runtime
+      | "equal_char", (DChar c1 :: DChar c2 :: _) ->
+         return (DInt (Int64.of_int (if c1 = c2 then 1 else 0))) runtime
+      | "equal_string", (DString s1 :: DString s2 :: _) ->
+         return (DInt (Int64.of_int (if s1 = s2 then 1 else 0))) runtime
+      | ("observe_int" | "print_int"), (DInt i :: _) ->
+         print_string (Mint.to_string i);
+         flush stdout;
+         return DUnit runtime
+      | "print_char", (DChar i :: _) ->
+         print_char i;
+         return DUnit runtime
+      | "print_string", (DString i :: _) ->
+         print_string i;
+         return DUnit runtime
+      | "add_eight_int",
+        (DInt i1 :: DInt i2 :: DInt i3 :: DInt i4
+         :: DInt i5 :: DInt i6 :: DInt i7 :: DInt i8 :: _) ->
+         let r =
+           List.fold_left Mint.add Mint.zero [i1; i2; i3; i4; i5; i6; i7; i8]
+         in
+         return (DInt r) runtime
+      | _ ->
+         Printf.eprintf
+           "NoSuchFunction or InvalidApplication of `%s' \
+            (%d argument(s) provided : %s)."
+           f
+           (List.length vs)
+           (String.concat " " (List.map type_of vs));
+         return DUnit runtime
+
+  and bind_local runtime x v =
+    { runtime with lvariables = IdMap.add x v runtime.lvariables }
+  in
+  let extract_observable runtime =
+    { new_variables =
+        IdMap.filter
+          (fun x _ -> not (IdMap.mem x runtime0.gvariables
+                           || is_intermediate x))
+          runtime.gvariables
+    }
+  in
+  let runtime = program runtime0 ast in
+  let observable = extract_observable runtime in
+  (runtime, observable)
+
+let print_observable runtime obs =
+  String.concat "\n" (List.map (fun (Id k, v) ->
+    Printf.sprintf "%s = %s" k (print_data runtime.memory v)
+  ) (IdMap.bindings obs.new_variables))

flap/src/retrolix/retrolixKillMove.ml

@@ -0,0 +1,23 @@
+(** This module removes all useless MOV in a program. *)
+
+open RetrolixAST
+
+(** [kill_moves p] produces a program [p] in which we have deleted
+    all the moves whose destination and source are equal. *)
+let kill_moves p =
+  let rec definition = function
+    | DValues (xs, b) ->
+      DValues (xs, block b)
+    | DFunction (f, xs, b) ->
+      DFunction (f, xs, block b)
+    | x ->
+      x
+  and block (locals, instructions) =
+    (locals, List.map (fun (l, i) -> (l, instruction i)) instructions)
+  and instruction = function
+    | Assign (x, Copy, [r]) when (x :> rvalue) = r ->
+      Comment "Killed move"
+    | i ->
+      i
+  in
+  List.map definition p

flap/src/retrolix/retrolixLexer.mll

@@ -0,0 +1,167 @@
+{ (* Emacs, use -*- tuareg -*- to open this file! *)
+  open Lexing
+  open Error
+  open Position
+  open RetrolixParser
+
+  let next_line_and f lexbuf  =
+    Lexing.new_line lexbuf;
+    f lexbuf
+
+  let error lexbuf =
+    error "during lexing" (lex_join lexbuf.lex_start_p lexbuf.lex_curr_p)
+
+  let string_buffer =
+    Buffer.create 13
+
+}
+
+let newline = ('\010' | '\013' | "\013\010")
+
+let blank   = [' ' '\009' '\012']
+
+let digit = ['0'-'9']
+
+let lowercase_alpha = ['a'-'z' '_']
+
+let uppercase_alpha = ['A'-'Z' '_']
+
+let alpha = lowercase_alpha | uppercase_alpha
+
+let alphanum = alpha | digit
+
+let identifier = alpha alphanum*
+
+let hexa   = [ '0'-'9' 'a'-'f' 'A'-'F']
+
+rule token = parse
+  (** Layout *)
+  | newline              { next_line_and token lexbuf }
+  | blank+               { token lexbuf }
+  | ";;" ([^';' '\n']* as c) { COMMENT c }
+
+  (** Keywords *)
+  | "add"                 { ADD }
+  | "mul"                 { MUL }
+  | "div"                 { DIV }
+  | "sub"                 { SUB }
+  | "copy"                { COPY }
+  | "and"                 { AND }
+  | "or"                  { OR  }
+  | "gt"                  { GT  }
+  | "gte"                 { GTE }
+  | "lt"                  { LT  }
+  | "lte"                 { LTE }
+  | "eq"                  { EQ }
+  | "jumpif"              { JUMPIF }
+  | "jump"                { JUMP }
+  | "switch"              { SWITCH }
+  | "orelse"              { ORELSE }
+  | "exit"                { EXIT }
+  | "def"                 { DEF }
+  | "globals"             { GLOBALS }
+  | "end"                 { END }
+  | "local"               { LOCAL }
+  | "ret"                 { RET }
+  | "call"                { CALL }
+  | "tail"                { TAIL }
+  | "external"            { EXTERNAL }
+  | identifier as i       { ID i }
+  | '%' (identifier as i) { RID i }
+
+  (** Literals *)
+  | digit+ as d     { INT (Mint.of_string d) }
+  | '"'             { string lexbuf }
+  | "'\\n'"                               { LCHAR '\n' }
+  | "'\\t'"                               { LCHAR '\t' }
+  | "'\\b'"                               { LCHAR '\b' }
+  | "'\\r'"                               { LCHAR '\r' }
+  | "'\\\\'"                              { LCHAR '\\' }
+  | "'\\''"                               { LCHAR '\'' }
+  | '\'' ([^ '\\' '\''] as c) '\''        {
+    if (Char.code c < 32) then
+      error lexbuf (
+        Printf.sprintf
+          "The ASCII character %d is not printable." (Char.code c)
+      );
+    LCHAR c
+  }
+  | "'\\" (digit digit digit as i) "'" {
+    let c = int_of_string i in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  | "'\\0" "x" (hexa hexa as i) "'" {
+    let c = int_of_string ("0x" ^ i) in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  | "'\\0" "o" (['0'-'7']+ as i) "'" {
+    let c = int_of_string ("0o" ^ i) in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+  | "'\\0" "b" (['0'-'1']+ as i) "'" {
+    let c = int_of_string ("0b" ^ i) in
+    if c < 0 || c > 255 then error lexbuf "";
+    LCHAR (char_of_int c)
+  }
+
+  (** Punctuation *)
+  | ":"             { COLON }
+  | ";"             { SEMICOLON }
+  | ","             { COMMA }
+  | "("             { LPAREN }
+  | ")"             { RPAREN }
+  | "<-"            { LARROW }
+  | "->"            { RARROW }
+  | "&"             { UPPERSAND }
+  | eof             { EOF }
+
+  (** Lexing error. *)
+  | _               { error lexbuf "unexpected character." }
+
+and string = parse
+| "\\n"                                 { Buffer.add_char string_buffer '\n'; string lexbuf }
+| "\\t"                                 { Buffer.add_char string_buffer '\t'; string lexbuf }
+| "\\b"                                 { Buffer.add_char string_buffer '\b'; string lexbuf }
+| "\\r"                                 { Buffer.add_char string_buffer '\r'; string lexbuf }
+| '\\' '\''                             { Buffer.add_char string_buffer '\''; string lexbuf }
+| '\\' '"'                              { Buffer.add_char string_buffer '"'; string lexbuf }
+| "\\\\"                                { Buffer.add_char string_buffer '\\'; string lexbuf }
+
+| '\\' (_ as c)                 { error lexbuf
+                                    (Printf.sprintf "Bad escape sequence in string '\\%c'" c)
+                                }
+| "\\" (digit digit digit as i) {
+   let c = int_of_string i in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| "\\0" "x" (hexa hexa as i) {
+   let c = int_of_string ("0x" ^ i) in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| "\\0" "b" (['0'-'1']+ as i) {
+   let c = int_of_string ("0b" ^ i) in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| "\\0" "o" (['0'-'7']+ as i) {
+   let c = int_of_string ("0o" ^ i) in
+   if c < 0 || c > 255 then error lexbuf "";
+   Buffer.add_char string_buffer (char_of_int c); string lexbuf
+}
+| '"'                                   {
+  let s = Buffer.contents string_buffer in
+  Buffer.clear string_buffer;
+  LSTRING s
+}
+| _ as c                                {
+  Buffer.add_char string_buffer c;
+  string lexbuf
+}
+| eof                                   {
+  error lexbuf "Unterminated string."
+}

flap/src/retrolix/retrolixLivenessAnalysis.ml

@@ -0,0 +1,142 @@
+(**
+
+   Liveness Analysis
+   =================
+
+   Liveness analysis is a *data flow* analysis. This means that it
+   overapproximates the set of possible values that can get involved
+   at each program point. The notion of "set of possible values" here
+   should be understood in a very broad set as it usually characterize
+   an abstract semantic notion like "the definitions that are
+   available", "the variables that are alive", ... etc.
+
+   To do that, the analysis works on the control-flow graph (CFG) (i)
+   by defining a *transfer function* for each node that
+   overapproximates the effects of the node instruction on the values
+   ; (ii) by refining the overapproximation iteratively until a
+   fixpoint is reached.
+
+   More precisely, a transfer function is defined by two functions
+   _IN_ and _OUT_ such that for each program point ℓ, IN(ℓ) is the set
+   of possible values entering ℓ and OUT(ℓ) is the set of possible
+   values leaving ℓ. If the _domain_ of the transfer function is equiped
+   with a partial order with no infinite descending chain and if
+   _IN_ and _OUT_ are monotonic with respect to this partial order,
+   then by Kleene-Knaster-Tarski's theorem, there exist a fixpoint.
+
+   For liveness analysis, the transfer functions are defined as follows:
+
+   1. The analysis abstract domain contains sets of alive variables.
+      The partial order is ⊆. Given that there is only a finite number
+      of variables, there is no infinite descending chain.
+
+   2. x ∈ IN(ℓ)
+      if x ∈ (OUT(ℓ) \ DEF(ℓ)) ∨ (∃ ℓ' -> ℓ, x ∈ OUT(ℓ')) ∨ x ∈ USE(ℓ)
+
+      x ∈ OUT(ℓ)
+      if ∃ ℓ', ℓ -> ℓ', x ∈ IN(ℓ')
+
+      where:
+      - USE(ℓ) is the set of variables possibly read at ℓ.
+      - DEF(ℓ) is the set of variables possibly written at ℓ.
+
+      or equivalently, removing the redundancy between IN and OUT:
+
+      IN(ℓ)  = USE(ℓ) ∪ (OUT(ℓ) ∖ DEF(ℓ))
+      OUT(ℓ) = ⋃_{s ∈ successors (ℓ)} IN(s)
+
+   Notice that OUT(ℓ) only depends on the values IN(s) obtained from
+   its successors. This is a characteristic of *backward data flow
+   analysis*. We will consider *forward* analyses is a forthcoming
+   optimization.
+
+*)
+
+open RetrolixAST
+open RetrolixUtils
+
+(**
+
+   The result of the liveness analysis is a mapping from program
+   points to pairs of sets of variables.
+
+*)
+type liveness_analysis_result = {
+  live_in  : LSet.t LabelMap.t;
+  live_out : LSet.t LabelMap.t;
+}
+
+let empty_results =
+  {
+    live_in  = LabelMap.empty;
+    live_out = LabelMap.empty;
+  }
+
+let string_of_results r =
+  Printf.sprintf
+    "IN:\n%s\nOUT:\n%s\n"
+    (string_of_lmap r.live_in)
+    (string_of_lmap r.live_out)
+
+(** [def i] returns the variables defined by the instruction [i]. *)
+let def i =
+  failwith "Student! This is your job!"
+
+(** [use i] returns the variables used by [i]. *)
+let use i =
+  failwith "Student! This is your job!"
+
+(** [instructions_of_labels b] returns a function [instruction_of_label]
+    such that [instruction_of_label l] returns the instruction labelled by
+    [l] in the block [b]. *)
+let instructions_of_labels ((_, is) : block) =
+  let m = LabelMap.(List.fold_left (fun m (l, i) -> add l i m) empty is) in
+  fun l -> try LabelMap.find l m with Not_found -> assert false
+
+(** [liveness_analysis b] returns the liveness analysis of block [b].
+
+   There are many ways to implement this analysis, but some
+   implementations will converge faster than others! Let us recall
+   what we said during the course:
+
+   1. A backward analysis converges faster by traversing the CFG
+      from exit to entry.
+
+   2. A fixpoint computation is better implemented using a *work list*
+      that maintains the nodes whose analysis may need a refinement.
+
+   Typically, in the case of the liveness analysis, when considering a
+   node [n], we compute [IN(n)] and if it has changed we must update
+   [OUT(p)] for all predecessors of [n] and consider these predecessors
+   on more time. (This again suggests a backward traversal of the CFG.)
+
+*)
+let liveness_analysis b : liveness_analysis_result =
+  failwith "Student! This is your job!"
+
+
+(**
+
+   Some debugging functions.
+
+*)
+
+let debug_liveness b results =
+  if Options.get_verbose_mode () then RetrolixPrettyPrinter.(
+    let get_decoration space m l =
+      let s = try LabelMap.find l m with Not_found -> LSet.empty in
+      [PPrint.string ("{ " ^ string_of_lset s ^ " }")]
+      @ (if space then [PPrint.empty] else [])
+    in
+    let decorations = {
+        pre = get_decoration false results.live_in;
+        post = get_decoration true results.live_out
+    }
+    in
+    let p = ExtPPrint.to_string (block decorations) b in
+    Printf.eprintf "Liveness:\n%s\n" p;
+  );
+  results
+
+let process b =
+  liveness_analysis b |> debug_liveness b

flap/src/retrolix/retrolixParser.mly

@@ -0,0 +1,194 @@
+%{ (* Emacs, use -*- tuareg -*- to open this file! *)
+
+  open RetrolixAST
+
+  let fresh_label =
+    let r = ref 0 in
+    fun () -> incr r; Label ("_L" ^ string_of_int !r)
+
+  let bool_of_unit_option o =
+    match o with None -> false | Some () -> true
+%}
+
+%token SEMICOLON COLON COMMA EOF DEF EXTERNAL GLOBALS END LPAREN RPAREN
+%token LOCAL CALL TAIL RET LARROW RARROW EXIT UPPERSAND
+%token JUMP JUMPIF SWITCH ORELSE
+%token GT LT GTE LTE EQ
+%token ADD MUL DIV SUB COPY AND OR
+%token<Mint.t> INT
+%token<string> ID RID COMMENT LSTRING
+%token<char> LCHAR
+%type<lvalue> lvalue
+%type<rvalue> rvalue
+%start<RetrolixAST.t> program
+
+%%
+
+program: ds=definition* EOF
+{
+  ds
+}
+| error {
+  let pos = Position.lex_join $startpos $endpos in
+  Error.error "parsing" pos "Syntax error."
+}
+
+definition: GLOBALS LPAREN xs=separated_list(COMMA, identifier)
+                               RPAREN b=block END {
+  DValues (xs, b)
+}
+| DEF f=function_identifier
+  LPAREN xs=separated_list(COMMA, identifier) RPAREN
+  b=block
+  END
+{
+  DFunction (f, xs, b)
+}
+| EXTERNAL f=function_identifier
+{
+  DExternalFunction f
+}
+
+locals: LOCAL xs=separated_nonempty_list(COMMA, identifier) COLON
+{
+  xs
+}
+| /* empty word */
+{
+  []
+}
+
+block: xs=locals ls=labelled_instruction*
+{
+  (xs, ls)
+}
+
+identifier: x=ID {
+  Id x
+}
+
+labelled_instruction: l=label COLON i=instruction SEMICOLON {
+  (l, i)
+}
+| i=instruction SEMICOLON {
+  (fresh_label (), i)
+}
+
+label: l=ID {
+  Label l
+}
+
+orelse_label: ORELSE l=label {
+  l
+}
+
+instruction:
+  CALL f=rvalue
+  LPAREN xs=separated_list(COMMA, rvalue) RPAREN t=option(TAIL)
+{
+  Call (f, xs, bool_of_unit_option t)
+}
+| f=function_identifier
+  LPAREN xs=separated_list(COMMA, rvalue) RPAREN t=option(TAIL)
+{
+  Call (`Immediate (LFun f), xs, bool_of_unit_option t)
+}
+| RET
+{
+  Ret
+}
+| l=lvalue LARROW o=op xs=separated_list(COMMA, rvalue)
+{
+  Assign (l, o, xs)
+}
+| JUMP l=label
+{
+  Jump l
+}
+| JUMPIF c=condition xs=separated_list(COMMA, rvalue)
+  RARROW l1=label COMMA l2=label
+{
+  ConditionalJump (c, xs, l1, l2)
+}
+| SWITCH rv=rvalue
+  RARROW ls=separated_list(COMMA, label)
+  dl=option(orelse_label)
+{
+  Switch (rv, Array.of_list ls, dl)
+}
+| c=COMMENT
+{
+  Comment c
+}
+| EXIT
+{
+  Exit
+}
+
+condition:
+  GT  { GT }
+| LT  { LT }
+| GTE { GTE }
+| LTE { LTE }
+| EQ  { EQ }
+
+op:
+  ADD { Add }
+| MUL { Mul }
+| DIV { Div }
+| SUB { Sub }
+| COPY { Copy }
+| AND { And }
+| OR  { Or }
+
+lvalue:
+ v=identifier
+{
+  `Variable v
+}
+| r=register
+{
+  `Register r
+}
+
+register: r=RID
+{
+  RId r
+}
+
+rvalue:
+  l=lvalue
+{
+  (l :> rvalue)
+}
+| l=literal
+{
+  `Immediate l
+}
+
+literal: x=INT
+{
+  LInt x
+}
+| UPPERSAND x=function_identifier
+{
+  LFun x
+}
+| c=LCHAR
+{
+  LChar c
+}
+| s=LSTRING
+{
+  LString s
+}
+
+
+%inline located(X): x=X {
+  Position.with_poss $startpos $endpos x
+}
+
+function_identifier: x=ID
+{
+  FId x
+}

flap/src/retrolix/retrolixPrettyPrinter.ml

@@ -0,0 +1,137 @@
+(** This module offers a pretty-printer for Retrolix programs. *)
+
+open PPrint
+
+open RetrolixAST
+
+let located f x = f (Position.value x)
+
+let max_label_length c =
+  List.fold_left (fun m (Label l, _) -> max m (String.length l)) 0 c
+
+let ( ++ ) x y =
+  x ^^ break 1 ^^ y
+
+let vcat = separate_map hardline (fun x -> x)
+
+type decorations = {
+    pre  : label -> document list;
+    post : label -> document list;
+}
+
+let nodecorations = { pre = (fun _ -> []); post = (fun _ -> []) }
+
+let rec program ?(decorations=nodecorations) p =
+  vcat (List.map (definition decorations) p)
+
+and definition decorations = function
+  | DValues (xs, b) ->
+    group (string "globals" ++ parens (identifiers xs))
+    ^^ hardline
+    ^^ block decorations b  ++ string "end" ^^ hardline
+  | DFunction (f, xs, b) ->
+    group (string "def"
+           ++ function_identifier ~uppersand:false f
+           ++ parens (identifiers xs))
+    ^^ hardline
+    ^^ block decorations b ++ string "end" ^^ hardline
+  | DExternalFunction f ->
+    group (string "external" ++ function_identifier ~uppersand:false f)
+
+and block decorations (ls, b) =
+  let shift = max_label_length b in
+  locals ls ^^ vcat (List.map (labelled_instruction decorations shift) b)
+
+and identifiers xs =
+  separate_map (comma ^^ space) identifier xs
+
+and identifier (Id x) =
+  string x
+
+and function_identifier ?(uppersand = true) (FId x) =
+  string (if uppersand then "&" ^ x else x)
+
+and locals = function
+  | [] ->
+     empty
+  | xs ->
+     group (string "local" ++ group (identifiers xs) ++ string ":") ^^ break 1
+
+and labelled_instruction decorations lsize (l, i) =
+  vcat (
+      (decorations.pre l)
+      @ [ group (label lsize l ^^ group (instruction i) ^^ string ";") ]
+      @ (decorations.post l)
+    )
+
+and label lsize (Label l) =
+  string (Printf.sprintf "%*s: " lsize l)
+
+and instruction = function
+  | Call (f, xs, tail) ->
+    string "call" ++ rvalue f ++ parens (rvalues xs)
+    ++ (if tail then string "tail" else empty)
+
+  | Ret ->
+    string "ret"
+
+  | Assign (l, o, rs) ->
+    lvalue l ++ string "<-" ++ string (op o) ++ rvalues rs
+
+  | Jump (Label l) ->
+    string "jump" ++ string l
+
+  | ConditionalJump (c, rs, Label l1, Label l2) ->
+    string "jumpif" ++ string (condition c) ++ rvalues rs
+    ++ string "->" ++ string l1 ^^ string ", " ++ string l2
+
+  | Comment s ->
+    string (";; " ^ s)
+
+  | Switch (r, ls, default) ->
+    string "switch" ++ rvalue r
+    ++ separate_map (break 0 ^^ comma ^^ space) slabel (Array.to_list ls)
+    ++ (match default with None -> empty | Some l -> string "orelse" ++ slabel l)
+
+  | Exit ->
+    string "exit"
+
+and slabel (Label s) =
+  string s
+
+and lvalue = function
+  | `Variable x -> identifier x
+  | `Register r -> register r
+
+and rvalue = function
+  | #lvalue as l -> lvalue l
+  | `Immediate l -> literal l
+
+and rvalues rs =
+  separate_map (break 0 ^^ comma ^^ space) rvalue rs
+
+and literal = function
+  | LInt x -> string (Mint.to_string x)
+  | LFun f -> function_identifier f
+  | LString s -> string ("\"" ^ String.escaped s ^ "\"")
+  | LChar c -> string ("'" ^ Char.escaped c ^ "'")
+
+and register (RId x) = string ("%" ^ x)
+
+and op = function
+  | Copy -> "copy"
+  | Add -> "add"
+  | Mul -> "mul"
+  | Div -> "div"
+  | Sub -> "sub"
+  | And -> "and"
+  | Or -> "or"
+
+and condition = function
+  | GT -> "gt"
+  | LT -> "lt"
+  | GTE -> "gte"
+  | LTE -> "lte"
+  | EQ -> "eq"
+
+let instruction i = group (instruction i)

flap/src/retrolix/retrolixRegisterAllocation.ml

@@ -0,0 +1,225 @@
+(**
+
+   The register allocation translates a Retrolix program into an
+   equivalent Retrolix program that uses hardware registers as much as
+   possible to hold intermediate results.
+
+   Register allocation is done in two steps:
+
+   - a static analysis called "Liveness Analysis of Variables" is
+   performed to compute a graph. This graph overapproximates the interference
+   relation of program variables, i.e. the intersection between the
+   live ranges of variables. The nodes of the graph are the program
+   variables and, in this graph, a node for 'x' and a node 'y' are
+   connected iff 'x' and 'y' are in interference.
+
+   - a graph coloring algorithm is executed on the interference graph:
+   if two variables live at the same time, then their values cannot
+   be carried by the same register ; thus, it suffices to use a different
+   color for their nodes. Graph coloring is NP-complete. Yet, we will
+   use a simple recursive algorithm that provides good results in
+   practice.
+
+*)
+
+open RetrolixAST
+open RetrolixUtils
+open RetrolixInterferenceGraph
+
+(**
+
+    Register allocation is an optimization.
+
+    Hence, we register this translation as such in the compiler.
+
+*)
+
+let activated = ref false
+
+module Source = Retrolix
+
+let shortname = "regalloc"
+
+let longname = "register allocation"
+
+(**
+
+   Coloring, definitions and operators.
+
+*)
+
+type colorization = Color of register | OnStack | Undecided
+
+type coloring = colorization LValueMap.t
+
+let color_of_register r =
+  match RetrolixUtils.register r with `Register r -> r | _ -> assert false
+
+let colors =
+  List.map color_of_register X86_64_Architecture.allocable_registers
+
+let is_precolored_node n =
+  match n with
+    | `Register r -> List.mem r colors
+    | _ -> false
+
+let nb_colors = List.length colors
+
+let colorization coloring x =
+  try LValueMap.find x coloring with Not_found -> Undecided
+
+let assign_colorization coloring x c =
+  LValueMap.add x c coloring
+
+(** In the initial coloring, hardware registers are colored by themselves. *)
+let initial_coloring : coloring =
+  List.fold_left (fun c r ->
+      let color = Color (color_of_register r)
+      and register = RetrolixUtils.register r in
+      assign_colorization c register color)
+    LValueMap.empty
+    X86_64_Architecture.all_registers
+
+let string_of_colorization = function
+  | OnStack -> "On stack"
+  | Color r -> RetrolixUtils.string_of_register r
+  | Undecided -> "undecided"
+
+let string_of_coloring coloring =
+  LValueMap.bindings coloring |>
+  List.map (fun (x, c) ->
+      Printf.sprintf "%s -> %s\n"
+        (string_of_lvalue x) (string_of_colorization c)
+  ) |> String.concat ""
+
+(** [build_variable_relations forbidden b] computes the interference
+    graph for the block [b], assuming that coloring global variables
+    is [forbidden]. *)
+module G = RetrolixInterferenceGraph.InterferenceGraph
+let build_variable_relations forbidden b : G.t =
+  RetrolixLivenessAnalysis.process b |>
+  RetrolixInterferenceGraph.interference_graph forbidden b
+
+(** [rewrite_block coloring b] rewrites [b] to use more hardware
+    registers as described by [coloring]. *)
+let rewrite_block coloring (xs, is) =
+  let lv : lvalue -> lvalue = function
+    | `Variable (Id _) as v ->
+       begin match colorization coloring v with
+       | Color r -> `Register r
+       | OnStack -> v
+       | Undecided -> v
+       end
+    | l -> l
+  in
+  let rv = function
+    | `Immediate l -> `Immediate l
+    | #lvalue as l -> (lv l :> rvalue)
+  in
+  List.(
+    let var x = `Variable x in
+    let xs = filter (fun x -> colorization coloring (var x) = OnStack) xs in
+    let is = map (fun (l, i) -> (l, RetrolixUtils.map_on_value lv rv i)) is in
+    (xs, is)
+  )
+
+(**
+
+   Graph simplification
+   ====================
+
+   Given an interference graph, there are three possible cases:
+
+   1. The graph only contains nodes that are not colorable because
+      they are hardware registers or global variables for instance.
+      The [initial_coloring] is fine for this graph.
+
+   2. There is a simplifiable node in the graph, that is a node whose
+      degree is strictly less than the number of available [colors].
+
+   3. There are no simplifiable nodes in the graph. The coloring
+      algorithm must try different from simplification to continue
+      its work.
+
+*)
+type simplify_result =
+  | PrecoloredGraph
+  | SimplifiableNode of NodeLabel.t
+  | NoSimplifiableNode
+
+(** [simplify uncolorable g] observes [g] to determine the
+   [simplify_result]. [uncolorable] is a predicate to filter
+   nodes that are not colorable. *)
+let simplify (uncolorable : NodeLabel.t -> bool) g : simplify_result =
+   failwith "Student! This is your job!"
+
+(**
+
+   Variable spilling
+   =================
+
+   At some point, if there is no more simplification (or coalescing)
+   to do, we must choose a variable that can be potentially spilled,
+   that is allocated [OnStack]. As graph coloring is NP-complete,
+   there is no way to quickly compute a local optimal choice. Yet,
+   considering the graph and the instructions, some reasonable
+   heuristic can be defined.
+
+*)
+
+(** [pick_spilling_candidate uncolorable g b] returns a node to
+    consider for spilling. *)
+let pick_spilling_candidate (uncolorable : NodeLabel.t -> bool) g _
+: NodeLabel.t =
+   failwith "Student! This is your job!"
+
+(** [colorize_block_variables_naively forbidden b] rewrites [b] to
+    use more hardware registers if that is possible. [forbidden]
+    is a list of variables that cannot be stored in hardware registers. *)
+let colorize_block_variables_naively forbidden b =
+   failwith "Student! This is your job!"
+
+(**
+
+   Coalescence
+   ===========
+
+   We can coalesce two nodes if they are not in conflict and if Briggs'
+   or George's criterion is satisfied.
+
+*)
+let can_coalesce g n1 n2 =
+   failwith "Student! This is your job!"
+
+(** [colorize_block_variables_meticulously forbidden b] performs
+    register allocation on [b] trying to optimize variable copy. *)
+let colorize_block_variables_meticulously forbidden b =
+   failwith "Student! This is your job!"
+
+(**
+
+   Putting all together.
+
+*)
+let translate_block forbidden b = Options.(
+  match get_regalloc_variant () with
+  | Naive ->
+     colorize_block_variables_naively forbidden b
+  | Realistic ->
+     colorize_block_variables_meticulously forbidden b
+  )
+
+let translate p =
+  let variables = List.map (fun x -> `Variable  x) in
+  let globals = variables (RetrolixUtils.global_variables p) in
+  let rec program ds =
+    List.map definition ds
+  and definition = function
+    | DValues (xs, b) ->
+       DValues (xs, translate_block globals b)
+    | DFunction (f, xs, b) ->
+       DFunction (f, xs, translate_block (variables xs @ globals) b)
+    | DExternalFunction f ->
+       DExternalFunction f
+  in
+  program p |> RetrolixKillMove.kill_moves

flap/src/retrolix/retrolixTypechecker.ml

@@ -0,0 +1,181 @@
+(** A scope-checker for Retrolix programs. *)
+
+open RetrolixAST
+
+(** {2 Errors} *)
+
+let type_error ?(loc = Position.dummy) message =
+  Error.error "typechecking" loc message
+
+let unknown_variable (Id xn) =
+  type_error ("Unbound variable " ^ xn)
+
+let unknown_function (FId fn) =
+  type_error ("Unbound function " ^ fn)
+
+let unknown_label (Label ln) =
+  type_error ("Unbound label " ^ ln)
+
+let duplicate_global (Id xn) =
+  type_error ("Global variable " ^ xn ^ " has been declared twice")
+
+let duplicate_function (FId fn) =
+  type_error ("Function " ^ fn ^ " has been declared twice")
+
+let duplicate_label (Label ln) =
+  type_error ("Label " ^ ln ^ " has been declared twice")
+
+(** {2 Runtime functions} *)
+
+let runtime_funs =
+  List.map
+    (fun fn -> FId fn)
+    [
+      "allocate_block";
+      "read_block";
+      "write_block";
+      "equal_string";
+      "equal_char";
+      "observe_int"; "print_int";
+      "print_string";
+      "add_eight_int";
+    ]
+
+(** {2 Environments} *)
+
+type typing_environment =
+  {
+    variables : IdSet.t;
+    functions : FIdSet.t;
+    labels : LabelSet.t
+  }
+
+let print_typing_environment _ =
+  ""
+
+let initial_typing_environment () =
+  {
+    variables = IdSet.empty;
+    functions = FIdSet.of_list runtime_funs;
+    labels = LabelSet.empty;
+  }
+
+let var_is_declared env x =
+  IdSet.mem x env.variables
+
+let fun_is_declared env f =
+  FIdSet.mem f env.functions
+
+let label_is_declared env l =
+  LabelSet.mem l env.labels
+
+let declare_var env x =
+  { env with variables = IdSet.add x env.variables; }
+
+let declare_vars ?on_shadowing env xs =
+  let f =
+    match on_shadowing with
+    | None -> fun _ _ -> ()
+    | Some f -> fun env x -> if var_is_declared env x then f x
+  in
+  let declare_enrich_var env x = f env x; declare_var env x in
+  List.fold_left declare_enrich_var env xs
+
+let define_label env l =
+  if label_is_declared env l then duplicate_label l;
+  { env with labels = LabelSet.add l env.labels; }
+
+let define_labels env body =
+  List.fold_left (fun env (l, _) -> define_label env l) env body
+
+let declare_fun env f =
+  { env with functions = FIdSet.add f env.functions; }
+
+let with_labels ~base ~labelled =
+  { base with labels = labelled.labels; }
+
+(** {2 Type-checking} *)
+
+let typecheck_literal env lit =
+  match lit with
+  | LInt _ | LChar _ | LString _ ->
+     ()
+  | LFun f ->
+     if not (fun_is_declared env f) then unknown_function f
+
+let typecheck_lvalue env (lv : lvalue) =
+  match lv with
+  | `Variable x ->
+     if not (var_is_declared env x) then unknown_variable x
+  | `Register _ ->
+     ()
+
+let typecheck_rvalue env (rv : rvalue) =
+  match rv with
+  | `Immediate lit ->
+     typecheck_literal env lit
+  | #lvalue as lv ->
+     typecheck_lvalue env lv
+
+let typecheck_rvalues env =
+  List.iter (typecheck_rvalue env)
+
+let typecheck_label env l =
+  if not (label_is_declared env l) then unknown_label l
+
+let typecheck_labels env =
+  List.iter (typecheck_label env)
+
+let typecheck_instruction env ins =
+  match ins with
+  | Call (rv1, rvs, _) ->
+     typecheck_rvalues env (rv1 :: rvs)
+  | Ret | Comment _ | Exit ->
+     ()
+  | Assign (lv, _, rvs) ->
+     typecheck_lvalue env lv;
+     typecheck_rvalues env rvs
+  | Jump l ->
+     typecheck_label env l
+  | ConditionalJump (_, rvs, l1, l2) ->
+     typecheck_rvalues env rvs;
+     typecheck_label env l1;
+     typecheck_label env l2
+  | Switch (rv, ls, lo) ->
+     typecheck_rvalue env rv;
+     Array.iter (typecheck_label env) ls;
+     ExtStd.Option.iter (typecheck_label env) lo
+
+let typecheck_labelled_instruction env (_, ins) =
+  typecheck_instruction env ins
+
+let typecheck_block env (locals, body) =
+  let env = declare_vars env locals in
+  let env = define_labels env body in
+  List.iter (typecheck_labelled_instruction env) body;
+  env
+
+let enrich_env_with_def env def =
+  match def with
+  | DValues (globals, _) ->
+     declare_vars ~on_shadowing:duplicate_global env globals
+  | DFunction (f, _, _) | DExternalFunction f ->
+     if fun_is_declared env f then duplicate_function f;
+     declare_fun env f
+
+let typecheck_def env def =
+  let env' =
+    match def with
+    | DValues (_, block) ->
+       typecheck_block env block
+    | DFunction (_, params, block) ->
+       let env = declare_vars env params in
+       typecheck_block env block
+    | DExternalFunction _ ->
+       env
+  in
+  with_labels ~base:env ~labelled:env'
+
+let typecheck env ast =
+  let env = List.fold_left enrich_env_with_def env ast in
+  List.fold_left typecheck_def env ast

flap/src/retrolix/retrolixUtils.ml

@@ -0,0 +1,199 @@
+(** This module provides helper functions for Retrolix program
+   analysis and manipulation. *)
+
+open RetrolixAST
+
+module LValueOrd = struct
+  type t = lvalue
+  let compare = compare
+  let print = RetrolixPrettyPrinter.lvalue
+end
+
+module LValueMap = ExtStd.Map (LValueOrd)
+module LValueSet = ExtStd.Set (LValueOrd)
+
+module LabelOrd = struct
+  type t = label
+  let compare (Label l1) (Label l2) = String.compare l1 l2
+end
+
+type location = lvalue
+
+module LSet = Set.Make (struct
+    type t = location
+    let compare = compare
+end)
+
+let find_default d k m =
+  try LabelMap.find k m with Not_found -> d
+
+let join rs =
+  List.fold_left (fun s x -> LSet.add x s) LSet.empty rs
+
+let string_of_register (RId r) = r
+
+let string_of_lvalue = function
+  | `Register (RId r) -> r
+  | `Variable (Id r) -> r
+
+let string_of_label (Label s) = s
+
+let string_of_lset s =
+  String.concat " " (List.map string_of_lvalue (LSet.elements s))
+
+let string_of_lmap m =
+  String.concat "\n" (
+      List.map (fun (l, s) ->
+          Printf.sprintf "  %s : %s\n" (string_of_label l) (string_of_lset s)
+      ) (LabelMap.bindings m)
+  )
+
+let register r =
+  `Register (RId (X86_64_Architecture.string_of_register r))
+
+let global_variables p =
+  let translate p =
+    let rec program ds =
+      List.(concat (map definition ds))
+    and definition = function
+      | DValues (xs, _) ->
+         xs
+      | _ ->
+         []
+    in
+    program p
+  in
+  translate p
+
+let map_on_value lvalue rvalue = function
+  | Call (r, rs, b) ->
+     Call (rvalue r, List.map rvalue rs, b)
+  | Ret ->
+     Ret
+  | Assign (l, o, rs) ->
+     Assign (lvalue l, o, List.map rvalue rs)
+  | Jump l ->
+     Jump l
+  | ConditionalJump (c, rs, l1, l2) ->
+     ConditionalJump (c, List.map rvalue rs, l1, l2)
+  | Switch (r, ls, l) ->
+     Switch (rvalue r, ls, l)
+  | Comment c ->
+     Comment c
+  | Exit ->
+     Exit
+
+(** [predecessors b] returns a function [pred] such that [pred l]
+   returns the predecessors of [l] in the control flow graph of
+   the block [b]. *)
+let predecessors b =
+  let block m (_, instructions) =
+    let new_predecessor prev m curr =
+      try
+        let s = LabelMap.find curr m in
+        let s = LabelSet.add prev s in
+        LabelMap.add curr s m
+      with Not_found ->
+        LabelMap.add curr (LabelSet.singleton prev) m
+    in
+    let rec traverse m = function
+      | (label, Jump goto_label) :: instructions ->
+         let m = new_predecessor label m goto_label in
+         traverse m instructions
+      | (label, ConditionalJump (_, _, l1, l2)) :: instructions ->
+         let m = List.fold_left (new_predecessor label) m [l1; l2] in
+         traverse m instructions
+      | (label, Switch (_, labels, default)) :: instructions ->
+         let labels =
+           (match default with None -> [] | Some x -> [x])
+           @ (Array.to_list labels)
+         in
+         let m = List.fold_left (new_predecessor label) m labels in
+         traverse m instructions
+      | (ilabel, _) :: (((nlabel, _) :: _) as instructions) ->
+         let m = new_predecessor ilabel m nlabel in
+         traverse m instructions
+      | [ _ ] | [] ->
+         m
+    in
+    traverse m instructions
+  in
+  let m = block LabelMap.empty b in
+  fun l -> try LabelMap.find l m with Not_found -> LabelSet.empty
+
+let nondefault_targets insn =
+  match insn with
+  | Call _ | Ret | Assign _ | Comment _ | Exit ->
+     []
+  | Jump l ->
+     [l]
+  | ConditionalJump (_, _, l1, l2) ->
+     [l1; l2]
+  | Switch (_, a, o) ->
+     ExtStd.Option.fold (fun l acc -> acc @ [l]) o (Array.to_list a)
+
+let instruction_targets (insns : labelled_instruction list) =
+  let targets _ insn next_lab =
+    match insn with
+    | Call (_, _, false) | Assign _ | Comment _  ->
+       next_lab
+
+    | Call (_, _, true) | Ret | Exit ->
+       []
+
+    | Jump lab ->
+       [lab]
+
+    | ConditionalJump (_, _, lab1, lab2) ->
+       [lab1; lab2]
+
+    | Switch (_, laba, labo) ->
+       ExtStd.Option.fold (fun lab acc -> acc @ [lab]) labo (Array.to_list laba)
+  in
+  let rec loop insns =
+    match insns with
+    | [] ->
+       []
+    | (lab, insn) :: insns ->
+       (lab,
+        insn,
+        targets lab insn (match insns with [] -> [] | (lab, _) :: _ -> [lab]))
+       :: loop insns
+  in
+  loop insns
+
+let map_blocks f definitions =
+  let definition def =
+    match def with
+    | DValues (xs, block) ->
+       DValues (xs, f block)
+    | DFunction (fn, xs, block) ->
+       DFunction (fn, xs, f block)
+    | DExternalFunction _ ->
+       def
+  in
+  List.map definition definitions
+
+let map_instructions f ((locals, insns) : block) =
+  (locals, List.map (fun ((l, _) as li) -> l, f li) insns)
+
+let transform_block f g block =
+  let open PPrint in
+  let info = f block in
+  if Options.get_debug_mode () then
+    ExtPPrint.to_channel
+      (!^ "Input block:"
+       ^//^ RetrolixPrettyPrinter.block
+                RetrolixPrettyPrinter.nodecorations
+                block);
+  let block = map_instructions (g info) block in
+  if Options.get_debug_mode () then
+    ExtPPrint.to_channel
+      (!^ "Output block:"
+       ^//^ RetrolixPrettyPrinter.block
+                RetrolixPrettyPrinter.nodecorations
+                block);
+  block
+
+let transform_blocks f g definitions =
+  map_blocks (transform_block f g) definitions

flap/src/utilities/dict.ml

@@ -0,0 +1,25 @@
+type ('k, 'v) dict =
+    ('k * 'v) list
+
+type ('k, 'v) t = ('k, 'v) dict
+
+let empty = []
+
+let lookup k d =
+  try
+    Some (List.assoc k d)
+  with Not_found ->
+    None
+
+let insert k v d =
+  (k, v) :: d
+
+let to_list d = d
+
+let of_list d = d
+
+let equal d1 d2 =
+  List.for_all (fun (k, v) ->
+    lookup k d2 = Some v
+  ) d1
+  && List.(length d1 = length d2)

flap/src/utilities/dict.mli

@@ -0,0 +1,15 @@
+type ('k, 'v) dict
+
+type ('k, 'v) t = ('k, 'v) dict
+
+val empty : ('k, 'v) dict
+
+val lookup : 'k -> ('k, 'v) dict -> 'v option
+
+val insert : 'k -> 'v -> ('k, 'v) dict -> ('k, 'v) dict
+
+val to_list : ('k, 'v) dict -> ('k * 'v) list
+
+val of_list : ('k * 'v) list -> ('k, 'v) dict
+
+val equal : ('k, 'v) dict -> ('k, 'v) dict -> bool

flap/src/utilities/digraph.ml

@@ -0,0 +1,160 @@
+module type EDGE = sig
+  include ExtStd.PrintableType
+end
+
+module type VERTEX = sig
+  include ExtStd.PrintableType
+  module Label : ExtStd.OrderedPrintableType
+  val label : t -> Label.t
+end
+
+module Make (Edge : EDGE) (Vertex : VERTEX) = struct
+  module VM = ExtStd.Map(Vertex.Label)
+  module VPM = ExtStd.Map(ExtStd.OrderedPrintablePairs(Vertex.Label))
+
+  type vinfo =
+    {
+      contents : Vertex.t;
+      incoming : (Vertex.Label.t * Edge.t) list;
+      outgoing : (Vertex.Label.t * Edge.t) list;
+    }
+
+  (** The type of directed graphs. *)
+  type t =
+    {
+      vertices : vinfo VM.t;
+      edges : Edge.t VPM.t;
+    }
+
+  let print { vertices; edges; } =
+    let open PPrint in
+    let edge_list =
+      separate_map
+        comma
+        (fun (v, e) -> OCaml.tuple [Vertex.Label.print v; Edge.print e])
+    in
+    let vinfo { contents; incoming; outgoing; } =
+      ExtPPrint.record
+        [
+          "contents", Vertex.print contents;
+          "incoming", edge_list incoming;
+          "outgoing", edge_list outgoing;
+        ]
+    in
+    ExtPPrint.record
+      [
+        "vertices", VM.print vinfo vertices;
+        "edges", VPM.print Edge.print edges;
+      ]
+
+  let dump_graphviz gr oc =
+    let dquotes s = "\"" ^ String.escaped s ^ "\"" in
+    let label l = dquotes @@ ExtPPrint.to_string Vertex.Label.print l in
+    let dump_vertex (vl, v) =
+      output_string oc (label vl);
+      output_string oc "[label = ";
+      output_string oc
+        (dquotes @@ ExtPPrint.to_string ~width:40 Vertex.print v.contents);
+      output_string oc "];\n"
+    in
+    let dump_edge ((srcl, dstl), _) =
+      output_string oc (label srcl);
+      output_string oc " -> ";
+      output_string oc (label dstl);
+      output_string oc ";\n"
+    in
+    output_string oc "digraph {\n";
+    List.iter dump_vertex @@ List.of_seq @@ VM.to_seq gr.vertices;
+    List.iter dump_edge @@ List.of_seq @@ VPM.to_seq gr.edges;
+    output_string oc "}\n"
+  ;;
+
+  let empty =
+    {
+      vertices = VM.empty;
+      edges = VPM.empty;
+    }
+
+  exception Vertex_already_present of Vertex.Label.t
+  exception Vertex_not_found of Vertex.Label.t
+  exception Edge_already_present of Vertex.Label.t * Vertex.Label.t
+
+  let add_vertex gr v =
+    let vl = Vertex.label v in
+    if VM.mem vl gr.vertices
+    then raise (Vertex_already_present vl);
+    let vi = { contents = v; incoming = []; outgoing = []; } in
+    { gr with vertices = VM.add vl vi gr.vertices; }
+
+  let find_vertex_info gr v =
+    try VM.find v gr.vertices with Not_found -> raise (Vertex_not_found v)
+
+  let add_edge gr ~src ~dst e =
+    if VPM.mem (src, dst) gr.edges then raise (Edge_already_present (src, dst));
+    let srci = find_vertex_info gr src in
+    let dsti = find_vertex_info gr dst in
+    let srci = { srci with outgoing = (dst, e) :: srci.outgoing; } in
+    let dsti = { dsti with incoming = (src, e) :: dsti.incoming; } in
+    { vertices = VM.(add src srci @@ add dst dsti @@ gr.vertices);
+      edges = VPM.add (src, dst) e gr.edges; }
+
+  let find_vertex vl gr =
+    (find_vertex_info gr vl).contents
+
+  let fold_vertices f gr acc =
+    VM.fold (fun _ vi acc -> f vi.contents acc) gr.vertices acc
+
+  let fold_edges f gr acc =
+    VPM.fold (fun (srcl, dstl) e acc ->
+        let src = find_vertex srcl gr in
+        let dst = find_vertex dstl gr in
+        f ~src ~dst e acc)
+      gr.edges
+      acc
+
+  type 'a edge_folder = Vertex.t -> Edge.t -> 'a -> 'a
+
+  let fold_successors srcl (f : 'a edge_folder) acc gr =
+    let srci = find_vertex_info gr srcl in
+    List.fold_left
+      (fun acc (dstl, e) -> f (find_vertex dstl gr) e acc)
+      acc
+      srci.outgoing
+
+  let fold_predecessors dstl f acc gr =
+    let dsti = find_vertex_info gr dstl in
+    List.fold_left
+      (fun acc (srcl, e) -> f (find_vertex srcl gr) e acc)
+      acc
+      dsti.incoming
+
+  let iter_vertices f gr =
+    VM.iter (fun _ v -> f v.contents) gr.vertices
+
+  let iter_edges f gr =
+    VPM.iter
+      (fun (srcl, dstl) e ->
+        let src = find_vertex srcl gr in
+        let dst = find_vertex dstl gr in
+        f ~src ~dst e)
+      gr.edges
+
+  type edge_iter = Vertex.t -> Edge.t -> unit
+
+  let iter_successors f gr srcl =
+    let srci = find_vertex_info gr srcl in
+    List.iter (fun (dstl, e) -> f (find_vertex dstl gr) e) srci.outgoing
+
+  let iter_predecessors f gr dstl =
+    let dsti = find_vertex_info gr dstl in
+    List.iter (fun (srcl, e) -> f (find_vertex srcl gr) e) dsti.incoming
+
+  let initial_vertices, terminal_vertices =
+    let gather proj gr =
+      VM.fold
+        (fun _ v l -> if proj v = [] then v.contents :: l else l)
+        gr.vertices
+        []
+    in
+    gather (fun v -> v.incoming), gather (fun v -> v.outgoing)
+end

flap/src/utilities/digraph.mli

@@ -0,0 +1,102 @@
+(** A module for directed graphs.
+
+    This module, like the one in {!m Graph}, provides a functional
+    representation of directed graphs.
+ *)
+
+module type EDGE = sig
+  include ExtStd.PrintableType
+end
+
+module type VERTEX = sig
+  include ExtStd.PrintableType
+  module Label : ExtStd.OrderedPrintableType
+  val label : t -> Label.t
+end
+
+module Make (Edge : EDGE) (Vertex : VERTEX) : sig
+  (** The type of directed graphs. *)
+  type t
+
+  (** Pretty-print the internal representation of the graph for debugging. *)
+  val print : t -> PPrint.document
+
+  (** Dump the graph in the Graphviz "dot", so that it can later be displayed by
+      dotty and friends. *)
+  val dump_graphviz : t -> out_channel -> unit
+
+  (** {2 Exceptions} *)
+
+  exception Vertex_not_found of Vertex.Label.t
+
+  exception Edge_already_present of Vertex.Label.t * Vertex.Label.t
+
+  (** {2 Graph construction operations} *)
+
+  (** The empty digraph. *)
+  val empty : t
+
+  exception Vertex_already_present of Vertex.Label.t
+
+  (** [add_vertex gr v] add the vertex [v] to the graph [gr]. This function
+     raises {!e Vertex_already_present} if a node with label [V.label v] has
+     already been added to [gr]. *)
+  val add_vertex : t -> Vertex.t -> t
+
+  (** [add_edge gr ~src ~dst e] adds an edge [e] between two vertices [src] and
+     [dst] of [gr], identified by their labels. This function raises {!e
+     Vertex_not_found} when either [src] or [dst] is not already present in
+     [gr], and raises {!e Edge_already_present} when an edge between [src] and
+     [dst] has already been added. *)
+  val add_edge : t -> src:Vertex.Label.t -> dst:Vertex.Label.t -> Edge.t -> t
+
+  (** {2 Graph traversal operations} *)
+
+  (** [find_vertex vl g] finds the vertex with label [vl] in [g], or raises {!
+     Vertex_not_found} if [g] contains no such vertex. *)
+  val find_vertex : Vertex.Label.t -> t -> Vertex.t
+
+  (** [fold_vertices f acc gr] applies [f v1 (f v2 (... acc))] to all the
+     vertices [vi] of [gr]. They are enumerated in no particular order. *)
+  val fold_vertices : (Vertex.t -> 'a -> 'a) -> t -> 'a -> 'a
+
+  type 'a edge_folder = Vertex.t -> Edge.t -> 'a -> 'a
+
+  (** [fold_edges f acc gr] is similar to [fold_vertices] but applies to the
+     edges of [gr]. *)
+  val fold_edges :
+    (src:Vertex.t -> dst:Vertex.t -> Edge.t -> 'a -> 'a) -> t -> 'a -> 'a
+
+  val fold_successors : Vertex.Label.t -> 'a edge_folder -> 'a -> t -> 'a
+
+  val fold_predecessors : Vertex.Label.t -> 'a edge_folder -> 'a -> t -> 'a
+
+  (** [iter_vertices f gr] applies function [f] to every vertex of [gr], in no
+     particular order. *)
+  val iter_vertices : (Vertex.t -> unit) -> t -> unit
+
+  type edge_iter = Vertex.t -> Edge.t -> unit
+
+  (** [iter_edges f gr] applies function [f] to every edge of [gr], in no
+     particular order. *)
+  val iter_edges :
+    (src:Vertex.t -> dst:Vertex.t -> Edge.t -> unit) -> t -> unit
+
+  (** [iter_successors f gr v] applies function [f] to every outgoing edge of
+     [v] in [gr], in LIFO order. This function raises {!e Vertex_not_found} when
+     [v] has not been added to [gr]. *)
+  val iter_successors : edge_iter -> t -> Vertex.Label.t -> unit
+
+  (** [iter_predecessors f gr v] applies function [f] to every incoming edge of
+     [v] in [gr], in LIFO order. This function raises {!e Vertex_not_found} when
+     [v] has not been added to [gr]. *)
+  val iter_predecessors : edge_iter -> t -> Vertex.Label.t -> unit
+
+  (** [initial_vertices gr] returns the list of all nodes of [gr] that have no
+     predecessors. *)
+  val initial_vertices : t -> Vertex.t list
+
+  (** [terminal_vertices gr] returns the list of all nodes of [gr] that have no
+     successors. *)
+  val terminal_vertices : t -> Vertex.t list
+end

flap/src/utilities/error.ml

@@ -0,0 +1,33 @@
+let exit_flag = ref true
+
+let exit_on_error () = exit_flag := true
+
+let resume_on_error () = exit_flag := false
+
+let print_locs = ref true
+
+exception Error of Position.t list * string
+
+let print_error positions msg =
+  Printf.sprintf "%s%s\n"
+    (if !print_locs
+     then String.concat "\n"
+            (List.map (fun p -> Position.string_of_pos p ^": ") positions)
+     else "")
+    msg
+
+let error_alert positions msg =
+  if !exit_flag then (
+    output_string stderr (print_error positions msg);
+    exit 1
+  )
+  else raise (Error (positions, msg))
+
+let global_error kind msg =
+  error_alert [] (Printf.sprintf "Global Error (%s)\n  %s"  kind msg)
+
+let errorN kind poss msg =
+  error_alert poss (Printf.sprintf "Error (%s)\n  %s" kind msg)
+
+let error kind pos = errorN kind [pos]
+let error2 kind pos1 pos2 = errorN kind [pos1; pos2]

flap/src/utilities/error.mli

@@ -0,0 +1,32 @@
+(** This module provides a uniform way of reporting (located) error messages. *)
+
+(** [exit_on_error ()] forces the program to stop if an error is encountered.
+    (This is the default behavior.) *)
+val exit_on_error: unit -> unit
+
+(** [resume_on_error ()] makes the program throw the exception {!Error}
+    if an error is encountered. *)
+val resume_on_error: unit -> unit
+
+(** The value of [print_locs] controls whether locations are printed by the
+    functions of this module. It is set to [true] by default. *)
+val print_locs : bool ref
+
+exception Error of Position.t list * string
+
+(** [print_error positions msg] formats an error message. *)
+val print_error : Position.t list -> string -> string
+
+(** [error k p msg] prints [msg] with [k] as a message prefix and stops
+    the program. *)
+val error : string -> Position.t -> string -> 'a
+
+(** [error2 k p1 p2 msg] prints two positions instead of one. *)
+val error2 : string -> Position.t -> Position.t -> string -> 'a
+
+(** [errorN k ps msg] prints several positions. *)
+val errorN : string -> Position.t list -> string -> 'a
+
+(** [global_error k msg] prints [msg] with [k] as a message prefix and stops
+    the program. *)
+val global_error : string -> string -> 'a

flap/src/utilities/extPPrint.ml

@@ -0,0 +1,25 @@
+(** This module extends the PPrint library. *)
+
+open PPrint
+
+let ribbon = 0.7
+
+let to_string ?(width = 120) f x =
+  ignore width;
+  let b = Buffer.create 13 in
+  ToBuffer.pretty ribbon 120 b (f x);
+  Buffer.contents b
+
+let to_channel ?(channel = stdout) ?(width = 80) doc =
+  ignore width;
+  PPrint.ToChannel.pretty ribbon 80 channel doc;
+  print_newline ()
+
+let ( ++ ) x y = x ^^ break 1 ^^ y
+
+let assoc_list ?(bind = "=") ?(sep = ",") pp_key pp_val assl =
+  let b = string (" " ^ bind) in
+  separate_map (string sep) (fun (k, v) -> pp_key k ^^ b ^/^ pp_val v) assl
+
+let record =
+  OCaml.record ""

flap/src/utilities/extStd.ml

@@ -0,0 +1,340 @@
+(** This module extends some modules of the standard library. *)
+
+module Ref = struct
+
+  let functions_of_ref r =
+    (fun x -> r := x), (fun () -> !r)
+
+  let as_functions default =
+    functions_of_ref (ref default)
+
+end
+
+module List = struct
+
+  include List
+
+  exception EmptyListHasNoMin
+  let min_assoc_list xs =
+    let rec aux k' v' = function
+      | [] ->
+         (k', v')
+      | (k, v) :: xs ->
+         if v < v' then aux k v xs else aux k' v' xs
+    in
+    match xs with
+    | [] -> raise EmptyListHasNoMin
+    | (k, v) :: xs -> aux k v xs
+
+  exception InvalidSwap
+
+  let rec swap i x' xs =
+    match i, xs with
+    | 0, x :: xs ->
+       x, x' :: xs
+    | _, x :: xs ->
+       let y, xs' = swap (i - 1) x' xs in
+       y, x :: xs'
+    | _, _ ->
+       raise InvalidSwap
+
+  let rec range start stop =
+    if stop < start then [] else start :: range (start + 1) stop
+
+  let asymmetric_map2 f =
+    let rec aux accu xs ys =
+      match xs, ys with
+        | xs, [] ->
+          (List.rev accu, xs, [])
+        | [], ys ->
+          (List.rev accu, [], ys)
+        | x :: xs, y :: ys ->
+          aux (f x y :: accu) xs ys
+    in
+    aux []
+
+  let repeat k v =
+    let rec aux accu k =
+      if k = 0 then accu else aux (v :: accu) (k - 1)
+    in
+    aux [] k
+
+  let repeatf k f =
+    let rec aux accu k =
+      if k = 0 then accu else aux (f () :: accu) (k - 1)
+    in
+    aux [] k
+
+  let rec uniq = function
+    | [] -> []
+    | [x] -> [x]
+    | x :: ((y :: _) as xs) -> if x = y then uniq xs else x :: uniq xs
+
+  (** [index_of p l] returns the index of the first element [x] of [l]
+      such [p x = true]. Raise [Not_found] otherwise. *)
+  let index_of : ('a -> bool) -> 'a list -> int =
+    fun p l ->
+      let rec aux i = function
+        | [] -> raise Not_found
+        | x :: xs -> if p x then i else aux (succ i) xs
+      in
+      aux 0 l
+
+   (** [all_distinct ls] returns true if all the elements of [ls]
+       are distinct. *)
+  let all_distinct ls =
+    let ls = List.sort Stdlib.compare ls in
+    let rec aux = function
+      | [] | [_] -> true
+      | x :: y :: ys -> x <> y && aux (y :: ys)
+    in
+    aux ls
+
+  let all_equal ls =
+    let rec aux = function
+      | [] | [_] -> true
+      | x :: y :: ys -> x = y && aux (y :: ys)
+    in
+    aux ls
+
+  let transpose xs =
+    assert (all_equal (List.map length xs));
+    let rec aux rows =
+      match rows with
+      | [] -> assert false
+      | [] :: _ -> []
+      | rows ->
+         List.(
+          let row', rows = map (fun l -> (hd l, tl l)) rows |> split in
+          row' :: aux rows
+         )
+    in
+    aux xs
+
+  let unique_value ls =
+    match uniq ls with
+      | [x] -> Some x
+      | _ -> None
+
+  let foldmap f init =
+    let rec aux (accu, ys) = function
+      | [] ->
+        (accu, List.rev ys)
+      | x :: xs ->
+        let accu, y = f accu x in
+        aux (accu, y :: ys) xs
+    in
+    aux (init, [])
+
+  exception FoldMap2
+
+  let foldmap2 f init l1 l2 =
+    let rec aux (accu, ys) = function
+      | [], [] ->
+        (accu, List.rev ys)
+      | x :: xs, z :: zs ->
+        let accu, y = f accu x z in
+        aux (accu, y :: ys) (xs, zs)
+      | _, _ ->
+         raise FoldMap2
+    in
+    aux (init, []) (l1, l2)
+
+  let update_assoc k v l =
+    let rec aux = function
+      | [] -> [(k, v)]
+      | ((k', _) as x) :: l -> if k = k' then (k, v) :: l else x :: aux l
+    in
+    aux l
+
+  module Monad : sig
+      type 'a t
+      val return : 'a -> 'a t
+      val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+      val take_one : 'a list -> 'a t
+      val fail : 'a t
+      val and_try : 'a t -> 'a t -> 'a t
+      val run : 'a t -> 'a list
+  end = struct
+      type 'a t = 'a list
+      let return x = [x]
+      let ( >>= ) x f = List.(flatten (map f x))
+      let fail = []
+      let and_try a b = a @ b
+      let run x = x
+      let take_one x = x
+  end
+
+  let last l = List.(hd (rev l))
+
+end
+
+let update
+    (find : 'k -> 'c -> 'v)
+    (add : 'k -> 'v -> 'c -> 'c)
+    (k : 'k) (m : 'c)
+    (default : 'v)
+    (f : 'v -> 'v)
+: 'c =
+  try
+    let v = find k m in
+    add k (f v) m
+  with Not_found ->
+    add k (f default) m
+
+module Random = struct
+
+  let int_in_range start stop =
+    start + Random.int (stop - start + 1)
+
+end
+
+module Option = struct
+
+  let map f = function
+    | None -> None
+    | Some x -> Some (f x)
+
+  let iter f = function
+    | None -> ()
+    | Some x -> f x
+
+  let fold f x acc =
+    match x with
+    | None -> acc
+    | Some x -> f x acc
+
+end
+
+module Stdlib = struct
+  let ( |< ) default e x =
+    try e x with _ -> default
+
+  let file_content filename =
+    let cin = open_in filename in
+    let b = Buffer.create 24 in
+    let rec read () =
+      try Buffer.add_channel b cin 1; read () with End_of_file -> ()
+    in
+    read ();
+    close_in cin;
+    Buffer.contents b
+
+end
+
+module Buffer = struct
+  include Buffer
+
+  let slurp ?(buffer_size = 4096) ic =
+    let b = Buffer.create buffer_size in
+    let rec loop () =
+      match Buffer.add_channel b ic buffer_size with
+      | () ->
+         loop ()
+      | exception _ ->
+         b
+    in
+    loop ()
+
+end
+
+module Unix = struct
+
+  open Unix
+
+  let output_and_error_of_command ?(env = Unix.environment ()) cmd =
+    let cin, cout, cerr = open_process_full cmd env in
+    let stdin = Buffer.slurp cin in
+    let stderr = Buffer.slurp cerr in
+    let status = close_process_full (cin, cout, cerr) in
+    status, Buffer.contents stdin, Buffer.contents stderr
+
+  let output_of_command cmd =
+    let status, stdin, _ = output_and_error_of_command cmd in
+    status, stdin
+
+  let string_of_process_status = function
+    | WEXITED k -> Printf.sprintf "exited(%d)" k
+    | WSTOPPED k -> Printf.sprintf "stopped(%d)" k
+    | WSIGNALED k -> Printf.sprintf "signaled(%d)" k
+
+  let add_exec_bits filename =
+    let st = stat filename in
+    chmod filename (st.st_perm lor 0o111)
+end
+
+module Hashtbl = struct
+
+  let counting_table (type a) () : (a -> int) * (a -> unit) =
+    let t = Hashtbl.create 13 in
+    let get k = try Hashtbl.find t k with Not_found -> 0 in
+    let incr k = Hashtbl.replace t k (get k + 1) in
+    (get, incr)
+
+end
+
+module Array = struct
+
+  let present_to_list a =
+    List.(rev (fold_left (fun accu -> function
+                   | None -> accu
+                   | Some t -> t :: accu) [] (Array.to_list a)))
+
+end
+
+module Pair = struct
+
+  let swap (x, y) = (y, x)
+
+end
+
+module type PrintableType = sig
+  type t
+  val print : t -> PPrint.document
+end
+
+module type OrderedPrintableType = sig
+  include Map.OrderedType
+  include PrintableType with type t := t
+end
+
+module OrderedPrintablePairs (T : OrderedPrintableType) = struct
+  type t = T.t * T.t
+
+  let compare (x1, y1) (x2, y2) =
+    let n = T.compare x1 x2 in
+    if n <> 0 then n else T.compare y1 y2
+
+  let print (x, y) = PPrint.OCaml.tuple [T.print x; T.print y]
+end
+
+module Set (T : OrderedPrintableType) =
+  struct
+    module M = Set.Make(T)
+    include M
+    let print s =
+      let open PPrint in
+      surround_separate_map 2 1
+        (string "{}")
+        (string "{")
+        (string "," ^^ break 1)
+        (string "}")
+        T.print
+        (List.of_seq @@ M.to_seq s)
+  end
+
+module Map (T : OrderedPrintableType) =
+  struct
+    module M = Map.Make(T)
+    include M
+    let print value m =
+      let open PPrint in
+      let pp (k, v) = prefix 2 1 (T.print k ^^ string " =") (value v) in
+      surround_separate_map 2 1
+        (string "{}")
+        (string "{")
+        (string "," ^^ break 1)
+        (string "}")
+        pp
+        (List.of_seq @@ M.to_seq m)
+  end

flap/src/utilities/graph.ml

@@ -0,0 +1,428 @@
+(** A module for graphs.
+
+    The implementation is based on purely functional datastructures
+    only: we make use of OCaml's standard modules Map and Set.
+
+    The implementation is generic with respect to the type of labels
+    for nodes and for edges. The module is therefore a functor
+    parameterized by the two descriptions of these types and their
+    operations.
+
+*)
+
+(** The type for edge labels.
+
+    We assume that there is a relatively small number of edge labels.
+    These labels are comparable and enumerable.
+
+*)
+module type EdgeLabelSig = sig
+    include Set.OrderedType
+    (** [all] enumerates all the possible edge labels. *)
+    val all : t list
+    (** [to_string e] converts [e] in a human readable value. *)
+    val to_string : t -> string
+end
+
+(** The type for node labels.
+
+    Node labels must be comparable.
+
+*)
+module type NodeLabelSig = sig
+  include Set.OrderedType
+    (** [to_string n] converts [n] in a human readable value. *)
+  val to_string : t -> string
+end
+
+(** The functor is parameterized by the previous two signatures. *)
+module Make (EdgeLabel : EdgeLabelSig) (NodeLabel : NodeLabelSig) =
+struct
+
+  (** A type for maps whose keys are integers. *)
+  module IntMap = Map.Make (struct type t = int let compare = compare end)
+  let int_map_update k m d f = ExtStd.update IntMap.find IntMap.add k m d f
+
+  (** A type for maps whose keys are edge labels. *)
+  module EdgeLabelMap = Map.Make (EdgeLabel)
+
+  (** A type for maps whose keys are node labels. *)
+  module NodeLabelMap = Map.Make (NodeLabel)
+
+  (** Internally, each node has an identifier which is a small integer. *)
+  type nodeid = NodeId of int
+  module IdCmp = struct type t = nodeid let compare = compare end
+
+  (** A type for maps whose keys are node identifiers. *)
+  module NodeIdMap = Map.Make (IdCmp)
+  let nodeid_map_update k m d f =
+    ExtStd.update NodeIdMap.find NodeIdMap.add k m d f
+
+  (** A type for sets of node identifiers. *)
+  module NodeIdSet = Set.Make (IdCmp)
+
+  (** The type for graphs.
+
+      The datastructure maintains redundant information about the
+      graph using multiple maps. Each map provides a logarithmic
+      complexity for important services of the datastructure, namely
+      the computation of nodes of least [degrees] and the computation
+      of a node [neighbourhood].
+
+      A node is externally characterized by a list of node labels
+      while internally it is characterized by a node identifier. We
+      also maintain this mapping using maps, namely [node_of_label]
+      and [labels].
+
+      [next_node_id] is a counter that helps determining the identifier
+      for a newly created node.
+  *)
+
+  type t = {
+    next_node_id   : int;
+    node_of_label  : nodeid NodeLabelMap.t;
+    labels         : NodeLabel.t list NodeIdMap.t;
+    neighbours     : NodeIdSet.t NodeIdMap.t EdgeLabelMap.t;
+    degrees        : NodeIdSet.t IntMap.t EdgeLabelMap.t
+  }
+
+  let string_of_nodeid (NodeId x) = string_of_int x
+
+  (** [dump g] returns a text-based representation of the graph, for
+      debugging. *)
+  let dump g =
+    let neighbours =
+      EdgeLabelMap.bindings g.neighbours |> List.map (fun (c, m) ->
+        NodeIdMap.bindings m |> List.map (fun (id, ids) ->
+          Printf.sprintf "%s -%s-> %s"
+            (string_of_nodeid id)
+            (EdgeLabel.to_string c)
+            (String.concat "," (List.map string_of_nodeid (NodeIdSet.elements ids)))
+        )
+      ) |> List.flatten |> String.concat "\n"
+    in
+    let degrees =
+      EdgeLabelMap.bindings g.degrees |> List.map (fun (c, m) ->
+        IntMap.bindings m |> List.map (fun (d, ids) ->
+          Printf.sprintf "%d =%s=> %s"
+            d
+            (EdgeLabel.to_string c)
+            (String.concat "," (List.map string_of_nodeid (NodeIdSet.elements ids)))
+        )
+      ) |> List.flatten |> String.concat "\n"
+    in
+    Printf.sprintf "%s\n%s\n" neighbours degrees
+
+  (** The empty graph. *)
+  let empty =
+    let degrees =
+      List.fold_left
+        (fun m e -> EdgeLabelMap.add e IntMap.empty m)
+        EdgeLabelMap.empty
+        EdgeLabel.all
+    in
+    let neighbours =
+      List.fold_left
+        (fun m e -> EdgeLabelMap.add e NodeIdMap.empty m)
+        EdgeLabelMap.empty
+        EdgeLabel.all
+    in
+    {
+      next_node_id = 0;
+      node_of_label = NodeLabelMap.empty;
+      labels = NodeIdMap.empty;
+      neighbours;
+      degrees;
+    }
+
+  exception InvalidNode
+  exception InvalidEdge
+
+  let defined_node g n = NodeLabelMap.mem n g.node_of_label
+
+  exception UnboundNode of NodeLabel.t
+  let id_of_node g n = try
+      NodeLabelMap.find n g.node_of_label
+    with Not_found ->
+      raise (UnboundNode n)
+
+  let nodes_of_id g n = NodeIdMap.find n g.labels
+
+  let nodes g =
+    List.map snd (NodeIdMap.bindings g.labels)
+
+  (** Sanity check for the data structure. *)
+  let sanity_check = false
+  exception InconsistentDegree
+  let check_consistent_degree g =
+    (** The number of neighbours of [x] is the degree of [x]. *)
+    let valid_degree c x ngb =
+      let xdegree = NodeIdSet.cardinal ngb in
+      NodeIdSet.mem x (IntMap.find xdegree (EdgeLabelMap.find c g.degrees))
+    in
+    EdgeLabelMap.iter (fun c ngbs ->
+      NodeIdMap.iter (fun x ngb ->
+        if not (valid_degree c x ngb) then (
+          raise InconsistentDegree
+        )
+      ) ngbs
+    ) g.neighbours
+
+  let update_neighbour update_set g id1 e id2 =
+    (** We focus on [e]. *)
+    let nbg = EdgeLabelMap.find e g.neighbours
+    and deg = EdgeLabelMap.find e g.degrees in
+
+    (** What is the degree of id1? *)
+    let id1_nbg = try NodeIdMap.find id1 nbg with _ -> assert false in
+    let id1_deg = NodeIdSet.cardinal id1_nbg in
+
+    (** Update the neighbours of id1 with update_set id2. *)
+    let nbg = nodeid_map_update id1 nbg NodeIdSet.empty (update_set id2) in
+
+    (** Update the degree of id1. *)
+    let deg = int_map_update id1_deg deg NodeIdSet.empty (NodeIdSet.remove id1) in
+    let deg =
+      if IntMap.find id1_deg deg = NodeIdSet.empty then
+        IntMap.remove id1_deg deg
+      else
+        deg
+    in
+    let id1_nbg = try NodeIdMap.find id1 nbg with _ -> assert false in
+    let id1_deg = NodeIdSet.cardinal id1_nbg in
+    let deg = int_map_update id1_deg deg NodeIdSet.empty (NodeIdSet.add id1) in
+
+    (** Finally, update the graph. *)
+    let neighbours = EdgeLabelMap.add e nbg g.neighbours
+    and degrees = EdgeLabelMap.add e deg g.degrees in
+    let g = { g with neighbours; degrees } in
+
+    (** If you suspect a bug in the implementation of the graph data
+        structure, which is always possible. Activating sanity check
+        might help you to track it down. *)
+    if sanity_check then check_consistent_degree g;
+    g
+
+  let add_neighbour = update_neighbour NodeIdSet.add
+  let del_neighbour = update_neighbour NodeIdSet.remove
+
+  (** [add_node g [n1;...;nN]] returns a new graph that extends [g] with
+      a new node labelled by [n1;...;nN]. None of the [nI] can be used
+      by another node in [g]. Otherwise, [InvalidNode] is raised.
+
+      In the sequel, the new node can be identified by any [nI].
+  *)
+  let add_node g ns =
+    (** First, a fresh identifier for the node. *)
+    let nodeid = NodeId g.next_node_id in
+    let next_node_id = g.next_node_id + 1 in
+
+    (** Second, we check that [ns] are not used by any other node. *)
+    if List.exists (defined_node g) ns then
+      raise InvalidNode;
+
+    (** Third, update maps. *)
+    let node_of_label =
+      List.fold_left (fun m n -> NodeLabelMap.add n nodeid m) g.node_of_label ns
+    in
+    let labels = NodeIdMap.add nodeid ns g.labels in
+    let neighbours =
+      EdgeLabelMap.map (fun nbg ->
+        NodeIdMap.add nodeid NodeIdSet.empty nbg
+      ) g.neighbours
+    in
+    (** Initially, the node has a degree 0 since it has no neighbour. *)
+    let degrees =
+      EdgeLabelMap.map
+        (fun deg -> int_map_update 0 deg NodeIdSet.empty (NodeIdSet.add nodeid))
+        g.degrees
+    in
+    { next_node_id; node_of_label; labels; degrees; neighbours }
+
+  (** [add_edge g n1 e n2] returns a new graph that extends [g] with a
+      new edge between [n1] and [n2]. The edge is labelled by [e]. If [n1]
+      or [n2] does not exist, then [InvalidNode] is raised. *)
+  let add_edge g n1 e n2 =
+    if not (defined_node g n1 && defined_node g n2) then
+      raise InvalidNode;
+    let id1 = id_of_node g n1 and id2 = id_of_node g n2 in
+    let g = add_neighbour g id1 e id2 in
+    let g = add_neighbour g id2 e id1 in
+    g
+
+  (** [neighbours g e n] returns the neighbours of [n] in [g]. *)
+  let neighbours g e n =
+    let id = id_of_node g n in
+    let ids =
+      NodeIdSet.elements (NodeIdMap.find id (EdgeLabelMap.find e g.neighbours))
+    in
+    List.map (fun id -> NodeIdMap.find id g.labels) ids
+
+  (** [del_node g n] returns a new graph that contains [g] minus the
+      node [n] and its edges. *)
+  let del_node g n =
+    let id = id_of_node g n in
+    let g =
+      EdgeLabelMap.fold (fun e nbg g ->
+        let nnbg = NodeIdMap.find id nbg in
+        NodeIdSet.fold (fun id' g ->
+          let g = del_neighbour g id' e id in
+          let g = del_neighbour g id e id' in
+          g
+        ) nnbg g
+      ) g.neighbours g
+    in
+    let neighbours =
+      EdgeLabelMap.map (fun nbg ->
+        NodeIdMap.remove id nbg
+      ) g.neighbours
+    in
+    let degrees =
+      EdgeLabelMap.map (fun deg ->
+        let deg0 = IntMap.find 0 deg in
+        let deg0 = NodeIdSet.remove id deg0 in
+        if deg0 = NodeIdSet.empty then
+          IntMap.remove 0 deg
+        else
+          IntMap.add 0 deg0 deg
+      ) g.degrees
+    in
+    let node_of_label = List.fold_left (fun node_of_label l ->
+      NodeLabelMap.remove l node_of_label
+    ) g.node_of_label (NodeIdMap.find id g.labels)
+    in
+    let labels = NodeIdMap.remove id g.labels in
+    { g with node_of_label; neighbours; labels; degrees }
+
+  (** [del_edge g n1 e n2] *)
+  let del_edge g n1 e n2 =
+    let i1 = id_of_node g n1 and i2 = id_of_node g n2 in
+    let g = del_neighbour g i1 e i2 in
+    del_neighbour g i2 e i1
+
+  (** [edges g e] returns all the edges of kind [e] in [g]. *)
+  let edges g e =
+    let nbg = EdgeLabelMap.find e g.neighbours in
+    let edges =
+      NodeIdMap.fold (fun id ids edges ->
+        NodeIdSet.fold (fun id' edges ->
+          (NodeIdMap.find id g.labels, NodeIdMap.find id' g.labels) :: edges
+        ) ids edges) nbg []
+    in
+    let edges = List.map (fun (n1, n2) ->
+      if n1 < n2 then (n1, n2) else (n2, n1)
+    ) edges
+    in
+    let edges = List.sort compare edges in
+    ExtStd.List.uniq edges
+
+  let min_degree exclusion_criteria g c nc =
+    let cdegrees = EdgeLabelMap.find c g.degrees in
+    let forbidden = EdgeLabelMap.find nc g.neighbours in
+    let rec aux degrees =
+      try
+        let k, ids = IntMap.min_binding degrees in
+        let rec aux' ids =
+          try
+            let id = NodeIdSet.choose ids in
+            let excluded = List.exists exclusion_criteria (nodes_of_id g id) in
+            if not excluded
+               && NodeIdMap.find id forbidden = NodeIdSet.empty then
+              Some (k, List.hd (NodeIdMap.find id g.labels))
+            else
+              aux' (NodeIdSet.remove id ids)
+          with Not_found ->
+            aux (IntMap.remove k degrees)
+        in
+        aux' ids
+      with Not_found -> None
+    in
+    aux cdegrees
+
+  (** [are_connected g n1 e n2] *)
+  let are_connected g n1 e n2 =
+    let id1 = id_of_node g n1 in
+    let id2 = id_of_node g n2 in
+    NodeIdSet.mem id2 (NodeIdMap.find id1 (EdgeLabelMap.find e g.neighbours))
+
+  (** [pick_edge g e] *)
+  let pick_edge g e =
+    try
+      let degrees = EdgeLabelMap.find e g.degrees in
+      let k, ids = IntMap.max_binding degrees in
+      if k = 0 then None
+      else
+        let id = NodeIdSet.choose ids in
+        let nbg = EdgeLabelMap.find e g.neighbours in
+        let nbgid = NodeIdMap.find id nbg in
+        let id2 = NodeIdSet.choose nbgid in
+        Some (List.hd (nodes_of_id g id), List.hd (nodes_of_id g id2))
+    with Not_found ->
+      None
+
+  (** [merge g n1 n2] *)
+  let merge g n1 n2 =
+    let i1 = id_of_node g n1 and i2 = id_of_node g n2 in
+    let nodes1 = nodes_of_id g i1 and nodes2 = nodes_of_id g i2 in
+    let nbgs =
+      List.map
+        (fun e ->
+          (e, List.filter (fun n -> not (List.mem n1 n) && not (List.mem n2 n))
+                (neighbours g e n1 @ neighbours g e n2)))
+        EdgeLabel.all
+    in
+    let g = del_node g n1 in
+    let g = del_node g n2 in
+    let g = add_node g (nodes1 @ nodes2) in
+    List.fold_left (fun g (e, nbgs) ->
+      List.fold_left (fun g ns ->
+        add_edge g n1 e (List.hd ns)
+      ) g nbgs
+    ) g nbgs
+
+  (** [all_labels g n] *)
+  let all_labels g n =
+    let i = id_of_node g n in
+    nodes_of_id g i
+
+  (** [show g labels] represents the graph [g] in the DOT format and
+      uses [dotty] to display it. *)
+  let show g labels =
+    let dot_node (NodeId n, ns) =
+      let ns =
+        String.concat "," (List.map (fun n ->
+          NodeLabel.to_string n ^ (match labels n with None -> "" | Some s -> " => " ^ s)
+        ) ns)
+      in
+      Printf.sprintf "n%d [label=\"%s\"];" n ns
+    in
+    let dot_nodes =
+      String.concat "\n" (List.map dot_node (NodeIdMap.bindings g.labels))
+    in
+    let seen = Hashtbl.create 13 in
+    let dot_edge (NodeId n) c (NodeId n') =
+      let n, n' = min n n', max n n' in
+      if not (Hashtbl.mem seen (n, n')) then (
+        Hashtbl.add seen (n, n') ();
+        Printf.sprintf "n%d -- n%d [label=\"%s\"];" n n' (EdgeLabel.to_string c)
+      ) else ""
+    in
+    let neighbour c (id, ids) =
+      String.concat "\n" (List.map (dot_edge id c) (NodeIdSet.elements ids))
+    in
+    let dot_edges_of_kind (c, ngb) =
+      String.concat "\n" (List.map (neighbour c) (NodeIdMap.bindings ngb))
+    in
+    let dot_edges =
+      String.concat "\n" (List.map dot_edges_of_kind (EdgeLabelMap.bindings g.neighbours))
+    in
+    let dot =
+      Printf.sprintf "graph g {\n%s\n%s\n}" dot_nodes dot_edges
+    in
+    let fname, cout = Filename.open_temp_file "flap" ".dot" in
+    output_string cout dot;
+    close_out cout;
+    Printf.printf "Graph written in %s. (You need to install dotty to display it.)\n%!" fname;
+    ignore (Sys.command ("dotty " ^ fname ^ "&"))
+
+end

flap/src/utilities/graph.mli

@@ -0,0 +1,99 @@
+(** A module for undirected graphs.
+
+    This module provides a functional data structure to represent a
+    graph which nodes contain a set of labels and which edges can have
+    one label too.
+
+    We maintain the invariant that two nodes always have different
+    labels: thus, nodes are identified by their labels.
+
+*)
+
+module type EdgeLabelSig = sig
+    include Set.OrderedType
+    (** [all] enumerates all the possible edge labels. *)
+    val all : t list
+    (** [to_string e] converts [e] in a human readable value. *)
+    val to_string : t -> string
+end
+
+module type NodeLabelSig = sig
+  include Set.OrderedType
+    (** [to_string n] converts [n] in a human readable value. *)
+  val to_string : t -> string
+end
+
+module Make (EdgeLabel : EdgeLabelSig) (NodeLabel : NodeLabelSig) : sig
+
+  (** The type for graphs. *)
+  type t
+
+  (** The empty graph. *)
+  val empty : t
+
+  (** [add_node g [n1;...;nN]] returns a new graph that extends [g] with
+      a new node labelled by [n1;...;nN]. None of the [nI] can be used
+      by another node in [g]. Otherwise, [InvalidNode] is raised.
+
+      In the sequel, the new node can be identified by any [nI].
+  *)
+  val add_node : t -> NodeLabel.t list -> t
+  exception InvalidNode
+  exception InvalidEdge
+
+  (** [add_edge g n1 e n2] returns a new graph that extends [g] with a
+      new edge between [n1] and [n2]. The edge is labelled by [e]. If [n1]
+      or [n2] does not exist, then [InvalidNode] is raised. *)
+  val add_edge : t -> NodeLabel.t -> EdgeLabel.t -> NodeLabel.t -> t
+
+  (** [del_edge g n1 e n2] returns a new graph that restricts [g] by removing
+      thge edge between [n1] and [n2]. The edge is labelled by [e]. If [n1]
+      or [n2] does not exist, then [InvalidNode] is raised. If there is no
+      such edge between [n1] and [n2] then [InvalidEdge] is raised. *)
+  val del_edge : t -> NodeLabel.t -> EdgeLabel.t -> NodeLabel.t -> t
+
+  (** [del_node g n] returns a new graph that contains [g] minus the
+      node [n] and its edges. *)
+  val del_node : t -> NodeLabel.t -> t
+
+  (** [neighbours g e n] returns the neighbours of [n] in [g]
+      that are connected with an edge labelled by [e]. One neighbour is
+      characterized by all its node labels. *)
+  val neighbours : t -> EdgeLabel.t -> NodeLabel.t -> NodeLabel.t list list
+
+  (** [edges g e] returns all the edges of kind [e] in [g].
+      WARNING: This function is inefficient! Use it only for debugging. *)
+  val edges : t -> EdgeLabel.t -> (NodeLabel.t list * NodeLabel.t list) list
+
+  (** [nodes g] returns all the nodes of [g]. *)
+  val nodes : t -> NodeLabel.t list list
+
+  (** [min_degree excluded g c nc] returns a node [n] of minimal degree for [c]
+      that has no edge for [nc] and so that not [excluded c], or returns None
+      if no such node exists. *)
+  val min_degree :
+    (NodeLabel.t -> bool)
+    -> t -> EdgeLabel.t -> EdgeLabel.t -> (int * NodeLabel.t) option
+
+  (** [pick_edge g c] returns an arbitrary edge for [c] or None if
+      there is no such edge. *)
+  val pick_edge : t -> EdgeLabel.t -> (NodeLabel.t * NodeLabel.t) option
+
+  (** [merge g n1 n2] returns a new graph which is [g] in which [n1]
+      and [n2] have been merged. *)
+  val merge : t -> NodeLabel.t -> NodeLabel.t -> t
+
+  (** [all_labels g n] returns all the node labels of node [n]. *)
+  val all_labels : t -> NodeLabel.t -> NodeLabel.t list
+
+  (** [are_connected g n1 e n2] returns true iff [n1] and [n2] are connected
+      by [e]. *)
+  val are_connected : t -> NodeLabel.t -> EdgeLabel.t -> NodeLabel.t -> bool
+
+  (** [show g labels] runs [dotty] to display the graph [g]. [labels n] may
+      optionally return an additional information to be display in the node
+      for [n]. *)
+  val show : t -> (NodeLabel.t -> string option) -> unit
+  val dump : t -> string
+
+end

flap/src/utilities/int16.ml

@@ -0,0 +1,29 @@
+type t = int
+
+exception LiteralExceeds16bits of int
+
+(** [check_invariant x] ensures that the integer [x] is a valid
+    representation for a 16 bits signed integer. *)
+let check_invariant x =
+  failwith "Students! This is your job!"
+
+(** [hi x] returns the 16 highest bits of [x]'s 32 bits. *)
+let hi x =
+  failwith "Students! This is your job!"
+
+(** [low x] returns the 16 lowests bits of [x]'s 32 bits. *)
+let low x =
+  failwith "Students! This is your job!"
+
+(** [of_int x] turns an OCaml integer literal into a 16 bits literal. *)
+let of_int x =
+  check_invariant x;
+  x
+
+(** [of_int32 x] turns an OCaml integer literal into a 16 bits literal. *)
+let of_int32 x =
+  of_int (Int32.to_int x)
+
+(** [to_string x] turns an integer [x] into a string. *)
+let to_string x =
+  string_of_int x

flap/src/utilities/int16.mli

@@ -0,0 +1,22 @@
+(** This module implements 16 bits signed integers. *)
+
+type t
+
+(** This exception is raised if a literal is too large to be
+    represented using only 16 bits. *)
+exception LiteralExceeds16bits of int
+
+(** [of_int32 x] turns an OCaml integer literal into a 16 bits literal. *)
+val of_int32 : Int32.t -> t
+
+(** [of_int x] turns an OCaml integer literal into a 16 bits literal. *)
+val of_int : int -> t
+
+(** [hi x] returns the 16 highests bits of [x]'s 32 bits. *)
+val hi : Int32.t -> t
+
+(** [low x] returns the 16 lowests bits of [x]'s 32 bits. *)
+val low : Int32.t -> t
+
+(** [to_string x] turns an integer [x] into a string. *)
+val to_string : t -> string

flap/src/utilities/list.ml

@@ -0,0 +1,9 @@
+include Stdlib.List
+
+let map_fold_right
+        : type a b c. (a -> b -> c * b) -> a list -> b -> c list * b =
+  fun f xs acc ->
+  fold_right
+    (fun x (ys, acc) -> let y, acc = f x acc in y :: ys, acc)
+    xs
+    ([], acc)

flap/src/utilities/listMonad.ml

@@ -0,0 +1,12 @@
+type 'a t = 'a list
+
+let pick cs = cs
+
+let return a = [a]
+
+let fail = []
+
+let ( >>= ) m f =
+  List.(flatten (map f m))
+
+let run m = m

flap/src/utilities/listMonad.mli

@@ -0,0 +1,93 @@
+(**
+
+    The list monad
+    or "non deterministic computations in OCaml"
+    or "list comprehension in OCaml"
+
+    As any monad, the purpose of the list monad is to represent in
+    OCaml computations that are not directly expressible in OCaml.
+
+    OCaml is a deterministic language: there is at most one value for
+    each expression, i.e. at most one result for each computation.
+
+    What if we want to represent computations that have zero, one
+    or many results? For instance, imagine the following algorithm:
+
+    pick x in {1..10}
+    pick y in {1..10}
+    return (x + y)
+
+    This algorithm is non deterministic because "pick" takes one of
+    the integers in the set {1..10}. Imagine that we want to know
+    all possible executions of this program. How to do that?
+
+    Before answering that question, you may wonder why it would be
+    useful to write such a program and then ask for all its execution.
+    The answer is: because that is exactly the syntax of sequences
+    defined by comprehension! So, it is a concise and declarative way
+    to represent a set of values defined by means of generators,
+    combinaisons and filters. In other words, the previous program
+    represents what a mathematician would write:
+
+    { x + y | x ∈ [1..10], y ∈ [1.10] }
+
+    Nice, isn't it?
+
+    Now, let us come back to monads. In OCaml, there is no "pick"
+    but we can program it. More generally, we can *represent*
+    computations that are non deterministic as terms of type ['a t].
+
+*)
+type 'a t
+(**
+
+   A value of type ['a t] is a computation that may produce nothing or
+   a value of type 'a or many values of type 'a.
+
+*)
+
+(** [pick s] is a non deterministic operation that takes one of the
+    element of [s]. You do not know which one. *)
+val pick : 'a list -> 'a t
+
+(** [return x] is a non deterministic computation that evaluates
+    into [x]. *)
+val return : 'a -> 'a t
+
+(** [fail] is a non deterministic computation with no result. *)
+val fail : 'a t
+
+(** [m >>= (fun x -> e)] is a computation that first executes
+    [m], name its result [x] and then executes [e]. [x] may
+    correspond to zero, one or many values of type ['a] but
+    you consider it as a single potential value.
+*)
+val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+
+(** Now, here is how to write the previous program using these
+    functions:
+
+    let allsums =
+      pick (range 0 10) >>= (fun x ->
+      pick (range 0 10) >>= (fun y ->
+        return (x + y)
+      )
+
+    (assuming [range start stop] is the list of integers between
+    [start] and [stop]).
+
+    Finally, how to get all these integers? Just use [run]:
+*)
+val run : 'a t -> 'a list
+
+(**
+
+    For instance, [run allsums] evaluates into:
+
+   [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 2; 3; 4; 5;
+    6; 7; 8; 9; 10; 11; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 4; 5; 6; 7; 8; 9; 10;
+    11; 12; 13; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 6; 7; 8; 9; 10; 11; 12; 13;
+    14; 15; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 8; 9; 10; 11; 12; 13; 14; 15;
+    16; 17; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18]
+
+*)

flap/src/utilities/option.ml

@@ -0,0 +1,7 @@
+let map f = function
+  | None -> None
+  | Some x -> Some (f x)
+
+let destruct default f = function
+  | None -> default ()
+  | Some x -> f x

flap/src/utilities/position.ml

@@ -0,0 +1,152 @@
+open Sexplib.Std
+open Lexing
+
+type lexing_position = Lexing.position
+
+let lexing_position_of_sexp p =
+  [%of_sexp: string * int * int * int] p
+  |> fun (pos_fname, pos_lnum, pos_bol, pos_cnum) ->
+     { pos_fname; pos_lnum; pos_bol; pos_cnum }
+
+let sexp_of_lexing_position p =
+  [%sexp_of: string * int * int * int]
+  (p.pos_fname, p.pos_lnum, p.pos_bol, p.pos_cnum)
+
+type t =
+    {
+      start_p : lexing_position;
+      end_p   : lexing_position
+    } [@@deriving sexp]
+
+type position = t
+
+type 'a located =
+    {
+      value    : 'a;
+      position : t;
+    } [@@deriving sexp]
+
+let value { value = v } =
+  v
+
+let position { position = p } =
+  p
+
+let destruct p =
+  (p.value, p.position)
+
+let located f x =
+  f (value x)
+
+let located_pos f x =
+  f (position x) (value x)
+
+let with_pos p v =
+  {
+    value     = v;
+    position  = p;
+  }
+
+let with_poss p1 p2 v =
+  with_pos { start_p = p1; end_p = p2 } v
+
+let map f v =
+  {
+    value     = f v.value;
+    position  = v.position;
+  }
+
+let iter f { value = v } =
+  f v
+
+let mapd f v =
+  let w1, w2 = f v.value in
+  let pos = v.position in
+    ({ value = w1; position = pos }, { value = w2; position = pos })
+
+let dummy =
+  {
+    start_p = Lexing.dummy_pos;
+    end_p   = Lexing.dummy_pos
+  }
+
+let unknown_pos v =
+  {
+    value     = v;
+    position  = dummy
+  }
+
+let start_of_position p = p.start_p
+
+let end_of_position p = p.end_p
+
+let filename_of_position p =
+  p.start_p.Lexing.pos_fname
+
+let line p =
+  p.pos_lnum
+
+let column p =
+  p.pos_cnum - p.pos_bol
+
+let characters p1 p2 =
+  (column p1, p2.pos_cnum - p1.pos_bol) (* intentionally [p1.pos_bol] *)
+
+let join x1 x2 =
+  {
+    start_p = if x1 = dummy then x2.start_p else x1.start_p;
+    end_p   = if x2 = dummy then x1.end_p else x2.end_p
+  }
+
+let lex_join x1 x2 =
+  {
+    start_p = x1;
+    end_p   = x2
+  }
+
+let join_located l1 l2 f =
+  {
+    value    = f l1.value l2.value;
+    position = join l1.position l2.position;
+  }
+
+let string_of_lex_pos p =
+  let c = p.pos_cnum - p.pos_bol in
+  (string_of_int p.pos_lnum)^":"^(string_of_int c)
+
+let string_of_pos p =
+  let filename = filename_of_position p in
+  let l = line p.start_p in
+  let c1, c2 = characters p.start_p p.end_p in
+    if filename = "" then
+      Printf.sprintf "Line %d, characters %d-%d" l c1 c2
+    else 
+      Printf.sprintf "File \"%s\", line %d, characters %d-%d" filename l c1 c2
+
+let pos_or_undef = function
+  | None -> dummy
+  | Some x -> x
+
+let cpos lexbuf =
+  {
+    start_p = Lexing.lexeme_start_p lexbuf;
+    end_p   = Lexing.lexeme_end_p   lexbuf;
+  }
+
+let with_cpos lexbuf v =
+  with_pos (cpos lexbuf) v
+
+let string_of_cpos lexbuf =
+  string_of_pos (cpos lexbuf)
+
+let joinf f t1 t2 =
+  join (f t1) (f t2)
+
+let ljoinf f =
+  List.fold_left (fun p t -> join p (f t)) dummy
+
+let join_located_list ls f =
+  {
+    value     = f (List.map (fun l -> l.value) ls);
+    position  = ljoinf (fun x -> x.position) ls
+  }

flap/src/utilities/position.mli

@@ -0,0 +1,112 @@
+(** Extension of standard library's positions. *)
+
+(** {2 Extended lexing positions} *)
+
+(** Abstract type for pairs of positions in the lexing stream. *)
+type t
+type position = t
+
+(** Decoration of a value with a position. *)
+type 'a located =
+    {
+      value    : 'a;
+      position : t;
+    } [@@deriving sexp]
+
+(** [value dv] returns the raw value that underlies the
+    decorated value [dv]. *)
+val value: 'a located -> 'a
+
+(** [position dv] returns the position that decorates the
+    decorated value [dv]. *)
+val position: 'a located -> t
+
+(** [destruct dv] returns the couple of position and value
+    of a decorated value [dv]. *)
+val destruct: 'a located -> 'a * t
+
+(** [located f x] applies [f] to the value of [x]. *)
+val located : ('a -> 'b) -> 'a located -> 'b
+
+(** [located_pos f x] applies [f] to the position and value of [x]. *)
+val located_pos : (t -> 'a -> 'b) -> 'a located -> 'b
+
+(** [with_pos p v] decorates [v] with a position [p]. *)
+val with_pos : t -> 'a -> 'a located
+
+(** [with_cpos p v] decorates [v] with a lexical position [p]. *)
+val with_cpos: Lexing.lexbuf -> 'a -> 'a located
+
+(** [with_poss start stop v] decorates [v] with a position [(start, stop)]. *)
+val with_poss : Lexing.position -> Lexing.position -> 'a -> 'a located
+
+(** [unknown_pos x] decorates [v] with an unknown position. *)
+val unknown_pos : 'a -> 'a located
+
+(** This value is used when an object does not come from a particular
+    input location. *)
+val dummy: t
+
+(** [map f v] extends the decoration from [v] to [f v]. *)
+val map: ('a -> 'b) -> 'a located -> 'b located
+
+(** [iter f dv] applies [f] to the value inside [dv]. *)
+val iter: ('a -> unit) -> 'a located -> unit
+
+(** [mapd f v] extends the decoration from [v] to both members of the pair
+    [f v]. *)
+val mapd: ('a -> 'b1 * 'b2) -> 'a located -> 'b1 located * 'b2 located
+
+(** {2 Accessors} *)
+
+(** [column p] returns the number of characters from the
+    beginning of the line of the Lexing.position [p]. *)
+val column : Lexing.position -> int
+
+(** [column p] returns the line number of to the Lexing.position [p]. *)
+val line : Lexing.position -> int
+
+(** [characters p1 p2] returns the character interval
+    between [p1] and [p2] assuming they are located in the same
+    line. *)
+val characters : Lexing.position -> Lexing.position -> int * int
+
+(** [start_of_position p] returns the beginning of a position [p]. *)
+val start_of_position: t -> Lexing.position
+
+(** [end_of_position p] returns the end of a position [p]. *)
+val end_of_position: t -> Lexing.position
+
+(** [filename_of_position p] returns the filename of a position [p]. *)
+val filename_of_position: t -> string
+
+(** {2 Position handling} *)
+
+(** [join p1 p2] returns a position that starts where [p1]
+    starts and stops where [p2] stops. *)
+val join : t -> t -> t
+
+(** [lex_join l1 l2] returns a position that starts at [l1] and stops
+    at [l2]. *)
+val lex_join : Lexing.position -> Lexing.position -> t
+
+(** [string_of_lex_pos p] returns a string representation for
+    the lexing position [p]. *)
+val string_of_lex_pos : Lexing.position -> string
+
+(** [string_of_pos p] returns the standard (Emacs-like) representation
+    of the position [p]. *)
+val string_of_pos : t -> string
+
+(** [pos_or_undef po] is the identity function except if po = None,
+    in that case, it returns [undefined_position]. *)
+val pos_or_undef : t option -> t
+
+(** {2 Interaction with the lexer runtime} *)
+
+(** [cpos lexbuf] returns the current position of the lexer. *)
+val cpos : Lexing.lexbuf -> t
+
+(** [string_of_cpos p] returns a string representation of
+    the lexer's current position. *)
+val string_of_cpos : Lexing.lexbuf -> string

flap/src/utilities/stdUserInput.ml

@@ -0,0 +1,22 @@
+let prompt = ref ""
+
+let set_prompt = ( := ) prompt
+
+let print_prompt () =
+  output_string stdout !prompt;
+  flush stdout
+
+let input_char =
+  let display_prompt  = ref true in
+  let ask stdin =
+    if !display_prompt then begin
+      display_prompt := false;
+      print_prompt ()
+    end;
+    let c = input_char stdin in
+    if c = '\n' then display_prompt := true;
+    String.make 1 c
+  in
+    ask
+
+let set_ascii () = ()

flap/src/utilities/userInput.ml

@@ -0,0 +1 @@
+include StdUserInput

flap/src/version.ml

@@ -0,0 +1 @@
+let number = "19.1"

flap/src/x86-64/retrolixToX86_64.ml

@@ -0,0 +1,584 @@
+(** This module implements a compiler from Retrolix to X86-64 *)
+
+(** In more details, this module performs the following tasks:
+   - turning accesses to local variables and function parameters into stack
+     loads and stores ;
+   - generating initialization code and reserving space in the .data section for
+     global variables ;
+   - reserving space in the .data section for literal strings.
+ *)
+
+(* TODO tail recursion *)
+
+let error ?(pos = Position.dummy) msg =
+  Error.error "compilation" pos msg
+
+(** As in any module that implements {!Compilers.Compiler}, the source
+    language and the target language must be specified. *)
+module Source = Retrolix
+module Target = X86_64
+module S = Source.AST
+module T = Target.AST
+
+module Str = struct type t = string let compare = Stdlib.compare end
+module StrMap = Map.Make(Str)
+module StrSet = Set.Make(Str)
+
+(** {2 Low-level helpers} *)
+
+let scratchr = X86_64_Architecture.scratch_register
+
+let scratch = `Reg scratchr
+let rsp = `Reg X86_64_Architecture.RSP
+let rbp = `Reg X86_64_Architecture.RBP
+let rdi = `Reg X86_64_Architecture.RDI
+
+(** [align n b] returns the smallest multiple of [b] larger than [n]. *)
+let align n b =
+  let m = n mod b in
+  if m = 0 then n else n + b - m
+
+(** {2 Label mangling and generation} *)
+
+let hash x = string_of_int (Hashtbl.hash x)
+
+let label_for_string_id id =
+  ".S_" ^ string_of_int id
+
+let label_of_retrolix_label (s : string) =
+  s
+
+let label_of_function_identifier (S.FId s) =
+  label_of_retrolix_label s
+
+let data_label_of_global (S.Id s) =
+  label_of_retrolix_label s
+
+let init_label_of_global (xs : S.identifier list) =
+  ".I_" ^ hash xs
+
+let label_of_internal_label_id (id : T.label) =
+  ".X_" ^ id
+
+let fresh_label : unit -> T.label =
+  let r = ref 0 in
+  fun () -> incr r; label_of_internal_label_id (string_of_int !r)
+
+let fresh_string_label : unit -> string =
+  let r = ref 0 in
+  fun () -> let n = !r in incr r; label_for_string_id n
+
+(** {2 Environments} *)
+
+type environment =
+  {
+    externals : S.FIdSet.t;
+    (** All the external functions declared in the retrolix program. *)
+    globals : S.IdSet.t;
+    (** All the global variables found in the Retrolix program, each with a
+        unique integer. *)
+    data_lines : T.line list;
+    (** All the lines to be added to the .data section of the complete file. *)
+  }
+
+let make_environment ~externals ~globals () =
+  let open T in
+
+  let data_lines =
+    S.IdSet.fold
+      (fun ((S.Id id_s) as id) lines ->
+        Label (data_label_of_global id)
+        :: Instruction (Comment id_s)
+        :: Directive (Quad [Lit Mint.zero])
+        :: lines
+      )
+      globals
+      []
+  in
+
+  let data_lines =
+    S.FIdSet.fold
+      (fun (S.FId f) lines -> Directive (Extern f) :: lines)
+      externals
+      data_lines
+  in
+
+  {
+    externals;
+    globals;
+    data_lines;
+  }
+
+let is_external env (f : S.rvalue) =
+  match f with
+  | `Immediate (S.LFun f) ->
+     S.FIdSet.mem f env.externals
+  | _ ->
+     false
+
+let is_global env f =
+  S.IdSet.mem f env.globals
+
+let register_string s env =
+  let open T in
+  let l = fresh_string_label () in
+  l,
+  { env with data_lines = Label l :: Directive (String s) :: env.data_lines; }
+
+(* The following function is here to please Flap's architecture. *)
+let initial_environment () =
+  make_environment ~externals:S.FIdSet.empty ~globals:S.IdSet.empty ()
+
+let register_globals global_set env =
+  let open T in
+  let globals, data_lines =
+    S.IdSet.fold
+      (fun ((S.Id id_s) as id) (globals, lines) ->
+        S.IdSet.add id globals,
+        Label (data_label_of_global id)
+        :: Instruction (Comment id_s)
+        :: Directive (Quad [Lit Mint.zero])
+        :: lines
+      )
+      global_set
+      (S.IdSet.empty, env.data_lines)
+  in
+  { env with globals; data_lines; }
+
+(** {2 Abstract instruction selectors and calling conventions} *)
+
+module type InstructionSelector =
+  sig
+    (** [mov ~dst ~src] generates the x86-64 assembly listing to copy [src] into
+        [dst]. *)
+    val mov : dst:T.dst -> src:T.src -> T.line list
+
+    (** [add ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl + srcr] into [dst]. *)
+    val add : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [sub ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl - srcr] into [dst]. *)
+    val sub : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [mul ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl * srcr] into [dst]. *)
+    val mul : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [div ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl / srcr] into [dst]. *)
+    val div : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [andl ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl & srcr] into [dst]. *)
+    val andl : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [orl ~dst ~srcl ~srcr] generates the x86-64 assembly listing to store
+        [srcl | srcr] into [dst]. *)
+    val orl : dst:T.dst -> srcl:T.src -> srcr:T.src -> T.line list
+
+    (** [conditional_jump ~cc ~srcl ~srcr ~ll ~lr] generates the x86-64 assembly
+        listing to test whether [srcl, srcr] satisfies the relation described by
+        [cc] and jump to [ll] if they do or to [lr] when they do not. *)
+    val conditional_jump :
+      cc:T.condcode ->
+      srcl:T.src -> srcr:T.src ->
+      ll:T.label -> lr:T.label ->
+      T.line list
+
+    (** [switch ~default ~discriminant ~cases ()] generates the x86-64 assembly
+       listing to jump to [cases.(discriminant)], or to the (optional) [default]
+       label when discriminant is larger than [Array.length cases].
+
+       The behavior of the program is undefined if [discriminant < 0], or if
+       [discriminant >= Array.length cases] and no [default] has been given. *)
+    val switch :
+      ?default:T.label ->
+      discriminant:T.src ->
+      cases:T.label array ->
+      unit ->
+      T.line list
+  end
+
+module type FrameManager =
+  sig
+    (** The abstract data structure holding the information necessary to
+        implement the calling convention. *)
+    type frame_descriptor
+
+    (** Generate a frame descriptor for the function with parameter [params] and
+        locals [locals]. *)
+    val frame_descriptor :
+      params:S.identifier list ->
+      locals:S.identifier list ->
+      frame_descriptor
+
+    (** [location_of fd v] computes the address of [v] according to the frame
+        descriptor [fd]. Note that [v] might be a local variable, a function
+        parameter, or a global variable. *)
+    val location_of : frame_descriptor -> S.identifier -> T.address
+
+    (** [function_prologue fd] generates the x86-64 assembly listing to setup
+        a stack frame according to the frame descriptor [fd]. *)
+    val function_prologue : frame_descriptor -> T.line list
+
+    (** [function_epilogue fd] generates the x86-64 assembly listing to setup a
+        stack frame according to the frame descriptor [fd]. *)
+    val function_epilogue : frame_descriptor -> T.line list
+
+    (** [call fd ~kind ~f ~args] generates the x86-64 assembly listing to setup
+        a call to the function at [f], with arguments [args], with [kind]
+        specifying whether this should be a normal or tail call.  *)
+    val call :
+      frame_descriptor ->
+      kind:[ `Normal | `Tail ] ->
+      f:T.src ->
+      args:T.src list ->
+      T.line list
+  end
+
+(** {2 Code generator} *)
+
+(** This module implements an x86-64 code generator for Retrolix using the
+    provided [InstructionSelector] and [FrameManager].  *)
+module Codegen(IS : InstructionSelector)(FM : FrameManager) =
+  struct
+    let translate_label (S.Label l) =
+      label_of_retrolix_label l
+
+    let translate_variable fd v =
+      `Addr (FM.location_of fd v)
+
+    let translate_literal lit env =
+      match lit with
+      | S.LInt i ->
+         T.Lit i, env
+
+      | S.LFun f ->
+         T.Lab (label_of_function_identifier f), env
+
+      | S.LChar c ->
+         T.Lit (Mint.of_int @@ Char.code c), env
+
+      | S.LString s ->
+         let l, env = register_string s env in
+         T.Lab l, env
+
+    let translate_register (S.RId s) =
+      X86_64_Architecture.register_of_string s
+
+    let translate_lvalue fi lv =
+      match lv with
+      | `Variable v ->
+         translate_variable fi v
+      | `Register reg ->
+         `Reg (translate_register reg)
+
+    let translate_rvalue fi rv env =
+      match rv with
+      | `Immediate lit ->
+         let lit, env = translate_literal lit env in
+         `Imm lit, env
+      | (`Variable _ | `Register _) as lv ->
+         translate_lvalue fi lv, env
+
+    let translate_rvalues fi rvs env =
+      List.fold_right
+        (fun rv (rvs, env) ->
+          let rv, env = translate_rvalue fi rv env in
+          rv :: rvs, env)
+        rvs
+        ([], env)
+
+    let translate_label_to_operand (S.Label l) =
+      `Imm (T.Lab l)
+
+    let translate_cond cond =
+      match cond with
+      | S.GT -> T.G
+      | S.LT -> T.L
+      | S.GTE -> T.GE
+      | S.LTE -> T.LE
+      | S.EQ -> T.E
+
+    let translate_instruction fd ins env : T.line list * environment  =
+      let open T in
+      begin match ins with
+      | S.Call (f, args, is_tail) ->
+         let kind = if is_tail then `Tail else `Normal in
+         let f, env = translate_rvalue fd f env in
+         let args, env = translate_rvalues fd args env in
+         FM.call fd ~kind ~f ~args,
+         env
+
+      | S.Assign (dst, op, args) ->
+         let dst = translate_lvalue fd dst in
+         let args, env = translate_rvalues fd args env in
+         let inss =
+           match op, args with
+           | S.Add, [ srcl; srcr; ] ->
+              IS.add ~dst ~srcl ~srcr
+           | S.Sub, [ srcl; srcr; ] ->
+              IS.sub ~dst ~srcl ~srcr
+           | S.Mul, [ srcl; srcr; ] ->
+              IS.mul ~dst ~srcl ~srcr
+           | S.Div, [ srcl; srcr; ] ->
+              IS.div ~dst ~srcl ~srcr
+           | S.And, [ srcl; srcr; ] ->
+              IS.andl ~dst ~srcl ~srcr
+           | S.Or, [ srcl; srcr; ] ->
+              IS.orl ~dst ~srcl ~srcr
+           | S.Copy, [ src; ] ->
+              IS.mov ~dst ~src
+           | _ ->
+              error "Unknown operator or bad arity"
+         in
+         inss, env
+
+      | S.Ret ->
+         FM.function_epilogue fd @ insns [T.Ret],
+         env
+
+      | S.Jump l ->
+         insns
+           [
+             T.jmpl ~tgt:(translate_label l);
+           ],
+         env
+
+      | S.ConditionalJump (cond, args, ll, lr) ->
+         let cc = translate_cond cond in
+         let srcl, srcr, env =
+           match args with
+           | [ src1; src2; ] ->
+              let src1, env = translate_rvalue fd src1 env in
+              let src2, env = translate_rvalue fd src2 env in
+              src1, src2, env
+           | _ ->
+              failwith "translate_exp: conditional jump with invalid arity"
+         in
+         IS.conditional_jump
+           ~cc
+           ~srcl ~srcr
+           ~ll:(translate_label ll) ~lr:(translate_label lr),
+         env
+
+      | S.Switch (discriminant, cases, default) ->
+         let discriminant, env = translate_rvalue fd discriminant env in
+         let cases = Array.map translate_label cases in
+         let default = ExtStd.Option.map translate_label default in
+         IS.switch ?default ~discriminant ~cases (),
+         env
+
+      | S.Comment s ->
+         insns
+           [
+             Comment s;
+           ],
+         env
+
+      | S.Exit ->
+         IS.mov ~src:(liti 0) ~dst:rdi
+         @ FM.call fd ~kind:`Normal ~f:(`Imm (Lab "exit")) ~args:[],
+         env
+      end
+
+
+    let translate_labelled_instruction fi (body, env) (l, ins) =
+      let ins, env = translate_instruction fi ins env in
+      List.rev ins @ T.Label (translate_label l) :: body,
+      env
+
+    let translate_labelled_instructions fi env inss =
+      let inss, env =
+        List.fold_left (translate_labelled_instruction fi) ([], env) inss
+      in
+      List.rev inss, env
+
+    let translate_fun_def ~name ?(desc = "") ~params ~locals gen_body =
+      let open T in
+
+      let fd = FM.frame_descriptor ~params ~locals in
+
+      let prologue = FM.function_prologue fd in
+
+      let body, env = gen_body fd in
+
+      Directive (PadToAlign { pow = 3; fill = 0x90; }) :: Label name
+      :: (if desc = ""
+          then prologue
+          else Instruction (Comment desc) :: prologue)
+      @ body,
+      env
+
+    let translate_block ~name ?(desc = "") ~params (locals, body) env =
+      translate_fun_def
+        ~name
+        ~desc
+        ~params
+        ~locals
+        (fun fi -> translate_labelled_instructions fi env body)
+
+    let translate_definition def (body, env) =
+      match def with
+      | S.DValues (xs, block) ->
+         let ids = ExtPPrint.to_string RetrolixPrettyPrinter.identifiers xs in
+         let name = init_label_of_global xs in
+         let def, env =
+           translate_block
+             ~name
+             ~desc:("Initializer for " ^ ids ^ ".")
+             ~params:[]
+             block
+             env
+         in
+         def @ body, env
+
+      | S.DFunction ((S.FId id) as f, params, block) ->
+         let def, env =
+           translate_block
+             ~desc:("Retrolix function " ^ id ^ ".")
+             ~name:(label_of_function_identifier f)
+             ~params
+             block
+             env
+         in
+         def @ body, env
+
+      | S.DExternalFunction (S.FId id) ->
+         T.(Directive (Extern id)) :: body,
+         env
+
+    let generate_main _ p =
+      let open T in
+
+      let body =
+        List.rev
+          [
+            Directive (PadToAlign { pow = 3; fill = 0x90; });
+            Label "main";
+            Instruction (Comment "Program entry point.");
+            Instruction (T.subq ~src:(`Imm (Lit 8L)) ~dst:rsp);
+          ]
+      in
+
+      (* Call all initialization stubs *)
+      let body =
+        let call body def =
+          match def with
+          | S.DValues (ids, _) ->
+             let l = init_label_of_global ids in
+             Instruction (T.calld ~tgt:(Lab l)) :: body
+          | S.DFunction _ | S.DExternalFunction _ ->
+             body
+        in
+        List.fold_left call body p
+      in
+
+      let body =
+        T.insns
+          [
+            T.calld ~tgt:(Lab "exit");
+            T.movq ~src:(liti 0) ~dst:rdi;
+          ]
+        @ body
+      in
+
+      Directive (Global "main") :: List.rev body
+
+    (** [translate p env] turns a Retrolix program into a X86-64 program. *)
+    let translate (p : S.t) (env : environment) : T.t * environment =
+      let env = register_globals (S.globals p) env in
+      let pt, env = List.fold_right translate_definition p ([], env) in
+      let main = generate_main env p in
+      let p = T.data_section :: env.data_lines @ T.text_section :: main @ pt in
+      T.remove_unused_labels p, env
+  end
+
+(** {2 Concrete instructions selectors and calling conventions} *)
+
+module InstructionSelector : InstructionSelector =
+  struct
+    open T
+
+    let mov ~(dst : dst) ~(src : src) =
+      failwith "Students! This is your job!"
+
+    let bin ins ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let add ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let sub ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let mul ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let div ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let andl ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let orl ~dst ~srcl ~srcr =
+      failwith "Students! This is your job!"
+
+    let conditional_jump ~cc ~srcl ~srcr ~ll ~lr =
+      failwith "Students! This is your job!"
+
+    let switch ?default ~discriminant ~cases () =
+      failwith "Students! This is your job!"
+
+  end
+
+module FrameManager(IS : InstructionSelector) : FrameManager =
+  struct
+    type frame_descriptor =
+      {
+        param_count : int;
+        (** Number of parameters. *)
+        locals_space : int;
+        (** Amount of space dedicated to local variables in the stack frame. *)
+        stack_map : Mint.t S.IdMap.t;
+        (** Maps stack-allocated variable names to stack slots expressed as
+            frame-pointer relative offsets. *)
+      }
+
+    (** [empty_frame fd] returns [true] if and only if the stack frame described
+        by [fd] is empty. *)
+    let empty_frame fd =
+      fd.param_count = 0 && fd.locals_space = 0
+
+    (** [stack_usage_after_prologue fd] returns the size, in bytes, of the stack
+        space after the function prologue. *)
+    let stack_usage_after_prologue fd =
+      Mint.size_in_bytes
+      + (if empty_frame fd then 0 else 1) * Mint.size_in_bytes
+      + fd.locals_space
+
+    let frame_descriptor ~params ~locals =
+      (* Student! Implement me! *)
+      { param_count = 0; locals_space = 0; stack_map = S.IdMap.empty; }
+
+    let location_of fd id =
+      failwith "Students! This is your job!"
+
+    let function_prologue fd =
+      (* Student! Implement me! *)
+      []
+
+    let function_epilogue fd =
+      (* Student! Implement me! *)
+      []
+
+    let call fd ~kind ~f ~args =
+      failwith "Students! This is your job!"
+
+  end
+
+module CG =
+  Codegen(InstructionSelector)(FrameManager(InstructionSelector))
+
+let translate = CG.translate