├── .gitignore ├── Makefile ├── README.md ├── dune-project ├── src ├── boundID.ml ├── boundID.mli ├── dune ├── env.ml ├── env.mli ├── evaluator.ml ├── freeID.ml ├── freeID.mli ├── lexer.mll ├── main.ml ├── operation.ml ├── parser.mly ├── parserInterface.ml ├── primitives.ml ├── range.ml ├── range.mli ├── richPrinting.ml ├── symbol.ml ├── symbol.mli ├── syntax.ml ├── typechecker.ml ├── typeenv.ml └── typeenv.mli └── test ├── bind.txt ├── genpower.txt ├── genpower2.txt ├── genpower3.txt └── single-stage.txt /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *~ 3 | .merlin 4 | .DS_Store 5 | main 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build src/main.exe 3 | cp _build/default/src/main.exe ./main 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # An implementation of MacroML 2 | 3 | This is an implementation of *MacroML* \[1\]. It consists of 4 | 5 | * a type checker for MacroML (which also performs the translation of MacroML programs to *MetaML* \[2\]), and 6 | * a naïve back-end interpreter of MetaML. 7 | 8 | The syntax and the type system are naturally extended from the original version as to macro parameters. See the paper below \[1\] for detail: 9 | 10 | > 1. Steve Ganz, Amr Sabry, and Walid Taha. [Macros as multi-stage computations: Type-safe, generative, binding macros in MacroML](https://dl.acm.org/citation.cfm?id=507646). In _Proceedings of the International Conference on Functional Programming (ICFP’01)_, pages 74–85, 2001. 11 | > 2. Walid Taha and Tim Sheard. [MetaML: Multi-stage programming with explicit annotations](https://dl.acm.org/citation.cfm?id=259019). In _Proceedings of the Symposium on Partial Evaluation and Semantic-Based Program Manipulation (PEPM’97)_, pages 203–217, 1997. 12 | 13 | 14 | ## How to Compile 15 | 16 | Under the condition that `make` and `dune` are installed, invoke: 17 | 18 | ~~~sh 19 | $ make 20 | ~~~ 21 | 22 | and then the executable file `./main` will be created. 23 | 24 | 25 | ## Usage 26 | 27 | Just invoke: 28 | 29 | ~~~sh 30 | $ ./main 31 | ~~~ 32 | 33 | and then you can see on stdout: 34 | 35 | ~~~sh 36 | Type: 37 | Result1: 38 | Result0: 39 | ~~~ 40 | 41 | 42 | ## Syntax 43 | 44 | ~~~ 45 | an expression: 46 | e ::= 47 | | '(' e ')' 48 | | b (a Boolean value) 49 | | n (an integer) 50 | | x 51 | | 'fun' '(' x ':' ty ')' '->' e 52 | | e e 53 | | 'let' '(' x ':' ty ')' '=' e 'in' e 54 | | 'letrec' '('x ':' ty ')' '=' e 'in' e 55 | | 'if' e 'then' e 'else e 56 | | 'letmac' x '!' '(' ps ')' ':' ty '=' e 'in' e (a macro definition) 57 | | x '!' '(' as ')' (a macro application) 58 | | '~' e (so-called an escape) 59 | | '@' e (so-called a bracket) 60 | 61 | a non-empty sequence of macro parameter(s): 62 | ps ::= p | p ',' ps 63 | 64 | a macro parameter: 65 | p ::= 66 | | '~' '(' x ':' ty ')' (an early parameter) 67 | | x ':' ty (a late parameter) 68 | | '(' x ':' ty ')' '->' '(' x ':' ty ')' (a binder/bindee parameter) 69 | 70 | a non-empty sequence of macro argument(s): 71 | as ::= a | a ',' as 72 | 73 | a macro argument: 74 | a ::= 75 | | '~' e (an early argument) 76 | | e (a late argument) 77 | | x '->' e (a binder/bindee argument) 78 | 79 | a monomorphic type: 80 | ty ::= 81 | | '(' ty ')' 82 | | 'bool' 83 | | 'int' 84 | | ty '->' ty 85 | | '@' ty (a code type) 86 | ~~~ 87 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (using menhir 1.0) 3 | -------------------------------------------------------------------------------- /src/boundID.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = { 3 | id : int; 4 | } 5 | 6 | 7 | let equal bid1 bid2 = 8 | bid1.id = bid2.id 9 | 10 | 11 | let hash = Hashtbl.hash 12 | 13 | 14 | let current_max = ref 0 15 | 16 | 17 | let initialize () = 18 | current_max := 0 19 | 20 | 21 | let fresh () = 22 | incr current_max; 23 | { id = !current_max; } 24 | -------------------------------------------------------------------------------- /src/boundID.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val initialize : unit -> unit 5 | 6 | val fresh : unit -> t 7 | 8 | val equal : t -> t -> bool 9 | 10 | val hash : t -> int 11 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | ; (public_name langprocbase) 4 | (flags (-w -3 -bin-annot -thread)) 5 | (libraries 6 | menhirLib 7 | ) 8 | (preprocess 9 | (pps 10 | ppx_deriving.show 11 | ) 12 | ) 13 | ) 14 | 15 | ;; dune requires all the .ml/.mli files to be in the same directory as the jbuild. 16 | ;; https://github.com/ocaml/dune/issues/109 17 | ;;(copy_files# ./*.{ml,mli}) 18 | ;;(copy_files ./*.{mll,mly}) 19 | 20 | (ocamllex 21 | (modules lexer)) 22 | 23 | (menhir 24 | (modules parser) 25 | (flags (--table --explain))) 26 | -------------------------------------------------------------------------------- /src/env.ml: -------------------------------------------------------------------------------- 1 | 2 | module VarMap = Map.Make(String) 3 | 4 | type ('v0, 'v1) entry = 5 | | V0 of 'v0 6 | | V1 of 'v1 7 | | Both of 'v0 8 | 9 | type ('v0, 'v1) t = (('v0, 'v1) entry) VarMap.t 10 | 11 | 12 | let empty = VarMap.empty 13 | 14 | 15 | let add = VarMap.add 16 | 17 | 18 | let find_opt = VarMap.find_opt 19 | -------------------------------------------------------------------------------- /src/env.mli: -------------------------------------------------------------------------------- 1 | 2 | type ('v0, 'v1) entry = 3 | | V0 of 'v0 4 | | V1 of 'v1 5 | | Both of 'v0 6 | 7 | type ('v0, 'v1) t 8 | 9 | val empty : ('v0, 'v1) t 10 | 11 | val add : string -> ('v0, 'v1) entry -> ('v0, 'v1) t -> ('v0, 'v1) t 12 | 13 | val find_opt : string -> ('v0, 'v1) t -> (('v0, 'v1) entry) option 14 | -------------------------------------------------------------------------------- /src/evaluator.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | let rec eval_0 (env : environment) (eve : ev_ast) : ev_value_0 = 6 | match eve with 7 | | EvValue0(v) -> 8 | v 9 | 10 | | EvValue1(_) -> 11 | failwith "EvValue1 at stage 0" 12 | 13 | | EvVariable(x) -> 14 | begin 15 | match env |> Env.find_opt x with 16 | | None -> 17 | failwith ("variable '" ^ x ^ "' not found") 18 | 19 | | Some(entry) -> 20 | begin 21 | match entry with 22 | | Env.V1(_) -> failwith ("variable '" ^ x ^ "' is for stage 1") 23 | | Env.V0(v) -> v 24 | | Env.Both(v) -> v 25 | end 26 | end 27 | 28 | | EvFix(fopt, x, eve1) -> 29 | V0Closure(fopt, x, eve1, env) 30 | 31 | | EvApply(eve1, eve2) -> 32 | let v1 = eval_0 env eve1 in 33 | let v2 = eval_0 env eve2 in 34 | begin 35 | match v1 with 36 | | V0Closure(fopt, x, eve0, env0) -> 37 | let env0 = 38 | match fopt with 39 | | Some(f) -> env0 |> Env.add f (Env.V0(v1)) 40 | | None -> env0 41 | in 42 | eval_0 (env0 |> Env.add x (Env.V0(v2))) eve0 43 | 44 | | _ -> 45 | failwith "not a stage-0 closure" 46 | end 47 | 48 | | EvOperation(opapp) -> 49 | let opapp0 = Operation.map (eval_0 env) opapp in 50 | Primitives.eval_0_operation opapp0 51 | 52 | | EvIf(eve0, eve1, eve2) -> 53 | let v0 = eval_0 env eve0 in 54 | begin 55 | match v0 with 56 | | V0Embed(ValBool(b)) -> 57 | if b then 58 | eval_0 env eve1 59 | else 60 | eval_0 env eve2 61 | 62 | | _ -> 63 | failwith "not a stage-0 Boolean value for an if-expression" 64 | end 65 | 66 | | EvPrev(_) -> 67 | failwith "Prev at stage 0" 68 | 69 | | EvNext(eve0) -> 70 | let v0 = eval_1 env eve0 in 71 | V0Next(v0) 72 | 73 | 74 | and eval_1 (env : environment) (eve : ev_ast) : ev_value_1 = 75 | match eve with 76 | | EvValue0(_) -> 77 | failwith "EvValue0 at stage 1" 78 | 79 | | EvValue1(v) -> 80 | v 81 | 82 | | EvVariable(x) -> 83 | begin 84 | match env |> Env.find_opt x with 85 | | None -> 86 | failwith ("variable '" ^ x ^ "' not found") 87 | 88 | | Some(entry) -> 89 | begin 90 | match entry with 91 | | Env.V0(_) -> failwith ("variable '" ^ x ^ "' is for stage 0") 92 | | Env.V1(v) -> v 93 | | Env.Both(_) -> V1Primitive(x) 94 | end 95 | end 96 | 97 | | EvFix(fopt, x, eve0) -> 98 | let (sfopt, env) = 99 | match fopt with 100 | | None -> 101 | (None, env) 102 | 103 | | Some(f) -> 104 | let sf = Symbol.generate () in 105 | (Some(sf), env |> Env.add f (Env.V1(V1Symbol(sf)))) 106 | in 107 | let sx = Symbol.generate () in 108 | let v0 = eval_1 (env |> Env.add x (Env.V1(V1Symbol(sx)))) eve0 in 109 | V1Fix(sfopt, sx, v0) 110 | 111 | | EvApply(eve1, eve2) -> 112 | let v1 = eval_1 env eve1 in 113 | let v2 = eval_1 env eve2 in 114 | V1Apply(v1, v2) 115 | 116 | | EvOperation(opapp) -> 117 | failwith "EvOperation at stage 1" 118 | 119 | | EvIf(eve0, eve1, eve2) -> 120 | let v0 = eval_1 env eve0 in 121 | let v1 = eval_1 env eve1 in 122 | let v2 = eval_1 env eve2 in 123 | V1If(v0, v1, v2) 124 | 125 | | EvPrev(eve0) -> 126 | let v0 = eval_0 env eve0 in 127 | begin 128 | match v0 with 129 | | V0Next(v) -> v 130 | | _ -> failwith "not a V0Next" 131 | end 132 | 133 | | EvNext(_) -> 134 | failwith "EvNext at stage 1" 135 | 136 | 137 | let rec unlift (v : ev_value_1) : ev_ast = 138 | match v with 139 | | V1Embed(c) -> 140 | EvValue0(V0Embed(c)) 141 | 142 | | V1Symbol(symb) -> 143 | let x = Symbol.to_identifier symb in 144 | EvVariable(x) 145 | 146 | | V1Primitive(x) -> 147 | EvVariable(x) 148 | 149 | | V1Fix(sfopt, sx, v0) -> 150 | let fopt = 151 | match sfopt with 152 | | None -> None 153 | | Some(sf) -> Some(Symbol.to_identifier sf) 154 | in 155 | let x = Symbol.to_identifier sx in 156 | let eve0 = unlift v0 in 157 | EvFix(fopt, x, eve0) 158 | 159 | | V1Apply(v1, v2) -> 160 | let eve1 = unlift v1 in 161 | let eve2 = unlift v2 in 162 | EvApply(eve1, eve2) 163 | 164 | | V1If(v0, v1, v2) -> 165 | let eve0 = unlift v0 in 166 | let eve1 = unlift v1 in 167 | let eve2 = unlift v2 in 168 | EvIf(eve0, eve1, eve2) 169 | 170 | 171 | let main (env : environment) (eve : ev_ast) : ev_value_0 = 172 | let v1 = eval_1 env eve in 173 | Format.printf "Result1: %a\n" RichPrinting.pp_ev_value_1_single v1; 174 | let eve = unlift v1 in 175 | eval_0 env eve 176 | -------------------------------------------------------------------------------- /src/freeID.ml: -------------------------------------------------------------------------------- 1 | 2 | type level = int 3 | 4 | type t = { 5 | id : int; 6 | mutable level : level; 7 | } 8 | 9 | 10 | let equal fid1 fid2 = 11 | fid1.id = fid2.id 12 | 13 | 14 | let hash = Hashtbl.hash 15 | 16 | 17 | let current_max = ref 0 18 | 19 | 20 | let initialize () = 21 | current_max := 0 22 | 23 | 24 | let fresh lev = 25 | incr current_max; 26 | { id = !current_max; level = lev; } 27 | 28 | 29 | let get_level fid = 30 | fid.level 31 | 32 | 33 | let update_level fid lev = 34 | fid.level <- min fid.level lev 35 | 36 | 37 | let pp ppf fid = 38 | Format.fprintf ppf "'%d" fid.id 39 | -------------------------------------------------------------------------------- /src/freeID.mli: -------------------------------------------------------------------------------- 1 | 2 | type level = int 3 | 4 | type t 5 | 6 | val equal : t -> t -> bool 7 | 8 | val hash : t -> int 9 | 10 | val initialize : unit -> unit 11 | 12 | val fresh : level -> t 13 | 14 | val get_level : t -> level 15 | 16 | val update_level : t -> level -> unit 17 | 18 | val pp : Format.formatter -> t -> unit 19 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Syntax 3 | open Parser 4 | } 5 | 6 | let space = [' ' '\t'] 7 | let break = ['\n' '\r'] 8 | let nzdigit = ['1'-'9'] 9 | let digit = (nzdigit | "0") 10 | let hex = (digit | ['A'-'F']) 11 | let capital = ['A'-'Z'] 12 | let small = ['a'-'z'] 13 | let latin = (small | capital) 14 | let identifier = (small (digit | latin | "_")*) 15 | let constructor = (capital (digit | latin | "_")*) 16 | let nssymbol = ['&' '|' '=' '<' '>' '/' '+' '-'] 17 | 18 | rule token = parse 19 | | space { token lexbuf } 20 | | break { Lexing.new_line lexbuf; token lexbuf } 21 | | identifier { 22 | let s = Lexing.lexeme lexbuf in 23 | let pos = Range.from_lexbuf lexbuf in 24 | match s with 25 | | "let" -> LET(pos) 26 | | "letrec" -> LETREC(pos) 27 | | "letmac" -> LETMAC(pos) 28 | | "in" -> IN(pos) 29 | | "fun" -> LAMBDA(pos) 30 | | "if" -> IF(pos) 31 | | "then" -> THEN(pos) 32 | | "else" -> ELSE(pos) 33 | | "true" -> TRUE(pos) 34 | | "false" -> FALSE(pos) 35 | | _ -> IDENT(pos, s) 36 | } 37 | | ("0" | nzdigit (digit*) | ("0x" | "0X") hex+) { 38 | let s = Lexing.lexeme lexbuf in 39 | let rng = Range.from_lexbuf lexbuf in 40 | INT(rng, int_of_string s) 41 | } 42 | | "=" { DEFEQ(Range.from_lexbuf lexbuf) } 43 | | "->" { ARROW(Range.from_lexbuf lexbuf) } 44 | | "(" { LPAREN(Range.from_lexbuf lexbuf) } 45 | | ")" { RPAREN(Range.from_lexbuf lexbuf) } 46 | | ":" { COLON(Range.from_lexbuf lexbuf) } 47 | | "~" { TILDE(Range.from_lexbuf lexbuf) } 48 | | "@" { ATMARK(Range.from_lexbuf lexbuf) } 49 | | "!" { EXCLAMATION(Range.from_lexbuf lexbuf) } 50 | | "," { COMMA(Range.from_lexbuf lexbuf) } 51 | | "/*" { comment (Range.from_lexbuf lexbuf) lexbuf; token lexbuf } 52 | | ("&" (nssymbol*)) { BINOP_AMP(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 53 | | ("|" (nssymbol*)) { BINOP_BAR(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 54 | | ("=" (nssymbol+)) { BINOP_EQ(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 55 | | ("<" (nssymbol+)) { BINOP_LT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 56 | | (">" (nssymbol+)) { BINOP_GT(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 57 | | ("*" (nssymbol*)) { BINOP_TIMES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 58 | | ("/" (nssymbol*)) { BINOP_DIVIDES(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 59 | | ("+" (nssymbol*)) { BINOP_PLUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 60 | | ("-" (nssymbol*)) { BINOP_MINUS(Range.from_lexbuf lexbuf, Lexing.lexeme lexbuf) } 61 | | eof { EOI } 62 | | _ as c { raise (UnidentifiedToken(Range.from_lexbuf lexbuf, String.make 1 c)) } 63 | 64 | and comment rng = parse 65 | | "/*" { comment (Range.from_lexbuf lexbuf) lexbuf; comment rng lexbuf } 66 | | "*/" { () } 67 | | break { Lexing.new_line lexbuf; comment rng lexbuf } 68 | | eof { raise (SeeEndOfFileInComment(rng)) } 69 | | _ { comment rng lexbuf } 70 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | let main fname = 6 | let inc = open_in fname in 7 | let lexbuf = Lexing.from_channel inc in 8 | let utast = ParserInterface.process lexbuf in 9 | let (tyenv, env) = Primitives.initial_type_environment in 10 | let (ty, eve) = Typechecker.main tyenv utast in 11 | Format.printf "Type: %a\n" RichPrinting.pp_mono_type ty; 12 | let v = Evaluator.main env eve in 13 | Format.printf "Result0: %a\n" RichPrinting.pp_ev_value_0_single v; 14 | () 15 | 16 | 17 | let () = 18 | try 19 | Arg.parse [] main "" 20 | with 21 | | ParserInterface.Error(rng) -> 22 | Format.printf "%a: syntax error\n" Range.pp rng 23 | 24 | | UnidentifiedToken(rng, s) -> 25 | Format.printf "%a: unidentified token\n" Range.pp rng 26 | 27 | | SeeEndOfFileInComment(rng) -> 28 | Format.printf "%a: unclosed comment\n" Range.pp rng 29 | 30 | | UnknownBaseType(rng, s) -> 31 | Format.printf "%a: unknown base type %s\n" Range.pp rng s 32 | 33 | | Typechecker.UnboundVariable(rng, x) -> 34 | Format.printf "%a: unbound variable '%s'\n" Range.pp rng x 35 | 36 | | Typechecker.NotAFunction(rng, ty) -> 37 | Format.printf "%a: not a function; it is of type %a\n" 38 | Range.pp rng 39 | pp_mono_type ty 40 | 41 | | Typechecker.InvalidOccurrenceAsToStage(rng, x, stg, stgreq) -> 42 | Format.printf "%a: variable '%s' occurs at %a but is expected to occur at %a\n" 43 | Range.pp rng x pp_stage stg pp_stage stgreq 44 | 45 | | Typechecker.InvalidMacroOccurrence(rng, x) -> 46 | Format.printf "%a: variable '%s' is bound to a macro\n" 47 | Range.pp rng x 48 | 49 | | Typechecker.NotAMacro(rng, x) -> 50 | Format.printf "%a: variable '%s' is not a macro\n" 51 | Range.pp rng x 52 | 53 | | Typechecker.InvalidMacroApplication(rng, x) -> 54 | Format.printf "%a: imvalid macro application of variable '%s'" 55 | Range.pp rng x 56 | 57 | | Typechecker.MacroArgContradiction(_, macparamty, macarg) -> 58 | let (rng, sarg) = 59 | match macarg with 60 | | EarlyArg((rng, _)) -> (rng, "an early argument") 61 | | LateArg((rng, _)) -> (rng, "a late argument") 62 | | BindingArg((_, (rng, _))) -> (rng, "a binder/bindee argument") 63 | in 64 | let pp_req ppf = function 65 | | EarlyParamType(ty) -> 66 | Format.fprintf ppf "an early argument '~ ...' of type %a" 67 | pp_mono_type ty 68 | 69 | | LateParamType(ty) -> 70 | Format.fprintf ppf "a late argument of type %a" 71 | pp_mono_type ty 72 | 73 | | BindingParamType(ty1, ty2) -> 74 | Format.fprintf ppf "a binder/bindee argument where binder is of type %a and bindee is of type %a" 75 | pp_mono_type ty1 76 | pp_mono_type ty2 77 | in 78 | Format.printf "%a: %s is given, but the macro expects %a\n" 79 | Range.pp rng 80 | sarg 81 | pp_req macparamty 82 | 83 | | Typechecker.InvalidNumberOfMacroArgs(rng, n, nreq) -> 84 | Format.printf "%a: the macro requires %d argument(s), but here is applied to %d argument(s)\n" 85 | Range.pp rng n nreq 86 | 87 | | Typechecker.InvalidPrev(rng) -> 88 | Format.printf "%a: '~ ...' occurs at stage 0\n" 89 | Range.pp rng 90 | 91 | | Typechecker.InvalidNext(rng) -> 92 | Format.printf "%a: '@@ ...' occurs at stage 1\n" 93 | Range.pp rng 94 | 95 | | Typechecker.InvalidLetMacro(rng) -> 96 | Format.printf "%a: 'letmac ... = ... in ...' occurs at stage 0\n" 97 | Range.pp rng 98 | 99 | | Typechecker.ContradictionError(ty1, ty2) -> 100 | let (rng1, _) = ty1 in 101 | let (rng2, _) = ty2 in 102 | let (rng, ty, tyreq, rngreqopt) = 103 | if Range.is_dummy rng1 then 104 | (rng2, ty2, ty1, None) 105 | else 106 | if Range.is_dummy rng2 then 107 | (rng1, ty1, ty2, None) 108 | else 109 | (rng1, ty1, ty2, Some(rng2)) 110 | in 111 | begin 112 | match rngreqopt with 113 | | None -> 114 | Format.printf "%a: this expression has type %a but is expected of type %a\n" 115 | Range.pp rng pp_mono_type ty pp_mono_type tyreq 116 | 117 | | Some(rngreq) -> 118 | Format.printf "%a: this expression has type %a but is expected of type %a; this constraint is required by %a\n" 119 | Range.pp rng pp_mono_type ty pp_mono_type tyreq Range.pp rngreq 120 | end 121 | 122 | | Typechecker.NotACode(rng, ty) -> 123 | Format.printf "%a: this expression is expected of some code type but has type %a\n" 124 | Range.pp rng pp_mono_type ty 125 | 126 | | Typechecker.ShouldBeBound(rng, x, x1, ty1) -> 127 | Format.printf "%a: in order to use variable '%s', variable '%s' should be bound to a value of type %a here\n" 128 | Range.pp rng x x1 pp_mono_type ty1 129 | -------------------------------------------------------------------------------- /src/operation.ml: -------------------------------------------------------------------------------- 1 | 2 | type arity2 = 3 | | Land 4 | | Lor 5 | | Equal 6 | | Leq 7 | | Geq 8 | | Lt 9 | | Gt 10 | | Plus 11 | | Minus 12 | | Mult 13 | | Div 14 | [@@deriving show { with_path = false; } ] 15 | 16 | type 'a t = 17 | | Arity2 of arity2 * 'a * 'a 18 | [@@deriving show { with_path = false; } ] 19 | 20 | 21 | let map f = function 22 | | Arity2(op2, x1, x2) -> Arity2(op2, f x1, f x2) 23 | 24 | 25 | let string_of_arity2 op2 = 26 | match op2 with 27 | | Land -> "&&" 28 | | Lor -> "||" 29 | | Equal -> "==" 30 | | Leq -> "<=" 31 | | Geq -> ">=" 32 | | Lt -> "<" 33 | | Gt -> ">" 34 | | Plus -> "+" 35 | | Minus -> "-" 36 | | Mult -> "*" 37 | | Div -> "/" 38 | 39 | 40 | let pp_arity2_rich ppf op2 = 41 | Format.fprintf ppf "%s" (string_of_arity2 op2) 42 | -------------------------------------------------------------------------------- /src/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | 4 | type 'a range_spec = 5 | | Token of Range.t 6 | | Ranged of (Range.t * 'a) 7 | 8 | 9 | let make_range rs1 rs2 = 10 | let aux = function 11 | | Token(rng) -> rng 12 | | Ranged((rng, _)) -> rng 13 | in 14 | let rng1 = aux rs1 in 15 | let rng2 = aux rs2 in 16 | Range.unite rng1 rng2 17 | 18 | 19 | let make_lambda rngopt args e = 20 | let (_, elammain) as elam = 21 | List.fold_right (fun arg e -> 22 | (Range.dummy "make_lambda", Lambda(arg, e)) 23 | ) args e 24 | in 25 | match rngopt with 26 | | None -> elam 27 | | Some(rng) -> (rng, elammain) 28 | 29 | 30 | let binary e1 op e2 = 31 | let rng = make_range (Ranged(e1)) (Ranged(e2)) in 32 | let (rngop, vop) = op in 33 | (rng, Apply((Range.dummy "binary", Apply((rngop, Var(vop)), e1)), e2)) 34 | 35 | 36 | let macro_arg_cons ((rng, emain) as e) tail = 37 | match emain with 38 | | Prev(esub) -> EarlyArg(esub) :: tail 39 | | _ -> LateArg(e) :: tail 40 | 41 | 42 | let macro_binding_arg_cons (_, x) e tail = 43 | BindingArg(x, e) :: tail 44 | %} 45 | 46 | %token LET LETREC LETMAC DEFEQ IN LAMBDA ARROW IF THEN ELSE LPAREN RPAREN TRUE FALSE TILDE ATMARK COLON COMMA EXCLAMATION 47 | %token IDENT BINOP_AMP BINOP_BAR BINOP_EQ BINOP_LT BINOP_GT 48 | %token BINOP_TIMES BINOP_DIVIDES BINOP_PLUS BINOP_MINUS 49 | %token INT 50 | %token EOI 51 | 52 | %start main 53 | %type main 54 | 55 | %% 56 | 57 | main: 58 | | dec=letdec; e2=main { 59 | let (tok1, ident, isrec, e1) = dec in 60 | let rng = make_range (Token(tok1)) (Ranged(e2)) in 61 | if isrec then 62 | (rng, LetRecIn(ident, e1, e2)) 63 | else 64 | (rng, LetIn(ident, e1, e2)) 65 | } 66 | | dec=macdec; e2=main { 67 | let (tok1, x, macparams, ty, e1) = dec in 68 | let rng = make_range (Token(tok1)) (Ranged(e2)) in 69 | (rng, LetMacroIn(x, macparams, ty, e1, e2)) 70 | } 71 | | IN; e=exprfun; EOI { e } 72 | ; 73 | ty: 74 | | ty1=tybot; ARROW; ty2=ty { 75 | let rng = make_range (Ranged(ty1)) (Ranged(ty2)) in 76 | (rng, FuncType(ty1, ty2)) 77 | } 78 | | ty=tybot { ty } 79 | ; 80 | tybot: 81 | | ident=IDENT { 82 | let (rng, s) = ident in 83 | let tymain = 84 | match s with 85 | | "int" -> BaseType(IntType) 86 | | "bool" -> BaseType(BoolType) 87 | | _ -> raise (UnknownBaseType(rng, s)) 88 | in 89 | (rng, tymain) 90 | } 91 | | tok1=ATMARK; ty=tybot { 92 | let rng = make_range (Token(tok1)) (Ranged(ty)) in 93 | (rng, CodeType(ty)) 94 | } 95 | | LPAREN; ty=ty; RPAREN { ty } 96 | ; 97 | ident: 98 | | ident=IDENT { ident } 99 | ; 100 | %inline ident_and_ty_raw: 101 | | ident=IDENT; COLON; ty=ty { (ident, ty) } 102 | ; 103 | %inline ident_and_ty: 104 | | LPAREN; p=ident_and_ty_raw; RPAREN { p } 105 | ; 106 | letdec: 107 | | tok1=LET; ident_and_ty=ident_and_ty; params=list(ident_and_ty); DEFEQ; e1=exprlet { 108 | (tok1, ident_and_ty, false, make_lambda None params e1) 109 | } 110 | | tok1=LETREC; ident_and_ty=ident_and_ty; params=list(ident_and_ty); DEFEQ; e1=exprlet { 111 | (tok1, ident_and_ty, true, make_lambda None params e1) 112 | } 113 | ; 114 | macdec: 115 | | tok1=LETMAC; ident=ident; EXCLAMATION; LPAREN; macparams=macroparams; RPAREN; COLON; ty=ty; DEFEQ; e1=exprlet { 116 | let (_, x) = ident in 117 | (tok1, x, macparams, ty, e1) 118 | } 119 | ; 120 | macroparams: 121 | | macparam=macroparam { macparam :: [] } 122 | | macparam=macroparam; COMMA; tail=macroparams { macparam :: tail } 123 | ; 124 | %inline macroparam: 125 | | TILDE; ident_and_ty=ident_and_ty { EarlyParam(ident_and_ty) } 126 | | ident_and_ty=ident_and_ty_raw { LateParam(ident_and_ty) } 127 | | binder=ident_and_ty; ARROW; bindee=ident_and_ty { BindingParam(binder, bindee) } 128 | ; 129 | exprlet: 130 | | dec=letdec; IN; e2=exprlet { 131 | let (tok1, ident_and_ty, isrec, e1) = dec in 132 | let rng = make_range (Token(tok1)) (Ranged(e2)) in 133 | if isrec then 134 | (rng, LetRecIn(ident_and_ty, e1, e2)) 135 | else 136 | (rng, LetIn(ident_and_ty, e1, e2)) 137 | } 138 | | dec=macdec; IN; e2=exprlet { 139 | let (tok1, x, macparams, ty, e1) = dec in 140 | let rng = make_range (Token(tok1)) (Ranged(e2)) in 141 | (rng, LetMacroIn(x, macparams, ty, e1, e2)) 142 | } 143 | | tok1=IF; e0=exprlet; THEN; e1=exprlet; ELSE; e2=exprlet { 144 | let rng = make_range (Token(tok1)) (Ranged(e2)) in 145 | (rng, If(e0, e1, e2)) 146 | } 147 | | e=exprfun { e } 148 | ; 149 | exprfun: 150 | | tok1=LAMBDA; args=nonempty_list(ident_and_ty); ARROW; e=exprlet { 151 | let rng = make_range (Token(tok1)) (Ranged(e)) in 152 | make_lambda (Some(rng)) args e 153 | } 154 | | e=exprland { e } 155 | ; 156 | exprland: 157 | | e1=exprlor; op=BINOP_AMP; e2=exprland { binary e1 op e2 } 158 | | e=exprlor { e } 159 | ; 160 | exprlor: 161 | | e1=exprcomp; op=BINOP_BAR; e2=exprlor { binary e1 op e2 } 162 | | e=exprcomp { e } 163 | ; 164 | exprcomp: 165 | | e1=exprtimes; op=BINOP_EQ; e2=exprcomp { binary e1 op e2 } 166 | | e1=exprtimes; op=BINOP_LT; e2=exprcomp { binary e1 op e2 } 167 | | e1=exprtimes; op=BINOP_GT; e2=exprcomp { binary e1 op e2 } 168 | | e=exprtimes { e } 169 | ; 170 | exprtimes: 171 | | e1=exprplus; op=BINOP_TIMES; e2=exprtimes { binary e1 op e2 } 172 | | e1=exprplus; op=BINOP_DIVIDES; e2=exprtimes { binary e1 op e2 } 173 | | e=exprplus { e } 174 | ; 175 | exprplus: 176 | | e1=exprapp; op=BINOP_PLUS; e2=exprplus { binary e1 op e2 } 177 | | e1=exprapp; op=BINOP_MINUS; e2=exprplus { binary e1 op e2 } 178 | | e=exprapp { e } 179 | ; 180 | exprapp: 181 | | e1=exprapp; e2=exprbot { 182 | let rng = make_range (Ranged(e1)) (Ranged(e2)) in 183 | (rng, Apply(e1, e2)) 184 | } 185 | | tok1=ATMARK; e=exprbot { 186 | let rng = make_range (Token(tok1)) (Ranged(e)) in 187 | (rng, Next(e)) 188 | } 189 | | tok1=TILDE; e=exprbot { 190 | let rng = make_range (Token(tok1)) (Ranged(e)) in 191 | (rng, Prev(e)) 192 | } 193 | | ident=ident; EXCLAMATION; LPAREN; macargs=macroargs; rng2=RPAREN { 194 | let (rng1, x) = ident in 195 | let rng = make_range (Token(rng1)) (Token(rng2)) in 196 | (rng, ApplyMacro(x, macargs)) 197 | } 198 | | e=exprbot { e } 199 | ; 200 | macroargs: 201 | | e=exprlet { macro_arg_cons e [] } 202 | | e=exprlet; COMMA; tail=macroargs { macro_arg_cons e tail } 203 | | ident=ident; ARROW; e=exprlet { macro_binding_arg_cons ident e [] } 204 | | ident=ident; ARROW; e=exprlet COMMA; tail=macroargs { macro_binding_arg_cons ident e tail } 205 | ; 206 | exprbot: 207 | | rng=TRUE { (rng, Bool(true)) } 208 | | rng=FALSE { (rng, Bool(false)) } 209 | | c=INT { let (rng, n) = c in (rng, Int(n)) } 210 | | ident=ident { let (rng, x) = ident in (rng, Var(x)) } 211 | | LPAREN; e=exprlet; RPAREN { e } 212 | ; 213 | -------------------------------------------------------------------------------- /src/parserInterface.ml: -------------------------------------------------------------------------------- 1 | 2 | exception Error of Range.t 3 | 4 | module I = Parser.MenhirInterpreter 5 | 6 | 7 | let k_success utast = 8 | utast 9 | 10 | 11 | let k_fail chkpt = 12 | (* print_endline "k_fail"; (* for debug *) *) 13 | match chkpt with 14 | | I.HandlingError(penv) -> 15 | let rng = Range.from_positions (I.positions penv) in 16 | raise (Error(rng)) 17 | 18 | | _ -> assert false 19 | 20 | 21 | let process lexbuf = 22 | let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in 23 | I.loop_handle k_success k_fail supplier (Parser.Incremental.main lexbuf.Lexing.lex_curr_p) 24 | -------------------------------------------------------------------------------- /src/primitives.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Operation 4 | 5 | 6 | let lam2 (op2 : arity2) : ev_value_0 = 7 | let x1 = "%p1" in 8 | let x2 = "%p2" in 9 | V0Closure(None, x1, EvFix(None, x2, EvOperation(Arity2(op2, EvVariable(x1), EvVariable(x2)))), Env.empty) 10 | 11 | 12 | let initial_type_environment : Typeenv.t * environment = 13 | let dr = Range.dummy "primitives" in 14 | let b = (dr, BaseType(BoolType)) in 15 | let i = (dr, BaseType(IntType)) in 16 | let ( @-> ) ty1 ty2 = (dr, FuncType(ty1, ty2)) in 17 | let tylogic = b @-> b @-> b in 18 | let tycomp = i @-> i @-> b in 19 | let tyarith = i @-> i @-> i in 20 | 21 | List.fold_left (fun (tyenv, env) (x, ty, v) -> 22 | let tyenv = tyenv |> Typeenv.add x (Typeenv.Primitive(ty)) in 23 | let env = env |> Env.add x (Env.Both(v)) in 24 | (tyenv, env) 25 | ) (Typeenv.empty, Env.empty) [ 26 | ("&&", tylogic, lam2 Land ); 27 | ("||", tylogic, lam2 Lor ); 28 | ("==", tycomp , lam2 Equal); 29 | ("<=", tycomp , lam2 Leq ); 30 | (">=", tycomp , lam2 Geq ); 31 | ("<" , tycomp , lam2 Lt ); 32 | (">" , tycomp , lam2 Gt ); 33 | ("*" , tyarith, lam2 Mult ); 34 | ("/" , tyarith, lam2 Div ); 35 | ("+" , tyarith, lam2 Plus ); 36 | ("-" , tyarith, lam2 Minus); 37 | ] 38 | 39 | 40 | let returnB b = 41 | V0Embed(ValBool(b)) 42 | 43 | 44 | let getB = function 45 | | V0Embed(ValBool(b)) -> b 46 | | _ -> failwith "getB" 47 | 48 | 49 | let returnI n = 50 | V0Embed(ValInt(n)) 51 | 52 | 53 | let getI = function 54 | | V0Embed(ValInt(n)) -> n 55 | | _ -> failwith "getI" 56 | 57 | 58 | let eval_0_arity2 op2 v1 v2 = 59 | match op2 with 60 | | Land -> returnB (getB v1 && getB v2) 61 | | Lor -> returnB (getB v1 || getB v2) 62 | | Equal -> returnB (getI v1 = getI v2) 63 | | Leq -> returnB (getI v1 <= getI v2) 64 | | Geq -> returnB (getI v1 >= getI v2) 65 | | Lt -> returnB (getI v1 < getI v2) 66 | | Gt -> returnB (getI v1 > getI v2) 67 | | Plus -> returnI (getI v1 + getI v2) 68 | | Minus -> returnI (getI v1 - getI v2) 69 | | Mult -> returnI (getI v1 * getI v2) 70 | | Div -> returnI (getI v1 / getI v2) 71 | 72 | 73 | let eval_0_operation opapp = 74 | match opapp with 75 | | Arity2(op2, v1, v2) -> eval_0_arity2 op2 v1 v2 76 | -------------------------------------------------------------------------------- /src/range.ml: -------------------------------------------------------------------------------- 1 | 2 | type real = { 3 | file_name : string; 4 | start_line : int; 5 | start_column : int; 6 | last_line : int; 7 | last_column : int; 8 | } 9 | 10 | type t = 11 | | Dummy of string 12 | | Real of real 13 | 14 | 15 | let pp ppf rng = 16 | match rng with 17 | | Dummy(s) -> 18 | Format.printf "(%s)" s 19 | 20 | | Real(r) -> 21 | if r.start_line = r.last_line then 22 | Format.fprintf ppf "file '%s', line %d, characters %d-%d" 23 | r.file_name r.start_line r.start_column r.last_column 24 | else 25 | Format.fprintf ppf "file '%s', line %d, character %d to line %d, character %d" 26 | r.file_name r.start_line r.start_column r.last_line r.last_column 27 | 28 | 29 | let from_positions (posS, posE) = 30 | let fname = posS.Lexing.pos_fname in 31 | let lnum = posS.Lexing.pos_lnum in 32 | let cnumS = posS.Lexing.pos_cnum - posS.Lexing.pos_bol in 33 | let cnumE = posE.Lexing.pos_cnum - posE.Lexing.pos_bol in 34 | Real{ 35 | file_name = fname; 36 | start_line = lnum; 37 | start_column = cnumS; 38 | last_line = lnum; 39 | last_column = cnumE; 40 | } 41 | 42 | 43 | let from_lexbuf lexbuf = 44 | let posS = Lexing.lexeme_start_p lexbuf in 45 | let posE = Lexing.lexeme_end_p lexbuf in 46 | from_positions (posS, posE) 47 | 48 | 49 | let dummy s = Dummy(s) 50 | 51 | 52 | let is_dummy = function 53 | | Dummy(_) -> true 54 | | _ -> false 55 | 56 | 57 | let unite r1 r2 = 58 | match (r1, r2) with 59 | | (Real(_), Dummy(_)) -> r1 60 | | (Dummy(_), Real(_)) -> r2 61 | | (Dummy(s1), Dummy(s2)) -> Dummy(s1 ^ "/" ^ s2) 62 | 63 | | (Real(x1), Real(x2)) -> 64 | Real{ 65 | file_name = x1.file_name; 66 | start_line = x1.start_line; 67 | start_column = x1.start_column; 68 | last_line = x2.last_line; 69 | last_column = x2.last_column; 70 | } 71 | -------------------------------------------------------------------------------- /src/range.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val pp : Format.formatter -> t -> unit 5 | 6 | val from_lexbuf : Lexing.lexbuf -> t 7 | 8 | val from_positions : Lexing.position * Lexing.position -> t 9 | 10 | val dummy : string -> t 11 | 12 | val is_dummy : t -> bool 13 | 14 | val unite : t -> t -> t 15 | -------------------------------------------------------------------------------- /src/richPrinting.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | let show_mono_type ty = 6 | let rec aux isdom (_, tymain) = 7 | match tymain with 8 | | BaseType(IntType) -> "int" 9 | | BaseType(BoolType) -> "bool" 10 | 11 | | CodeType(ty1) -> 12 | let s = aux true ty1 in 13 | "@" ^ s 14 | 15 | | FuncType(ty1, ty2) -> 16 | let s1 = aux true ty1 in 17 | let s2 = aux false ty2 in 18 | let s = s1 ^ " -> " ^ s2 in 19 | if isdom then "(" ^ s ^ ")" else s 20 | in 21 | aux false ty 22 | 23 | 24 | let pp_mono_type ppf ty = 25 | Format.fprintf ppf "%s" (show_mono_type ty) 26 | 27 | 28 | type level = 29 | | AppLeft 30 | | AppRight 31 | | Free 32 | 33 | 34 | let enclose_app_left ppf lev pp = 35 | match lev with 36 | | AppLeft -> Format.fprintf ppf "(%a)" pp () 37 | | AppRight | Free -> pp ppf () 38 | 39 | 40 | let enclose_app_right ppf lev pp = 41 | match lev with 42 | | AppLeft | AppRight -> Format.fprintf ppf "(%a)" pp () 43 | | Free -> pp ppf () 44 | 45 | 46 | let pp_ev_value ppf = function 47 | | ValInt(n) -> Format.fprintf ppf "%d" n 48 | | ValBool(b) -> Format.fprintf ppf "%B" b 49 | 50 | 51 | let rec pp_ev_value_1 lev ppf = function 52 | | V1Embed(c) -> 53 | pp_ev_value ppf c 54 | 55 | | V1Symbol(symb) -> 56 | Symbol.pp ppf symb 57 | 58 | | V1Apply(v1, v2) -> 59 | enclose_app_left ppf lev (fun ppf () -> 60 | Format.fprintf ppf "%a %a" 61 | (pp_ev_value_1 AppRight) v1 62 | (pp_ev_value_1 AppLeft) v2 63 | ) 64 | 65 | | V1Fix(None, sx, v0) -> 66 | enclose_app_right ppf lev (fun ppf () -> 67 | Format.fprintf ppf "fun %a -> %a" 68 | Symbol.pp sx 69 | (pp_ev_value_1 Free) v0 70 | ) 71 | 72 | | V1Fix(Some(sf), sx, v0) -> 73 | enclose_app_right ppf lev (fun ppf () -> 74 | Format.fprintf ppf "fix %a fun %a -> %a" 75 | Symbol.pp sf 76 | Symbol.pp sx 77 | (pp_ev_value_1 Free) v0 78 | ) 79 | 80 | | V1Primitive(x) -> 81 | Format.fprintf ppf "%s" x 82 | 83 | | V1If(v0, v1, v2) -> 84 | enclose_app_right ppf lev (fun ppf () -> 85 | Format.fprintf ppf "if %a then %a else %a" 86 | (pp_ev_value_1 Free) v0 87 | (pp_ev_value_1 Free) v1 88 | (pp_ev_value_1 Free) v2 89 | ) 90 | 91 | 92 | and pp_ev_value_0 lev ppf = function 93 | | V0Embed(c) -> 94 | pp_ev_value ppf c 95 | 96 | | V0Closure(_) -> 97 | Format.fprintf ppf "" 98 | 99 | | V0Primitive(x) -> 100 | Format.fprintf ppf "%s" x 101 | 102 | | V0Next(v1) -> 103 | enclose_app_left ppf lev (fun ppf () -> 104 | Format.fprintf ppf "@@%a" (pp_ev_value_1 AppLeft) v1 105 | ) 106 | 107 | 108 | let pp_ev_value_1_single = pp_ev_value_1 AppLeft 109 | 110 | 111 | let pp_ev_value_0_single = pp_ev_value_0 AppLeft 112 | -------------------------------------------------------------------------------- /src/symbol.ml: -------------------------------------------------------------------------------- 1 | 2 | type t = int 3 | 4 | 5 | let current = ref 0 6 | 7 | 8 | let generate () = 9 | incr current; 10 | !current 11 | 12 | 13 | let to_identifier symb = 14 | "S#" ^ string_of_int symb 15 | 16 | 17 | let pp ppf symb = 18 | Format.fprintf ppf "S#%d" symb 19 | -------------------------------------------------------------------------------- /src/symbol.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val generate : unit -> t 5 | 6 | val to_identifier : t -> string 7 | 8 | val pp : Format.formatter -> t -> unit 9 | -------------------------------------------------------------------------------- /src/syntax.ml: -------------------------------------------------------------------------------- 1 | 2 | exception UnidentifiedToken of Range.t * string 3 | exception SeeEndOfFileInComment of Range.t 4 | exception UnknownBaseType of Range.t * string 5 | 6 | 7 | type identifier = string 8 | 9 | 10 | let pp_identifier ppf s = 11 | Format.fprintf ppf "\"%s\"" s 12 | 13 | 14 | type base_type = 15 | | IntType 16 | | BoolType 17 | [@@deriving show { with_path = false; } ] 18 | 19 | type stage = 20 | | Stage0 21 | | Stage1 22 | 23 | 24 | let pp_stage ppf = function 25 | | Stage0 -> Format.fprintf ppf "stage 0" 26 | | Stage1 -> Format.fprintf ppf "stage 1" 27 | 28 | 29 | type untyped_ast = Range.t * untyped_ast_main 30 | [@printer (fun ppf (_, utastmain) -> pp_untyped_ast_main ppf utastmain)] 31 | 32 | and untyped_ast_main = 33 | | Bool of bool 34 | | Int of int 35 | | Var of identifier 36 | | Lambda of binder * untyped_ast 37 | | Apply of untyped_ast * untyped_ast 38 | | If of untyped_ast * untyped_ast * untyped_ast 39 | | LetIn of binder * untyped_ast * untyped_ast 40 | | LetRecIn of binder * untyped_ast * untyped_ast 41 | | Next of untyped_ast 42 | | Prev of untyped_ast 43 | | LetMacroIn of identifier * macro_param list * mono_type * untyped_ast * untyped_ast 44 | | ApplyMacro of identifier * macro_argument list 45 | 46 | and binder = (Range.t * identifier) * mono_type 47 | 48 | and macro_param = 49 | | EarlyParam of binder 50 | | LateParam of binder 51 | | BindingParam of binder * binder 52 | 53 | and macro_argument = 54 | | EarlyArg of untyped_ast 55 | | LateArg of untyped_ast 56 | | BindingArg of identifier * untyped_ast 57 | 58 | and mono_type = Range.t * mono_type_main 59 | 60 | and mono_type_main = 61 | | BaseType of base_type 62 | | CodeType of mono_type 63 | | FuncType of mono_type * mono_type 64 | 65 | and macro_param_type = 66 | | EarlyParamType of mono_type 67 | | LateParamType of mono_type 68 | | BindingParamType of mono_type * mono_type 69 | [@@deriving show { with_path = false; } ] 70 | 71 | 72 | let rec erase_range (_, tymain) = 73 | let iter = erase_range in 74 | let tymain = 75 | match tymain with 76 | | BaseType(_) -> tymain 77 | | FuncType(ty1, ty2) -> FuncType(iter ty1, iter ty2) 78 | | CodeType(ty1) -> CodeType(iter ty1) 79 | in 80 | (Range.dummy "erased", tymain) 81 | 82 | 83 | let overwrite_range rng (_, tymain) = (rng, tymain) 84 | 85 | 86 | type ev_value = 87 | | ValInt of int 88 | | ValBool of bool 89 | 90 | and ev_value_0 = 91 | | V0Embed of ev_value 92 | | V0Closure of identifier option * identifier * ev_ast * environment 93 | | V0Primitive of identifier 94 | | V0Next of ev_value_1 95 | 96 | and ev_value_1 = 97 | | V1Embed of ev_value 98 | | V1Primitive of identifier 99 | | V1Symbol of Symbol.t 100 | | V1Fix of Symbol.t option * Symbol.t * ev_value_1 101 | | V1Apply of ev_value_1 * ev_value_1 102 | | V1If of ev_value_1 * ev_value_1 * ev_value_1 103 | 104 | and ev_ast = 105 | | EvValue0 of ev_value_0 106 | | EvValue1 of ev_value_1 107 | | EvVariable of identifier 108 | | EvFix of identifier option * identifier * ev_ast 109 | | EvApply of ev_ast * ev_ast 110 | | EvOperation of ev_ast Operation.t 111 | | EvIf of ev_ast * ev_ast * ev_ast 112 | | EvPrev of ev_ast 113 | | EvNext of ev_ast 114 | 115 | and environment = (ev_value_0, ev_value_1) Env.t 116 | [@printer (fun ppf _ -> Format.fprintf ppf "")] 117 | [@@deriving show { with_path = false; } ] 118 | 119 | 120 | module Acc : sig 121 | type 'a t 122 | val empty : 'a t 123 | val extend : 'a t -> 'a -> 'a t 124 | val to_list : 'a t -> 'a list 125 | end = struct 126 | type 'a t = 'a list 127 | let empty = [] 128 | let extend acc x = x :: acc 129 | let to_list acc = List.rev acc 130 | end 131 | -------------------------------------------------------------------------------- /src/typechecker.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | exception UnboundVariable of Range.t * identifier 6 | exception InvalidOccurrenceAsToStage of Range.t * identifier * stage * stage 7 | exception InvalidMacroOccurrence of Range.t * identifier 8 | exception NotAMacro of Range.t * identifier 9 | exception InvalidMacroApplication of Range.t * identifier 10 | exception MacroArgContradiction of Range.t * macro_param_type * macro_argument 11 | exception InvalidNumberOfMacroArgs of Range.t * int * int 12 | exception InvalidPrev of Range.t 13 | exception InvalidNext of Range.t 14 | exception InvalidLetMacro of Range.t 15 | exception ContradictionError of mono_type * mono_type 16 | exception NotAFunction of Range.t * mono_type 17 | exception NotACode of Range.t * mono_type 18 | exception ShouldBeBound of Range.t * identifier * identifier * mono_type 19 | exception NonFunctionRecursion of Range.t 20 | 21 | 22 | let lam x eve = 23 | EvFix(None, x, eve) 24 | 25 | 26 | let fixpoint f x eve = 27 | EvFix(Some(f), x, eve) 28 | 29 | 30 | let make_fixpoint f xs eve = 31 | match xs with 32 | | [] -> assert false 33 | | x :: ys -> fixpoint f x (List.fold_right lam ys eve) 34 | 35 | 36 | let make_application f eves = 37 | List.fold_left (fun eve evearg -> EvApply(eve, evearg)) (EvVariable(f)) eves 38 | 39 | 40 | let unify tyact tyexp = 41 | let rec aux ty1 ty2 = 42 | let (_, ty1main) = ty1 in 43 | let (_, ty2main) = ty2 in 44 | match (ty1main, ty2main) with 45 | | (BaseType(bt1), BaseType(bt2)) -> bt1 = bt2 46 | 47 | | (FuncType(ty1d, ty1c), FuncType(ty2d, ty2c)) -> 48 | let res1 = aux ty1d ty2d in 49 | let res2 = aux ty1c ty2c in 50 | res1 && res2 51 | 52 | | (CodeType(ty1), CodeType(ty2)) -> aux ty1 ty2 53 | 54 | | _ -> false 55 | in 56 | let res = aux tyact tyexp in 57 | if res then () else raise (ContradictionError(tyact, tyexp)) 58 | 59 | 60 | let rec aux (stg : stage) (tyenv : Typeenv.t) ((rng, utastmain) : untyped_ast) = 61 | match utastmain with 62 | | Int(n) -> 63 | let ty = (rng, BaseType(IntType)) in 64 | let eve = 65 | match stg with 66 | | Stage0 -> EvValue0(V0Embed(ValInt(n))) 67 | | Stage1 -> EvValue1(V1Embed(ValInt(n))) 68 | in 69 | (ty, eve) 70 | 71 | | Bool(b) -> 72 | let ty = (rng, BaseType(BoolType)) in 73 | let eve = 74 | match stg with 75 | | Stage0 -> EvValue0(V0Embed(ValBool(b))) 76 | | Stage1 -> EvValue1(V1Embed(ValBool(b))) 77 | in 78 | (ty, eve) 79 | 80 | | Var(x) -> 81 | let (ty, eve) = 82 | match tyenv |> Typeenv.find_opt x with 83 | | None -> 84 | raise (UnboundVariable(rng, x)) 85 | 86 | | Some(boundto) -> 87 | begin 88 | match boundto with 89 | | Typeenv.Primitive(ty) -> 90 | (ty, EvVariable(x)) 91 | 92 | | Typeenv.Normal((ty, stgreq)) -> 93 | if stgreq = stg then 94 | let (_, tymain) = ty in 95 | ((rng, tymain), EvVariable(x)) 96 | else 97 | raise (InvalidOccurrenceAsToStage(rng, x, stg, stgreq)) 98 | 99 | | Typeenv.Late(ty) -> 100 | begin 101 | match stg with 102 | | Stage0 -> raise (InvalidOccurrenceAsToStage(rng, x, stg, Stage1)) 103 | | Stage1 -> (ty, EvPrev(EvVariable(x))) 104 | end 105 | 106 | | Typeenv.Bindee(x1, ty1req, ty) -> 107 | begin 108 | match stg with 109 | | Stage0 -> 110 | raise (InvalidOccurrenceAsToStage(rng, x, stg, Stage1)) 111 | 112 | | Stage1 -> 113 | begin 114 | match tyenv |> Typeenv.find_opt x1 with 115 | | Some(Typeenv.Normal(ty1, Stage1)) -> 116 | unify ty1 ty1req; 117 | (ty, EvPrev(EvApply(EvVariable(x), EvNext(EvVariable(x1))))) 118 | 119 | | _ -> 120 | raise (ShouldBeBound(rng, x, x1, ty1req)) 121 | end 122 | end 123 | 124 | | Typeenv.Macro(_) -> 125 | raise (InvalidMacroOccurrence(rng, x)) 126 | end 127 | in 128 | (overwrite_range rng ty, eve) 129 | 130 | | Lambda(((rngv, x), tydom), utast0) -> 131 | let (tycod, eve0) = aux stg (tyenv |> Typeenv.add x (Typeenv.Normal(tydom, stg))) utast0 in 132 | let ty = (rng, FuncType(tydom, tycod)) in 133 | (ty, lam x eve0) 134 | 135 | | Apply(utast1, utast2) -> 136 | let (ty1, eve1) = aux stg tyenv utast1 in 137 | let (ty2, eve2) = aux stg tyenv utast2 in 138 | begin 139 | match ty1 with 140 | | (_, FuncType(tydom, tycod)) -> 141 | unify ty2 tydom; 142 | (overwrite_range rng tycod, EvApply(eve1, eve2)) 143 | 144 | | _ -> 145 | let (rng1, _) = utast1 in 146 | raise (NotAFunction(rng1, ty1)) 147 | end 148 | 149 | | If(utast0, utast1, utast2) -> 150 | let (ty0, eve0) = aux stg tyenv utast0 in 151 | unify ty0 (Range.dummy "If", BaseType(BoolType)); 152 | let (ty1, eve1) = aux stg tyenv utast1 in 153 | let (ty2, eve2) = aux stg tyenv utast2 in 154 | unify ty1 ty2; 155 | let ty = overwrite_range rng ty1 in 156 | (ty, EvIf(eve0, eve1, eve2)) 157 | 158 | | LetIn(((_, x), ty1req), utast1, utast2) -> 159 | let (ty1, eve1) = aux stg tyenv utast1 in 160 | let tyenv = tyenv |> Typeenv.add x (Typeenv.Normal(erase_range ty1, stg)) in 161 | let (ty2, eve2) = aux stg tyenv utast2 in 162 | (ty2, EvApply(lam x eve2, eve1)) 163 | 164 | | LetRecIn(((rngv, f), ty1req), utast1, utast2) -> 165 | let tyenv = tyenv |> Typeenv.add f (Typeenv.Normal(erase_range ty1req, stg)) in 166 | let (ty1, eve1) = aux stg tyenv utast1 in 167 | unify ty1 ty1req; 168 | let (ty2, eve2) = aux stg tyenv utast2 in 169 | begin 170 | match eve1 with 171 | | EvFix(None, x, eve1sub) -> 172 | (ty2, EvApply(lam f eve2, fixpoint f x eve1sub)) 173 | 174 | | _ -> 175 | raise (NonFunctionRecursion(rng)) 176 | end 177 | 178 | | Prev(utast1) -> 179 | begin 180 | match stg with 181 | | Stage0 -> 182 | raise (InvalidPrev(rng)) 183 | 184 | | Stage1 -> 185 | let (ty1, eve1) = aux Stage0 tyenv utast1 in 186 | begin 187 | match ty1 with 188 | | (_, CodeType(ty)) -> 189 | (overwrite_range rng ty, EvPrev(eve1)) 190 | 191 | | _ -> 192 | raise (NotACode(rng, ty1)) 193 | end 194 | end 195 | 196 | | Next(utast1) -> 197 | begin 198 | match stg with 199 | | Stage1 -> 200 | raise (InvalidNext(rng)) 201 | 202 | | Stage0 -> 203 | let (ty1, eve1) = aux Stage1 tyenv utast1 in 204 | ((rng, CodeType(ty1)), EvNext(eve1)) 205 | end 206 | 207 | | LetMacroIn(f, macparams, ty1req, utast1, utast2) -> 208 | begin 209 | match stg with 210 | | Stage0 -> 211 | raise (InvalidLetMacro(rng)) 212 | 213 | | Stage1 -> 214 | let macparamtys = 215 | macparams |> List.map (function 216 | | EarlyParam((_, ty)) -> EarlyParamType(ty) 217 | | LateParam((_, ty)) -> LateParamType(ty) 218 | | BindingParam((_, ty1), (_, ty2)) -> BindingParamType(ty1, ty2) 219 | ) 220 | in 221 | let tyenv2 = tyenv |> Typeenv.add f (Typeenv.Macro(macparamtys, ty1req)) in 222 | let (xacc, tyenv1) = 223 | List.fold_left (fun (acc, tyenv) macparam -> 224 | match macparam with 225 | | EarlyParam((ident, ty)) -> 226 | let (_, x) = ident in 227 | (Acc.extend acc x, tyenv |> Typeenv.add x (Typeenv.Normal(ty, Stage0))) 228 | 229 | | LateParam((ident, ty)) -> 230 | let (_, x) = ident in 231 | (Acc.extend acc x, tyenv |> Typeenv.add x (Typeenv.Late(ty))) 232 | 233 | | BindingParam((ident1, ty1), (ident2, ty2)) -> 234 | let (_, x1) = ident1 in 235 | let (_, x2) = ident2 in 236 | (Acc.extend acc x2, tyenv |> Typeenv.add x2 (Typeenv.Bindee(x1, ty1, ty2))) 237 | 238 | ) (Acc.empty, tyenv2) macparams 239 | in 240 | let xs = Acc.to_list xacc in 241 | let (ty1, eve1) = aux Stage1 tyenv1 utast1 in 242 | unify ty1 ty1req; 243 | let (ty2, eve2) = aux Stage1 tyenv2 utast2 in 244 | let eve = 245 | EvPrev(EvApply(lam f (EvNext(eve2)), make_fixpoint f xs (EvNext(eve1)))) 246 | in 247 | (ty2, eve) 248 | end 249 | 250 | | ApplyMacro(f, macargs) -> 251 | begin 252 | match stg with 253 | | Stage0 -> 254 | raise (InvalidMacroApplication(rng, f)) 255 | 256 | | Stage1 -> 257 | begin 258 | match tyenv |> Typeenv.find_opt f with 259 | | None -> 260 | raise (UnboundVariable(rng, f)) 261 | 262 | | Some(Typeenv.Macro(macparamtys, ty)) -> 263 | let evargs = aux_macro_args rng tyenv macparamtys macargs in 264 | (overwrite_range rng ty, EvPrev(make_application f evargs)) 265 | 266 | | Some(_) -> 267 | raise (NotAMacro(rng, f)) 268 | end 269 | end 270 | 271 | 272 | and aux_macro_args (rng : Range.t) (tyenv : Typeenv.t) (macparamtys : macro_param_type list) (macargs : macro_argument list) = 273 | let lenP = List.length macparamtys in 274 | let lenA = List.length macargs in 275 | let rec iter evargacc macparamtys macargs = 276 | match (macparamtys, macargs) with 277 | | ([], []) -> 278 | Acc.to_list evargacc 279 | 280 | | (macparamty :: macparamtytail, macarg :: macargtail) -> 281 | let eve = 282 | match (macparamty, macarg) with 283 | | (EarlyParamType(tyP), EarlyArg(utastA)) -> 284 | let (tyA, eveA) = aux Stage0 tyenv utastA in 285 | unify tyA tyP; 286 | eveA 287 | 288 | | (LateParamType(tyP), LateArg(utastA)) -> 289 | let (tyA, eveA) = aux Stage1 tyenv utastA in 290 | unify tyA tyP; 291 | EvNext(eveA) 292 | 293 | | (BindingParamType(tyB, tyP), BindingArg(x, utastA)) -> 294 | let tyenv = tyenv |> Typeenv.add x (Typeenv.Late(tyB)) in 295 | let (tyA, eveA) = aux Stage1 tyenv utastA in 296 | unify tyA tyP; 297 | lam x (EvNext(eveA)) 298 | 299 | | _ -> 300 | raise (MacroArgContradiction(rng, macparamty, macarg)) 301 | in 302 | iter (Acc.extend evargacc eve) macparamtytail macargtail 303 | 304 | | _ -> 305 | raise (InvalidNumberOfMacroArgs(rng, lenA, lenP)) 306 | in 307 | iter Acc.empty macparamtys macargs 308 | 309 | 310 | let main tyenv utast = 311 | aux Stage1 tyenv utast 312 | -------------------------------------------------------------------------------- /src/typeenv.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | 5 | module VarMap = Map.Make(String) 6 | 7 | 8 | type bound_to = 9 | | Primitive of mono_type 10 | | Normal of mono_type * stage 11 | | Late of mono_type 12 | | Bindee of identifier * mono_type * mono_type 13 | | Macro of macro_param_type list * mono_type 14 | 15 | type t = { 16 | main : bound_to VarMap.t; 17 | } 18 | 19 | 20 | let empty = 21 | { 22 | main = VarMap.empty; 23 | } 24 | 25 | let add x boundto tyenv = 26 | { 27 | main = tyenv.main |> VarMap.add x boundto; 28 | } 29 | 30 | let find_opt x tyenv = 31 | tyenv.main |> VarMap.find_opt x 32 | -------------------------------------------------------------------------------- /src/typeenv.mli: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | 4 | type bound_to = 5 | | Primitive of mono_type 6 | | Normal of mono_type * stage 7 | | Late of mono_type 8 | | Bindee of identifier * mono_type * mono_type 9 | | Macro of macro_param_type list * mono_type 10 | 11 | type t 12 | 13 | val empty : t 14 | 15 | val add : identifier -> bound_to -> t -> t 16 | 17 | val find_opt : identifier -> t -> bound_to option 18 | -------------------------------------------------------------------------------- /test/bind.txt: -------------------------------------------------------------------------------- 1 | letmac bind_double!(e1 : int, (x : int) -> (e2 : int)) : int = 2 | let (x : int) = e1 + e1 in e2 3 | in 4 | bind_double!(3, y -> y * y) 5 | -------------------------------------------------------------------------------- /test/genpower.txt: -------------------------------------------------------------------------------- 1 | letmac pow!(~(n : int), x : int) : int = 2 | ~(if n <= 0 then @1 else @(x * pow!(~(n - 1), x))) 3 | in 4 | pow!(~(2 * 3), 5 + 6) 5 | -------------------------------------------------------------------------------- /test/genpower2.txt: -------------------------------------------------------------------------------- 1 | letmac pow!(~(n : int), x : int) : int = 2 | ~(if n <= 0 then @1 else @(x * pow!(~(n - 1), x))) 3 | in 4 | pow!(~(1 + 2), pow!(~(7 - 3), 8 - 5) + 4) + 6 5 | -------------------------------------------------------------------------------- /test/genpower3.txt: -------------------------------------------------------------------------------- 1 | let (power3 : int -> int) = 2 | ~(let (genpower : int -> @(int -> int)) = 3 | letrec (aux : int -> @int -> @int) (n : int) (x : @int) = 4 | if n <= 0 then @1 else @(~x * ~(aux (n - 1) x)) 5 | in 6 | (fun (n : int) -> @(fun (y : int) -> ~(aux n (@y)))) 7 | in 8 | genpower (2 * 3)) 9 | in 10 | power3 (5 + 6) 11 | -------------------------------------------------------------------------------- /test/single-stage.txt: -------------------------------------------------------------------------------- 1 | 2 | letrec (foldn : (int -> int -> int) -> int -> int -> int) (f : int -> int -> int) (i : int) (c : int) = 3 | if i <= 0 then c else 4 | foldn f (i - 1) (f i c) 5 | 6 | in 7 | foldn (fun (i : int) (c : int) -> i + c) 10 0 8 | --------------------------------------------------------------------------------