From c6197953ce9792b400d9d3d0d313435914d4f6e2 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 27 Jun 2018 01:27:38 +0900 Subject: [PATCH 01/42] midway --- src/frontend/lexer.mll | 6 +- src/frontend/typechecker.ml | 4 +- src/frontend/typeenv.ml | 34 ++--- src/frontend/types_template.ml | 227 ++++++++++++++++++--------------- 4 files changed, 150 insertions(+), 121 deletions(-) diff --git a/src/frontend/lexer.mll b/src/frontend/lexer.mll index bd5fbfa6d..3124f2f9c 100644 --- a/src/frontend/lexer.mll +++ b/src/frontend/lexer.mll @@ -283,9 +283,9 @@ rule progexpr stack = parse | (digit | (nzdigit digit+)) { INTCONST(get_pos lexbuf, int_of_string (Lexing.lexeme lexbuf)) } | (("0x" | "0X") hex+) { INTCONST(get_pos lexbuf, int_of_string (Lexing.lexeme lexbuf)) } | ((digit+ "." digit*) | ("." digit+)) { FLOATCONST(get_pos lexbuf, float_of_string (Lexing.lexeme lexbuf)) } - | (((digit | (nzdigit digit+)) as i) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_int (int_of_string i), unitnm) } - | (((digit+ "." digit*) as flt) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_string flt, unitnm) } - | ((("." digit+) as flt) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_string flt, unitnm) } + | (((("-"? digit) | ("-"? nzdigit digit+)) as i) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_int (int_of_string i), unitnm) } + | ((("-"? digit+ "." digit*) as flt) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_string flt, unitnm) } + | ((("-"? "." digit+) as flt) (identifier as unitnm)) { LENGTHCONST(get_pos lexbuf, float_of_string flt, unitnm) } | eof { if Stack.length stack = 1 then EOI else report_error lexbuf "text input ended while reading a program area" diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 0d1cd184d..69c14714a 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -362,7 +362,7 @@ and unify_options tyopts1r tyopts2r = let unify_ (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono_type) = - let () = print_for_debug_typecheck (" ####UNIFY " ^ (string_of_mono_type_basic ty1) ^ " = " ^ (string_of_mono_type_basic ty2)) in (* for debug *) + let () = print_endline (" ####UNIFY " ^ (string_of_mono_type_basic ty1) ^ " = " ^ (string_of_mono_type_basic ty2)) in (* for debug *) try unify_sub ty1 ty2 with @@ -436,7 +436,7 @@ let rec typecheck | Some((pty, evid)) -> let tyfree = instantiate lev qtfbl pty in let tyres = overwrite_range_of_type tyfree rng in - let () = print_for_debug_typecheck ("\n#Content " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty) ^ " = " ^ (string_of_mono_type_basic tyres) ^ "\n (" ^ (Range.to_string rng) ^ ")") in (* for debug *) + let () = print_endline ("\n#Content " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty) ^ " = " ^ (string_of_mono_type_basic tyres) ^ "\n (" ^ (Range.to_string rng) ^ ")") in (* for debug *) (ContentOf(rng, evid), tyres) end diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index e7252a27c..dae56a51f 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -268,8 +268,8 @@ module MapList type type_argument_mode = - | StrictMode of (type_argument_name, type_variable_info ref) MapList.t - | FreeMode of (type_argument_name, type_variable_info ref) MapList.t + | StrictMode of (type_argument_name, poly_type_variable_info ref) MapList.t + | FreeMode of (type_argument_name, poly_type_variable_info ref) MapList.t (* -- StrictMode : case where all type arguments should be declared; e.g. for type definitions FreeMode : case where type arguments do not need to be declared; e.g. for type annotations @@ -353,9 +353,9 @@ let find_type_name (_ : t) (tyid : TypeID.t) : type_name = let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) (tyid : TypeID.t) (tyenv : t) : t = - +(* let () = print_for_debug_variantenv ("C-add " ^ constrnm ^ " of [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_poly_type_basic pty)) in (* for debug *) - +*) let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in match ModuleTree.update mtr addrlst (update_cd (ConstrMap.add constrnm (tyid, (bidlist, pty)))) with @@ -364,19 +364,19 @@ let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) let instantiate_type_scheme (tyarglist : mono_type list) (bidlist : BoundID.t list) (Poly(ty) : poly_type) = - +(* let () = print_for_debug_variantenv ("I-input [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_mono_type_basic ty)) in (* for debug *) - - let bid_to_type_ht : (type_variable_info ref) BoundIDHashtbl.t = BoundIDHashtbl.create 32 in +*) + let bid_to_type_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in let rec pre tyargs bids = match (tyargs, bids) with | ([], []) -> () | (tyarg :: tyargtail, bid :: bidtail) -> - let tvref = ref (Link(tyarg)) in + let tvref = ref (MonoLink(tyarg)) in begin print_for_debug_variantenv ("I-add '#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " -> " ^ (string_of_mono_type_basic tyarg)); (* for debug *) - BoundIDHashtbl.add bid_to_type_ht bid tvref; + BoundIDHashTable.add bid_to_type_ht bid tvref; pre tyargtail bidtail; end | (_, _) -> assert false @@ -422,7 +422,7 @@ let rec type_argument_length tyargcons = List.length tyargcons let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargmode : type_argument_mode) (mnty : manual_type) = - let rec aux mnty = + let rec aux (mnty : manual_type) : poly_type = let (rng, mntymain) = mnty in let error tynm lenexp lenerr = raise (IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr)) in let tymainnew = @@ -528,15 +528,17 @@ let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : Fr in let ty = aux mnty in match tyargmode with - | ( StrictMode(tyargmaplist) - | FreeMode(tyargmaplist) ) -> + | StrictMode(tyargmaplist) + | FreeMode(tyargmaplist) + -> let bidlist = (MapList.to_list tyargmaplist) |> List.map (fun (_, tvref) -> match !tvref with - | Free(tvid) -> - let bid = BoundID.fresh (FreeID.get_kind tvid) () in + | PolyFree(tvid) -> + let kd = FreeID.get_kind tvid in + let bid = BoundID.fresh kd () in begin - tvref := Bound(bid); + tvref := PolyBound(bid); bid end | _ -> assert false @@ -642,7 +644,7 @@ let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev let ty = instantiate_type_scheme tyarglist bidlist pty in return (tyarglist, tyid, ty) -let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (typeid : TypeID.t) +let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (typeid : TypeID.t) : (constructor_name * (mono_type list -> mono_type)) list = let open OptionMonad in let addrlst = Alist.to_list tyenv.current_address in diff --git a/src/frontend/types_template.ml b/src/frontend/types_template.ml index a46d05dcd..880f85191 100644 --- a/src/frontend/types_template.ml +++ b/src/frontend/types_template.ml @@ -230,52 +230,62 @@ let base_type_hash_table = end -type mono_type = Range.t * mono_type_main -and mono_type_main = +type 'a typ = Range.t * 'a type_main +and 'a type_main = | BaseType of base_type - | FuncType of (mono_type list) ref * mono_type * mono_type - | ListType of mono_type - | RefType of mono_type - | ProductType of mono_type list - | TypeVariable of type_variable_info ref - | SynonymType of (mono_type list) * TypeID.t * mono_type - | VariantType of (mono_type list) * TypeID.t - | RecordType of mono_type Assoc.t + | FuncType of (('a typ) list) ref * 'a typ * 'a typ + | ListType of 'a typ + | RefType of 'a typ + | ProductType of ('a typ) list + | TypeVariable of 'a ref + | SynonymType of ('a typ) list * TypeID.t * 'a typ + | VariantType of ('a typ) list * TypeID.t + | RecordType of ('a typ) Assoc.t [@printer (fun fmt _ -> Format.fprintf fmt "RecordType(...)")] - | HorzCommandType of command_argument_type list - | VertCommandType of command_argument_type list - | MathCommandType of command_argument_type list + | HorzCommandType of ('a command_argument_type) list + | VertCommandType of ('a command_argument_type) list + | MathCommandType of ('a command_argument_type) list -and command_argument_type = - | MandatoryArgumentType of mono_type - | OptionalArgumentType of mono_type +and 'a command_argument_type = + | MandatoryArgumentType of 'a typ + | OptionalArgumentType of 'a typ -and poly_type = - | Poly of mono_type - -and kind = +and 'a kind = | UniversalKind - | RecordKind of mono_type Assoc.t + | RecordKind of ('a typ) Assoc.t [@printer (fun fmt _ -> Format.fprintf fmt "RecordKind(...)")] -and type_variable_info = - | Free of kind FreeID_.t_ - | Bound of kind BoundID_.t_ - | Link of mono_type +and mono_type_variable_info = + | MonoFree of (mono_type_variable_info kind) FreeID_.t_ + | MonoLink of mono_type_variable_info typ + +and poly_type_variable_info = + | PolyFree of (mono_type_variable_info kind) FreeID_.t_ + | PolyBound of (poly_type_variable_info kind) BoundID_.t_ + [@@deriving show] +type mono_type = mono_type_variable_info typ + +type poly_type = + | Poly of poly_type_variable_info typ + +type mono_kind = mono_type_variable_info kind + +type poly_kind = poly_type_variable_info kind + module FreeID = struct include FreeID_ - type t = kind FreeID_.t_ + type t = mono_kind FreeID_.t_ end module BoundID = struct include BoundID_ - type t = kind BoundID_.t_ + type t = poly_kind BoundID_.t_ end (* ---- untyped ---- *) @@ -739,9 +749,10 @@ type output_unit = | OShallow *) +(* let poly_extend (fmono : mono_type -> mono_type) : (poly_type -> poly_type) = (fun (Poly(ty)) -> Poly(fmono ty)) - +*) let get_range (rng, _) = rng @@ -759,7 +770,7 @@ let lift_manual_common f = function | MOptionalArgumentType(mnty) -> f mnty -(* -- 'normalize_mono_type': eliminates 'Link(_)' -- *) +(* -- 'normalize_type': eliminates 'Link(_)' -- *) let rec normalize_mono_type ty = let iter = normalize_mono_type in let (rng, tymain) = ty in @@ -767,9 +778,8 @@ let rec normalize_mono_type ty = | TypeVariable(tvinforef) -> begin match !tvinforef with - | Bound(_) -> ty - | Free(_) -> ty - | Link(tylink) -> iter tylink + | MonoFree(_) -> ty + | MonoLink(tylink) -> iter tylink end | VariantType(tylist, tyid) -> (rng, VariantType(List.map iter tylist, tyid)) @@ -785,9 +795,6 @@ let rec normalize_mono_type ty = | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) -let normalize_poly_type (Poly(ty)) = Poly(normalize_mono_type ty) - - let normalize_kind kd = match kd with | UniversalKind -> kd @@ -815,32 +822,41 @@ let rec erase_range_of_type (ty : mono_type) = (Range.dummy "erased", tymainnew) -and erase_range_of_kind (kd : kind) = +and erase_range_of_kind (kd : 'a kind) = match kd with | UniversalKind -> UniversalKind | RecordKind(asc) -> RecordKind(Assoc.map_value erase_range_of_type asc) -module BoundIDHashtbl = Hashtbl.Make( +module BoundIDHashTable = Hashtbl.Make( struct type t = BoundID.t let equal = BoundID.eq let hash = Hashtbl.hash end) +module FreeIDHashTable = Hashtbl.Make( + struct + type t = FreeID.t + let equal = FreeID.equal + let hash = Hashtbl.hash + end) + -let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : poly_type) = - let current_ht : (type_variable_info ref) BoundIDHashtbl.t = BoundIDHashtbl.create 32 in - let rec aux ((rng, tymain) as ty) = +let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : poly_type) : mono_type = + let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in + let rec aux (rng, tymain) = match tymain with | TypeVariable(tvref) -> begin match !tvref with - | Link(tyl) -> aux tyl - | Free(tvid) -> ty - | Bound(bid) -> + | PolyFree(tvid) -> + let tvrefnew = ref (MonoFree(tvid)) in + (rng, TypeVariable(tvrefnew)) + + | PolyBound(bid) -> begin - match BoundIDHashtbl.find_opt current_ht bid with + match BoundIDHashTable.find_opt bid_ht bid with | Some(tvrefnew) -> (rng, TypeVariable(tvrefnew)) @@ -848,9 +864,9 @@ let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : pol let kd = BoundID.get_kind bid in let kdfree = instantiate_kind kd in let tvid = FreeID.fresh kdfree qtfbl lev () in - let tvrefnew = ref (Free(tvid)) in + let tvrefnew = ref (MonoFree(tvid)) in begin - BoundIDHashtbl.add current_ht bid tvrefnew; + BoundIDHashTable.add bid_ht bid tvrefnew; (rng, TypeVariable(tvrefnew)) end end @@ -858,16 +874,16 @@ let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : pol | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map aux (!tyoptsr)), aux tydom, aux tycod)) | ProductType(tylist) -> (rng, ProductType(List.map aux tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value aux tyasc)) - | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, tyreal)) + | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, aux tyreal)) | VariantType(tylist, tyid) -> (rng, VariantType(List.map aux tylist, tyid)) | ListType(tysub) -> (rng, ListType(aux tysub)) | RefType(tysub) -> (rng, RefType(aux tysub)) - | BaseType(_) -> ty + | BaseType(bty) -> (rng, BaseType(bty)) | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type aux) tylist)) | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) - and instantiate_kind kd = + and instantiate_kind (kd : poly_kind) : mono_kind = match kd with | UniversalKind -> UniversalKind | RecordKind(tyasc) -> RecordKind(Assoc.map_value aux tyasc) @@ -875,29 +891,31 @@ let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : pol aux ty -let generalize (lev : FreeID.level) (ty : mono_type) = - let rec iter ((rng, tymain) as ty) = +let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = + let rec iter (rng, tymain) = match tymain with | TypeVariable(tvref) -> begin match !tvref with - | Link(tyl) -> iter tyl - | Bound(_) -> ty - | Free(tvid) -> - if not (FreeID.is_quantifiable tvid) then - ty - else - if not (FreeID.less_than lev (FreeID.get_level tvid)) then - ty + | MonoLink(tyl) -> + iter tyl + + | MonoFree(tvid) -> + let tvrefgen = + if not (FreeID.is_quantifiable tvid) then + ref (PolyFree(tvid)) else - let kd = FreeID.get_kind tvid in - let kdgen = generalize_kind kd in - let bid = BoundID.fresh kdgen () in - begin - tvref := Bound(bid); - ty - end + if not (FreeID.less_than lev (FreeID.get_level tvid)) then + ref (PolyFree(tvid)) + else + let kd = FreeID.get_kind tvid in + let kdgen = generalize_kind kd in + let bid = BoundID.fresh kdgen () in + ref (PolyBound(bid)) + in + (rng, TypeVariable(tvrefgen)) end + | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value iter tyasc)) @@ -905,7 +923,7 @@ let generalize (lev : FreeID.level) (ty : mono_type) = | VariantType(tylist, tyid) -> (rng, VariantType(List.map iter tylist, tyid)) | ListType(tysub) -> (rng, ListType(iter tysub)) | RefType(tysub) -> (rng, RefType(iter tysub)) - | BaseType(_) -> ty + | BaseType(bty) -> (rng, BaseType(bty)) | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type iter) tylist)) | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type iter) tylist)) | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) @@ -1108,7 +1126,7 @@ let global_hash_env : (string, location) Hashtbl.t = Hashtbl.create 32 (* -- following are all for debugging -- *) -let string_of_record_type (f : mono_type -> string) (asc : mono_type Assoc.t) = +let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) = let rec aux lst = match lst with | [] -> " -- " @@ -1118,7 +1136,7 @@ let string_of_record_type (f : mono_type -> string) (asc : mono_type Assoc.t) = "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let string_of_kind (f : mono_type -> string) (kdstr : kind) = +let string_of_kind (type a) (f : a typ -> string) (kdstr : a kind) = let rec aux lst = match lst with | [] -> " -- " @@ -1130,7 +1148,8 @@ let string_of_kind (f : mono_type -> string) (kdstr : kind) = | RecordKind(asc) -> "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let rec string_of_mono_type_basic tystr = +let rec string_of_type_basic tvf tystr : string = + let iter = string_of_type_basic tvf in let (rng, tymain) = tystr in let qstn = if Range.is_dummy rng then "%" else "" in match tymain with @@ -1158,15 +1177,15 @@ let rec string_of_mono_type_basic tystr = | BaseType(RegExpType) -> "regexp" ^ qstn | VariantType(tyarglist, tyid) -> - (string_of_type_argument_list_basic tyarglist) ^ (TypeID.show_direct tyid) (* temporary *) ^ "@" ^ qstn + (string_of_type_argument_list_basic tvf tyarglist) ^ (TypeID.show_direct tyid) (* temporary *) ^ "@" ^ qstn | SynonymType(tyarglist, tyid, tyreal) -> - (string_of_type_argument_list_basic tyarglist) ^ (TypeID.show_direct tyid) ^ "@ (= " ^ (string_of_mono_type_basic tyreal) ^ ")" + (string_of_type_argument_list_basic tvf tyarglist) ^ (TypeID.show_direct tyid) ^ "@ (= " ^ (iter tyreal) ^ ")" | FuncType(tyoptsr, tydom, tycod) -> let stropts = !tyoptsr |> List.map (fun ((_, tymain) as ty) -> - let s = string_of_mono_type_basic ty in + let s = iter ty in match tymain with | FuncType(_, _, _) | ProductType(_) @@ -1176,8 +1195,8 @@ let rec string_of_mono_type_basic tystr = | _ -> s ^ "? -> " ) in - let strdom = string_of_mono_type_basic tydom in - let strcod = string_of_mono_type_basic tycod in + let strdom = iter tydom in + let strcod = iter tycod in (String.concat "" stropts) ^ begin match tydom with | (_, FuncType(_, _, _)) -> "(" ^ strdom ^ ")" @@ -1185,7 +1204,7 @@ let rec string_of_mono_type_basic tystr = end ^ " ->" ^ qstn ^ " " ^ strcod | ListType(tycont) -> - let strcont = string_of_mono_type_basic tycont in + let strcont = iter tycont in let (_, tycontmain) = tycont in begin match tycontmain with | FuncType(_, _, _) @@ -1199,7 +1218,7 @@ let rec string_of_mono_type_basic tystr = end ^ " list" ^ qstn | RefType(tycont) -> - let strcont = string_of_mono_type_basic tycont in + let strcont = iter tycont in let (_, tycontmain) = tycont in begin match tycontmain with | FuncType(_, _, _) @@ -1214,43 +1233,38 @@ let rec string_of_mono_type_basic tystr = end ^ " ref" ^ qstn | ProductType(tylist) -> - string_of_mono_type_list_basic tylist + string_of_type_list_basic tvf tylist | TypeVariable(tvref) -> - begin - match !tvref with - | Link(tyl) -> "$(" ^ (string_of_mono_type_basic tyl) ^ ")" - | Free(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn - | Bound(bid) -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ qstn - end + tvf qstn !tvref | RecordType(asc) -> - string_of_record_type string_of_mono_type_basic asc + string_of_record_type iter asc | HorzCommandType(tylist) -> - let slist = List.map string_of_command_argument_type tylist in + let slist = List.map (string_of_command_argument_type tvf) tylist in "[" ^ (String.concat "; " slist) ^ "] horz-command" | VertCommandType(tylist) -> - let slist = List.map string_of_command_argument_type tylist in + let slist = List.map (string_of_command_argument_type tvf) tylist in "[" ^ (String.concat "; " slist) ^ "] vert-command" | MathCommandType(tylist) -> - let slist = List.map string_of_command_argument_type tylist in + let slist = List.map (string_of_command_argument_type tvf) tylist in "[" ^ (String.concat "; " slist) ^ "] math-command" -and string_of_command_argument_type = function - | MandatoryArgumentType(ty) -> string_of_mono_type_basic ty - | OptionalArgumentType(ty) -> "(" ^ (string_of_mono_type_basic ty) ^ ")?" +and string_of_command_argument_type tvf = function + | MandatoryArgumentType(ty) -> string_of_type_basic tvf ty + | OptionalArgumentType(ty) -> "(" ^ (string_of_type_basic tvf ty) ^ ")?" -and string_of_type_argument_list_basic tyarglist = +and string_of_type_argument_list_basic tvf tyarglist = match tyarglist with | [] -> "" | head :: tail -> - let strhd = string_of_mono_type_basic head in - let strtl = string_of_type_argument_list_basic tail in + let strhd = string_of_type_basic tvf head in + let strtl = string_of_type_argument_list_basic tvf tail in let (_, headmain) = head in begin match headmain with @@ -1265,11 +1279,11 @@ and string_of_type_argument_list_basic tyarglist = end ^ " " ^ strtl -and string_of_mono_type_list_basic tylist = +and string_of_type_list_basic tvf tylist = match tylist with | [] -> "" | head :: [] -> - let strhd = string_of_mono_type_basic head in + let strhd = string_of_type_basic tvf head in let (_, headmain) = head in begin match headmain with @@ -1279,8 +1293,8 @@ and string_of_mono_type_list_basic tylist = | _ -> strhd end | head :: tail -> - let strhd = string_of_mono_type_basic head in - let strtl = string_of_mono_type_list_basic tail in + let strhd = string_of_type_basic tvf head in + let strtl = string_of_type_list_basic tvf tail in let (_, headmain) = head in begin match headmain with @@ -1290,9 +1304,22 @@ and string_of_mono_type_list_basic tylist = | _ -> strhd end ^ " * " ^ strtl +let rec string_of_mono_type_basic ty = + let tvf qstn tvref = + match tvref with + | MonoLink(tyl) -> "$(" ^ (string_of_mono_type_basic tyl) ^ ")" + | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn + in + string_of_type_basic tvf ty + -and string_of_poly_type_basic (Poly(ty)) = - string_of_mono_type_basic ty (* temporary *) +let rec string_of_poly_type_basic (Poly(ty)) = + let tvf qstn tvref = + match tvref with + | PolyBound(bid) -> "'#" ^ (BoundID.show_direct (string_of_kind (fun ty -> string_of_poly_type_basic (Poly(ty)))) bid) ^ qstn + | PolyFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn + in + string_of_type_basic tvf ty and string_of_kind_basic kd = string_of_kind string_of_mono_type_basic kd From cc8468155cf1d76830b3efd8120a43ff7d228177 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 14 Jul 2018 14:15:29 +0900 Subject: [PATCH 02/42] (midway) --- src/frontend/typeenv.ml | 214 +++++++++++++++++++++--------------- src/frontend/types_.cppo.ml | 107 ++++++++++-------- 2 files changed, 186 insertions(+), 135 deletions(-) diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index dae56a51f..c60e3eb51 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -268,8 +268,8 @@ module MapList type type_argument_mode = - | StrictMode of (type_argument_name, poly_type_variable_info ref) MapList.t - | FreeMode of (type_argument_name, poly_type_variable_info ref) MapList.t + | StrictMode of (type_argument_name, BoundID.t) MapList.t + | FreeMode of (type_argument_name, poly_type_variable_info) MapList.t (* -- StrictMode : case where all type arguments should be declared; e.g. for type definitions FreeMode : case where type arguments do not need to be declared; e.g. for type annotations @@ -363,40 +363,45 @@ let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } -let instantiate_type_scheme (tyarglist : mono_type list) (bidlist : BoundID.t list) (Poly(ty) : poly_type) = +let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info ref -> a typ) (tyarglist : (a typ) list) (bidlist : BoundID.t list) (Poly(pty) : poly_type) : a typ = (* let () = print_for_debug_variantenv ("I-input [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_mono_type_basic ty)) in (* for debug *) *) - let bid_to_type_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in + let bid_to_type_ht : (a typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in - let rec pre tyargs bids = + let rec pre (tyargs : (a typ) list) (bids : BoundID.t list) = match (tyargs, bids) with - | ([], []) -> () + | ([], []) -> + () + | (tyarg :: tyargtail, bid :: bidtail) -> - let tvref = ref (MonoLink(tyarg)) in begin - print_for_debug_variantenv ("I-add '#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " -> " ^ (string_of_mono_type_basic tyarg)); (* for debug *) - BoundIDHashTable.add bid_to_type_ht bid tvref; +(* + print_for_debug_variantenv ("I-add '#" ^ (BoundID.show_direct string_of_poly_kind bid) ^ " -> " ^ (string_of_mono_type_basic tyarg)); (* for debug *) +*) + BoundIDHashTable.add bid_to_type_ht bid tyarg; pre tyargtail bidtail; end - | (_, _) -> assert false + + | (_, _) -> assert false in - let rec aux (rng, tymain) = + let rec aux ((rng, ptymain) : poly_type_variable_info typ) : a typ = +(* let () = print_for_debug_variantenv ("aux " ^ (string_of_mono_type_basic (rng, tymain))) in (* for debug *) - match tymain with - | TypeVariable(tvref) -> +*) + match ptymain with + | TypeVariable(ptvi) -> begin - match !tvref with - | Link(tysub) -> aux tysub - | Free(tvid) -> (rng, tymain) - | Bound(bid) -> + match ptvi with + | PolyFree(tvref) -> + freef rng tvref + + | PolyBound(bid) -> begin - try - let tvrefsubst = BoundIDHashtbl.find bid_to_type_ht bid in - (rng, TypeVariable(tvrefsubst)) - with - | Not_found -> assert false + match BoundIDHashTable.find_opt bid_to_type_ht bid with + | None -> assert false + | Some(tysub) -> tysub end end @@ -407,25 +412,25 @@ let instantiate_type_scheme (tyarglist : mono_type list) (bidlist : BoundID.t li | VariantType(tylist, tyid) -> (rng, VariantType(List.map aux tylist, tyid)) | ListType(tysub) -> (rng, ListType(aux tysub)) | RefType(tysub) -> (rng, RefType(aux tysub)) - | BaseType(_) -> (rng, tymain) + | BaseType(bt) -> (rng, BaseType(bt)) | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type aux) tylist)) | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) in begin pre tyarglist bidlist; - aux ty + aux pty end let rec type_argument_length tyargcons = List.length tyargcons -let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargmode : type_argument_mode) (mnty : manual_type) = - let rec aux (mnty : manual_type) : poly_type = +let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (freef : Range.t -> mono_type_variable_info ref -> a typ) (typaramf : Range.t -> string -> a type_main) (mnty : manual_type) : a typ = + let rec aux (mnty : manual_type) : a typ = let (rng, mntymain) = mnty in let error tynm lenexp lenerr = raise (IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr)) in - let tymainnew = + let ptymainnew = match mntymain with | MFuncType(mntyopts, mntydom, mntycod) -> FuncType(ref (List.map aux mntyopts), aux mntydom, aux mntycod) @@ -465,7 +470,7 @@ let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : Fr | Some((tyid, Alias(bidlist, ptyscheme))) -> let lenexp = List.length bidlist in if lenexp <> len then error tynm lenexp len else - let tyreal = instantiate_type_scheme tyarglist bidlist ptyscheme in + let tyreal = instantiate_type_scheme freef tyarglist bidlist ptyscheme in let () = print_for_debug_variantenv ("FS " ^ tynm ^ " -> " ^ TypeID.show_direct tyid) in (* for debug *) SynonymType(tyarglist, tyid, tyreal) in @@ -485,7 +490,7 @@ let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : Fr | SynonymVertex(_, tyid, tyargcons, mnty, {contents= Some(bidlist, ptyscheme)}) -> let lenexp = type_argument_length tyargcons in if len <> lenexp then error tynm lenexp len else - let tyreal = instantiate_type_scheme tyarglist bidlist ptyscheme in + let tyreal = instantiate_type_scheme freef tyarglist bidlist ptyscheme in SynonymType(tyarglist, tyid, tyreal) | SynonymVertex(_, _, _, _, {contents= None}) -> assert false @@ -495,104 +500,127 @@ let rec fix_manual_type_general (dpmode : dependency_mode) (tyenv : t) (lev : Fr end end - | MTypeParam(tyargnm) -> + | MTypeParam(tyargnm) -> typaramf rng tyargnm +(* begin match tyargmode with - | StrictMode(tyargmaplist) -> - begin - match MapList.find_opt tyargmaplist tyargnm with - | None -> raise (UndefinedTypeArgument(rng, tyargnm)) - | Some(tvref) -> TypeVariable(tvref) - end + | StrictMode(bidmaplist) -> | FreeMode(tyargmaplist) -> - begin - match MapList.find_opt tyargmaplist tyargnm with - | Some(tvref) -> TypeVariable(tvref) - | None -> - let tvid = FreeID.fresh UniversalKind Quantifiable lev () in - let tvref = ref (Free(tvid)) in - begin - MapList.add tyargmaplist tyargnm tvref; - TypeVariable(tvref) - end - end end +*) in - (rng, tymainnew) + (rng, ptymainnew) + and aux_cmd = function | MMandatoryArgumentType(mnty) -> MandatoryArgumentType(aux mnty) | MOptionalArgumentType(mnty) -> OptionalArgumentType(aux mnty) in - let ty = aux mnty in + aux mnty +(* match tyargmode with - | StrictMode(tyargmaplist) - | FreeMode(tyargmaplist) - -> + | StrictMode(bidmaplist) -> + let bidlist = + MapList.to_list bidmaplist |> List.map (fun (_, bid) -> bid) + in + (bidlist, Poly(pty)) + + | FreeMode(tyargmaplist) -> let bidlist = - (MapList.to_list tyargmaplist) |> List.map (fun (_, tvref) -> - match !tvref with - | PolyFree(tvid) -> - let kd = FreeID.get_kind tvid in + (MapList.to_list tyargmaplist) |> List.map (fun (_, ptvi) -> + match ptvi with + | PolyFree(tvref) -> + let kd = BoundID.get_kind tvid in let bid = BoundID.fresh kd () in begin tvref := PolyBound(bid); bid end + | _ -> assert false ) in - (bidlist, Poly(ty)) - + (bidlist, Poly(pty)) +*) -and fix_manual_kind_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargmode : type_argument_mode) (mnkd : manual_kind) : kind = +and fix_manual_kind_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) freef typaramf (mnkd : manual_kind) = match mnkd with | MUniversalKind -> UniversalKind | MRecordKind(mntyasc) -> - let aux asc = - let (_, Poly(ty)) = fix_manual_type_general dpmode tyenv lev tyargmode asc in - ty + let aux mnty = + fix_manual_type_general dpmode tyenv lev freef typaramf mnty in - RecordKind(Assoc.map_value aux mntyasc) + RecordKind(Assoc.map_value aux mntyasc) -let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargcons : untyped_type_argument list) (mnty : manual_type) = - let tyargmaplist = MapList.create () in +let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargcons : untyped_type_argument list) (mnty : manual_type) : BoundID.t list * poly_type = + let bidmaplist = MapList.create () in + let freef rng tvref = + (rng, TypeVariable(PolyFree(tvref))) + in + let typaramf rng param = + match MapList.find_opt bidmaplist param with + | None -> raise (UndefinedTypeArgument(rng, param)) + | Some(bid) -> TypeVariable(PolyBound(bid)) + in let rec aux cons = match cons with | [] -> () | (_, tyargnm, mnkd) :: tailcons -> - let kd = fix_manual_kind_general dpmode tyenv lev (StrictMode(tyargmaplist)) mnkd in + let kd = fix_manual_kind_general dpmode tyenv lev freef typaramf mnkd in +(* let () = print_for_debug_variantenv ("FMT " ^ tyargnm ^ " :: " ^ (string_of_kind string_of_mono_type_basic kd)) in (* for debug *) - let tvid = FreeID.fresh (normalize_kind kd) Quantifiable lev () in +*) + let bid = BoundID.fresh kd () in begin - MapList.add tyargmaplist tyargnm (ref (Free(tvid))); + MapList.add bidmaplist tyargnm bid; aux tailcons end in begin aux tyargcons; - fix_manual_type_general dpmode tyenv lev (StrictMode(tyargmaplist)) mnty + let pty = fix_manual_type_general dpmode tyenv lev freef typaramf mnty in + let bidlist = MapList.to_list bidmaplist |> List.map (fun (_, bid) -> bid) in + (bidlist, Poly(pty)) end (* PUBLIC *) -let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (mnty : manual_type) (constrnts : constraints) = +let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (mnty : manual_type) (constrnts : constraints) : mono_type = + + let tyargmaplist : (string, mono_type_variable_info ref) MapList.t = MapList.create () in - let tyargmaplist = MapList.create () in + let freef rng tvref = + (rng, TypeVariable(tvref)) + in + let typaramf rng param = + match MapList.find_opt tyargmaplist param with + | Some(tvref) -> + TypeVariable(tvref) + + | None -> + let tvid = FreeID.fresh UniversalKind qtfbl lev () in + let tvref = ref (MonoFree(tvid)) in + begin + MapList.add tyargmaplist param tvref; + TypeVariable(tvref) + end + in let () = - constrnts |> List.iter (fun (tyargnm, mkd) -> - let kd = fix_manual_kind_general NoDependency tyenv lev (FreeMode(tyargmaplist)) mkd in + constrnts |> List.iter (fun (param, mkd) -> + let kd = fix_manual_kind_general NoDependency tyenv lev freef typaramf mkd in let tvid = FreeID.fresh (normalize_kind kd) qtfbl lev () in - let tvref = ref (Free(tvid)) in - MapList.add tyargmaplist tyargnm tvref + let tvref = ref (MonoFree(tvid)) in + MapList.add tyargmaplist param tvref ) in - let (bidlist, ptyin) = fix_manual_type_general NoDependency tyenv lev (FreeMode(tyargmaplist)) mnty in + let ty = fix_manual_type_general NoDependency tyenv lev freef typaramf mnty in + ty +(* let tyarglist = bidlist |> List.map (fun bid -> let tvid = FreeID.fresh (normalize_kind (BoundID.get_kind bid)) qtfbl lev () in @@ -600,6 +628,7 @@ let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev ) in instantiate_type_scheme tyarglist bidlist ptyin +*) let register_type (tynm : type_name) (tyid : TypeID.t) (dfn : type_definition) (tyenv : t) : t = @@ -630,31 +659,39 @@ let register_type_from_vertex (dg : vertex_label DependencyGraph.t) (tyenv : t) let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (constrnm : constructor_name) : (mono_type list * TypeID.t * mono_type) option = - let open OptionMonad in + let freef rng tvref = + (rng, TypeVariable(tvref)) + in let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in + let open OptionMonad in ModuleTree.search_backward mtr addrlst [] (fun (_, _, cdmap, _) -> ConstrMap.find_opt constrnm cdmap) >>= fun dfn -> let (tyid, (bidlist, pty)) = dfn in - let tyarglist = + let tyarglist : mono_type list = bidlist |> List.map (fun bid -> - let tvid = FreeID.fresh (normalize_kind (BoundID.get_kind bid)) qtfbl lev () in - (Range.dummy "tc-constructor", TypeVariable(ref (Free(tvid)))) + let kd = BoundID.get_kind bid in + let tvid = FreeID.fresh (instantiate_kind lev qtfbl kd) qtfbl lev () in + (Range.dummy "tc-constructor", TypeVariable(ref (MonoFree(tvid)))) ) in - let ty = instantiate_type_scheme tyarglist bidlist pty in + let ty = instantiate_type_scheme freef tyarglist bidlist pty in return (tyarglist, tyid, ty) + let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (typeid : TypeID.t) : (constructor_name * (mono_type list -> mono_type)) list = - let open OptionMonad in + let freef rng tvref = + (rng, TypeVariable(tvref)) + in let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in + let open OptionMonad in let constrs = ModuleTree.search_backward mtr addrlst [] (fun (_, _, cdmap, _) -> let constrs = ConstrMap.fold (fun constrnm dfn acc -> let (tyid, (bidlist, pty)) = dfn in if TypeID.equal typeid tyid then - (constrnm, (fun tyarglist -> instantiate_type_scheme tyarglist bidlist pty))::acc + (constrnm, (fun tyarglist -> instantiate_type_scheme freef tyarglist bidlist pty))::acc else acc ) cdmap [] @@ -825,10 +862,10 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = let current_ht : BoundID.t BoundIDHashtbl.t = BoundIDHashtbl.create 32 in (* -- hash table mapping bound IDs in 'pty2' to bound IDs in 'pty1' -- *) *) - let current_bid_to_ty : (mono_type * type_variable_info ref) BoundIDHashtbl.t = BoundIDHashtbl.create 32 in + let current_bid_to_ty : ('a * poly_type_variable_info) BoundIDHashTable.t = BoundIDHashTable.create 32 in (* -- hash table mapping bound IDs in 'pty2' to types -- *) - let rec aux ((_, tymain1) as ty1 : mono_type) ((_, tymain2) as ty2 : mono_type) = + let rec aux ((_, tymain1) as ty1) ((_, tymain2) as ty2) = let () = print_for_debug_variantenv ("reflects " ^ (string_of_mono_type_basic ty1) ^ " << " ^ (string_of_mono_type_basic ty2)) in (* for debug *) let aux_list tylistcomb = @@ -845,12 +882,13 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = match (tymain1, tymain2) with | (SynonymType(tyl1, tyid1, tyreal1), _) -> aux tyreal1 ty2 | (_, SynonymType(tyl2, tyid2, tyreal2)) -> aux ty1 tyreal2 +(* | (TypeVariable({contents= Link(tysub1)}), _) -> aux tysub1 ty2 | (_, TypeVariable({contents= Link(tysub2)})) -> aux ty1 tysub2 - - | (TypeVariable({contents= Bound(bid1)}), TypeVariable({contents= Bound(bid2)} as tyref2)) -> +*) + | (TypeVariable(PolyBound(bid1)), TypeVariable(PolyBound(bid2))) -> begin - match BoundIDHashtbl.find_opt current_bid_to_ty bid2 with + match BoundIDHashTable.find_opt current_bid_to_ty bid2 with | Some(((_, TypeVariable({contents= Bound(bid1old)})), _)) -> BoundID.eq bid1 bid1old diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 575c22243..89617ac04 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -237,7 +237,7 @@ and 'a type_main = | ListType of 'a typ | RefType of 'a typ | ProductType of ('a typ) list - | TypeVariable of 'a ref + | TypeVariable of 'a | SynonymType of ('a typ) list * TypeID.t * 'a typ | VariantType of ('a typ) list * TypeID.t | RecordType of ('a typ) Assoc.t @@ -256,23 +256,23 @@ and 'a kind = [@printer (fun fmt _ -> Format.fprintf fmt "RecordKind(...)")] and mono_type_variable_info = - | MonoFree of (mono_type_variable_info kind) FreeID_.t_ - | MonoLink of mono_type_variable_info typ + | MonoFree of mono_kind FreeID_.t_ + | MonoLink of mono_type and poly_type_variable_info = - | PolyFree of (mono_type_variable_info kind) FreeID_.t_ + | PolyFree of mono_type_variable_info ref | PolyBound of (poly_type_variable_info kind) BoundID_.t_ -[@@deriving show] - -type mono_type = mono_type_variable_info typ +and mono_type = (mono_type_variable_info ref) typ -type poly_type = +and poly_type = | Poly of poly_type_variable_info typ -type mono_kind = mono_type_variable_info kind +and mono_kind = (mono_type_variable_info ref) kind + +and poly_kind = poly_type_variable_info kind +[@@deriving show] -type poly_kind = poly_type_variable_info kind module FreeID = @@ -800,7 +800,7 @@ let normalize_kind kd = | RecordKind(tyasc) -> RecordKind(Assoc.map_value normalize_mono_type tyasc) -let rec erase_range_of_type (ty : mono_type) = +let rec erase_range_of_type (ty : mono_type) : mono_type = let iter = erase_range_of_type in let tymainnew = let (_, tymain) = normalize_mono_type ty in @@ -842,16 +842,14 @@ module FreeIDHashTable = Hashtbl.Make( end) -let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : poly_type) : mono_type = - let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in - let rec aux (rng, tymain) = - match tymain with - | TypeVariable(tvref) -> +let rec instantiate_aux bid_ht lev qtfbl (rng, ptymain) = + let aux = instantiate_aux bid_ht lev qtfbl in + match ptymain with + | TypeVariable(ptvi) -> begin - match !tvref with - | PolyFree(tvid) -> - let tvrefnew = ref (MonoFree(tvid)) in - (rng, TypeVariable(tvrefnew)) + match ptvi with + | PolyFree(tvref) -> + (rng, TypeVariable(tvref)) | PolyBound(bid) -> begin @@ -861,12 +859,12 @@ let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : pol | None -> let kd = BoundID.get_kind bid in - let kdfree = instantiate_kind kd in + let kdfree = instantiate_kind_aux bid_ht lev qtfbl kd in let tvid = FreeID.fresh kdfree qtfbl lev () in - let tvrefnew = ref (MonoFree(tvid)) in + let tvref = ref (MonoFree(tvid)) in begin - BoundIDHashTable.add bid_ht bid tvrefnew; - (rng, TypeVariable(tvrefnew)) + BoundIDHashTable.add bid_ht bid tvref; + (rng, TypeVariable(tvref)) end end end @@ -882,12 +880,21 @@ let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(ty)) : pol | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) - and instantiate_kind (kd : poly_kind) : mono_kind = + +and instantiate_kind_aux bid_ht lev qtfbl (kd : poly_kind) : mono_kind = match kd with | UniversalKind -> UniversalKind - | RecordKind(tyasc) -> RecordKind(Assoc.map_value aux tyasc) - in - aux ty + | RecordKind(tyasc) -> RecordKind(Assoc.map_value (instantiate_aux bid_ht lev qtfbl) tyasc) + + +let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(pty)) : poly_type) : mono_type = + let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in + instantiate_aux bid_ht lev qtfbl pty + + +let instantiate_kind (lev : FreeID.level) (qtfbl : quantifiability) (pkd : poly_kind) : mono_kind = + let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in + instantiate_kind_aux bid_ht lev qtfbl pkd let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = @@ -900,19 +907,18 @@ let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = iter tyl | MonoFree(tvid) -> - let tvrefgen = + let ptvi = if not (FreeID.is_quantifiable tvid) then - ref (PolyFree(tvid)) + PolyFree(tvref) + else if not (FreeID.less_than lev (FreeID.get_level tvid)) then + PolyFree(tvref) else - if not (FreeID.less_than lev (FreeID.get_level tvid)) then - ref (PolyFree(tvid)) - else - let kd = FreeID.get_kind tvid in - let kdgen = generalize_kind kd in - let bid = BoundID.fresh kdgen () in - ref (PolyBound(bid)) + let kd = FreeID.get_kind tvid in + let kdgen = generalize_kind kd in + let bid = BoundID.fresh kdgen () in + PolyBound(bid) in - (rng, TypeVariable(tvrefgen)) + (rng, TypeVariable(ptvi)) end | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) @@ -1234,8 +1240,8 @@ let rec string_of_type_basic tvf tystr : string = | ProductType(tylist) -> string_of_type_list_basic tvf tylist - | TypeVariable(tvref) -> - tvf qstn !tvref + | TypeVariable(tvi) -> + tvf qstn tvi | RecordType(asc) -> string_of_record_type iter asc @@ -1305,20 +1311,27 @@ and string_of_type_list_basic tvf tylist = let rec string_of_mono_type_basic ty = let tvf qstn tvref = - match tvref with + match !tvref with | MonoLink(tyl) -> "$(" ^ (string_of_mono_type_basic tyl) ^ ")" | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn in string_of_type_basic tvf ty -let rec string_of_poly_type_basic (Poly(ty)) = - let tvf qstn tvref = - match tvref with - | PolyBound(bid) -> "'#" ^ (BoundID.show_direct (string_of_kind (fun ty -> string_of_poly_type_basic (Poly(ty)))) bid) ^ qstn - | PolyFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn +let rec string_of_poly_type_basic (Poly(pty)) = + let ptvf qstn ptvi = + match ptvi with + | PolyBound(bid) -> + "'#" ^ (BoundID.show_direct (string_of_kind (fun ty -> string_of_poly_type_basic (Poly(ty)))) bid) ^ qstn + + | PolyFree(tvref) -> + begin + match !tvref with + | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn + | MonoLink(ty) -> string_of_mono_type_basic ty + end in - string_of_type_basic tvf ty + string_of_type_basic ptvf pty and string_of_kind_basic kd = string_of_kind string_of_mono_type_basic kd From 59acc7d892196937d950f5a8e632d69c4eb432f5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 15 Jul 2018 00:00:25 +0900 Subject: [PATCH 03/42] finish making distinction between type schemes and polymorphic types --- src/frontend/display.ml | 94 +++++++------ src/frontend/primitives_.cppo.ml | 12 +- src/frontend/primitives_.mli | 4 +- src/frontend/typechecker.ml | 96 +++++++------ src/frontend/typeenv.ml | 234 +++++++++++++++++++------------ src/frontend/types_.cppo.ml | 31 ++-- 6 files changed, 284 insertions(+), 187 deletions(-) diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 0c787f433..01b92eb78 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -2,7 +2,7 @@ module Types = Types_ open Types -let string_of_record_type (f : mono_type -> string) (asc : mono_type Assoc.t) = +let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) = let rec aux lst = match lst with | [] -> " -- " @@ -12,7 +12,7 @@ let string_of_record_type (f : mono_type -> string) (asc : mono_type Assoc.t) = "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let string_of_kind (f : mono_type -> string) (kdstr : kind) = +let string_of_kind (type a) (f : a typ -> string) (kdstr : a kind) = let rec aux lst = match lst with | [] -> " -- " @@ -32,10 +32,10 @@ let rec variable_name_of_number (n : int) = ) ^ (String.make 1 (Char.chr ((Char.code 'a') + n mod 26))) -let show_type_variable (f : mono_type -> string) (name : string) (kd : kind) = +let show_type_variable (type a) (f : a typ -> string) (name : string) (kd : a kind) = match kd with | UniversalKind -> name - | RecordKind(asc) -> "(" ^ name ^ " <: " ^ (string_of_kind f (normalize_kind kd)) ^ ")" + | RecordKind(asc) -> "(" ^ name ^ " <: " ^ (string_of_kind f kd) ^ ")" type general_id = FreeID of FreeID.t | BoundID of BoundID.t @@ -93,33 +93,21 @@ module GeneralIDHashTable end -let rec string_of_mono_type_sub (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) ((_, tymain) : mono_type) = - let iter = string_of_mono_type_sub tyenv current_ht in - let iter_cmd = string_of_command_argument_type tyenv current_ht in - let iter_args = string_of_type_argument_list tyenv current_ht in - let iter_list = string_of_mono_type_list tyenv current_ht in +let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) ((_, tymain) : 'a typ) = + let iter = string_of_mono_type_sub tvf tyenv current_ht in + let iter_cmd = string_of_command_argument_type tvf tyenv current_ht in + let iter_args = string_of_type_argument_list tvf tyenv current_ht in + let iter_list = string_of_mono_type_list tvf tyenv current_ht in match tymain with - | TypeVariable(tvref) -> - begin - match !tvref with - | Link(tyl) -> - (* -- 'Link(_)' must be eliminated by 'normalize_mono_type' and 'normalize_kind' -- *) - assert false + | TypeVariable(tvi) -> tvf tvi +(* (* "${" ^ iter tyl ^ "}" (* TEMPORARY *) *) | Bound(bid) -> - let num = GeneralIDHashTable.intern_number current_ht (BoundID(bid)) in - let s = "'#" ^ (variable_name_of_number num) in - show_type_variable iter s (BoundID.get_kind bid) - - | Free(tvid) -> - let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in - let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable iter s (FreeID.get_kind tvid) - end +*) | BaseType(EnvType) -> "env" (* -- unused -- *) | BaseType(UnitType) -> "unit" @@ -211,12 +199,12 @@ let rec string_of_mono_type_sub (tyenv : Typeenv.t) (current_ht : int GeneralIDH "[" ^ (String.concat "; " slist) ^ "] math-cmd" -and string_of_command_argument_type tyenv current_ht = function +and string_of_command_argument_type tvf tyenv current_ht = function | MandatoryArgumentType(ty) -> - string_of_mono_type_sub tyenv current_ht ty + string_of_mono_type_sub tvf tyenv current_ht ty | OptionalArgumentType((_, tymain) as ty) -> - let strty = string_of_mono_type_sub tyenv current_ht ty in + let strty = string_of_mono_type_sub tvf tyenv current_ht ty in begin match tymain with | ProductType(_) @@ -227,9 +215,9 @@ and string_of_command_argument_type tyenv current_ht = function end -and string_of_type_argument_list tyenv current_ht tyarglist = - let iter = string_of_mono_type_sub tyenv current_ht in - let iter_args = string_of_type_argument_list tyenv current_ht in +and string_of_type_argument_list tvf tyenv current_ht tyarglist = + let iter = string_of_mono_type_sub tvf tyenv current_ht in + let iter_args = string_of_type_argument_list tvf tyenv current_ht in match tyarglist with | [] -> "" | head :: tail -> @@ -249,9 +237,9 @@ and string_of_type_argument_list tyenv current_ht tyarglist = end ^ " " ^ strtl -and string_of_mono_type_list tyenv current_ht tylist = - let iter = string_of_mono_type_sub tyenv current_ht in - let iter_list = string_of_mono_type_list tyenv current_ht in +and string_of_mono_type_list tvf tyenv current_ht tylist = + let iter = string_of_mono_type_sub tvf tyenv current_ht in + let iter_list = string_of_mono_type_list tvf tyenv current_ht in match tylist with | [] -> "" | head :: tail -> @@ -272,12 +260,36 @@ and string_of_mono_type_list tyenv current_ht tylist = end +let rec tvf_mono current_ht tyenv tvref = + match !tvref with + | MonoFree(tvid) -> + let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in + let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in + show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + + | MonoLink(ty) -> + assert false + (* -- links should be omitted by 'normalize_mono_type' -- *) + + +let rec tvf_poly current_ht tyenv ptvi = + match ptvi with + | PolyFree(tvref) -> + tvf_mono current_ht tyenv tvref + (* doubtful *) + + | PolyBound(bid) -> + let num = GeneralIDHashTable.intern_number current_ht (BoundID(bid)) in + let s = "'#" ^ (variable_name_of_number num) in + show_type_variable (string_of_mono_type_sub (tvf_poly current_ht tyenv) tyenv current_ht) s (BoundID.get_kind bid) + + let string_of_mono_type (tyenv : Typeenv.t) (ty : mono_type) = begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in let tyn = normalize_mono_type ty in - string_of_mono_type_sub tyenv current_ht tyn + string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht tyn end @@ -287,15 +299,19 @@ let string_of_mono_type_double (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono let current_ht = GeneralIDHashTable.create 32 in let tyn1 = normalize_mono_type ty1 in let tyn2 = normalize_mono_type ty2 in - let strty1 = string_of_mono_type_sub tyenv current_ht tyn1 in - let strty2 = string_of_mono_type_sub tyenv current_ht tyn2 in + let strf = string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht in + let strty1 = strf tyn1 in + let strty2 = strf tyn2 in (strty1, strty2) end -let string_of_poly_type (tyenv : Typeenv.t) (Poly(ty) : poly_type) = - let tyn = normalize_mono_type ty in - string_of_mono_type tyenv tyn (* temporary *) +let string_of_poly_type (tyenv : Typeenv.t) (Poly(pty) : poly_type) = + begin + GeneralIDHashTable.initialize (); + let current_ht = GeneralIDHashTable.create 32 in + string_of_mono_type_sub (tvf_poly current_ht tyenv) tyenv current_ht pty + end (* -- following are all for debug -- *) diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 2c11803d5..a360da328 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -51,7 +51,7 @@ let (@->) dom cod = (~! "func" , FuncType(ref [], dom, cod)) (* -- predefined data types -- *) let tOPT ty = (~! "option" , VariantType([ty], tyid_option)) -let tITMZ = (~! "itemize" , VariantType([], tyid_itemize) ) +let tITMZ () = (~! "itemize" , VariantType([], tyid_itemize) ) let tSCR = (~! "script" , VariantType([], tyid_script) ) let tLANG = (~! "language", VariantType([], tyid_language)) let tCLR = (~! "color" , VariantType([], tyid_color) ) @@ -135,13 +135,13 @@ let tRULESF = (tL tLN) @-> (tL tLN) @-> (tL tGR) let option_type = tOPT -let itemize_type = tITMZ +let itemize_type () = tITMZ () let add_default_types (tyenvmid : Typeenv.t) : Typeenv.t = let dr = Range.dummy "add_default_types" in let bid = BoundID.fresh UniversalKind () in - let typaram = (dr, TypeVariable(ref (Bound(bid)))) in + let typaram = (dr, TypeVariable(PolyBound(bid))) in tyenvmid |> Typeenv.Raw.register_type "option" tyid_option (Typeenv.Data(1)) @@ -149,7 +149,7 @@ let add_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.add_constructor "Some" ([bid], Poly(typaram)) tyid_option |> Typeenv.Raw.register_type "itemize" tyid_itemize (Typeenv.Data(0)) - |> Typeenv.Raw.add_constructor "Item" ([], Poly(tPROD [tIT; tL tITMZ])) tyid_itemize + |> Typeenv.Raw.add_constructor "Item" ([], Poly(tPROD [tIT; tL (tITMZ ())])) tyid_itemize |> Typeenv.Raw.register_type "color" tyid_color (Typeenv.Data(0)) |> Typeenv.Raw.add_constructor "Gray" ([], Poly(tFL)) tyid_color @@ -551,8 +551,8 @@ let make_environments () = let (~@) n = (~! "tv", TypeVariable(n)) in let (-%) n ptysub = ptysub in let (~%) ty = Poly(ty) in - let tv1 = (let bid1 = BoundID.fresh UniversalKind () in ref (Bound(bid1))) in - let tv2 = (let bid2 = BoundID.fresh UniversalKind () in ref (Bound(bid2))) in + let tv1 = (let bid1 = BoundID.fresh UniversalKind () in PolyBound(bid1)) in + let tv2 = (let bid2 = BoundID.fresh UniversalKind () in PolyBound(bid2)) in let table : (var_name * poly_type * (environment -> syntactic_value)) list = let ptyderef = tv1 -% (~% ((tR (~@ tv1)) @-> (~@ tv1))) in diff --git a/src/frontend/primitives_.mli b/src/frontend/primitives_.mli index d185c7a9d..52fdf1626 100644 --- a/src/frontend/primitives_.mli +++ b/src/frontend/primitives_.mli @@ -3,9 +3,9 @@ module Types = Types_ open Types open LengthInterface -val option_type : mono_type -> mono_type +val option_type : 'a typ -> 'a typ -val itemize_type : mono_type +val itemize_type : unit -> 'a typ val get_initial_context : length -> HorzBox.context_main diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 69c14714a..e38a6ec18 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -29,14 +29,15 @@ let print_for_debug_typecheck msg = () -let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) = +let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_type list * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> let evid = EvalVarID.fresh varnm in let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let tvref = ref (MonoFree(tvid)) in + let beta = (rng, TypeVariable(PolyFree(tvref))) in let tyenvnew = Typeenv.add tyenv varnm (Poly(Primitives.option_type beta), evid) in - (tyenvnew, Alist.extend tyacc beta, Alist.extend evidacc evid) + (tyenvnew, Alist.extend tyacc (rng, TypeVariable(tvref)), Alist.extend evidacc evid) ) (tyenv, Alist.empty, Alist.empty) in (Alist.to_list tyacc, Alist.to_list evidacc, tyenvnew) @@ -81,14 +82,14 @@ let unite_pattern_var_map (patvarmap1 : pattern_var_map) (patvarmap2 : pattern_v let add_pattern_var_mono (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typeenv.t = PatternVarMap.fold (fun varnm (_, evid, ty) tyenvacc -> - let pty = poly_extend erase_range_of_type (Poly(ty)) in + let pty = lift_poly (erase_range_of_type ty) in Typeenv.add tyenvacc varnm (pty, evid) ) patvarmap tyenv let add_pattern_var_poly lev (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typeenv.t = PatternVarMap.fold (fun varnm (_, evid, ty) tyenvacc -> - let pty = poly_extend erase_range_of_type (generalize lev ty) in + let pty = (generalize lev (erase_range_of_type ty)) in Typeenv.add tyenvacc varnm (pty, evid) ) patvarmap tyenv @@ -111,7 +112,7 @@ let apply_tree_of_list astfunc astlst = (* -- 'flatten_type': converts type (t1 -> ... -> tN -> t) into ([t1; ...; tN], t) -- *) -let flatten_type (ty : mono_type) : command_argument_type list * mono_type = +let flatten_type (ty : mono_type) : ((mono_type_variable_info ref) command_argument_type) list * mono_type = let rec aux acc ty = let (rng, tymain) = normalize_mono_type ty in match tymain with @@ -152,16 +153,18 @@ let rec occurs (tvid : FreeID.t) ((_, tymain) : mono_type) = | TypeVariable(tvref) -> begin match !tvref with - | Link(tyl) -> iter tyl + | MonoLink(tyl) -> iter tyl +(* | Bound(_) -> false - | Free(tvidx) -> +*) + | MonoFree(tvidx) -> if FreeID.equal tvidx tvid then true else let lev = FreeID.get_level tvid in let levx = FreeID.get_level tvidx in let () = (* -- update level -- *) if FreeID.less_than lev levx then - tvref := Free(FreeID.set_level tvidx lev) + tvref := MonoFree(FreeID.set_level tvidx lev) else () in @@ -245,15 +248,17 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | (RefType(tysub1), RefType(tysub2)) -> unify_sub tysub1 tysub2 - | (TypeVariable({contents= Link(tyl1)}), _) -> unify_sub tyl1 (rng2, tymain2) + | (TypeVariable({contents= MonoLink(tyl1)}), _) -> unify_sub tyl1 (rng2, tymain2) - | (_, TypeVariable({contents= Link(tyl2)})) -> unify_sub (rng1, tymain1) tyl2 + | (_, TypeVariable({contents= MonoLink(tyl2)})) -> unify_sub (rng1, tymain1) tyl2 +(* | ( (TypeVariable({contents= Bound(_)}), _) | (_, TypeVariable({contents= Bound(_)})) ) -> failwith ("unify_sub: bound type variable in " ^ (string_of_mono_type_basic ty1) ^ " (" ^ (Range.to_string rng1) ^ ")" ^ " or " ^ (string_of_mono_type_basic ty2) ^ " (" ^ (Range.to_string rng2) ^ ")") +*) - | (TypeVariable({contents= Free(tvid1)} as tvref1), TypeVariable({contents= Free(tvid2)} as tvref2)) -> + | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), TypeVariable({contents= MonoFree(tvid2)} as tvref2)) -> if FreeID.equal tvid1 tvid2 then () else @@ -275,8 +280,8 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : in let () = begin - tvref1 := Free(tvid1l); - tvref2 := Free(tvid2l); + tvref1 := MonoFree(tvid1l); + tvref2 := MonoFree(tvid2l); end in let (oldtvref, newtvref, newtvid, newty) = @@ -285,7 +290,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : let _ = print_for_debug_typecheck (* for debug *) (" substituteVV " ^ (string_of_mono_type_basic (Range.dummy "", TypeVariable(oldtvref))) (* for debug *) ^ " with " ^ (string_of_mono_type_basic newty)) in (* for debug *) - let () = ( oldtvref := Link(newty) ) in + let () = ( oldtvref := MonoLink(newty) ) in let kd1 = FreeID.get_kind tvid1l in let kd2 = FreeID.get_kind tvid2l in let (eqnlst, kdunion) = @@ -299,10 +304,10 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : in begin unify_list eqnlst; - newtvref := Free(FreeID.set_kind newtvid kdunion); + newtvref := MonoFree(FreeID.set_kind newtvid kdunion); end - | (TypeVariable({contents= Free(tvid1)} as tvref1), RecordType(tyasc2)) -> + | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), RecordType(tyasc2)) -> let kd1 = FreeID.get_kind tvid1 in let binc = match kd1 with @@ -326,10 +331,10 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : in begin unify_list eqnlst; - tvref1 := Link(newty2); + tvref1 := MonoLink(newty2); end - | (TypeVariable({contents= Free(tvid1)} as tvref1), _) -> + | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), _) -> let chk = occurs tvid1 ty2 in if chk then raise InternalInclusionError @@ -338,7 +343,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : let _ = print_for_debug_typecheck (* for debug *) (" substituteVX " ^ (string_of_mono_type_basic ty1) (* for debug *) ^ " with " ^ (string_of_mono_type_basic newty2)) in (* for debug *) - tvref1 := Link(newty2) + tvref1 := MonoLink(newty2) | (_, TypeVariable(_)) -> unify_sub ty2 ty1 @@ -475,7 +480,7 @@ let rec typecheck | UTLambdaHorz(varrng, varnmctx, utast1) -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(ref (Free(tvid)))) in + let beta = (varrng, TypeVariable(PolyFree(ref (MonoFree(tvid))))) in let evid = EvalVarID.fresh varnmctx in let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(beta), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in @@ -484,7 +489,7 @@ let rec typecheck | UTLambdaVert(varrng, varnmctx, utast1) -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(ref (Free(tvid)))) in + let beta = (varrng, TypeVariable(PolyFree(ref (MonoFree(tvid))))) in let evid = EvalVarID.fresh varnmctx in let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(beta), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in @@ -526,7 +531,7 @@ let rec typecheck | _ -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let () = unify ty1sub (get_range utast1, FuncType(ref [], ty2, beta)) in (* let _ = print_for_debug_typecheck ("2 " ^ (string_of_ast (Apply(e1, e2))) ^ " : " ^ (string_of_mono_type_basic beta) ^ " = " ^ (string_of_mono_type_basic beta)) in (* for debug *) @@ -546,9 +551,9 @@ let rec typecheck | _ -> let tvid1 = FreeID.fresh UniversalKind qtfbl lev () in - let beta1 = (rng, TypeVariable(ref (Free(tvid1)))) in + let beta1 = (rng, TypeVariable(ref (MonoFree(tvid1)))) in let tvid2 = FreeID.fresh UniversalKind qtfbl lev () in - let beta2 = (rng, TypeVariable(ref (Free(tvid2)))) in + let beta2 = (rng, TypeVariable(ref (MonoFree(tvid2)))) in let () = unify ty1 (get_range utast1, FuncType(ref [ty2], beta1, beta2)) in (Apply(e1, NonValueConstructor("Some", e2)), (rng, FuncType(ref [], beta1, beta2))) (* doubtful *) @@ -564,11 +569,11 @@ let rec typecheck | _ -> let tvid0 = FreeID.fresh UniversalKind qtfbl lev () in - let beta0 = (rng, TypeVariable(ref (Free(tvid0)))) in + let beta0 = (rng, TypeVariable(ref (MonoFree(tvid0)))) in let tvid1 = FreeID.fresh UniversalKind qtfbl lev () in - let beta1 = (rng, TypeVariable(ref (Free(tvid1)))) in + let beta1 = (rng, TypeVariable(ref (MonoFree(tvid1)))) in let tvid2 = FreeID.fresh UniversalKind qtfbl lev () in - let beta2 = (rng, TypeVariable(ref (Free(tvid2)))) in + let beta2 = (rng, TypeVariable(ref (MonoFree(tvid2)))) in let () = unify ty1 (get_range utast1, FuncType(ref [beta0], beta1, beta2)) in (eret, (rng, FuncType(ref [], beta1, beta2))) end @@ -576,9 +581,9 @@ let rec typecheck | UTFunction(optargs, utpatbrs) -> let (tyopts, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in let tvidO = FreeID.fresh UniversalKind qtfbl lev () in - let betaO = (Range.dummy "UTFunction:dom", TypeVariable(ref (Free(tvidO)))) in + let betaO = (Range.dummy "UTFunction:dom", TypeVariable(ref (MonoFree(tvidO)))) in let tvidR = FreeID.fresh UniversalKind qtfbl lev () in - let betaR = (Range.dummy "UTFunction:cod", TypeVariable(ref (Free(tvidR)))) in + let betaR = (Range.dummy "UTFunction:cod", TypeVariable(ref (MonoFree(tvidR)))) in let (patbrs, _) = typecheck_pattern_branch_list qtfbl lev tyenvnew utpatbrs betaO betaR in let e = append_optional_ids evids (Function(patbrs)) in (e, (rng, FuncType(ref tyopts, betaO, betaR))) @@ -595,7 +600,7 @@ let rec typecheck | UTPatternMatch(utastO, utpatbrs) -> let (eO, tyO) = typecheck_iter tyenv utastO in let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (Range.dummy "ut-pattern-match", TypeVariable(ref (Free(tvid)))) in + let beta = (Range.dummy "ut-pattern-match", TypeVariable(ref (MonoFree(tvid)))) in let (patbrs, tyP) = typecheck_pattern_branch_list qtfbl lev tyenv utpatbrs tyO beta in let () = Exhchecker.main rng patbrs tyO qtfbl lev tyenv in (PatternMatch(rng, eO, patbrs), tyP) @@ -715,7 +720,7 @@ let rec typecheck | UTItemize(utitmz) -> let eitmz = typecheck_itemize qtfbl lev tyenv utitmz in - let ty = overwrite_range_of_type Primitives.itemize_type rng in + let ty = overwrite_range_of_type (Primitives.itemize_type ()) rng in (eitmz, ty) (* ---- list ---- *) @@ -729,7 +734,7 @@ let rec typecheck | UTEndOfList -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in (Value(EndOfList), (rng, ListType(beta))) (* ---- tuple ---- *) @@ -754,9 +759,9 @@ let rec typecheck | UTAccessField(utast1, fldnm) -> let (e1, ty1) = typecheck_iter tyenv utast1 in let tvidF = FreeID.fresh UniversalKind qtfbl lev () in - let betaF = (rng, TypeVariable(ref (Free(tvidF)))) in + let betaF = (rng, TypeVariable(ref (MonoFree(tvidF)))) in let tvid1 = FreeID.fresh (normalize_kind (RecordKind(Assoc.of_list [(fldnm, betaF)]))) qtfbl lev () in - let beta1 = (get_range utast1, TypeVariable(ref (Free(tvid1)))) in + let beta1 = (get_range utast1, TypeVariable(ref (MonoFree(tvid1)))) in let () = unify beta1 ty1 in (AccessField(e1, fldnm), betaF) @@ -797,7 +802,7 @@ let rec typecheck (HorzLex(ectx, ev), (rng, BaseType(BoxColType))) -and typecheck_command_arguments (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : command_argument_type list) : abstract_tree list = +and typecheck_command_arguments (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : ((mono_type_variable_info ref) command_argument_type) list) : abstract_tree list = let rec aux eacc utcmdarglst cmdargtylst = match (utcmdarglst, cmdargtylst) with | ([], _) -> @@ -1169,7 +1174,7 @@ and typecheck_pattern | UTPEndOfList -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in (PEndOfList, (rng, ListType(beta)), PatternVarMap.empty) | UTPTupleCons(utpat1, utpat2) -> @@ -1187,19 +1192,19 @@ and typecheck_pattern | UTPWildCard -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in (PWildCard, beta, PatternVarMap.empty) | UTPVariable(varnm) -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let evid = EvalVarID.fresh varnm in let () = print_for_debug_typecheck ("\n#PAdd " ^ varnm ^ " : " ^ (string_of_mono_type_basic beta)) in (* for debug *) (PVariable(evid), beta, PatternVarMap.empty |> PatternVarMap.add varnm (rng, evid, beta)) | UTPAsVariable(varnm, utpat1) -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rng, TypeVariable(ref (Free(tvid)))) in + let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let (epat1, typat1, patvarmap1) = iter utpat1 in begin match PatternVarMap.find_opt varnm patvarmap1 with @@ -1236,10 +1241,13 @@ and make_type_environment_by_letrec | UTLetRecBinding(_, varnm, astdef) :: tailcons -> let tvid = FreeID.fresh UniversalKind qtfbl (FreeID.succ_level lev) () in - let beta = (get_range astdef, TypeVariable(ref (Free(tvid)))) in + let tvref = ref (MonoFree(tvid)) in + let rng = get_range astdef in + let beta = (rng, TypeVariable(tvref)) in + let pbeta = (rng, TypeVariable(PolyFree(tvref))) in let _ = print_for_debug_typecheck ("#AddMutualVar " ^ varnm ^ " : '" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ " :: U") in (* for debug *) let evid = EvalVarID.fresh varnm in - let (tyenvfinal, tvtylst) = iter (Typeenv.add acctyenv varnm (Poly(beta), evid)) tailcons in + let (tyenvfinal, tvtylst) = iter (Typeenv.add acctyenv varnm (Poly(pbeta), evid)) tailcons in (tyenvfinal, ((varnm, beta, evid) :: tvtylst)) in @@ -1291,7 +1299,7 @@ and make_type_environment_by_letrec | (varnm, tvty, evid) :: tvtytail -> let prety = tvty in let () = print_for_debug_typecheck ("#Generalize1 " ^ varnm ^ " : " ^ (string_of_mono_type_basic prety)) in (* for debug *) - let pty = poly_extend erase_range_of_type (generalize lev prety) in + let pty = (generalize lev (erase_range_of_type prety)) in let () = print_for_debug_typecheck ("#Generalize2 " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty)) in (* for debug *) let tvtylst_forall_new = (varnm, pty, evid) :: tvtylst_forall in make_forall_type_mutual (Typeenv.add tyenv varnm (pty, evid)) tyenv_before_let tvtytail tvtylst_forall_new @@ -1308,7 +1316,7 @@ and make_type_environment_by_let_mutable (lev : FreeID.level) (tyenv : Typeenv.t let (eI, tyI) = typecheck Unquantifiable lev tyenv utastI in let () = print_for_debug_typecheck ("#AddMutable " ^ varnm ^ " : " ^ (string_of_mono_type_basic (varrng, RefType(tyI)))) in (* for debug *) let evid = EvalVarID.fresh varnm in - let tyenvI = Typeenv.add tyenv varnm (Poly((varrng, RefType(tyI))), evid) in + let tyenvI = Typeenv.add tyenv varnm (lift_poly (varrng, RefType(tyI)), evid) in (tyenvI, evid, eI, tyI) diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index c60e3eb51..37abe970b 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -363,29 +363,12 @@ let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } -let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info ref -> a typ) (tyarglist : (a typ) list) (bidlist : BoundID.t list) (Poly(pty) : poly_type) : a typ = +let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info ref -> a typ) (pairlst : (a typ * BoundID.t) list) (Poly(pty) : poly_type) : a typ = (* let () = print_for_debug_variantenv ("I-input [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_mono_type_basic ty)) in (* for debug *) *) let bid_to_type_ht : (a typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in - let rec pre (tyargs : (a typ) list) (bids : BoundID.t list) = - match (tyargs, bids) with - | ([], []) -> - () - - | (tyarg :: tyargtail, bid :: bidtail) -> - begin -(* - print_for_debug_variantenv ("I-add '#" ^ (BoundID.show_direct string_of_poly_kind bid) ^ " -> " ^ (string_of_mono_type_basic tyarg)); (* for debug *) -*) - BoundIDHashTable.add bid_to_type_ht bid tyarg; - pre tyargtail bidtail; - end - - | (_, _) -> assert false - in - let rec aux ((rng, ptymain) : poly_type_variable_info typ) : a typ = (* let () = print_for_debug_variantenv ("aux " ^ (string_of_mono_type_basic (rng, tymain))) in (* for debug *) @@ -418,7 +401,7 @@ let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) in begin - pre tyarglist bidlist; + pairlst |> List.iter (fun (tyarg, bid) -> BoundIDHashTable.add bid_to_type_ht bid tyarg); aux pty end @@ -468,11 +451,18 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) VariantType(List.map aux mntyarglist, tyid) | Some((tyid, Alias(bidlist, ptyscheme))) -> - let lenexp = List.length bidlist in - if lenexp <> len then error tynm lenexp len else - let tyreal = instantiate_type_scheme freef tyarglist bidlist ptyscheme in + begin + try + let pairlst = List.combine tyarglist bidlist in + let tyreal = instantiate_type_scheme freef pairlst ptyscheme in let () = print_for_debug_variantenv ("FS " ^ tynm ^ " -> " ^ TypeID.show_direct tyid) in (* for debug *) SynonymType(tyarglist, tyid, tyreal) + with + | Invalid_argument(_) -> + let lenexp = List.length bidlist in + error tynm lenexp len + end + in begin match dpmode with @@ -488,27 +478,27 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) VariantType(tyarglist, tyid) | SynonymVertex(_, tyid, tyargcons, mnty, {contents= Some(bidlist, ptyscheme)}) -> - let lenexp = type_argument_length tyargcons in - if len <> lenexp then error tynm lenexp len else - let tyreal = instantiate_type_scheme freef tyarglist bidlist ptyscheme in - SynonymType(tyarglist, tyid, tyreal) - - | SynonymVertex(_, _, _, _, {contents= None}) -> assert false + begin + try + let pairlst = List.combine tyarglist bidlist in + let tyreal = instantiate_type_scheme freef pairlst ptyscheme in + SynonymType(tyarglist, tyid, tyreal) + with + | Invalid_argument(_) -> + let lenexp = type_argument_length tyargcons in + error tynm lenexp len + end + + | SynonymVertex(_, _, _, _, {contents= None}) -> + assert false with | DependencyGraph.UndefinedSourceVertex -> find_in_variant_environment () end end - | MTypeParam(tyargnm) -> typaramf rng tyargnm -(* - begin - match tyargmode with - | StrictMode(bidmaplist) -> - - | FreeMode(tyargmaplist) -> - end -*) + | MTypeParam(tyargnm) -> + typaramf rng tyargnm in (rng, ptymainnew) @@ -667,15 +657,17 @@ let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev let open OptionMonad in ModuleTree.search_backward mtr addrlst [] (fun (_, _, cdmap, _) -> ConstrMap.find_opt constrnm cdmap) >>= fun dfn -> let (tyid, (bidlist, pty)) = dfn in - let tyarglist : mono_type list = + let pairlst = bidlist |> List.map (fun bid -> let kd = BoundID.get_kind bid in let tvid = FreeID.fresh (instantiate_kind lev qtfbl kd) qtfbl lev () in - (Range.dummy "tc-constructor", TypeVariable(ref (MonoFree(tvid)))) + let ty = (Range.dummy "tc-constructor", TypeVariable(ref (MonoFree(tvid)))) in + (ty, bid) ) in - let ty = instantiate_type_scheme freef tyarglist bidlist pty in - return (tyarglist, tyid, ty) + let ty = instantiate_type_scheme freef pairlst pty in + let tyarglst = pairlst |> List.map (fun (ty, _) -> ty) in + return (tyarglst, tyid, ty) let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (typeid : TypeID.t) @@ -691,14 +683,14 @@ let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : Free let constrs = ConstrMap.fold (fun constrnm dfn acc -> let (tyid, (bidlist, pty)) = dfn in if TypeID.equal typeid tyid then - (constrnm, (fun tyarglist -> instantiate_type_scheme freef tyarglist bidlist pty))::acc + (constrnm, (fun tyarglist -> instantiate_type_scheme freef (List.combine tyarglist bidlist) pty)) :: acc else acc ) cdmap [] in match constrs with | [] -> None - | _ -> Some(constrs)) + | _ -> Some(constrs)) in match constrs with | Some(lst) -> lst @@ -856,18 +848,73 @@ let add_val_to_signature (sigopt : signature option) (varnm : var_name) (pty : p | Some(tdmap, vtmap) -> Some(tdmap, VarMap.add varnm pty vtmap) +let rec poly_type_equal ((_, ptymain1) : poly_type_variable_info typ) ((_, ptymain2) : poly_type_variable_info typ) = + let iter = poly_type_equal in + let combine p lst1 lst2 = + try let lst = List.combine lst1 lst2 in p lst with Invalid_argument(_) -> false + in + let iter_list lst = + lst |> List.fold_left (fun b (pty1, pty2) -> b && iter pty1 pty2) true + in + match (ptymain1, ptymain2) with + | (BaseType(bt1), BaseType(bt2)) -> + bt1 = bt2 + + | (TypeVariable(PolyBound(bid1)), TypeVariable(PolyBound(bid2))) -> + BoundID.eq bid1 bid2 + + | (TypeVariable(PolyFree(_)), TypeVariable(PolyFree(_))) -> + false (* -- does not handle free variables -- *) + + | (FuncType(tyoptsr1, ty1d, ty1c), FuncType(tyoptsr2, ty2d, ty2c)) -> + (combine iter_list !tyoptsr1 !tyoptsr2) && iter ty1d ty2d && iter ty1c ty2c + + | (ProductType(tylst1), ProductType(tylst2)) -> + combine iter_list tylst1 tylst2 + + | (RecordType(tyasc1), RecordType(tyasc2)) -> + (Assoc.domain_same tyasc1 tyasc2) && iter_list (Assoc.combine_value tyasc1 tyasc2) + + | (ListType(ty1sub), ListType(ty2sub)) + | (RefType(ty1sub), RefType(ty2sub)) -> + iter ty1sub ty2sub + + | (VariantType(tylst1, tyid1), VariantType(tylst2, tyid2)) -> + TypeID.equal tyid1 tyid2 && (combine iter_list tylst1 tylst2) + + | (HorzCommandType(catyl1), HorzCommandType(catyl2)) + | (VertCommandType(catyl1), VertCommandType(catyl2)) + | (MathCommandType(catyl1), MathCommandType(catyl2)) + -> + begin + try + List.fold_left2 (fun b caty1 caty2 -> + match (caty1, caty2) with + | (MandatoryArgumentType(ty1), MandatoryArgumentType(ty2)) + | (OptionalArgumentType(ty1) , OptionalArgumentType(ty2) ) + -> b && iter ty1 ty2 + | _ -> false + ) true catyl1 catyl2 + with + | Invalid_argument(_) -> false + end + + | _ -> false + + (* -- 'reflects pty1 pty2' returns whether 'pty2' is more general than 'pty1' -- *) -let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = +let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = (* let current_ht : BoundID.t BoundIDHashtbl.t = BoundIDHashtbl.create 32 in (* -- hash table mapping bound IDs in 'pty2' to bound IDs in 'pty1' -- *) *) - let current_bid_to_ty : ('a * poly_type_variable_info) BoundIDHashTable.t = BoundIDHashTable.create 32 in + let current_bid_to_ty : (poly_type_variable_info typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in (* -- hash table mapping bound IDs in 'pty2' to types -- *) - let rec aux ((_, tymain1) as ty1) ((_, tymain2) as ty2) = + let rec aux ((_, tymain1) as ty1 : poly_type_variable_info typ) ((_, tymain2) as ty2 : poly_type_variable_info typ) = +(* let () = print_for_debug_variantenv ("reflects " ^ (string_of_mono_type_basic ty1) ^ " << " ^ (string_of_mono_type_basic ty2)) in (* for debug *) - +*) let aux_list tylistcomb = tylistcomb |> List.fold_left (fun b (ty1, ty2) -> b && aux ty1 ty2) true in @@ -882,58 +929,64 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = match (tymain1, tymain2) with | (SynonymType(tyl1, tyid1, tyreal1), _) -> aux tyreal1 ty2 | (_, SynonymType(tyl2, tyid2, tyreal2)) -> aux ty1 tyreal2 -(* - | (TypeVariable({contents= Link(tysub1)}), _) -> aux tysub1 ty2 - | (_, TypeVariable({contents= Link(tysub2)})) -> aux ty1 tysub2 -*) + | (TypeVariable(PolyBound(bid1)), TypeVariable(PolyBound(bid2))) -> begin match BoundIDHashTable.find_opt current_bid_to_ty bid2 with - | Some(((_, TypeVariable({contents= Bound(bid1old)})), _)) -> - BoundID.eq bid1 bid1old - - | Some(_) -> - false + | Some(tyold) -> + poly_type_equal ty1 tyold | None -> if is_stronger_kind (BoundID.get_kind bid1) (BoundID.get_kind bid2) then - begin BoundIDHashtbl.add current_bid_to_ty bid2 (ty1, tyref2); true end + begin BoundIDHashTable.add current_bid_to_ty bid2 ty1; true end else false end - | (RecordType(tyasc1), TypeVariable({contents= Bound(bid2)} as tvref2)) -> - let kd2 = BoundID.get_kind bid2 in - let binc = - match kd2 with - | UniversalKind -> true - | RecordKind(tyasc2) -> Assoc.domain_included tyasc2 tyasc1 - in - if not binc then false else - begin - match BoundIDHashtbl.find_opt current_bid_to_ty bid2 with - | None -> begin BoundIDHashtbl.add current_bid_to_ty bid2 (ty1, tvref2); true end - | Some((ty1old, _)) -> aux ty1 ty1old - end - (* -- valid substitution of bound type variables -- *) - - | (_, TypeVariable({contents= Bound(bid2)} as tvref2)) -> - let kd2 = BoundID.get_kind bid2 in + | (RecordType(tyasc1), TypeVariable(PolyBound(bid2))) -> begin - match kd2 with - | UniversalKind -> begin BoundIDHashtbl.add current_bid_to_ty bid2 (ty1, tvref2); true end - | RecordKind(_) -> false + match BoundIDHashTable.find_opt current_bid_to_ty bid2 with + | Some(tyold) -> + poly_type_equal ty1 tyold + + | None -> + let kd2 = BoundID.get_kind bid2 in + let binc = + match kd2 with + | UniversalKind -> true + | RecordKind(tyasc2) -> Assoc.domain_included tyasc2 tyasc1 + in + if not binc then false else + begin + BoundIDHashTable.add current_bid_to_ty bid2 ty1; + true + end + end + + | (_, TypeVariable(PolyBound(bid2))) -> + begin + match BoundIDHashTable.find_opt current_bid_to_ty bid2 with + | Some(tyold) -> + poly_type_equal ty1 tyold + + | None -> + let kd2 = BoundID.get_kind bid2 in + begin + match kd2 with + | UniversalKind -> begin BoundIDHashTable.add current_bid_to_ty bid2 ty1; true end + | RecordKind(_) -> false + end end - (* -- valid substitution of bound type variables -- *) - | (RecordType(tyasc1), TypeVariable({contents= Free(tvid2)} as tvref)) -> +(* + | (RecordType(tyasc1), TypeVariable(PolyFree({contents= MonoFree(tvid2)} as tvref))) -> let kd2 = FreeID.get_kind tvid2 in let binc = match kd2 with | UniversalKind -> true | RecordKind(tyasc2) -> Assoc.domain_included tyasc1 tyasc2 in - if binc then tvref := Link(ty1) else (); + if binc then tvref := MonoLink(ty1) else (); binc | (_, TypeVariable({contents= Free(tvid2)} as tvref)) -> @@ -945,7 +998,7 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = in if binc then tvref := Link(ty1) else (); binc - +*) | (FuncType(tyopts1r, tyd1, tyc1), FuncType(tyopts2r, tyd2, tyc2)) -> (aux_opt_list (!tyopts1r) (!tyopts2r)) && (aux tyd1 tyd2) && (aux tyc1 tyc2) (* -- both domain and codomain are covariant -- *) @@ -989,7 +1042,7 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = | _ -> false - and is_stronger_kind (kd1 : kind) (kd2 : kind) = + and is_stronger_kind (kd1 : poly_kind) (kd2 : poly_kind) = match (kd1, kd2) with | (_, UniversalKind) -> true | (UniversalKind, _) -> false @@ -997,19 +1050,24 @@ let reflects (Poly(ty1) : poly_type) (Poly(ty2) : poly_type) : bool = begin tyasc2 |> Assoc.fold (fun b k ty2 -> match Assoc.find_opt tyasc1 k with - | Some(ty1) -> b && (aux ty1 ty2) - | None -> false + | Some(pty1) -> b && (aux pty1 pty2) + | None -> false ) true end in - let b = aux ty1 ty2 in + let b = aux pty1 pty2 in +(* begin if b then - current_bid_to_ty |> BoundIDHashtbl.iter (fun bid (ty, tyref) -> - tyref := Link(ty) - ) + let pairlst = + BoundIDHashTable.fold (fun bid ty acc -> + Alist.extend acc (ty, bid) + ) current_bid_to_ty Alist.empty |> Alist.to_list + in + instantiate else () end; +*) b diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 89617ac04..14a696cbf 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -897,7 +897,8 @@ let instantiate_kind (lev : FreeID.level) (qtfbl : quantifiability) (pkd : poly_ instantiate_kind_aux bid_ht lev qtfbl pkd -let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = +let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = + let tvidht = FreeIDHashTable.create 32 in let rec iter (rng, tymain) = match tymain with | TypeVariable(tvref) -> @@ -908,15 +909,21 @@ let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = | MonoFree(tvid) -> let ptvi = - if not (FreeID.is_quantifiable tvid) then - PolyFree(tvref) - else if not (FreeID.less_than lev (FreeID.get_level tvid)) then + if p tvid then PolyFree(tvref) else - let kd = FreeID.get_kind tvid in - let kdgen = generalize_kind kd in - let bid = BoundID.fresh kdgen () in - PolyBound(bid) + begin + match FreeIDHashTable.find_opt tvidht tvid with + | Some(bid) -> + PolyBound(bid) + + | None -> + let kd = FreeID.get_kind tvid in + let kdgen = generalize_kind kd in + let bid = BoundID.fresh kdgen () in + FreeIDHashTable.add tvidht tvid bid; + PolyBound(bid) + end in (rng, TypeVariable(ptvi)) end @@ -940,6 +947,14 @@ let generalize (lev : FreeID.level) (ty : mono_type) : poly_type = in Poly(iter ty) + +let generalize (lev : FreeID.level) = + lift_poly_general (fun tvid -> not (FreeID.is_quantifiable tvid) || not (FreeID.less_than lev (FreeID.get_level tvid))) + + +let lift_poly = + lift_poly_general (fun _ -> true) + (* let copy_environment (env : environment) : environment = let (valenv, stenv) = env in From 21be79138afe344fc7fbb539960cb9e5ab784d12 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 15 Jul 2018 01:27:45 +0900 Subject: [PATCH 04/42] fix 'reflects' in 'typeenv.ml' etc. --- src/frontend/display.ml | 38 +++++++++++++++---------- src/frontend/exhchecker.ml | 51 ++++++++++++++++----------------- src/frontend/main.ml | 2 ++ src/frontend/typechecker.ml | 11 +++++-- src/frontend/typeenv.ml | 8 ++++-- src/frontend/types_.cppo.ml | 57 +++++++++++++++++++++++-------------- 6 files changed, 100 insertions(+), 67 deletions(-) diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 01b92eb78..581e021d6 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -38,7 +38,9 @@ let show_type_variable (type a) (f : a typ -> string) (name : string) (kd : a ki | RecordKind(asc) -> "(" ^ name ^ " <: " ^ (string_of_kind f kd) ^ ")" -type general_id = FreeID of FreeID.t | BoundID of BoundID.t +type general_id = + | NomID of nom_kind FreeID_.t_ + | BoundID of BoundID.t module GeneralIDHashTable_ = Hashtbl.Make( @@ -47,7 +49,7 @@ module GeneralIDHashTable_ = Hashtbl.Make( let equal gid1 gid2 = match (gid1, gid2) with - | (FreeID(tvid1), FreeID(tvid2)) -> FreeID.equal tvid1 tvid2 + | (NomID(tvid1), NomID(tvid2)) -> FreeID.equal tvid1 tvid2 | (BoundID(bid1), BoundID(bid2)) -> BoundID.eq bid1 bid2 | (_, _) -> false @@ -260,23 +262,29 @@ and string_of_mono_type_list tvf tyenv current_ht tylist = end -let rec tvf_mono current_ht tyenv tvref = - match !tvref with - | MonoFree(tvid) -> - let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in +let rec tvf_nom current_ht tyenv tvi = + match tvi with + | NomFree(tvid) -> + let num = GeneralIDHashTable.intern_number current_ht (NomID(tvid)) in let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) - - | MonoLink(ty) -> - assert false - (* -- links should be omitted by 'normalize_mono_type' -- *) + show_type_variable (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) let rec tvf_poly current_ht tyenv ptvi = match ptvi with | PolyFree(tvref) -> - tvf_mono current_ht tyenv tvref - (* doubtful *) + begin + match !tvref with + | MonoFree(tvid) -> + let tvid = FreeID.map_kind normalize_kind tvid in + let num = GeneralIDHashTable.intern_number current_ht (NomID(tvid)) in + let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in + show_type_variable (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + + | MonoLink(ty) -> + let tyn = normalize_mono_type ty in + "(" ^ (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht tyn) ^ ")" + end | PolyBound(bid) -> let num = GeneralIDHashTable.intern_number current_ht (BoundID(bid)) in @@ -289,7 +297,7 @@ let string_of_mono_type (tyenv : Typeenv.t) (ty : mono_type) = GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in let tyn = normalize_mono_type ty in - string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht tyn + string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht tyn end @@ -299,7 +307,7 @@ let string_of_mono_type_double (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono let current_ht = GeneralIDHashTable.create 32 in let tyn1 = normalize_mono_type ty1 in let tyn2 = normalize_mono_type ty2 in - let strf = string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht in + let strf = string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht in let strty1 = strf tyn1 in let strty2 = strf tyn2 in (strty1, strty2) diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index 0dbe19467..34cab49ae 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -13,7 +13,7 @@ type type_element = | ETuple | EWildCard -and pattern_instance = +and pattern_instance = | IUnitConstant | IIntegerConstant of int | IBooleanConstant of bool @@ -23,7 +23,7 @@ and pattern_instance = | IConstructor of string * pattern_instance * mono_type | ITupleCons of pattern_instance list | IWildCard - + and expand_type = | ExpandListCons | ExpandConstructor of string * mono_type @@ -86,7 +86,7 @@ let is_all_wildcard mat = ) (List.hd mat) let flatten_tuple tup = - let rec iter ast acc = + let rec iter ast acc = match ast with | PTupleCons(hd, PEndOfTuple) -> List.rev (hd::acc) | PTupleCons(hd, tl) -> iter tl (hd::acc) @@ -94,7 +94,7 @@ let flatten_tuple tup = in iter tup [] -let instance_of_element ele = +let instance_of_element ele = match ele with | EUnitConstant -> IUnitConstant | EBooleanConstant(b) -> IBooleanConstant(b) @@ -159,19 +159,19 @@ let expand_mat mat i epat ty = in let rec sub epat pat = match (epat, pat) with - | (ExpandListCons, PListCons(h, t))-> + | (ExpandListCons, PListCons(h, t))-> [[h]; [t]] | (ExpandListCons, PWildCard) -> [[PWildCard]; [PWildCard]] - | (ExpandConstructor(_, _), PConstructor(_, innerpat)) -> + | (ExpandConstructor(_, _), PConstructor(_, innerpat)) -> [[innerpat]] | (ExpandConstructor(_, _), PWildCard) -> [[PWildCard]] - | (ExpandTuple(_), PTupleCons(h, t)) -> + | (ExpandTuple(_), PTupleCons(h, t)) -> let ftup = flatten_tuple (PTupleCons(h, t)) in List.map (fun pat -> [pat]) ftup @@ -195,7 +195,7 @@ let rec get_specialized_mat mat patinfo ele tylst = let (nmat, ninfo, nomatch) = List.fold_left (fun (cols, info, no_match) col -> let (newcol, newinfo, no_m) = (fold_left3 (fun (col, info, no_m) p q i -> - let needs_append = + let needs_append = match ele, p with | EListCons, PListCons(_, _) | EEndOfList, PEndOfList @@ -217,11 +217,11 @@ let rec get_specialized_mat mat patinfo ele tylst = -> false in match needs_append, i with - | true, (n, PatternBranch(_, _)) -> + | true, (n, PatternBranch(_, _)) -> (q::col, i::info, false) - | true, (n, PatternBranchWhen(_, _, _)) -> + | true, (n, PatternBranchWhen(_, _, _)) -> (q::col, i::info, no_m) - | false, _ -> + | false, _ -> (col, info, no_m) ) ([], [], true) fst col patinfo @@ -232,12 +232,12 @@ let rec get_specialized_mat mat patinfo ele tylst = | EListCons, (_, ListType(lty))::_ -> let expnd = ExpandListCons in let (nmat, ninfo, nomatch) = iter (List.hd mat) mat in - (expand_mat nmat 0 expnd tylst, ninfo, lty::tylst, expnd, nomatch) + (expand_mat nmat 0 expnd tylst, ninfo, lty::tylst, expnd, nomatch) | EConstructor(nm, ity), (_, VariantType(_, _))::rest -> let expnd = ExpandConstructor(nm, ity) in let (nmat, ninfo, nomatch) = iter (List.hd mat) mat in - (expand_mat nmat 0 expnd tylst, ninfo, ity::rest, expnd, nomatch) + (expand_mat nmat 0 expnd tylst, ninfo, ity::rest, expnd, nomatch) | ETuple, (_, ProductType(ptylst))::rest -> let expnd = ExpandTuple(List.length ptylst) in @@ -250,7 +250,7 @@ let rec get_specialized_mat mat patinfo ele tylst = (List.tl nmat, ninfo, List.tl tylst, NoExpand, nomatch) | [] -> ([], [], [], NoExpand, true) end - + let unit_sig = ElementSet.of_list [EUnitConstant] let bool_sig = ElementSet.of_list [EBooleanConstant(true); EBooleanConstant(false)] @@ -276,10 +276,11 @@ let make_string_sig col = let make_variant_sig qtfbl lev tyenv tyarglst tyid = let constrs = Typeenv.enumerate_constructors qtfbl tyenv lev tyid in - ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> EConstructor(nm, normalize_mono_type (tyf tyarglst)))) + ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> EConstructor(nm, (tyf tyarglst)))) let rec complete_sig col qtfbl lev tyenv ty = match snd ty with + | TypeVariable({contents= MonoLink(tylink)}) -> complete_sig col qtfbl lev tyenv tylink | BaseType(UnitType) -> unit_sig | BaseType(BoolType) -> bool_sig | BaseType(IntType) -> make_int_sig col @@ -320,7 +321,7 @@ let rec exhcheck_mat tylst mat patinfo qtfbl lev tyenv = let patinfo_extract patinfo = patinfo |> List.map (fun (n, _) -> n) in let patinfo_until_match patinfo = - fst @@ List.fold_left (fun (acc, fin) (n, patbr) -> + fst @@ List.fold_left (fun (acc, fin) (n, patbr) -> match fin, patbr with | false, PatternBranch(_, _) -> (n::acc, true) | false, PatternBranchWhen(_, _, _) -> (n::acc, false) @@ -343,7 +344,7 @@ let rec exhcheck_mat tylst mat patinfo qtfbl lev tyenv = | false, _ -> let (nonexh, nonexh_guard, used) = exhcheck_mat stylst smat spatinfo qtfbl lev tyenv in ((List.map (fold_instance expnd ele) nonexh) @ a_nonexh, - (List.map (fold_instance expnd ele) nonexh_guard) @ a_nonexh_guard, + (List.map (fold_instance expnd ele) nonexh_guard) @ a_nonexh_guard, IntSet.union used a_used) end) set ([], [], IntSet.empty) in (List.rev nonexh, List.rev nonexh_guard, used) @@ -361,8 +362,8 @@ let non_empty lst = | [] -> false | _ -> true -let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) - (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) : unit = +let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) + (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) : unit = let patbrs = patbrs |> List.map (fun patbr -> match patbr with | PatternBranch(p, a) -> PatternBranch(normalize_pat p, a) @@ -375,21 +376,19 @@ let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) )] in let patid = one_to_n (List.length patbrs) in let patinfo = List.combine patid patbrs in - let nom_ty = normalize_mono_type ty in - let (nonexh, nonexh_guard, used) = exhcheck_mat [nom_ty] mat patinfo qtfbl lev tyenv in + let (nonexh, nonexh_guard, used) = exhcheck_mat [ty] mat patinfo qtfbl lev tyenv in let unused = IntSet.diff (IntSet.of_list patid) used in if (non_empty nonexh) || (non_empty nonexh_guard) || not (IntSet.is_empty unused) then begin Format.printf "! [Warning about pattern-matching] at %s\n" (Range.to_string rng); - nonexh |> List.iter (function [ins] -> - Format.printf " non-exhaustive: %s\n" (string_of_instance ins) + nonexh |> List.iter (function [ins] -> + Format.printf " non-exhaustive: %s\n" (string_of_instance ins) | _ -> ()); - nonexh_guard |> List.iter (function [ins] -> - Format.printf " non-exhaustive(guarded clause may match): %s\n" (string_of_instance ins) + nonexh_guard |> List.iter (function [ins] -> + Format.printf " non-exhaustive(guarded clause may match): %s\n" (string_of_instance ins) | _ -> ()); IntSet.iter (fun id -> Format.printf " pattern #%d is unused\n" id) unused; Format.printf "\n"; end else () - diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 1d80c8b41..c13bd8c82 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -592,8 +592,10 @@ let error_log_environment suspended = NormalLine("at " ^ (Range.to_string rng) ^ ":"); NormalLine("The implementation of value '" ^ varnm ^ "' has type"); DisplayLine(Display.string_of_poly_type tyenv1 pty1); + DisplayLine(string_of_poly_type_basic pty1); (* FOR DEBUG *) NormalLine("which is inconsistent with the type required by the signature"); DisplayLine(Display.string_of_poly_type tyenv2 pty2); + DisplayLine(string_of_poly_type_basic pty2); (* FOR DEBUG *) ] | Typechecker.ContradictionError(tyenv, ((rng1, _) as ty1), ((rng2, _) as ty2)) -> diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index e38a6ec18..c900b6c98 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -114,8 +114,11 @@ let apply_tree_of_list astfunc astlst = (* -- 'flatten_type': converts type (t1 -> ... -> tN -> t) into ([t1; ...; tN], t) -- *) let flatten_type (ty : mono_type) : ((mono_type_variable_info ref) command_argument_type) list * mono_type = let rec aux acc ty = - let (rng, tymain) = normalize_mono_type ty in + let (rng, tymain) = ty in match tymain with + | TypeVariable({contents= MonoLink(tylink)}) -> + aux acc tylink + | FuncType(tyoptsr, tydom, tycod) -> let accnew = Alist.append acc (List.append (List.map (fun ty -> OptionalArgumentType(ty)) (!tyoptsr)) [MandatoryArgumentType(tydom)]) @@ -367,7 +370,9 @@ and unify_options tyopts1r tyopts2r = let unify_ (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono_type) = +(* let () = print_endline (" ####UNIFY " ^ (string_of_mono_type_basic ty1) ^ " = " ^ (string_of_mono_type_basic ty2)) in (* for debug *) +*) try unify_sub ty1 ty2 with @@ -441,7 +446,9 @@ let rec typecheck | Some((pty, evid)) -> let tyfree = instantiate lev qtfbl pty in let tyres = overwrite_range_of_type tyfree rng in +(* let () = print_endline ("\n#Content " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty) ^ " = " ^ (string_of_mono_type_basic tyres) ^ "\n (" ^ (Range.to_string rng) ^ ")") in (* for debug *) +*) (ContentOf(rng, evid), tyres) end @@ -760,7 +767,7 @@ let rec typecheck let (e1, ty1) = typecheck_iter tyenv utast1 in let tvidF = FreeID.fresh UniversalKind qtfbl lev () in let betaF = (rng, TypeVariable(ref (MonoFree(tvidF)))) in - let tvid1 = FreeID.fresh (normalize_kind (RecordKind(Assoc.of_list [(fldnm, betaF)]))) qtfbl lev () in + let tvid1 = FreeID.fresh (RecordKind(Assoc.of_list [(fldnm, betaF)])) qtfbl lev () in let beta1 = (get_range utast1, TypeVariable(ref (MonoFree(tvid1)))) in let () = unify beta1 ty1 in (AccessField(e1, fldnm), betaF) diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index 37abe970b..fc044d0a3 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -602,7 +602,7 @@ let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev let () = constrnts |> List.iter (fun (param, mkd) -> let kd = fix_manual_kind_general NoDependency tyenv lev freef typaramf mkd in - let tvid = FreeID.fresh (normalize_kind kd) qtfbl lev () in + let tvid = FreeID.fresh kd qtfbl lev () in let tvref = ref (MonoFree(tvid)) in MapList.add tyargmaplist param tvref ) @@ -930,6 +930,9 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = | (SynonymType(tyl1, tyid1, tyreal1), _) -> aux tyreal1 ty2 | (_, SynonymType(tyl2, tyid2, tyreal2)) -> aux ty1 tyreal2 + | (TypeVariable(PolyFree({contents= MonoLink(tylink1)})), _) -> aux (lift_poly tylink1 |> (function Poly(pty) -> pty)) ty2 + | (_, TypeVariable(PolyFree({contents= MonoLink(tylink2)}))) -> aux ty1 (lift_poly tylink2 |> (function Poly(pty) -> pty)) + | (TypeVariable(PolyBound(bid1)), TypeVariable(PolyBound(bid2))) -> begin match BoundIDHashTable.find_opt current_bid_to_ty bid2 with @@ -1048,7 +1051,7 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = | (UniversalKind, _) -> false | (RecordKind(tyasc1), RecordKind(tyasc2)) -> begin - tyasc2 |> Assoc.fold (fun b k ty2 -> + tyasc2 |> Assoc.fold (fun b k pty2 -> match Assoc.find_opt tyasc1 k with | Some(pty1) -> b && (aux pty1 pty2) | None -> false @@ -1115,7 +1118,6 @@ let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tye | Some((ptyimp, _)) -> let b = reflects ptysigI ptyimp in - (* -- 'reflects pty1 pty2' may change 'pty2' -- *) if b then let sigoptaccnew = add_val_to_signature sigoptacc varnm ptysigO in iter tyenvacc tyenvforsigI tyenvforsigO tail sigoptaccnew diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 14a696cbf..f50a6ccbe 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -64,6 +64,7 @@ module FreeID_ val set_quantifiability : quantifiability -> 'a t_ -> 'a t_ val get_kind : 'a t_ -> 'a val set_kind : 'a t_ -> 'a -> 'a t_ + val map_kind : ('a -> 'b) -> 'a t_ -> 'b t_ val show_direct : ('a -> string) -> 'a t_ -> string val show_direct_level : level -> string end @@ -109,6 +110,8 @@ module FreeID_ let set_kind (idmain, _, qtfbl, lev) kd = (idmain, kd, qtfbl, lev) + let map_kind f (idmain, kd, qtfbl, lev) = (idmain, f kd, qtfbl, lev) + let show_direct f (idmain, kd, qtfbl, lev) = match qtfbl with | Quantifiable -> (string_of_int idmain) ^ "[Q" ^ (string_of_int lev) ^ "::" ^ (f kd) ^ "]" @@ -274,6 +277,14 @@ and poly_kind = poly_type_variable_info kind [@@deriving show] +type nom_type_variable_info = + | NomFree of nom_kind FreeID_.t_ + +and nom_kind = nom_type_variable_info kind + +and nom_type = nom_type_variable_info typ +[@@deriving show] + module FreeID = struct @@ -770,20 +781,20 @@ let lift_manual_common f = function (* -- 'normalize_type': eliminates 'Link(_)' -- *) -let rec normalize_mono_type ty = +let rec normalize_mono_type (ty : mono_type) : nom_type = let iter = normalize_mono_type in let (rng, tymain) = ty in match tymain with | TypeVariable(tvinforef) -> begin match !tvinforef with - | MonoFree(_) -> ty + | MonoFree(tvid) -> (rng, TypeVariable(NomFree(FreeID.map_kind normalize_kind tvid))) | MonoLink(tylink) -> iter tylink end | VariantType(tylist, tyid) -> (rng, VariantType(List.map iter tylist, tyid)) | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map iter tylist, tyid, iter tyreal)) - | BaseType(_) -> ty + | BaseType(bt) -> (rng, BaseType(bt)) | ListType(tycont) -> (rng, ListType(iter tycont)) | RefType(tycont) -> (rng, RefType(iter tycont)) | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) @@ -794,31 +805,35 @@ let rec normalize_mono_type ty = | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) -let normalize_kind kd = +and normalize_kind (kd : mono_kind) : nom_kind = match kd with - | UniversalKind -> kd + | UniversalKind -> UniversalKind | RecordKind(tyasc) -> RecordKind(Assoc.map_value normalize_mono_type tyasc) let rec erase_range_of_type (ty : mono_type) : mono_type = let iter = erase_range_of_type in - let tymainnew = - let (_, tymain) = normalize_mono_type ty in + let rng = Range.dummy "erased" in + let (_, tymain) = ty in match tymain with - | BaseType(_) -> tymain - | TypeVariable(_) -> tymain - | FuncType(tyoptsr, tydom, tycod) -> FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod) - | ProductType(tylist) -> ProductType(List.map iter tylist) - | RecordType(tyasc) -> RecordType(Assoc.map_value iter tyasc) - | SynonymType(tylist, tyid, tyreal) -> SynonymType(List.map iter tylist, tyid, iter tyreal) - | VariantType(tylist, tyid) -> VariantType(List.map iter tylist, tyid) - | ListType(tycont) -> ListType(iter tycont) - | RefType(tycont) -> RefType(iter tycont) - | HorzCommandType(tylist) -> HorzCommandType(List.map (lift_argument_type iter) tylist) - | VertCommandType(tylist) -> VertCommandType(List.map (lift_argument_type iter) tylist) - | MathCommandType(tylist) -> MathCommandType(List.map (lift_argument_type iter) tylist) - in - (Range.dummy "erased", tymainnew) + | TypeVariable(tvref) -> + begin + match !tvref with + | MonoFree(tvid) -> tvref := MonoFree(FreeID.map_kind erase_range_of_kind tvid); (rng, tymain) + | MonoLink(ty) -> erase_range_of_type ty + end + + | BaseType(_) -> (rng, tymain) + | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) + | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) + | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value iter tyasc)) + | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map iter tylist, tyid, iter tyreal)) + | VariantType(tylist, tyid) -> (rng, VariantType(List.map iter tylist, tyid)) + | ListType(tycont) -> (rng, ListType(iter tycont)) + | RefType(tycont) -> (rng, RefType(iter tycont)) + | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type iter) tylist)) + | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type iter) tylist)) + | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) and erase_range_of_kind (kd : 'a kind) = From 392ba72b470167236960206b0f1dfa18871ade48 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 15 Jul 2018 01:28:24 +0900 Subject: [PATCH 05/42] fix 'list.satyh' about value restriction --- lib-satysfi/dist/packages/list.satyh | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/lib-satysfi/dist/packages/list.satyh b/lib-satysfi/dist/packages/list.satyh index 3cd3ffba5..64ef6f562 100644 --- a/lib-satysfi/dist/packages/list.satyh +++ b/lib-satysfi/dist/packages/list.satyh @@ -26,12 +26,12 @@ module List | f (x :: xs) = (f x) :: map f xs - let mapi = + let mapi f = let-rec aux | i f [] = [] | i f (x :: xs) = (f i x) :: aux (i + 1) f xs in - aux 0 + aux 0 f let-rec iter @@ -39,12 +39,12 @@ module List | f (x :: xs) = f x before iter f xs - let iteri = + let iteri f = let-rec aux | i f [] = () | i f (x :: xs) = f i x before aux (i + 1) f xs in - aux 0 + aux 0 f let-rec fold-left @@ -52,12 +52,12 @@ module List | f init (x :: xs) = fold-left f (f init x) xs - let fold-lefti = + let fold-lefti f = let-rec aux | i f init [] = init | i f init (x :: xs) = aux (i + 1) f (f i init x) xs in - aux 0 + aux 0 f let-rec fold-right @@ -85,10 +85,10 @@ module List | x :: xs -> x :: append xs lst2 - let concat = fold-right append [] + let concat lst = fold-right append [] lst - let fold-left-adjacent f init lst = + let fold-left-adjacent f = let-rec aux leftopt init lst = match lst with | [] -> @@ -102,7 +102,7 @@ module List let initnew = f init head leftopt (Some(right)) in aux (Some(head)) initnew tail in - aux None init lst + aux None let map-adjacent f lst = @@ -120,16 +120,16 @@ module List reverse acc - let length = - fold-right (fun _ i -> i + 1) 0 + let length lst = + fold-right (fun _ i -> i + 1) 0 lst - let nth = + let nth lst = let-rec aux i n xs = match xs with | [] -> None | head :: tail -> if n == i then Some(head) else aux (i + 1) n tail in - aux 0 + aux 0 lst end From a91b22470741af0c70fa06f2ac60eea741eab9c5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 15 Jul 2018 02:11:43 +0900 Subject: [PATCH 06/42] fix 'exhchecker.ml' etc. by using 'unnormalize' --- src/frontend/display.ml | 2 +- src/frontend/exhchecker.ml | 17 ++++++---- src/frontend/typeenv.ml | 21 ++++++++---- src/frontend/types_.cppo.ml | 66 ++++++++++++++++++++++++++++++++++--- 4 files changed, 87 insertions(+), 19 deletions(-) diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 581e021d6..31e4dffb6 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -264,7 +264,7 @@ and string_of_mono_type_list tvf tyenv current_ht tylist = let rec tvf_nom current_ht tyenv tvi = match tvi with - | NomFree(tvid) -> + | NomFree(tvid, _) -> let num = GeneralIDHashTable.intern_number current_ht (NomID(tvid)) in let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in show_type_variable (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index 34cab49ae..fef5eb382 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -9,7 +9,7 @@ type type_element = | EStringConstant of string | EListCons | EEndOfList - | EConstructor of string * mono_type + | EConstructor of string * nom_type | ETuple | EWildCard @@ -20,13 +20,13 @@ and pattern_instance = | IStringConstant of string | IListCons of pattern_instance * pattern_instance | IEndOfList - | IConstructor of string * pattern_instance * mono_type + | IConstructor of string * pattern_instance * nom_type | ITupleCons of pattern_instance list | IWildCard and expand_type = | ExpandListCons - | ExpandConstructor of string * mono_type + | ExpandConstructor of string * nom_type | ExpandTuple of int | NoExpand [@@deriving show] @@ -274,13 +274,16 @@ let make_string_sig col = | _ -> acc ) [EWildCard] col) -let make_variant_sig qtfbl lev tyenv tyarglst tyid = +let make_variant_sig qtfbl lev tyenv (tyarglst : nom_type list) tyid = let constrs = Typeenv.enumerate_constructors qtfbl tyenv lev tyid in - ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> EConstructor(nm, (tyf tyarglst)))) + ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> + EConstructor(nm, normalize_mono_type (tyf (List.map unnormalize tyarglst))))) -let rec complete_sig col qtfbl lev tyenv ty = +let rec complete_sig col qtfbl lev tyenv (ty : nom_type) = match snd ty with +(* | TypeVariable({contents= MonoLink(tylink)}) -> complete_sig col qtfbl lev tyenv tylink +*) | BaseType(UnitType) -> unit_sig | BaseType(BoolType) -> bool_sig | BaseType(IntType) -> make_int_sig col @@ -376,7 +379,7 @@ let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) )] in let patid = one_to_n (List.length patbrs) in let patinfo = List.combine patid patbrs in - let (nonexh, nonexh_guard, used) = exhcheck_mat [ty] mat patinfo qtfbl lev tyenv in + let (nonexh, nonexh_guard, used) = exhcheck_mat [normalize_mono_type ty] mat patinfo qtfbl lev tyenv in let unused = IntSet.diff (IntSet.of_list patid) used in if (non_empty nonexh) || (non_empty nonexh_guard) || not (IntSet.is_empty unused) then begin diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index fc044d0a3..42f672e8d 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -981,7 +981,6 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = end end -(* | (RecordType(tyasc1), TypeVariable(PolyFree({contents= MonoFree(tvid2)} as tvref))) -> let kd2 = FreeID.get_kind tvid2 in let binc = @@ -989,19 +988,27 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = | UniversalKind -> true | RecordKind(tyasc2) -> Assoc.domain_included tyasc1 tyasc2 in - if binc then tvref := MonoLink(ty1) else (); - binc + if binc then + match unlift_poly ty1 with + | None -> false + | Some(ty1) -> tvref := MonoLink(ty1); true + else + false - | (_, TypeVariable({contents= Free(tvid2)} as tvref)) -> + | (_, TypeVariable(PolyFree({contents= MonoFree(tvid2)} as tvref))) -> let kd2 = FreeID.get_kind tvid2 in let binc = match kd2 with | UniversalKind -> true | RecordKind(_) -> false in - if binc then tvref := Link(ty1) else (); - binc -*) + if binc then + match unlift_poly ty1 with + | None -> false + | Some(ty1) -> tvref := MonoLink(ty1); true + else + false + | (FuncType(tyopts1r, tyd1, tyc1), FuncType(tyopts2r, tyd2, tyc2)) -> (aux_opt_list (!tyopts1r) (!tyopts2r)) && (aux tyd1 tyd2) && (aux tyc1 tyc2) (* -- both domain and codomain are covariant -- *) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index f50a6ccbe..dd33ae531 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -278,7 +278,7 @@ and poly_kind = poly_type_variable_info kind type nom_type_variable_info = - | NomFree of nom_kind FreeID_.t_ + | NomFree of nom_kind FreeID_.t_ * mono_type_variable_info ref and nom_kind = nom_type_variable_info kind @@ -785,10 +785,10 @@ let rec normalize_mono_type (ty : mono_type) : nom_type = let iter = normalize_mono_type in let (rng, tymain) = ty in match tymain with - | TypeVariable(tvinforef) -> + | TypeVariable(tvref) -> begin - match !tvinforef with - | MonoFree(tvid) -> (rng, TypeVariable(NomFree(FreeID.map_kind normalize_kind tvid))) + match !tvref with + | MonoFree(tvid) -> (rng, TypeVariable(NomFree(FreeID.map_kind normalize_kind tvid, tvref))) | MonoLink(tylink) -> iter tylink end @@ -811,6 +811,27 @@ and normalize_kind (kd : mono_kind) : nom_kind = | RecordKind(tyasc) -> RecordKind(Assoc.map_value normalize_mono_type tyasc) +let rec unnormalize (ty : nom_type) : mono_type = + let iter = unnormalize in + let (rng, tymain) = ty in + let tymainu = + match tymain with + | TypeVariable(NomFree(_, tvref)) -> TypeVariable(tvref) + | VariantType(tylist, tyid) -> VariantType(List.map iter tylist, tyid) + | SynonymType(tylist, tyid, tyreal) -> SynonymType(List.map iter tylist, tyid, iter tyreal) + | BaseType(bt) -> BaseType(bt) + | ListType(tycont) -> ListType(iter tycont) + | RefType(tycont) -> RefType(iter tycont) + | FuncType(tyoptsr, tydom, tycod) -> FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod) + | ProductType(tylist) -> ProductType(List.map iter tylist) + | RecordType(tyassoc) -> RecordType(Assoc.map_value iter tyassoc) + | HorzCommandType(tylist) -> HorzCommandType(List.map (lift_argument_type iter) tylist) + | VertCommandType(tylist) -> VertCommandType(List.map (lift_argument_type iter) tylist) + | MathCommandType(tylist) -> MathCommandType(List.map (lift_argument_type iter) tylist) + in + (rng, tymainu) + + let rec erase_range_of_type (ty : mono_type) : mono_type = let iter = erase_range_of_type in let rng = Range.dummy "erased" in @@ -970,6 +991,43 @@ let generalize (lev : FreeID.level) = let lift_poly = lift_poly_general (fun _ -> true) + +let unlift_poly (pty : poly_type_variable_info typ) : mono_type option = + let rec aux pty = + let (rng, ptymain) = pty in + let ptymainnew = + match ptymain with + | BaseType(bt) -> BaseType(bt) + + | TypeVariable(ptvi) -> + begin + match ptvi with + | PolyFree(tvref) -> TypeVariable(tvref) + | PolyBound(_) -> raise Exit + end + + | FuncType(ptyoptsr, pty1, pty2) -> FuncType(ref (List.map aux !ptyoptsr), aux pty1, aux pty2) + | ProductType(ptylst) -> ProductType(List.map aux ptylst) + | RecordType(ptyasc) -> RecordType(Assoc.map_value aux ptyasc) + | ListType(ptysub) -> ListType(aux ptysub) + | RefType(ptysub) -> RefType(aux ptysub) + | VariantType(ptylst, tyid) -> VariantType(List.map aux ptylst, tyid) + | SynonymType(ptylst, tyid, ptya) -> SynonymType(List.map aux ptylst, tyid, aux ptya) + | HorzCommandType(catyl) -> HorzCommandType(List.map aux_cmd catyl) + | VertCommandType(catyl) -> VertCommandType(List.map aux_cmd catyl) + | MathCommandType(catyl) -> MathCommandType(List.map aux_cmd catyl) + in + (rng, ptymainnew) + + and aux_cmd = function + | MandatoryArgumentType(pty) -> MandatoryArgumentType(aux pty) + | OptionalArgumentType(pty) -> OptionalArgumentType(aux pty) + + in + try Some(aux pty) with + | Exit -> None + + (* let copy_environment (env : environment) : environment = let (valenv, stenv) = env in From 6db2c544df53624eca1b191ecc5946be53973c84 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 23 Jul 2018 11:30:03 +0900 Subject: [PATCH 07/42] arrange spaces in 'typeenv.ml' --- src/frontend/typeenv.ml | 180 ++++++++++++++-------------------------- 1 file changed, 61 insertions(+), 119 deletions(-) diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index 1b9693da6..fb35258ad 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -108,9 +108,7 @@ exception NotProvidingValueImplementation of Range.t * var_name exception NotProvidingTypeImplementation of Range.t * type_name exception NotMatchingInterface of Range.t * var_name * t * poly_type * t * poly_type exception UndefinedModuleName of Range.t * module_name * module_name list -(* -exception UndefinedModuleNameList of module_name list -*) + let empty : t = { @@ -156,10 +154,10 @@ let edit_distance s1 s2 mindist = d.(i).(j) <- min (min (d.(i - 1).(j) + 1) (d.(i).(j - 1) + 1)) (d.(i - 1).(j - 1) + replace) done done; - (*Format.printf "%s %s => %d\n" s1 s2 (d.(len1).(len2));*) d.(len1).(len2) end + let initial_candidates nm = let maxdist = match String.length nm with @@ -170,25 +168,29 @@ let initial_candidates nm = in ([], maxdist) + let get_candidates_cont foldf map nm acc = foldf (fun k _ (cand, mindist) -> let dist = edit_distance nm k mindist in if dist < mindist then ([k], dist) else if dist = mindist then - (k::cand, mindist) + (k :: cand, mindist) else (cand, mindist) ) map acc + let get_candidates_first foldf map nm = get_candidates_cont foldf map nm (initial_candidates nm) + let get_candidates_last pair = fst pair + let get_candidates foldf map nm = - get_candidates_last @@ get_candidates_first foldf map nm + get_candidates_last @@ get_candidates_first foldf map nm (* PUBLIC *) @@ -196,7 +198,7 @@ let add (tyenv : t) (varnm : var_name) ((pty, evid) : poly_type * EvalVarID.t) : let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in match ModuleTree.update mtr addrlst (update_vt (VarMap.add varnm (pty, evid))) with - | None -> assert false (* raise (UndefinedModuleNameList(addrlst |> List.map ModuleID.extract_name)) *) + | None -> assert false | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } @@ -227,6 +229,7 @@ let find (tyenv : t) (mdlnmlst : module_name list) (varnm : var_name) (rng : Ran return (ptysig, evid) ) + (* PUBLIC *) let find_candidates (tyenv : t) (mdlnmlst : module_name list) (varnm : var_name) (rng : Range.t) : var_name list = let open OptionMonad in @@ -277,11 +280,8 @@ let open_module (tyenv : t) (rng : Range.t) (mdlnm : module_name) = ) in match mtropt with - | None -> - raise (UndefinedModuleName(rng, mdlnm, get_candidates ModuleNameMap.fold nmtoid mdlnm)) - - | Some(mtrnew) -> - { tyenv with main_tree = mtrnew; } + | None -> raise (UndefinedModuleName(rng, mdlnm, get_candidates ModuleNameMap.fold nmtoid mdlnm)) + | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } let find_for_inner (tyenv : t) (varnm : var_name) : (poly_type * EvalVarID.t) option = @@ -301,16 +301,12 @@ let enter_new_module (tyenv : t) (mdlnm : module_name) : t = | None -> assert false | Some(mtrnew) -> { tyenv with current_address = addrnew; main_tree = mtrnew; } -(* -let enter_module_by_id ((addr, nmtoid, mtr) : t) (mdlid : ModuleID.t) : t = - let addrnew = List.append addr [mdlid] in - let mtrnew = ModuleTree.add_stage mtr addr mdlid (VarMap.empty, TyNameMap.empty, ConstrMap.empty, None) in - (addrnew, nmtoid, mtrnew) -*) let leave_module (tyenv : t) : t = match Alist.chop_last tyenv.current_address with - | None -> assert false + | None -> + assert false + | Some((addr_outer, mdlid)) -> let mdlnm = ModuleID.extract_name mdlid in let nmtoidnew = ModuleNameMap.add mdlnm mdlid tyenv.name_to_id_map in @@ -342,15 +338,6 @@ module MapList end -type type_argument_mode = - | StrictMode of (type_argument_name, BoundID.t) MapList.t - | FreeMode of (type_argument_name, poly_type_variable_info) MapList.t - (* -- - StrictMode : case where all type arguments should be declared; e.g. for type definitions - FreeMode : case where type arguments do not need to be declared; e.g. for type annotations - -- *) - - module DependencyGraph = DirectedGraph.Make (struct type t = type_name @@ -379,7 +366,7 @@ let add_type_definition (tyenv : t) (tynm : type_name) ((tyid, dfn) : TypeID.t * let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in match ModuleTree.update mtr addrlst (update_td (TyNameMap.add tynm (tyid, dfn))) with - | None -> assert false (* raise (UndefinedModuleNameList(addrlst |> List.map ModuleID.extract_name)) *) + | None -> assert false | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } @@ -429,11 +416,8 @@ let find_type_definition_candidates_for_outer (tyenv : t) (mdlnmlst : module_nam let base_type_candidates = get_candidates_first Hashtbl.fold base_type_hash_table tynm in get_candidates_last @@ ModuleTree.fold_backward mtr addrlst mdlidlst (fun acc (_, tdmap, _, sigopt) -> match sigopt with - | None -> - get_candidates_cont TyNameMap.fold tdmap tynm acc - - | Some((tdmapsig, _)) -> - get_candidates_cont TyNameMap.fold tdmapsig tynm acc + | None -> get_candidates_cont TyNameMap.fold tdmap tynm acc + | Some((tdmapsig, _)) -> get_candidates_cont TyNameMap.fold tdmapsig tynm acc ) base_type_candidates @@ -450,52 +434,43 @@ let find_type_name (_ : t) (tyid : TypeID.t) : type_name = let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) (tyid : TypeID.t) (tyenv : t) : t = -(* - let () = print_for_debug_variantenv ("C-add " ^ constrnm ^ " of [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_poly_type_basic pty)) in (* for debug *) -*) let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in match ModuleTree.update mtr addrlst (update_cd (ConstrMap.add constrnm (tyid, (bidlist, pty)))) with - | None -> assert false (* raise (UndefinedModuleNameList(addrlst |> List.map ModuleID.extract_name)) *) + | None -> assert false | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info ref -> a typ) (pairlst : (a typ * BoundID.t) list) (Poly(pty) : poly_type) : a typ = -(* - let () = print_for_debug_variantenv ("I-input [" ^ (List.fold_left (fun s bid -> "'#" ^ (BoundID.show_direct (string_of_kind string_of_mono_type_basic) bid) ^ " " ^ s) "" bidlist) ^ "] " ^ (string_of_mono_type_basic ty)) in (* for debug *) -*) let bid_to_type_ht : (a typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in let rec aux ((rng, ptymain) : poly_type_variable_info typ) : a typ = -(* - let () = print_for_debug_variantenv ("aux " ^ (string_of_mono_type_basic (rng, tymain))) in (* for debug *) -*) - match ptymain with - | TypeVariable(ptvi) -> - begin - match ptvi with - | PolyFree(tvref) -> - freef rng tvref + match ptymain with + | TypeVariable(ptvi) -> + begin + match ptvi with + | PolyFree(tvref) -> + freef rng tvref - | PolyBound(bid) -> - begin - match BoundIDHashTable.find_opt bid_to_type_ht bid with - | None -> assert false - | Some(tysub) -> tysub - end - end + | PolyBound(bid) -> + begin + match BoundIDHashTable.find_opt bid_to_type_ht bid with + | None -> assert false + | Some(tysub) -> tysub + end + end - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map aux (!tyoptsr)), aux tydom, aux tycod)) - | ProductType(tylist) -> (rng, ProductType(List.map aux tylist)) - | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value aux tyasc)) - | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, aux tyreal)) - | VariantType(tylist, tyid) -> (rng, VariantType(List.map aux tylist, tyid)) - | ListType(tysub) -> (rng, ListType(aux tysub)) - | RefType(tysub) -> (rng, RefType(aux tysub)) - | BaseType(bt) -> (rng, BaseType(bt)) - | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type aux) tylist)) - | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) - | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) + | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map aux (!tyoptsr)), aux tydom, aux tycod)) + | ProductType(tylist) -> (rng, ProductType(List.map aux tylist)) + | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value aux tyasc)) + | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, aux tyreal)) + | VariantType(tylist, tyid) -> (rng, VariantType(List.map aux tylist, tyid)) + | ListType(tysub) -> (rng, ListType(aux tysub)) + | RefType(tysub) -> (rng, RefType(aux tysub)) + | BaseType(bt) -> (rng, BaseType(bt)) + | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type aux) tylist)) + | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) + | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) in begin pairlst |> List.iter (fun (tyarg, bid) -> BoundIDHashTable.add bid_to_type_ht bid tyarg); @@ -503,13 +478,12 @@ let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info end -let rec type_argument_length tyargcons = List.length tyargcons - - let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (freef : Range.t -> mono_type_variable_info ref -> a typ) (typaramf : Range.t -> string -> a type_main) (mnty : manual_type) : a typ = let rec aux (mnty : manual_type) : a typ = let (rng, mntymain) = mnty in - let error tynm lenexp lenerr = raise (IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr)) in + let error tynm lenexp lenerr = + raise (IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr)) + in let ptymainnew = match mntymain with @@ -540,7 +514,8 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) let tyarglist = List.map aux mntyarglist in let find_in_variant_environment () = match find_type_definition_for_outer tyenv mdlnmlst tynm rng with - | None -> raise (UndefinedTypeName(rng, mdlnmlst, tynm, find_type_definition_candidates_for_outer tyenv mdlnmlst tynm rng)) + | None -> + raise (UndefinedTypeName(rng, mdlnmlst, tynm, find_type_definition_candidates_for_outer tyenv mdlnmlst tynm rng)) | Some((tyid, Data(lenexp))) -> if lenexp <> len then error tynm lenexp len else @@ -563,14 +538,16 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) in begin match dpmode with - | NoDependency -> find_in_variant_environment () + | NoDependency -> + find_in_variant_environment () + | DependentMode(dg) -> begin try match DependencyGraph.find_vertex dg tynm with | VariantVertex(_, tyid, tyargcons, utvarntcons) -> - let lenexp = type_argument_length tyargcons in + let lenexp = List.length tyargcons in if len <> lenexp then error tynm lenexp len else VariantType(tyarglist, tyid) @@ -582,7 +559,7 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) SynonymType(tyarglist, tyid, tyreal) with | Invalid_argument(_) -> - let lenexp = type_argument_length tyargcons in + let lenexp = List.length tyargcons in error tynm lenexp len end @@ -607,40 +584,12 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) in aux mnty -(* - match tyargmode with - | StrictMode(bidmaplist) -> - let bidlist = - MapList.to_list bidmaplist |> List.map (fun (_, bid) -> bid) - in - (bidlist, Poly(pty)) - - | FreeMode(tyargmaplist) -> - let bidlist = - (MapList.to_list tyargmaplist) |> List.map (fun (_, ptvi) -> - match ptvi with - | PolyFree(tvref) -> - let kd = BoundID.get_kind tvid in - let bid = BoundID.fresh kd () in - begin - tvref := PolyBound(bid); - bid - end - | _ -> assert false - ) - in - (bidlist, Poly(pty)) -*) and fix_manual_kind_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) freef typaramf (mnkd : manual_kind) = match mnkd with | MUniversalKind -> UniversalKind - | MRecordKind(mntyasc) -> - let aux mnty = - fix_manual_type_general dpmode tyenv lev freef typaramf mnty - in - RecordKind(Assoc.map_value aux mntyasc) + | MRecordKind(mntyasc) -> RecordKind(Assoc.map_value (fix_manual_type_general dpmode tyenv lev freef typaramf) mntyasc) let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargcons : untyped_type_argument list) (mnty : manual_type) : BoundID.t list * poly_type = @@ -650,12 +599,14 @@ let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) in let typaramf rng param = match MapList.find_opt bidmaplist param with - | None -> raise (UndefinedTypeArgument(rng, param)) + | None -> raise (UndefinedTypeArgument(rng, param, get_candidates MapList.fold bidmaplist param)) | Some(bid) -> TypeVariable(PolyBound(bid)) in let rec aux cons = match cons with - | [] -> () + | [] -> + () + | (_, tyargnm, mnkd) :: tailcons -> let kd = fix_manual_kind_general dpmode tyenv lev freef typaramf mnkd in (* @@ -708,15 +659,6 @@ let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev let ty = fix_manual_type_general NoDependency tyenv lev freef typaramf mnty in ty -(* - let tyarglist = - bidlist |> List.map (fun bid -> - let tvid = FreeID.fresh (normalize_kind (BoundID.get_kind bid)) qtfbl lev () in - (Range.dummy "fix_manual_type_free", TypeVariable(ref (Free(tvid)))) - ) - in - instantiate_type_scheme tyarglist bidlist ptyin -*) let register_type (tynm : type_name) (tyid : TypeID.t) (dfn : type_definition) (tyenv : t) : t = @@ -735,7 +677,7 @@ let register_type_from_vertex (dg : vertex_label DependencyGraph.t) (tyenv : t) match DependencyGraph.find_vertex dg tynm with | VariantVertex(_, tyid, tyargcons, _) -> - let len = type_argument_length tyargcons in + let len = List.length tyargcons in register_type tynm tyid (Data(len)) tyenv | SynonymVertex(_, tyid, _, _, {contents= Some((bidlist, ptyscheme))}) -> @@ -1204,7 +1146,7 @@ let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tye | Some((tyid, dfn)) -> let tyenvforsigInew = add_type_definition tyenvforsigI tynm (tyid, dfn) in - let len = type_argument_length tyargcons in (* temporary; should check whether len is valid as to dfn *) + let len = List.length tyargcons in (* temporary; should check whether len is valid as to dfn *) let tyidout = TypeID.fresh (get_moduled_type_name tyenv tynm) in let sigoptaccnew = add_type_to_signature sigoptacc tynm tyidout len in let tyenvforsigOnew = @@ -1212,7 +1154,7 @@ let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tye let addrlst = Alist.to_list tyenvsub.current_address in let mtr = tyenvsub.main_tree in match ModuleTree.update mtr addrlst (update_so (fun _ -> sigoptaccnew)) with - | None -> assert false (* raise (UndefinedModuleNameList(addrlst |> List.map ModuleID.extract_name)) *) + | None -> assert false | Some(mtrnew) -> { tyenvsub with main_tree = mtrnew; } in iter tyenvacc tyenvforsigInew tyenvforsigOnew tail sigoptaccnew From ce04c563cba57bdf9b9b32d386c963821b70a993 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 5 Aug 2018 17:44:51 +0900 Subject: [PATCH 08/42] fix typechecker as to optional parameters --- src/frontend/bytecomp/bytecomp.ml | 5 +- src/frontend/bytecomp/ir_.cppo.ml | 33 ++-- src/frontend/display.ml | 74 +++---- src/frontend/display.mli | 1 + src/frontend/evaluator_.cppo.ml | 39 +++- src/frontend/exhchecker.ml | 18 +- src/frontend/exhchecker.mli | 2 +- src/frontend/primitives_.cppo.ml | 4 +- src/frontend/primitives_.mli | 4 +- src/frontend/typechecker.ml | 239 +++++++++++++--------- src/frontend/typeenv.ml | 145 +++++++++----- src/frontend/typeenv.mli | 12 +- src/frontend/types_.cppo.ml | 317 ++++++++++++++++++++---------- 13 files changed, 576 insertions(+), 317 deletions(-) diff --git a/src/frontend/bytecomp/bytecomp.ml b/src/frontend/bytecomp/bytecomp.ml index 4707d0d69..37682986a 100644 --- a/src/frontend/bytecomp/bytecomp.ml +++ b/src/frontend/bytecomp/bytecomp.ml @@ -18,15 +18,14 @@ let compile_and_exec env ast = let compile_environment env = let (binds, _) = env in - binds |> EvalVarIDMap.iter (fun evid loc -> + binds |> EvalVarIDMap.iter (fun evid loc -> match !loc with | PrimitiveWithEnvironment(parbrs, env1, arity, astf) -> begin - match compile_and_exec env (Function(parbrs)) with + match compile_and_exec env (Function([], parbrs)) with | CompiledFuncWithEnvironment(_, _, framesize, body, env1) -> loc := CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) | _ -> () end | _ -> () ) - diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index eccee4f59..0f260b27e 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -117,12 +117,12 @@ and transform_list env astlst = map_with_env transform env astlst -and transform_primitive env astlst op = +and transform_primitive (env : frame) (astlst : abstract_tree list) (op : instruction) : ir * frame = let (irargs, env) = transform_list env astlst in (IRApplyPrimitive(op, List.length astlst, irargs), env) -and transform_patsel env (patbrs : pattern_branch list) = +and transform_patsel (env : frame) (patbrs : pattern_branch list) : ir_pattern_branch list * frame = let before_size = env.size in let max_size = ref before_size in let (irpatsel, envnew) = @@ -151,7 +151,7 @@ and transform_pattern_list env patlst = map_with_env transform_pattern env patlst -and transform_pattern env (pat : pattern_tree) = +and transform_pattern (env : frame) (pat : pattern_tree) : ir_pattern_tree * frame = let return b = (b, env) in match pat with | PIntegerConstant(pnc) -> return (IRPIntegerConstant(pnc)) @@ -203,7 +203,7 @@ and newlevel (env : frame) = { env with level = env.level+1; size = 0; } -and add_to_environment (env : frame) evid = +and add_to_environment (env : frame) (evid : EvalVarID.t) : frame * varloc = let (var, newglobal) = if env.level = 0 then let loc = (ref Nil) in @@ -227,7 +227,7 @@ and find_in_environment (env : frame) (evid : EvalVarID.t) : varloc option = | None -> None -and add_letrec_bindings_to_environment env (recbinds : letrec_binding list) = +and add_letrec_bindings_to_environment (env : frame) (recbinds : letrec_binding list) : (varloc * pattern_branch list) list * frame = recbinds @|> env @|> map_with_env (fun env recbind -> let LetRecBinding(evid, patbrs) = recbind in let (env, var) = add_to_environment env evid in @@ -235,11 +235,11 @@ and add_letrec_bindings_to_environment env (recbinds : letrec_binding list) = ) -and flatten_function astfun = +and flatten_function (astfun : abstract_tree) : abstract_tree * pattern_tree list = let rec iter ast acc = match ast with - | Function([PatternBranch(pat, body)]) -> iter body (Alist.extend acc pat) - | _ -> (ast, Alist.to_list acc) + | Function([], [PatternBranch(pat, body)]) -> iter body (Alist.extend acc pat) + | _ -> (ast, Alist.to_list acc) in iter astfun Alist.empty @@ -327,10 +327,10 @@ and transform (env : frame) ast : (ir * frame) = (IRPath(irpt0, pathelemlst, closingopt), env) | LambdaVert(evid, astdef) -> - transform env (Function [(PatternBranch ((PVariable evid), astdef))]) + transform env (Function([], [(PatternBranch ((PVariable(evid)), astdef))])) | LambdaHorz(evid, astdef) -> - transform env (Function [(PatternBranch ((PVariable evid), astdef))]) + transform env (Function([], [(PatternBranch ((PVariable(evid)), astdef))])) | PrimitiveTupleCons(asthd, asttl) -> transform_tuple env ast @@ -352,7 +352,7 @@ and transform (env : frame) ast : (ir * frame) = let varir_lst = pairs |> List.map (fun pair -> let (var, patbrs) = pair in - let (ir, _) = transform env (Function(patbrs)) in + let (ir, _) = transform env (Function([], patbrs)) in (var, ir) ) in @@ -365,13 +365,16 @@ and transform (env : frame) ast : (ir * frame) = let (ir2, env) = transform env ast2 in (IRLetNonRecIn(ir1, irpat, ir2), env) - | Function(patbrs) -> + | Function([], patbrs) -> let (body, args) = flatten_function ast in let funenv = newlevel env in let (irargs, funenv) = transform_pattern_list funenv args in let (irbody, funenv) = transform funenv body in (IRFunction(funenv.size, irargs, irbody), env) + | Function(_ :: _, _) -> + failwith "Function with optional arguments: remains to be implemented." + | Apply(ast1, ast2) -> let (callee, args) = flatten_application ast in begin @@ -385,6 +388,12 @@ and transform (env : frame) ast : (ir * frame) = (IRApply(List.length irargs, ircallee, irargs), env) end + | ApplyOptional(ast1, ast2) -> + failwith "ApplyOptional: remains to be implemented." + + | ApplyOmission(ast1) -> + failwith "ApplyOmission: remains to be implemented." + | IfThenElse(astb, ast1, ast2) -> let (irb, env) = transform env astb in let before_size = env.size in diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 31e4dffb6..cdea94d14 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -2,7 +2,7 @@ module Types = Types_ open Types -let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) = +let string_of_record_type (type a) (type b) (f : (a, b) typ -> string) (asc : ((a, b) typ) Assoc.t) = let rec aux lst = match lst with | [] -> " -- " @@ -12,7 +12,7 @@ let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let string_of_kind (type a) (f : a typ -> string) (kdstr : a kind) = +let string_of_kind (type a) (type b) (f : (a, b) typ -> string) (kdstr : (a, b) kind) = let rec aux lst = match lst with | [] -> " -- " @@ -32,14 +32,14 @@ let rec variable_name_of_number (n : int) = ) ^ (String.make 1 (Char.chr ((Char.code 'a') + n mod 26))) -let show_type_variable (type a) (f : a typ -> string) (name : string) (kd : a kind) = +let show_type_variable (type a) (type b) (f : (a, b) typ -> string) (name : string) (kd : (a, b) kind) = match kd with | UniversalKind -> name | RecordKind(asc) -> "(" ^ name ^ " <: " ^ (string_of_kind f kd) ^ ")" type general_id = - | NomID of nom_kind FreeID_.t_ + | FreeID of mono_kind FreeID_.t_ | BoundID of BoundID.t @@ -49,7 +49,7 @@ module GeneralIDHashTable_ = Hashtbl.Make( let equal gid1 gid2 = match (gid1, gid2) with - | (NomID(tvid1), NomID(tvid2)) -> FreeID.equal tvid1 tvid2 + | (FreeID(tvid1), FreeID(tvid2)) -> FreeID.equal tvid1 tvid2 | (BoundID(bid1), BoundID(bid2)) -> BoundID.eq bid1 bid2 | (_, _) -> false @@ -95,11 +95,12 @@ module GeneralIDHashTable end -let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) ((_, tymain) : 'a typ) = +let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) ((_, tymain) : ('a, 'b) typ) = let iter = string_of_mono_type_sub tvf tyenv current_ht in let iter_cmd = string_of_command_argument_type tvf tyenv current_ht in let iter_args = string_of_type_argument_list tvf tyenv current_ht in let iter_list = string_of_mono_type_list tvf tyenv current_ht in + let iter_or = string_of_option_row tvf tyenv current_ht in match tymain with | TypeVariable(tvi) -> tvf tvi @@ -140,18 +141,11 @@ let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (curren | SynonymType(tyarglist, tyid, tyreal) -> (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) ^ " (= " ^ (iter tyreal) ^ ")" - | FuncType(tyoptsr, ((_, tydommain) as tydom), tycod) -> - let stropts = - !tyoptsr |> List.map (fun ((_, tymain) as ty) -> - let s = iter ty in - match tymain with - | FuncType(_, _, _) -> "(" ^ s ^ ") ?-> " - | _ -> s ^ " ?-> " - ) - in + | FuncType(optrow, ((_, tydommain) as tydom), tycod) -> + let stropts = iter_or optrow in let strdom = iter tydom in let strcod = iter tycod in - (String.concat "" stropts) ^ + stropts ^ begin match tydommain with | FuncType(_, _, _) -> "(" ^ strdom ^ ")" @@ -201,6 +195,21 @@ let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (curren "[" ^ (String.concat "; " slist) ^ "] math-cmd" +and string_of_option_row tvf tyenv current_ht = function + | OptionRowEmpty -> "" + + | OptionRowVariable(_) -> "..." (* temporary *) + + | OptionRowCons((_, tymain) as ty, tail) -> + let stysub = string_of_mono_type_sub tvf tyenv current_ht ty in + let sty = + match tymain with + | FuncType(_, _, _) -> "(" ^ stysub ^ ")" + | _ -> stysub + in + sty ^ "?-> " ^ (string_of_option_row tvf tyenv current_ht tail) + + and string_of_command_argument_type tvf tyenv current_ht = function | MandatoryArgumentType(ty) -> string_of_mono_type_sub tvf tyenv current_ht ty @@ -262,12 +271,16 @@ and string_of_mono_type_list tvf tyenv current_ht tylist = end -let rec tvf_nom current_ht tyenv tvi = - match tvi with - | NomFree(tvid, _) -> - let num = GeneralIDHashTable.intern_number current_ht (NomID(tvid)) in +let rec tvf_mono current_ht tyenv tvi = + match !tvi with + | MonoFree(tvid) -> + let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + + | MonoLink(ty) -> + "(" ^ (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty) ^ ")" + (* temporary; should omit unnecessary parentheses *) let rec tvf_poly current_ht tyenv ptvi = @@ -276,14 +289,12 @@ let rec tvf_poly current_ht tyenv ptvi = begin match !tvref with | MonoFree(tvid) -> - let tvid = FreeID.map_kind normalize_kind tvid in - let num = GeneralIDHashTable.intern_number current_ht (NomID(tvid)) in + let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) | MonoLink(ty) -> - let tyn = normalize_mono_type ty in - "(" ^ (string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht tyn) ^ ")" + "(" ^ (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty) ^ ")" end | PolyBound(bid) -> @@ -296,8 +307,7 @@ let string_of_mono_type (tyenv : Typeenv.t) (ty : mono_type) = begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in - let tyn = normalize_mono_type ty in - string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht tyn + string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty end @@ -305,11 +315,9 @@ let string_of_mono_type_double (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in - let tyn1 = normalize_mono_type ty1 in - let tyn2 = normalize_mono_type ty2 in - let strf = string_of_mono_type_sub (tvf_nom current_ht tyenv) tyenv current_ht in - let strty1 = strf tyn1 in - let strty2 = strf tyn2 in + let strf = string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht in + let strty1 = strf ty1 in + let strty2 = strf ty2 in (strty1, strty2) end diff --git a/src/frontend/display.mli b/src/frontend/display.mli index 14d957b45..178d07713 100644 --- a/src/frontend/display.mli +++ b/src/frontend/display.mli @@ -11,6 +11,7 @@ val string_of_poly_type_basic : poly_type -> string val string_of_kind_basic : kind -> string *) + val string_of_mono_type : Typeenv.t -> mono_type -> string val string_of_mono_type_double : Typeenv.t -> mono_type -> mono_type -> (string * string) diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index faeaacce4..3caa37c06 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -38,7 +38,7 @@ and reduce_beta_list valuef valuearglst = | valuearg :: astargtail -> begin match valuef with - | FuncWithEnvironment(patbrs, envf) -> + | FuncWithEnvironment(_, patbrs, envf) -> let valuefnew = select_pattern (Range.dummy "reduce_beta_list") envf valuearg patbrs in reduce_beta_list valuefnew astargtail @@ -175,14 +175,20 @@ and interpret env ast = let value1 = interpret env ast1 in select_pattern (Range.dummy "LetNonRecIn") env value1 [PatternBranch(pat, ast2)] - | Function(patbrs) -> - FuncWithEnvironment(patbrs, env) + | Function(evids, patbrs) -> + let envor = + evids |> List.fold_left (fun env evid -> + let loc = ref (Constructor("None", UnitConstant)) in + add_to_environment env evid loc + ) env + in + FuncWithEnvironment(evids, patbrs, envor) | Apply(ast1, ast2) -> let value1 = interpret env ast1 in begin match value1 with - | FuncWithEnvironment(patbrs, env1) -> + | FuncWithEnvironment(_, patbrs, env1) -> let value2 = interpret env ast2 in select_pattern (Range.dummy "Apply") env1 value2 patbrs @@ -193,6 +199,29 @@ and interpret env ast = | _ -> report_bug_reduction "Apply: not a function" ast1 value1 end + | ApplyOptional(ast1, ast2) -> + let value1 = interpret env ast1 in + begin + match value1 with + | FuncWithEnvironment(evid :: evids, patbrs, env1) -> + let value2 = interpret env ast2 in + let loc = ref (Constructor("Some", value2)) in + let env1new = add_to_environment env1 evid loc in + FuncWithEnvironment(evids, patbrs, env1new) + + | _ -> report_bug_reduction "ApplyOptional: not a function with optional parameter" ast1 value1 + end + + | ApplyOmission(ast1) -> + let value1 = interpret env ast1 in + begin + match value1 with + | FuncWithEnvironment(evid :: evids, patbrs, env1) -> + FuncWithEnvironment(evids, patbrs, env1) + + | _ -> report_bug_reduction "ApplyOmission: not a function with optional parameter" ast1 value1 + end + | IfThenElse(astb, ast1, ast2) -> let b = get_bool (interpret env astb) in if b then interpret env ast1 else interpret env ast2 @@ -492,6 +521,6 @@ and add_letrec_bindings_to_environment (env : environment) (recbinds : letrec_bi ) in trilst |> List.iter (fun (evid, loc, patbrs) -> - loc := FuncWithEnvironment(patbrs, envnew) + loc := FuncWithEnvironment([], patbrs, envnew) ); envnew diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index fef5eb382..2d0d0a4f6 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -9,7 +9,7 @@ type type_element = | EStringConstant of string | EListCons | EEndOfList - | EConstructor of string * nom_type + | EConstructor of string * mono_type | ETuple | EWildCard @@ -20,13 +20,13 @@ and pattern_instance = | IStringConstant of string | IListCons of pattern_instance * pattern_instance | IEndOfList - | IConstructor of string * pattern_instance * nom_type + | IConstructor of string * pattern_instance * mono_type | ITupleCons of pattern_instance list | IWildCard and expand_type = | ExpandListCons - | ExpandConstructor of string * nom_type + | ExpandConstructor of string * mono_type | ExpandTuple of int | NoExpand [@@deriving show] @@ -274,16 +274,14 @@ let make_string_sig col = | _ -> acc ) [EWildCard] col) -let make_variant_sig qtfbl lev tyenv (tyarglst : nom_type list) tyid = +let make_variant_sig qtfbl lev tyenv (tyarglst : mono_type list) tyid = let constrs = Typeenv.enumerate_constructors qtfbl tyenv lev tyid in ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> - EConstructor(nm, normalize_mono_type (tyf (List.map unnormalize tyarglst))))) + EConstructor(nm, tyf tyarglst))) -let rec complete_sig col qtfbl lev tyenv (ty : nom_type) = +let rec complete_sig col qtfbl lev tyenv (ty : mono_type) = match snd ty with -(* | TypeVariable({contents= MonoLink(tylink)}) -> complete_sig col qtfbl lev tyenv tylink -*) | BaseType(UnitType) -> unit_sig | BaseType(BoolType) -> bool_sig | BaseType(IntType) -> make_int_sig col @@ -366,7 +364,7 @@ let non_empty lst = | _ -> true let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) - (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) : unit = + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) : unit = let patbrs = patbrs |> List.map (fun patbr -> match patbr with | PatternBranch(p, a) -> PatternBranch(normalize_pat p, a) @@ -379,7 +377,7 @@ let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) )] in let patid = one_to_n (List.length patbrs) in let patinfo = List.combine patid patbrs in - let (nonexh, nonexh_guard, used) = exhcheck_mat [normalize_mono_type ty] mat patinfo qtfbl lev tyenv in + let (nonexh, nonexh_guard, used) = exhcheck_mat [ty] mat patinfo qtfbl lev tyenv in let unused = IntSet.diff (IntSet.of_list patid) used in if (non_empty nonexh) || (non_empty nonexh_guard) || not (IntSet.is_empty unused) then begin diff --git a/src/frontend/exhchecker.mli b/src/frontend/exhchecker.mli index 9c71784b8..f94ab33cf 100644 --- a/src/frontend/exhchecker.mli +++ b/src/frontend/exhchecker.mli @@ -2,4 +2,4 @@ module Types = Types_ open Types -val main : Range.t -> pattern_branch list -> mono_type -> quantifiability -> FreeID.level -> Typeenv.t -> unit +val main : Range.t -> pattern_branch list -> mono_type -> quantifiability -> level -> Typeenv.t -> unit diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index a360da328..a9a5de219 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -47,7 +47,7 @@ let tRE = (~! "regexp" , BaseType(RegExpType) ) let tL ty = (~! "list" , ListType(ty) ) let tR ty = (~! "ref" , RefType(ty) ) let tPROD tylst = (~! "product" , ProductType(tylst) ) -let (@->) dom cod = (~! "func" , FuncType(ref [], dom, cod)) +let (@->) dom cod = (~! "func" , FuncType(OptionRowEmpty, dom, cod)) (* -- predefined data types -- *) let tOPT ty = (~! "option" , VariantType([ty], tyid_option)) @@ -212,7 +212,7 @@ let add_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.register_type "inline-graphics" tyid_igraf (Typeenv.Alias(([], Poly(tIGR_raw)))) -let lam evid ast = Function([PatternBranch(PVariable(evid), ast)]) +let lam evid ast = Function([], [PatternBranch(PVariable(evid), ast)]) let lamenv env evid arity ast astf = PrimitiveWithEnvironment([PatternBranch(PVariable(evid), ast)], env, arity, astf) let ( !- ) evid = ContentOf(Range.dummy "temporary", evid) diff --git a/src/frontend/primitives_.mli b/src/frontend/primitives_.mli index 52fdf1626..f11b6220d 100644 --- a/src/frontend/primitives_.mli +++ b/src/frontend/primitives_.mli @@ -3,9 +3,9 @@ module Types = Types_ open Types open LengthInterface -val option_type : 'a typ -> 'a typ +val option_type : ('a, 'b) typ -> ('a, 'b) typ -val itemize_type : unit -> 'a typ +val itemize_type : unit -> ('a, 'b) typ val get_initial_context : length -> HorzBox.context_main diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index e0e21bb43..f5077f3a9 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -29,7 +29,7 @@ let print_for_debug_typecheck msg = () -let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_type list * EvalVarID.t list * Typeenv.t = +let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> let evid = EvalVarID.fresh varnm in @@ -40,12 +40,18 @@ let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : ( (tyenvnew, Alist.extend tyacc (rng, TypeVariable(tvref)), Alist.extend evidacc evid) ) (tyenv, Alist.empty, Alist.empty) in - (Alist.to_list tyacc, Alist.to_list evidacc, tyenvnew) + let optrow = + List.fold_right (fun ty acc -> + OptionRowCons(ty, acc) + ) (Alist.to_list tyacc) OptionRowEmpty + in + (optrow, Alist.to_list evidacc, tyenvnew) +(* let append_optional_ids (evidlst : EvalVarID.t list) (ast : abstract_tree) = List.fold_right (fun evid ast -> Function([PatternBranch(PVariable(evid), ast)])) evidlst ast - +*) let rec is_nonexpansive_expression e = let iter = is_nonexpansive_expression in @@ -112,16 +118,22 @@ let apply_tree_of_list astfunc astlst = (* -- 'flatten_type': converts type (t1 -> ... -> tN -> t) into ([t1; ...; tN], t) -- *) -let flatten_type (ty : mono_type) : ((mono_type_variable_info ref) command_argument_type) list * mono_type = +let flatten_type (ty : mono_type) : mono_command_argument_type list * mono_type = + + let rec aux_or = function + | OptionRowCons(ty, tail) -> OptionalArgumentType(ty) :: aux_or tail + | OptionRowEmpty | OptionRowVariable(_) -> [] + in + let rec aux acc ty = let (rng, tymain) = ty in match tymain with | TypeVariable({contents= MonoLink(tylink)}) -> aux acc tylink - | FuncType(tyoptsr, tydom, tycod) -> + | FuncType(optrow, tydom, tycod) -> let accnew = - Alist.append acc (List.append (List.map (fun ty -> OptionalArgumentType(ty)) (!tyoptsr)) [MandatoryArgumentType(tydom)]) + Alist.append acc (List.append (aux_or optrow) [MandatoryArgumentType(tydom)]) in aux accnew tycod @@ -129,7 +141,7 @@ let flatten_type (ty : mono_type) : ((mono_type_variable_info ref) command_argum in aux Alist.empty ty - +(* let eliminate_optionals (ty : mono_type) (e : abstract_tree) : mono_type * abstract_tree = let rec aux ty e = match ty with @@ -140,50 +152,59 @@ let eliminate_optionals (ty : mono_type) (e : abstract_tree) : mono_type * abstr (ty, e) in aux ty e +*) +let rec occurs (tvid : FreeID.t) (ty : mono_type) = + + let rec iter (_, tymain) = + match tymain with + | TypeVariable(tvref) -> + begin + match !tvref with + | MonoLink(tyl) -> iter tyl + (* + | Bound(_) -> false + *) + | MonoFree(tvidx) -> + if FreeID.equal tvidx tvid then true else + let lev = FreeID.get_level tvid in + let levx = FreeID.get_level tvidx in + let () = + (* -- update level -- *) + if Level.less_than lev levx then + tvref := MonoFree(FreeID.set_level tvidx lev) + else + () + in + false + end + | FuncType(optrow, tydom, tycod) -> iter_or optrow || iter tydom || iter tycod + | ProductType(tylist) -> iter_list tylist + | ListType(tysub) -> iter tysub + | RefType(tysub) -> iter tysub + | VariantType(tylist, _) -> iter_list tylist + | SynonymType(tylist, _, tyreal) -> iter_list tylist || iter tyreal + | RecordType(tyasc) -> iter_list (Assoc.to_value_list tyasc) + | BaseType(_) -> false + | HorzCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + | VertCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + | MathCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + + and iter_list tylst = + List.exists iter tylst + + and iter_cmd_list cmdargtylist = + List.exists (function + | MandatoryArgumentType(ty) -> iter ty + | OptionalArgumentType(ty) -> iter ty + ) cmdargtylist + + and iter_or = function + | OptionRowCons(ty, tail) -> iter ty && iter_or tail + | OptionRowEmpty | OptionRowVariable(_) -> false -let rec occurs (tvid : FreeID.t) ((_, tymain) : mono_type) = - let iter = occurs tvid in - let iter_list = List.fold_left (fun b ty -> b || iter ty) false in - let iter_cmd_list = - List.fold_left (fun b caty -> - match caty with - | MandatoryArgumentType(ty) -> b || iter ty - | OptionalArgumentType(ty) -> b || iter ty - ) false in - match tymain with - | TypeVariable(tvref) -> - begin - match !tvref with - | MonoLink(tyl) -> iter tyl -(* - | Bound(_) -> false -*) - | MonoFree(tvidx) -> - if FreeID.equal tvidx tvid then true else - let lev = FreeID.get_level tvid in - let levx = FreeID.get_level tvidx in - let () = - (* -- update level -- *) - if FreeID.less_than lev levx then - tvref := MonoFree(FreeID.set_level tvidx lev) - else - () - in - false - end - | FuncType(tyoptsr, tydom, tycod) -> iter_list (!tyoptsr) || iter tydom || iter tycod - | ProductType(tylist) -> iter_list tylist - | ListType(tysub) -> iter tysub - | RefType(tysub) -> iter tysub - | VariantType(tylist, _) -> iter_list tylist - | SynonymType(tylist, _, tyreal) -> iter_list tylist || iter tyreal - | RecordType(tyasc) -> iter_list (Assoc.to_value_list tyasc) - | BaseType(_) -> false - | HorzCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist - | VertCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist - | MathCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + iter ty let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : mono_type) = @@ -196,10 +217,10 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | (BaseType(bsty1), BaseType(bsty2)) when bsty1 = bsty2 -> () - | (FuncType(tyopts1r, tydom1, tycod1), FuncType(tyopts2r, tydom2, tycod2)) + | (FuncType(optrow1, tydom1, tycod1), FuncType(optrow2, tydom2, tycod2)) -> begin - unify_options tyopts1r tyopts2r; + unify_option_row optrow1 optrow2; unify_sub tydom1 tydom2; unify_sub tycod1 tycod2; end @@ -274,9 +295,9 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : let (tvid1l, tvid2l) = let lev1 = FreeID.get_level tvid1q in let lev2 = FreeID.get_level tvid2q in - if FreeID.less_than lev1 lev2 then + if Level.less_than lev1 lev2 then (tvid1q, FreeID.set_level tvid2q lev1) - else if FreeID.less_than lev2 lev1 then + else if Level.less_than lev2 lev1 then (FreeID.set_level tvid1q lev2, tvid2q) else (tvid1q, tvid2q) @@ -353,7 +374,34 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | _ -> raise InternalContradictionError -and unify_options tyopts1r tyopts2r = +and unify_option_row optrow1 optrow2 = + match (optrow1, optrow2) with + | (OptionRowVariable({contents = MonoORLink(optrow1)}), _) -> unify_option_row optrow1 optrow2 + | (_, OptionRowVariable({contents = MonoORLink(optrow1)})) -> unify_option_row optrow1 optrow2 + + | (OptionRowCons(ty1, tail1), OptionRowCons(ty2, tail2)) -> + unify_sub ty1 ty2; + unify_option_row tail1 tail2 + + | (OptionRowEmpty, OptionRowEmpty) -> + () + + | (OptionRowVariable({contents = MonoORFree(orv1)} as orviref1), OptionRowVariable({contents = MonoORFree(orv2)})) -> + if OptionRowVarID.equal orv1 orv2 then () else + orviref1 := MonoORLink(optrow2) + + | (OptionRowVariable({contents = MonoORFree(_)} as orviref1), _) -> + orviref1 := MonoORLink(optrow2) + + | (_, OptionRowVariable({contents = MonoORFree(_)} as orviref2)) -> + orviref2 := MonoORLink(optrow1) + + | (OptionRowEmpty, OptionRowCons(_, _)) + | (OptionRowCons(_, _), OptionRowEmpty) + -> + raise InternalContradictionError + +(* let rec aux tyopts1 tyopts2 = match (tyopts1, tyopts2) with | (_, []) -> @@ -367,7 +415,7 @@ and unify_options tyopts1r tyopts2r = aux tytail1 tytail2 in aux (!tyopts1r) (!tyopts2r) - +*) let unify_ (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono_type) = (* @@ -384,7 +432,7 @@ let final_tyenv : Typeenv.t ref = ref (Typeenv.empty) let rec typecheck - (qtfbl : quantifiability) (lev : FreeID.level) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) ((rng, utastmain) : untyped_abstract_tree) = let typecheck_iter ?l:(l = lev) ?q:(q = qtfbl) t u = typecheck q l t u in let unify = unify_ tyenv in @@ -523,10 +571,9 @@ let rec typecheck (* let _ = print_for_debug_typecheck ("#Apply " ^ (string_of_utast (rng, utastmain))) in (* for debug *) *) - let (ty1sub, e1sub) = eliminate_optionals ty1 e1 in - let eret = Apply(e1sub, e2) in + let eret = Apply(e1, e2) in begin - match ty1sub with + match ty1 with | (_, FuncType(_, tydom, tycod)) -> let () = unify tydom ty2 in (* @@ -539,7 +586,9 @@ let rec typecheck | _ -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in - let () = unify ty1sub (get_range utast1, FuncType(ref [], ty2, beta)) in + let orv = OptionRowVarID.fresh lev in + let optrow = OptionRowVariable(ref (MonoORFree(orv))) in + let () = unify ty1 (get_range utast1, FuncType(optrow, ty2, beta)) in (* let _ = print_for_debug_typecheck ("2 " ^ (string_of_ast (Apply(e1, e2))) ^ " : " ^ (string_of_mono_type_basic beta) ^ " = " ^ (string_of_mono_type_basic beta)) in (* for debug *) *) @@ -549,30 +598,32 @@ let rec typecheck | UTApplyOptional(utast1, utast2) -> let (e1, ty1) = typecheck_iter tyenv utast1 in let (e2, ty2) = typecheck_iter tyenv utast2 in + let eret = ApplyOptional(e1, e2) in begin match ty1 with - | (_, FuncType({contents = tyopt :: tyopttail}, tydom, tycod)) -> + | (_, FuncType(OptionRowCons(tyopt, optrow), tydom, tycod)) -> let () = unify tyopt ty2 in - let tynew = (rng, FuncType(ref tyopttail, tydom, tycod)) in - (Apply(e1, NonValueConstructor("Some", e2)), tynew) + let tynew = (rng, FuncType(optrow, tydom, tycod)) in + (eret, tynew) | _ -> let tvid1 = FreeID.fresh UniversalKind qtfbl lev () in let beta1 = (rng, TypeVariable(ref (MonoFree(tvid1)))) in let tvid2 = FreeID.fresh UniversalKind qtfbl lev () in let beta2 = (rng, TypeVariable(ref (MonoFree(tvid2)))) in - let () = unify ty1 (get_range utast1, FuncType(ref [ty2], beta1, beta2)) in - (Apply(e1, NonValueConstructor("Some", e2)), (rng, FuncType(ref [], beta1, beta2))) - (* doubtful *) + let orv = OptionRowVarID.fresh lev in + let optrow = OptionRowVariable(ref (MonoORFree(orv))) in + let () = unify ty1 (get_range utast1, FuncType(OptionRowCons(ty2, optrow), beta1, beta2)) in + (eret, (rng, FuncType(optrow, beta1, beta2))) end | UTApplyOmission(utast1) -> let (e1, ty1) = typecheck_iter tyenv utast1 in - let eret = Apply(e1, Value(Constructor("None", UnitConstant))) in + let eret = ApplyOmission(e1) in begin match ty1 with - | (_, FuncType({contents = _ :: tyopttail}, _, tycod)) -> - (eret, tycod) + | (_, FuncType(OptionRowCons(_, optrow), tydom, tycod)) -> + (eret, (rng, FuncType(optrow, tydom, tycod))) | _ -> let tvid0 = FreeID.fresh UniversalKind qtfbl lev () in @@ -581,19 +632,21 @@ let rec typecheck let beta1 = (rng, TypeVariable(ref (MonoFree(tvid1)))) in let tvid2 = FreeID.fresh UniversalKind qtfbl lev () in let beta2 = (rng, TypeVariable(ref (MonoFree(tvid2)))) in - let () = unify ty1 (get_range utast1, FuncType(ref [beta0], beta1, beta2)) in - (eret, (rng, FuncType(ref [], beta1, beta2))) + let orv = OptionRowVarID.fresh lev in + let optrow = OptionRowVariable(ref (MonoORFree(orv))) in + let () = unify ty1 (get_range utast1, FuncType(OptionRowCons(beta0, optrow), beta1, beta2)) in + (eret, (rng, FuncType(optrow, beta1, beta2))) end | UTFunction(optargs, utpatbrs) -> - let (tyopts, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in + let (optrow, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in let tvidO = FreeID.fresh UniversalKind qtfbl lev () in let betaO = (Range.dummy "UTFunction:dom", TypeVariable(ref (MonoFree(tvidO)))) in let tvidR = FreeID.fresh UniversalKind qtfbl lev () in let betaR = (Range.dummy "UTFunction:cod", TypeVariable(ref (MonoFree(tvidR)))) in let (patbrs, _) = typecheck_pattern_branch_list qtfbl lev tyenvnew utpatbrs betaO betaR in - let e = append_optional_ids evids (Function(patbrs)) in - (e, (rng, FuncType(ref tyopts, betaO, betaR))) + let e = Function(evids, patbrs) in + (e, (rng, FuncType(optrow, betaO, betaR))) (* let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (varrng, TypeVariable(ref (Free(tvid)))) in @@ -613,8 +666,8 @@ let rec typecheck (PatternMatch(rng, eO, patbrs), tyP) | UTLetNonRecIn(mntyopt, utpat, utast1, utast2) -> - let (pat, tyP, patvarmap) = typecheck_pattern qtfbl (FreeID.succ_level lev) tyenv utpat in - let (e1, ty1) = typecheck qtfbl (FreeID.succ_level lev) tyenv utast1 in + let (pat, tyP, patvarmap) = typecheck_pattern qtfbl (Level.succ lev) tyenv utpat in + let (e1, ty1) = typecheck qtfbl (Level.succ lev) tyenv utast1 in let () = unify ty1 tyP in let tyenvnew = if is_nonexpansive_expression e1 then @@ -809,7 +862,7 @@ let rec typecheck (HorzLex(ectx, ev), (rng, BaseType(BoxColType))) -and typecheck_command_arguments (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : ((mono_type_variable_info ref) command_argument_type) list) : abstract_tree list = +and typecheck_command_arguments (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : mono_command_argument_type list) : abstract_tree list = let rec aux eacc utcmdarglst cmdargtylst = match (utcmdarglst, cmdargtylst) with | ([], _) -> @@ -967,7 +1020,7 @@ and typecheck_path qtfbl lev tyenv (utpathcomplst : (untyped_abstract_tree untyp (List.rev pathcompacc, cycleopt) -and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) (utivlst : untyped_input_vert_element list) = +and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utivlst : untyped_input_vert_element list) = let rec aux (acc : input_vert_element list) (lst : untyped_input_vert_element list) = match lst with | [] -> @@ -1033,7 +1086,7 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID -and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) (utihlst : untyped_input_horz_element list) = +and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utihlst : untyped_input_horz_element list) = let rec aux (acc : input_horz_element Alist.t) (lst : untyped_input_horz_element list) = match lst with | [] -> Alist.to_list acc @@ -1091,7 +1144,7 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID and typecheck_record - (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (flutlst : (field_name * untyped_abstract_tree) list) (rng : Range.t) = let rec aux @@ -1109,7 +1162,7 @@ and typecheck_record (Record(Assoc.of_list elst), (rng, RecordType(Assoc.of_list tylstfinal))) -and typecheck_itemize (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Typeenv.t) (UTItem(utast1, utitmzlst)) = +and typecheck_itemize (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (UTItem(utast1, utitmzlst)) = let (e1, ty1) = typecheck qtfbl lev tyenv utast1 in let () = unify_ tyenv ty1 (Range.dummy "typecheck_itemize_string", BaseType(TextRowType)) in let elst = typecheck_itemize_list qtfbl lev tyenv utitmzlst in @@ -1117,7 +1170,7 @@ and typecheck_itemize (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : Ty and typecheck_itemize_list - (qtfbl : quantifiability) (lev : FreeID.level) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utitmzlst : untyped_itemize list) = match utitmzlst with | [] -> Value(EndOfList) @@ -1128,7 +1181,7 @@ and typecheck_itemize_list and typecheck_pattern_branch_list - (qtfbl : quantifiability) (lev : FreeID.level) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utpatbrs : untyped_pattern_branch list) (tyobj : mono_type) (tyres : mono_type) = let iter = typecheck_pattern_branch_list qtfbl lev in let unify = unify_ tyenv in @@ -1157,7 +1210,7 @@ and typecheck_pattern_branch_list and typecheck_pattern - (qtfbl : quantifiability) (lev : FreeID.level) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) ((rng, utpatmain) : untyped_pattern_tree) : pattern_tree * mono_type * pattern_var_map = let iter = typecheck_pattern qtfbl lev tyenv in @@ -1237,7 +1290,7 @@ and typecheck_pattern and make_type_environment_by_letrec - (qtfbl : quantifiability) (lev : FreeID.level) + (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utrecbinds : untyped_letrec_binding list) = let rec add_mutual_variables (acctyenv : Typeenv.t) (utrecbinds : untyped_letrec_binding list) : (Typeenv.t * (var_name * mono_type * EvalVarID.t) list) = @@ -1247,7 +1300,7 @@ and make_type_environment_by_letrec (acctyenv, []) | UTLetRecBinding(_, varnm, astdef) :: tailcons -> - let tvid = FreeID.fresh UniversalKind qtfbl (FreeID.succ_level lev) () in + let tvid = FreeID.fresh UniversalKind qtfbl (Level.succ lev) () in let tvref = ref (MonoFree(tvid)) in let rng = get_range astdef in let beta = (rng, TypeVariable(tvref)) in @@ -1259,7 +1312,7 @@ and make_type_environment_by_letrec in let rec typecheck_mutual_contents - (lev : FreeID.level) + (lev : level) (tyenvforrec : Typeenv.t) (utrecbinds : untyped_letrec_binding list) (tvtylst : (var_name * mono_type * EvalVarID.t) list) (acctvtylstout : (var_name * mono_type * EvalVarID.t) list) = @@ -1269,7 +1322,7 @@ and make_type_environment_by_letrec | ([], []) -> (tyenvforrec, [], List.rev acctvtylstout) | (UTLetRecBinding(mntyopt, varnm, utast1) :: tailcons, (_, beta, evid) :: tvtytail) -> - let (e1, ty1) = typecheck qtfbl (FreeID.succ_level lev) tyenvforrec utast1 in + let (e1, ty1) = typecheck qtfbl (Level.succ lev) tyenvforrec utast1 in begin match mntyopt with | None -> @@ -1279,8 +1332,8 @@ and make_type_environment_by_letrec in begin match e1 with - | Function(patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) - | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) + | Function([], patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) + | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) end | Some(mnty) -> @@ -1292,8 +1345,8 @@ and make_type_environment_by_letrec in begin match e1 with - | Function(patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) - | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) + | Function([], patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) + | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) end end @@ -1319,7 +1372,7 @@ and make_type_environment_by_letrec (tyenv_forall, tvtylst_forall, mutletcons) -and make_type_environment_by_let_mutable (lev : FreeID.level) (tyenv : Typeenv.t) varrng varnm utastI = +and make_type_environment_by_let_mutable (lev : level) (tyenv : Typeenv.t) varrng varnm utastI = let (eI, tyI) = typecheck Unquantifiable lev tyenv utastI in let () = print_for_debug_typecheck ("#AddMutable " ^ varnm ^ " : " ^ (string_of_mono_type_basic (varrng, RefType(tyI)))) in (* for debug *) let evid = EvalVarID.fresh varnm in @@ -1331,6 +1384,6 @@ let main (tyenv : Typeenv.t) (utast : untyped_abstract_tree) = begin final_tyenv := tyenv; (* Format.printf "%a" pp_untyped_abstract_tree utast; *) - let (e, ty) = typecheck Quantifiable FreeID.bottom_level tyenv utast in + let (e, ty) = typecheck Quantifiable Level.bottom tyenv utast in (ty, !final_tyenv, e) end diff --git a/src/frontend/typeenv.ml b/src/frontend/typeenv.ml index fb35258ad..74d65b971 100644 --- a/src/frontend/typeenv.ml +++ b/src/frontend/typeenv.ml @@ -441,10 +441,10 @@ let add_constructor (constrnm : constructor_name) ((bidlist, pty) : type_scheme) | Some(mtrnew) -> { tyenv with main_tree = mtrnew; } -let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info ref -> a typ) (pairlst : (a typ * BoundID.t) list) (Poly(pty) : poly_type) : a typ = - let bid_to_type_ht : (a typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in +let instantiate_type_scheme (type a) (type b) (freef : Range.t -> mono_type_variable_info ref -> (a, b) typ) (orfreef : mono_option_row_variable_info ref -> (a, b) option_row) (pairlst : ((a, b) typ * BoundID.t) list) (Poly(pty) : poly_type) : (a, b) typ = + let bid_to_type_ht : ((a, b) typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in - let rec aux ((rng, ptymain) : poly_type_variable_info typ) : a typ = + let rec aux ((rng, ptymain) : poly_type_body) : (a, b) typ = match ptymain with | TypeVariable(ptvi) -> begin @@ -460,7 +460,7 @@ let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info end end - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map aux (!tyoptsr)), aux tydom, aux tycod)) + | FuncType(optrow, tydom, tycod) -> (rng, FuncType(aux_or optrow, aux tydom, aux tycod)) | ProductType(tylist) -> (rng, ProductType(List.map aux tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value aux tyasc)) | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, aux tyreal)) @@ -471,6 +471,12 @@ let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type aux) tylist)) | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type aux) tylist)) | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type aux) tylist)) + + and aux_or optrow = + match optrow with + | OptionRowEmpty -> OptionRowEmpty + | OptionRowCons(ty, tail) -> OptionRowCons(aux ty, aux_or tail) + | OptionRowVariable(PolyORFree(orviref)) -> orfreef orviref in begin pairlst |> List.iter (fun (tyarg, bid) -> BoundIDHashTable.add bid_to_type_ht bid tyarg); @@ -478,8 +484,9 @@ let instantiate_type_scheme (type a) (freef : Range.t -> mono_type_variable_info end -let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (freef : Range.t -> mono_type_variable_info ref -> a typ) (typaramf : Range.t -> string -> a type_main) (mnty : manual_type) : a typ = - let rec aux (mnty : manual_type) : a typ = +let rec fix_manual_type_general (type a) (type b) (dpmode : dependency_mode) (tyenv : t) (lev : level) (freef : Range.t -> mono_type_variable_info ref -> (a, b) typ) (orfreef : mono_option_row_variable_info ref -> (a, b) option_row) (typaramf : Range.t -> string -> (a, b) type_main) (mnty : manual_type) : (a, b) typ = + + let rec aux (mnty : manual_type) : (a, b) typ = let (rng, mntymain) = mnty in let error tynm lenexp lenerr = raise (IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr)) @@ -487,7 +494,7 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) let ptymainnew = match mntymain with - | MFuncType(mntyopts, mntydom, mntycod) -> FuncType(ref (List.map aux mntyopts), aux mntydom, aux mntycod) + | MFuncType(mntyopts, mntydom, mntycod) -> FuncType(aux_or mntyopts, aux mntydom, aux mntycod) | MProductType(mntylist) -> ProductType(List.map aux mntylist) | MRecordType(mnasc) -> RecordType(Assoc.map_value aux mnasc) @@ -526,7 +533,7 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) begin try let pairlst = List.combine tyarglist bidlist in - let tyreal = instantiate_type_scheme freef pairlst ptyscheme in + let tyreal = instantiate_type_scheme freef orfreef pairlst ptyscheme in let () = print_for_debug_variantenv ("FS " ^ tynm ^ " -> " ^ TypeID.show_direct tyid) in (* for debug *) SynonymType(tyarglist, tyid, tyreal) with @@ -555,7 +562,7 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) begin try let pairlst = List.combine tyarglist bidlist in - let tyreal = instantiate_type_scheme freef pairlst ptyscheme in + let tyreal = instantiate_type_scheme freef orfreef pairlst ptyscheme in SynonymType(tyarglist, tyid, tyreal) with | Invalid_argument(_) -> @@ -582,21 +589,29 @@ let rec fix_manual_type_general (type a) (dpmode : dependency_mode) (tyenv : t) | MMandatoryArgumentType(mnty) -> MandatoryArgumentType(aux mnty) | MOptionalArgumentType(mnty) -> OptionalArgumentType(aux mnty) + and aux_or mntyopts = + List.fold_right (fun mnty acc -> + OptionRowCons(aux mnty, acc) + ) mntyopts OptionRowEmpty + in aux mnty -and fix_manual_kind_general (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) freef typaramf (mnkd : manual_kind) = +and fix_manual_kind_general (dpmode : dependency_mode) (tyenv : t) (lev : level) freef orfreef typaramf (mnkd : manual_kind) = match mnkd with | MUniversalKind -> UniversalKind - | MRecordKind(mntyasc) -> RecordKind(Assoc.map_value (fix_manual_type_general dpmode tyenv lev freef typaramf) mntyasc) + | MRecordKind(mntyasc) -> RecordKind(Assoc.map_value (fix_manual_type_general dpmode tyenv lev freef orfreef typaramf) mntyasc) -let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) (tyargcons : untyped_type_argument list) (mnty : manual_type) : BoundID.t list * poly_type = +let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : level) (tyargcons : untyped_type_argument list) (mnty : manual_type) : BoundID.t list * poly_type = let bidmaplist = MapList.create () in let freef rng tvref = (rng, TypeVariable(PolyFree(tvref))) in + let orfreef orviref = + OptionRowVariable(PolyORFree(orviref)) + in let typaramf rng param = match MapList.find_opt bidmaplist param with | None -> raise (UndefinedTypeArgument(rng, param, get_candidates MapList.fold bidmaplist param)) @@ -608,7 +623,7 @@ let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) () | (_, tyargnm, mnkd) :: tailcons -> - let kd = fix_manual_kind_general dpmode tyenv lev freef typaramf mnkd in + let kd = fix_manual_kind_general dpmode tyenv lev freef orfreef typaramf mnkd in (* let () = print_for_debug_variantenv ("FMT " ^ tyargnm ^ " :: " ^ (string_of_kind string_of_mono_type_basic kd)) in (* for debug *) *) @@ -620,20 +635,23 @@ let fix_manual_type (dpmode : dependency_mode) (tyenv : t) (lev : FreeID.level) in begin aux tyargcons; - let pty = fix_manual_type_general dpmode tyenv lev freef typaramf mnty in + let pty = fix_manual_type_general dpmode tyenv lev freef orfreef typaramf mnty in let bidlist = MapList.to_list bidmaplist |> List.map (fun (_, bid) -> bid) in (bidlist, Poly(pty)) end (* PUBLIC *) -let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (mnty : manual_type) (constrnts : constraints) : mono_type = +let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : level) (mnty : manual_type) (constrnts : constraints) : mono_type = let tyargmaplist : (string, mono_type_variable_info ref) MapList.t = MapList.create () in let freef rng tvref = (rng, TypeVariable(tvref)) in + let orfreef orviref = + OptionRowVariable(orviref) + in let typaramf rng param = match MapList.find_opt tyargmaplist param with | Some(tvref) -> @@ -650,14 +668,14 @@ let fix_manual_type_free (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev let () = constrnts |> List.iter (fun (param, mkd) -> - let kd = fix_manual_kind_general NoDependency tyenv lev freef typaramf mkd in + let kd = fix_manual_kind_general NoDependency tyenv lev freef orfreef typaramf mkd in let tvid = FreeID.fresh kd qtfbl lev () in let tvref = ref (MonoFree(tvid)) in MapList.add tyargmaplist param tvref ) in - let ty = fix_manual_type_general NoDependency tyenv lev freef typaramf mnty in + let ty = fix_manual_type_general NoDependency tyenv lev freef orfreef typaramf mnty in ty @@ -688,10 +706,13 @@ let register_type_from_vertex (dg : vertex_label DependencyGraph.t) (tyenv : t) | DependencyGraph.UndefinedSourceVertex -> failwith ("'" ^ tynm ^ "' not defined") -let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (constrnm : constructor_name) : (mono_type list * TypeID.t * mono_type) option = +let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : level) (constrnm : constructor_name) : (mono_type list * TypeID.t * mono_type) option = let freef rng tvref = (rng, TypeVariable(tvref)) in + let orfreef orviref = + OptionRowVariable(orviref) + in let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in let open OptionMonad in @@ -705,16 +726,19 @@ let rec find_constructor (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.lev (ty, bid) ) in - let ty = instantiate_type_scheme freef pairlst pty in + let ty = instantiate_type_scheme freef orfreef pairlst pty in let tyarglst = pairlst |> List.map (fun (ty, _) -> ty) in return (tyarglst, tyid, ty) -let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (typeid : TypeID.t) +let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : level) (typeid : TypeID.t) : (constructor_name * (mono_type list -> mono_type)) list = let freef rng tvref = (rng, TypeVariable(tvref)) in + let orfreef orviref = + OptionRowVariable(orviref) + in let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in let open OptionMonad in @@ -723,7 +747,7 @@ let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : Free let constrs = ConstrMap.fold (fun constrnm dfn acc -> let (tyid, (bidlist, pty)) = dfn in if TypeID.equal typeid tyid then - (constrnm, (fun tyarglist -> instantiate_type_scheme freef (List.combine tyarglist bidlist) pty)) :: acc + (constrnm, (fun tyarglist -> instantiate_type_scheme freef orfreef (List.combine tyarglist bidlist) pty)) :: acc else acc ) cdmap [] @@ -737,7 +761,7 @@ let rec enumerate_constructors (qtfbl : quantifiability) (tyenv : t) (lev : Free | None -> [] -let rec find_constructor_candidates (qtfbl : quantifiability) (tyenv : t) (lev : FreeID.level) (constrnm : constructor_name) : constructor_name list = +let rec find_constructor_candidates (qtfbl : quantifiability) (tyenv : t) (lev : level) (constrnm : constructor_name) : constructor_name list = let open OptionMonad in let addrlst = Alist.to_list tyenv.current_address in let mtr = tyenv.main_tree in @@ -755,7 +779,7 @@ let get_moduled_type_name (tyenv : t) (tynm : type_name) = (* PUBLIC *) -let rec add_mutual_cons (tyenv : t) (lev : FreeID.level) (mutvarntcons : untyped_mutual_variant_cons) = +let rec add_mutual_cons (tyenv : t) (lev : level) (mutvarntcons : untyped_mutual_variant_cons) = let dg = DependencyGraph.create 32 in @@ -897,14 +921,13 @@ let add_val_to_signature (sigopt : signature option) (varnm : var_name) (pty : p | Some(tdmap, vtmap) -> Some(tdmap, VarMap.add varnm pty vtmap) -let rec poly_type_equal ((_, ptymain1) : poly_type_variable_info typ) ((_, ptymain2) : poly_type_variable_info typ) = - let iter = poly_type_equal in +let rec poly_type_equal (pty1 : poly_type_body) (pty2 : poly_type_body) = + let combine p lst1 lst2 = try let lst = List.combine lst1 lst2 in p lst with Invalid_argument(_) -> false in - let iter_list lst = - lst |> List.fold_left (fun b (pty1, pty2) -> b && iter pty1 pty2) true - in + + let rec iter ((_, ptymain1) : poly_type_body) ((_, ptymain2) : poly_type_body) = match (ptymain1, ptymain2) with | (BaseType(bt1), BaseType(bt2)) -> bt1 = bt2 @@ -915,8 +938,8 @@ let rec poly_type_equal ((_, ptymain1) : poly_type_variable_info typ) ((_, ptyma | (TypeVariable(PolyFree(_)), TypeVariable(PolyFree(_))) -> false (* -- does not handle free variables -- *) - | (FuncType(tyoptsr1, ty1d, ty1c), FuncType(tyoptsr2, ty2d, ty2c)) -> - (combine iter_list !tyoptsr1 !tyoptsr2) && iter ty1d ty2d && iter ty1c ty2c + | (FuncType(optrow1, ty1d, ty1c), FuncType(optrow2, ty2d, ty2c)) -> + (iter_or optrow1 optrow2) && iter ty1d ty2d && iter ty1c ty2c | (ProductType(tylst1), ProductType(tylst2)) -> combine iter_list tylst1 tylst2 @@ -950,6 +973,19 @@ let rec poly_type_equal ((_, ptymain1) : poly_type_variable_info typ) ((_, ptyma | _ -> false + and iter_list lst = + lst |> List.fold_left (fun b (pty1, pty2) -> b && iter pty1 pty2) true + + and iter_or optrow1 optrow2 = + match (optrow1, optrow2) with + | (OptionRowEmpty, OptionRowEmpty) -> true + | (OptionRowCons(ty1, tail1), OptionRowCons(ty2, tail2)) -> iter ty1 ty2 && iter_or tail1 tail2 + | (OptionRowVariable(_), OptionRowVariable(_)) -> false (* -- does not handle free variables -- *) + | _ -> false + + in + iter pty1 pty2 + (* -- 'reflects pty1 pty2' returns whether 'pty2' is more general than 'pty1' -- *) let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = @@ -957,10 +993,10 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = let current_ht : BoundID.t BoundIDHashtbl.t = BoundIDHashtbl.create 32 in (* -- hash table mapping bound IDs in 'pty2' to bound IDs in 'pty1' -- *) *) - let current_bid_to_ty : (poly_type_variable_info typ) BoundIDHashTable.t = BoundIDHashTable.create 32 in + let current_bid_to_ty : poly_type_body BoundIDHashTable.t = BoundIDHashTable.create 32 in (* -- hash table mapping bound IDs in 'pty2' to types -- *) - let rec aux ((_, tymain1) as ty1 : poly_type_variable_info typ) ((_, tymain2) as ty2 : poly_type_variable_info typ) = + let rec aux ((_, tymain1) as ty1 : poly_type_body) ((_, tymain2) as ty2 : poly_type_body) = (* let () = print_for_debug_variantenv ("reflects " ^ (string_of_mono_type_basic ty1) ^ " << " ^ (string_of_mono_type_basic ty2)) in (* for debug *) *) @@ -968,13 +1004,6 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = tylistcomb |> List.fold_left (fun b (ty1, ty2) -> b && aux ty1 ty2) true in - let rec aux_opt_list tyopts1 tyopts2 = - match (tyopts1, tyopts2) with - | (_, []) -> true - | ([], _ :: _) -> false - | (ty1 :: tytail1, ty2 :: tytail2) -> if aux ty1 ty2 then aux_opt_list tytail1 tytail2 else false - in - match (tymain1, tymain2) with | (SynonymType(tyl1, tyid1, tyreal1), _) -> aux tyreal1 ty2 | (_, SynonymType(tyl2, tyid2, tyreal2)) -> aux ty1 tyreal2 @@ -1058,8 +1087,8 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = else false - | (FuncType(tyopts1r, tyd1, tyc1), FuncType(tyopts2r, tyd2, tyc2)) -> - (aux_opt_list (!tyopts1r) (!tyopts2r)) && (aux tyd1 tyd2) && (aux tyc1 tyc2) + | (FuncType(optrow1, tyd1, tyc1), FuncType(optrow2, tyd2, tyc2)) -> + (aux_or optrow1 optrow2) && (aux tyd1 tyd2) && (aux tyc1 tyc2) (* -- both domain and codomain are covariant -- *) | (HorzCommandType(catyl1), HorzCommandType(catyl2)) @@ -1100,6 +1129,26 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = | (BaseType(bsty1), BaseType(bsty2)) -> bsty1 = bsty2 | _ -> false + and aux_or optrow1 optrow2 = + match (optrow1, optrow2) with + | (_, OptionRowEmpty) -> + true + + | (OptionRowEmpty, OptionRowCons(_)) -> + false + + | (OptionRowCons(ty1, tail1), OptionRowCons(ty2, tail2)) -> + if aux ty1 ty2 then aux_or tail1 tail2 else false + + | (_, OptionRowVariable(PolyORFree(orviref))) -> + begin + match unlift_option_row optrow1 with + | None -> false + | Some(optrow1) -> orviref := MonoORLink(optrow1); true + end + + | (OptionRowVariable(_), _) -> + false and is_stronger_kind (kd1 : poly_kind) (kd2 : poly_kind) = match (kd1, kd2) with @@ -1130,7 +1179,7 @@ let reflects (Poly(pty1) : poly_type) (Poly(pty2) : poly_type) : bool = b -let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tyenv : t) (tyenvprev : t) (msigopt : manual_signature option) = +let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : t) (tyenvprev : t) (msigopt : manual_signature option) = let rec read_manual_signature (tyenvacc : t) (tyenvforsigI : t) (tyenvforsigO : t) (msig : manual_signature) (sigoptacc : signature option) = let iter = read_manual_signature in @@ -1162,11 +1211,11 @@ let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tye | SigValue(varnm, mty, constrntcons) :: tail -> let () = print_for_debug_variantenv ("SIGV " ^ varnm) in (* for debug *) - let tysigI = fix_manual_type_free qtfbl tyenvforsigI (FreeID.succ_level lev) mty constrntcons in + let tysigI = fix_manual_type_free qtfbl tyenvforsigI (Level.succ lev) mty constrntcons in let ptysigI = generalize lev tysigI in - let tysigO = fix_manual_type_free qtfbl tyenvforsigO (FreeID.succ_level lev) mty constrntcons in + let tysigO = fix_manual_type_free qtfbl tyenvforsigO (Level.succ lev) mty constrntcons in let ptysigO = generalize lev tysigO in - let () = print_for_debug_variantenv ("LEVEL " ^ (FreeID.show_direct_level lev) ^ "; " ^ (string_of_mono_type_basic tysigI) ^ " ----> " ^ (string_of_poly_type_basic ptysigI)) in (* for debug *) + let () = print_for_debug_variantenv ("LEVEL " ^ (Level.show lev) ^ "; " ^ (string_of_mono_type_basic tysigI) ^ " ----> " ^ (string_of_poly_type_basic ptysigI)) in (* for debug *) begin match find_for_inner tyenv varnm with | None -> @@ -1186,13 +1235,13 @@ let sigcheck (rng : Range.t) (qtfbl : quantifiability) (lev : FreeID.level) (tye (* let () = print_for_debug_variantenv ("D-OK0 " ^ (string_of_manual_type mty)) in (* for debug *) *) - let tysigI = fix_manual_type_free qtfbl tyenvforsigI (FreeID.succ_level lev) mty constrntcons in + let tysigI = fix_manual_type_free qtfbl tyenvforsigI (Level.succ lev) mty constrntcons in let () = print_for_debug_variantenv "D-OK1" in (* for debug *) let ptysigI = generalize lev tysigI in - let tysigO = fix_manual_type_free qtfbl tyenvforsigO (FreeID.succ_level lev) mty constrntcons in + let tysigO = fix_manual_type_free qtfbl tyenvforsigO (Level.succ lev) mty constrntcons in let () = print_for_debug_variantenv "D-OK2" in (* for debug *) let ptysigO = generalize lev tysigO in - let () = print_for_debug_variantenv ("LEVEL " ^ (FreeID.show_direct_level lev) ^ "; " ^ (string_of_mono_type_basic tysigI) ^ " ----> " ^ (string_of_poly_type_basic ptysigI)) in (* for debug *) + let () = print_for_debug_variantenv ("LEVEL " ^ (Level.show lev) ^ "; " ^ (string_of_mono_type_basic tysigI) ^ " ----> " ^ (string_of_poly_type_basic ptysigI)) in (* for debug *) begin match find_for_inner tyenv csnm with | None -> diff --git a/src/frontend/typeenv.mli b/src/frontend/typeenv.mli index dc2358343..a632e11a5 100644 --- a/src/frontend/typeenv.mli +++ b/src/frontend/typeenv.mli @@ -38,21 +38,21 @@ val enter_new_module : t -> module_name -> t val leave_module : t -> t -val add_mutual_cons : t -> FreeID.level -> untyped_mutual_variant_cons -> t +val add_mutual_cons : t -> level -> untyped_mutual_variant_cons -> t -val find_constructor : quantifiability -> t -> FreeID.level -> constructor_name -> (mono_type list * TypeID.t * mono_type) option +val find_constructor : quantifiability -> t -> level -> constructor_name -> (mono_type list * TypeID.t * mono_type) option -val find_constructor_candidates : quantifiability -> t -> FreeID.level -> constructor_name -> constructor_name list +val find_constructor_candidates : quantifiability -> t -> level -> constructor_name -> constructor_name list -val enumerate_constructors : quantifiability -> t -> FreeID.level -> TypeID.t -> (constructor_name * (mono_type list -> mono_type)) list +val enumerate_constructors : quantifiability -> t -> level -> TypeID.t -> (constructor_name * (mono_type list -> mono_type)) list -val fix_manual_type_free : quantifiability -> t -> FreeID.level -> manual_type -> constraints -> mono_type +val fix_manual_type_free : quantifiability -> t -> level -> manual_type -> constraints -> mono_type val find_type_id : t -> module_name list -> type_name -> Range.t -> TypeID.t option val find_type_name : t -> TypeID.t -> type_name -val sigcheck : Range.t -> quantifiability -> FreeID.level -> t -> t -> manual_signature option -> t +val sigcheck : Range.t -> quantifiability -> level -> t -> t -> manual_signature option -> t module Raw : sig val fresh_type_id : string -> TypeID.t diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index dd33ae531..a0464e4b8 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -48,13 +48,60 @@ type quantifiability = Quantifiable | Unquantifiable [@@deriving show] +module Level +: sig + type t [@@deriving show] + val bottom : t + val succ : t -> t + val less_than : t -> t -> bool + end += struct + type t = int + [@@deriving show] + + let bottom = 0 + + let succ lev = lev + 1 + + let less_than lev1 lev2 = (lev1 < lev2) + end + + +type level = Level.t +[@@deriving show] + + +module OptionRowVarID +: sig + type t [@@deriving show] + val initialize : unit -> unit + val fresh : level -> t + val equal : t -> t -> bool + end += struct + type t = { + level : level; + number : int; + } + [@@deriving show] + + let current_number = ref 0 + + let initialize () = + current_number := 0 + + let equal orv1 orv2 = + (orv1.number = orv2.number) + + let fresh lev = + incr current_number; + {level = lev; number = !current_number; } + end + + module FreeID_ : sig - type level [@@deriving show] type 'a t_ [@@deriving show] - val bottom_level : level - val succ_level : level -> level - val less_than : level -> level -> bool val get_level : 'a t_ -> level val set_level : 'a t_ -> level -> 'a t_ val initialize : unit -> unit @@ -66,21 +113,11 @@ module FreeID_ val set_kind : 'a t_ -> 'a -> 'a t_ val map_kind : ('a -> 'b) -> 'a t_ -> 'b t_ val show_direct : ('a -> string) -> 'a t_ -> string - val show_direct_level : level -> string end = struct - type level = int - [@@deriving show] - type 'a t_ = int * 'a * quantifiability * level [@@deriving show] - let bottom_level = 0 - - let succ_level lev = lev + 1 - - let less_than = (<) - let get_level (_, _, _, lev) = lev let set_level (idmain, kd, qtfbl, _) lev = (idmain, kd, qtfbl, lev) @@ -114,10 +151,8 @@ module FreeID_ let show_direct f (idmain, kd, qtfbl, lev) = match qtfbl with - | Quantifiable -> (string_of_int idmain) ^ "[Q" ^ (string_of_int lev) ^ "::" ^ (f kd) ^ "]" - | Unquantifiable -> (string_of_int idmain) ^ "[U" ^ (string_of_int lev) ^ "::" ^ (f kd) ^ "]" - - let show_direct_level = string_of_int + | Quantifiable -> (string_of_int idmain) ^ "[Q" ^ (Level.show lev) ^ "::" ^ (f kd) ^ "]" + | Unquantifiable -> (string_of_int idmain) ^ "[U" ^ (Level.show lev) ^ "::" ^ (f kd) ^ "]" end @@ -233,50 +268,68 @@ let base_type_hash_table = end -type 'a typ = Range.t * 'a type_main -and 'a type_main = +type ('a, 'b) typ = Range.t * ('a, 'b) type_main +and ('a, 'b) type_main = | BaseType of base_type - | FuncType of (('a typ) list) ref * 'a typ * 'a typ - | ListType of 'a typ - | RefType of 'a typ - | ProductType of ('a typ) list + | FuncType of ('a, 'b) option_row * ('a, 'b) typ * ('a, 'b) typ + | ListType of ('a, 'b) typ + | RefType of ('a, 'b) typ + | ProductType of (('a, 'b) typ) list | TypeVariable of 'a - | SynonymType of ('a typ) list * TypeID.t * 'a typ - | VariantType of ('a typ) list * TypeID.t - | RecordType of ('a typ) Assoc.t + | SynonymType of (('a, 'b) typ) list * TypeID.t * ('a, 'b) typ + | VariantType of (('a, 'b) typ) list * TypeID.t + | RecordType of (('a, 'b) typ) Assoc.t [@printer (fun fmt _ -> Format.fprintf fmt "RecordType(...)")] - | HorzCommandType of ('a command_argument_type) list - | VertCommandType of ('a command_argument_type) list - | MathCommandType of ('a command_argument_type) list + | HorzCommandType of (('a, 'b) command_argument_type) list + | VertCommandType of (('a, 'b) command_argument_type) list + | MathCommandType of (('a, 'b) command_argument_type) list -and 'a command_argument_type = - | MandatoryArgumentType of 'a typ - | OptionalArgumentType of 'a typ +and ('a, 'b) command_argument_type = + | MandatoryArgumentType of ('a, 'b) typ + | OptionalArgumentType of ('a, 'b) typ -and 'a kind = +and ('a, 'b) kind = | UniversalKind - | RecordKind of ('a typ) Assoc.t + | RecordKind of (('a, 'b) typ) Assoc.t [@printer (fun fmt _ -> Format.fprintf fmt "RecordKind(...)")] +and ('a, 'b) option_row = + | OptionRowCons of ('a, 'b) typ * ('a, 'b) option_row + | OptionRowEmpty + | OptionRowVariable of 'b + +and mono_option_row_variable_info = + | MonoORFree of OptionRowVarID.t + | MonoORLink of mono_option_row + +and poly_option_row_variable_info = + | PolyORFree of mono_option_row_variable_info ref + and mono_type_variable_info = | MonoFree of mono_kind FreeID_.t_ | MonoLink of mono_type and poly_type_variable_info = | PolyFree of mono_type_variable_info ref - | PolyBound of (poly_type_variable_info kind) BoundID_.t_ + | PolyBound of ((poly_type_variable_info, poly_option_row_variable_info) kind) BoundID_.t_ -and mono_type = (mono_type_variable_info ref) typ +and mono_type = (mono_type_variable_info ref, mono_option_row_variable_info ref) typ + +and poly_type_body = (poly_type_variable_info, poly_option_row_variable_info) typ and poly_type = - | Poly of poly_type_variable_info typ + | Poly of poly_type_body + +and mono_kind = (mono_type_variable_info ref, mono_option_row_variable_info ref) kind -and mono_kind = (mono_type_variable_info ref) kind +and poly_kind = (poly_type_variable_info, poly_option_row_variable_info) kind -and poly_kind = poly_type_variable_info kind +and mono_option_row = (mono_type_variable_info ref, mono_option_row_variable_info ref) option_row [@@deriving show] +type mono_command_argument_type = (mono_type_variable_info ref, mono_option_row_variable_info ref) command_argument_type +(* type nom_type_variable_info = | NomFree of nom_kind FreeID_.t_ * mono_type_variable_info ref @@ -285,6 +338,8 @@ and nom_kind = nom_type_variable_info kind and nom_type = nom_type_variable_info typ [@@deriving show] +type nom_option_row = nom_type_variable_info option_row +*) module FreeID = struct @@ -606,7 +661,7 @@ and syntactic_value = | Constructor of constructor_name * syntactic_value - | FuncWithEnvironment of pattern_branch list * environment + | FuncWithEnvironment of EvalVarID.t list * pattern_branch list * environment | PrimitiveWithEnvironment of pattern_branch list * environment * int * (abstract_tree list -> abstract_tree) | CompiledFuncWithEnvironment of int * syntactic_value list * int * instruction list * vmenv | CompiledPrimitiveWithEnvironment of int * syntactic_value list * int * instruction list * vmenv * (abstract_tree list -> abstract_tree) @@ -666,8 +721,10 @@ and abstract_tree = | LetNonRecIn of pattern_tree * abstract_tree * abstract_tree | ContentOf of Range.t * EvalVarID.t | IfThenElse of abstract_tree * abstract_tree * abstract_tree - | Function of pattern_branch list + | Function of EvalVarID.t list * pattern_branch list | Apply of abstract_tree * abstract_tree + | ApplyOptional of abstract_tree * abstract_tree + | ApplyOmission of abstract_tree (* -- pattern match -- *) | PatternMatch of Range.t * abstract_tree * pattern_branch list | NonValueConstructor of constructor_name * abstract_tree @@ -779,7 +836,7 @@ let lift_manual_common f = function | MMandatoryArgumentType(mnty) -> f mnty | MOptionalArgumentType(mnty) -> f mnty - +(* (* -- 'normalize_type': eliminates 'Link(_)' -- *) let rec normalize_mono_type (ty : mono_type) : nom_type = let iter = normalize_mono_type in @@ -797,7 +854,7 @@ let rec normalize_mono_type (ty : mono_type) : nom_type = | BaseType(bt) -> (rng, BaseType(bt)) | ListType(tycont) -> (rng, ListType(iter tycont)) | RefType(tycont) -> (rng, RefType(iter tycont)) - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) + | FuncType(optrow, tydom, tycod) -> (rng, FuncType(normalize_option_row optrow, iter tydom, iter tycod)) | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) | RecordType(tyassoc) -> (rng, RecordType(Assoc.map_value iter tyassoc)) | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type iter) tylist)) @@ -811,6 +868,14 @@ and normalize_kind (kd : mono_kind) : nom_kind = | RecordKind(tyasc) -> RecordKind(Assoc.map_value normalize_mono_type tyasc) +and normalize_option_row (optrow : mono_option_row) : nom_option_row = + match optrow with + | OptionRowEmpty -> OptionRowEmpty + | OptionRowCons(ty, tail) -> OptionRowCons(normalize_mono_type ty, normalize_option_row tail) + | OptionRowVariable({contents = OptionRowLink(optrow)}) -> normalize_option_row optrow + | OptionRowVariable(orref) -> OptionRowVariable(orref) + + let rec unnormalize (ty : nom_type) : mono_type = let iter = unnormalize in let (rng, tymain) = ty in @@ -830,7 +895,7 @@ let rec unnormalize (ty : nom_type) : mono_type = | MathCommandType(tylist) -> MathCommandType(List.map (lift_argument_type iter) tylist) in (rng, tymainu) - +*) let rec erase_range_of_type (ty : mono_type) : mono_type = let iter = erase_range_of_type in @@ -845,7 +910,7 @@ let rec erase_range_of_type (ty : mono_type) : mono_type = end | BaseType(_) -> (rng, tymain) - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) + | FuncType(optrow, tydom, tycod) -> (rng, FuncType(erase_range_of_option_row optrow, iter tydom, iter tycod)) | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value iter tyasc)) | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map iter tylist, tyid, iter tyreal)) @@ -857,12 +922,20 @@ let rec erase_range_of_type (ty : mono_type) : mono_type = | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) -and erase_range_of_kind (kd : 'a kind) = +and erase_range_of_kind (kd : mono_kind) = match kd with | UniversalKind -> UniversalKind | RecordKind(asc) -> RecordKind(Assoc.map_value erase_range_of_type asc) +and erase_range_of_option_row (optrow : mono_option_row) = + match optrow with + | OptionRowEmpty -> optrow + | OptionRowCons(ty, tail) -> OptionRowCons(erase_range_of_type ty, erase_range_of_option_row tail) + | OptionRowVariable({contents = MonoORLink(optrow)}) -> erase_range_of_option_row optrow + | OptionRowVariable({contents = MonoORFree(_)}) -> optrow + + module BoundIDHashTable = Hashtbl.Make( struct type t = BoundID.t @@ -880,6 +953,7 @@ module FreeIDHashTable = Hashtbl.Make( let rec instantiate_aux bid_ht lev qtfbl (rng, ptymain) = let aux = instantiate_aux bid_ht lev qtfbl in + let aux_or = instantiate_option_row_aux bid_ht lev qtfbl in match ptymain with | TypeVariable(ptvi) -> begin @@ -904,7 +978,7 @@ let rec instantiate_aux bid_ht lev qtfbl (rng, ptymain) = end end end - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map aux (!tyoptsr)), aux tydom, aux tycod)) + | FuncType(optrow, tydom, tycod) -> (rng, FuncType(aux_or optrow, aux tydom, aux tycod)) | ProductType(tylist) -> (rng, ProductType(List.map aux tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value aux tyasc)) | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map aux tylist, tyid, aux tyreal)) @@ -918,17 +992,27 @@ let rec instantiate_aux bid_ht lev qtfbl (rng, ptymain) = and instantiate_kind_aux bid_ht lev qtfbl (kd : poly_kind) : mono_kind = + let aux = instantiate_aux bid_ht lev qtfbl in match kd with | UniversalKind -> UniversalKind - | RecordKind(tyasc) -> RecordKind(Assoc.map_value (instantiate_aux bid_ht lev qtfbl) tyasc) + | RecordKind(tyasc) -> RecordKind(Assoc.map_value aux tyasc) -let instantiate (lev : FreeID.level) (qtfbl : quantifiability) ((Poly(pty)) : poly_type) : mono_type = +and instantiate_option_row_aux bid_ht lev qtfbl optrow : mono_option_row = + let aux = instantiate_aux bid_ht lev qtfbl in + let aux_or = instantiate_option_row_aux bid_ht lev qtfbl in + match optrow with + | OptionRowEmpty -> OptionRowEmpty + | OptionRowCons(pty, tail) -> OptionRowCons(aux pty, aux_or tail) + | OptionRowVariable(PolyORFree(orviref)) -> OptionRowVariable(orviref) + + +let instantiate (lev : level) (qtfbl : quantifiability) ((Poly(pty)) : poly_type) : mono_type = let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in instantiate_aux bid_ht lev qtfbl pty -let instantiate_kind (lev : FreeID.level) (qtfbl : quantifiability) (pkd : poly_kind) : mono_kind = +let instantiate_kind (lev : level) (qtfbl : quantifiability) (pkd : poly_kind) : mono_kind = let bid_ht : (mono_type_variable_info ref) BoundIDHashTable.t = BoundIDHashTable.create 32 in instantiate_kind_aux bid_ht lev qtfbl pkd @@ -964,7 +1048,7 @@ let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = (rng, TypeVariable(ptvi)) end - | FuncType(tyoptsr, tydom, tycod) -> (rng, FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod)) + | FuncType(optrow, tydom, tycod) -> (rng, FuncType(generalize_option_row optrow, iter tydom, iter tycod)) | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) | RecordType(tyasc) -> (rng, RecordType(Assoc.map_value iter tyasc)) | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map iter tylist, tyid, iter tyreal)) @@ -980,54 +1064,72 @@ let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = match kd with | UniversalKind -> UniversalKind | RecordKind(tyasc) -> RecordKind(Assoc.map_value iter tyasc) + + and generalize_option_row optrow = + match optrow with + | OptionRowEmpty -> OptionRowEmpty + | OptionRowCons(ty, tail) -> OptionRowCons(iter ty, generalize_option_row tail) + | OptionRowVariable(orviref) -> OptionRowVariable(PolyORFree(orviref)) in Poly(iter ty) -let generalize (lev : FreeID.level) = - lift_poly_general (fun tvid -> not (FreeID.is_quantifiable tvid) || not (FreeID.less_than lev (FreeID.get_level tvid))) +let generalize (lev : level) = + lift_poly_general (fun tvid -> not (FreeID.is_quantifiable tvid) || not (Level.less_than lev (FreeID.get_level tvid))) let lift_poly = lift_poly_general (fun _ -> true) -let unlift_poly (pty : poly_type_variable_info typ) : mono_type option = - let rec aux pty = - let (rng, ptymain) = pty in - let ptymainnew = - match ptymain with - | BaseType(bt) -> BaseType(bt) - - | TypeVariable(ptvi) -> - begin - match ptvi with - | PolyFree(tvref) -> TypeVariable(tvref) - | PolyBound(_) -> raise Exit - end - - | FuncType(ptyoptsr, pty1, pty2) -> FuncType(ref (List.map aux !ptyoptsr), aux pty1, aux pty2) - | ProductType(ptylst) -> ProductType(List.map aux ptylst) - | RecordType(ptyasc) -> RecordType(Assoc.map_value aux ptyasc) - | ListType(ptysub) -> ListType(aux ptysub) - | RefType(ptysub) -> RefType(aux ptysub) - | VariantType(ptylst, tyid) -> VariantType(List.map aux ptylst, tyid) - | SynonymType(ptylst, tyid, ptya) -> SynonymType(List.map aux ptylst, tyid, aux ptya) - | HorzCommandType(catyl) -> HorzCommandType(List.map aux_cmd catyl) - | VertCommandType(catyl) -> VertCommandType(List.map aux_cmd catyl) - | MathCommandType(catyl) -> MathCommandType(List.map aux_cmd catyl) - in - (rng, ptymainnew) - - and aux_cmd = function - | MandatoryArgumentType(pty) -> MandatoryArgumentType(aux pty) - | OptionalArgumentType(pty) -> OptionalArgumentType(aux pty) +let rec unlift_aux pty = + let aux = unlift_aux in + let (rng, ptymain) = pty in + let ptymainnew = + match ptymain with + | BaseType(bt) -> BaseType(bt) + | TypeVariable(ptvi) -> + begin + match ptvi with + | PolyFree(tvref) -> TypeVariable(tvref) + | PolyBound(_) -> raise Exit + end + + | FuncType(optrow, pty1, pty2) -> FuncType(unlift_aux_or optrow, aux pty1, aux pty2) + | ProductType(ptylst) -> ProductType(List.map aux ptylst) + | RecordType(ptyasc) -> RecordType(Assoc.map_value aux ptyasc) + | ListType(ptysub) -> ListType(aux ptysub) + | RefType(ptysub) -> RefType(aux ptysub) + | VariantType(ptylst, tyid) -> VariantType(List.map aux ptylst, tyid) + | SynonymType(ptylst, tyid, ptya) -> SynonymType(List.map aux ptylst, tyid, aux ptya) + | HorzCommandType(catyl) -> HorzCommandType(List.map unlift_aux_cmd catyl) + | VertCommandType(catyl) -> VertCommandType(List.map unlift_aux_cmd catyl) + | MathCommandType(catyl) -> MathCommandType(List.map unlift_aux_cmd catyl) in - try Some(aux pty) with - | Exit -> None + (rng, ptymainnew) + + +and unlift_aux_cmd = function + | MandatoryArgumentType(pty) -> MandatoryArgumentType(unlift_aux pty) + | OptionalArgumentType(pty) -> OptionalArgumentType(unlift_aux pty) + + +and unlift_aux_or = function + | OptionRowEmpty -> OptionRowEmpty + | OptionRowCons(pty, tail) -> OptionRowCons(unlift_aux pty, unlift_aux_or tail) + | OptionRowVariable(PolyORFree(orviref)) -> OptionRowVariable(orviref) +let unlift_poly (pty : poly_type_body) : mono_type option = + try Some(unlift_aux pty) with + | Exit -> None + + +let unlift_option_row poptrow = + try Some(unlift_aux_or poptrow) with + | Exit -> None + (* let copy_environment (env : environment) : environment = let (valenv, stenv) = env in @@ -1219,7 +1321,7 @@ let global_hash_env : (string, location) Hashtbl.t = Hashtbl.create 32 (* -- following are all for debugging -- *) -let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) = +let string_of_record_type (type a) (type b) (f : (a, b) typ -> string) (asc : ((a, b) typ) Assoc.t) = let rec aux lst = match lst with | [] -> " -- " @@ -1229,7 +1331,7 @@ let string_of_record_type (type a) (f : a typ -> string) (asc : (a typ) Assoc.t) "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let string_of_kind (type a) (f : a typ -> string) (kdstr : a kind) = +let string_of_kind (type a) (type b) (f : (a, b) typ -> string) (kdstr : (a, b) kind) = let rec aux lst = match lst with | [] -> " -- " @@ -1275,22 +1377,11 @@ let rec string_of_type_basic tvf tystr : string = | SynonymType(tyarglist, tyid, tyreal) -> (string_of_type_argument_list_basic tvf tyarglist) ^ (TypeID.show_direct tyid) ^ "@ (= " ^ (iter tyreal) ^ ")" - | FuncType(tyoptsr, tydom, tycod) -> - let stropts = - !tyoptsr |> List.map (fun ((_, tymain) as ty) -> - let s = iter ty in - match tymain with - | FuncType(_, _, _) - | ProductType(_) - | VariantType(_ :: _, _) - -> "(" ^ s ^ ")? -> " - - | _ -> s ^ "? -> " - ) - in + | FuncType(optrow, tydom, tycod) -> + let stropts = string_of_option_row_basic tvf optrow in let strdom = iter tydom in let strcod = iter tycod in - (String.concat "" stropts) ^ + stropts ^ begin match tydom with | (_, FuncType(_, _, _)) -> "(" ^ strdom ^ ")" | _ -> strdom @@ -1347,6 +1438,28 @@ let rec string_of_type_basic tvf tystr : string = "[" ^ (String.concat "; " slist) ^ "] math-command" +and string_of_option_row_basic tvf = function + | OptionRowEmpty -> "" + + | OptionRowVariable(_) -> "..." (* TEMPORARY *) + + | OptionRowCons(ty, tail) -> + let strtysub = string_of_type_basic tvf ty in + let strty = + let (_, tymain) = ty in + match tymain with + | FuncType(_, _, _) + | ProductType(_) + | ListType(_) + | RefType(_) + | VariantType(_ :: _, _) + -> "(" ^ strtysub ^ ")" + + | _ -> strtysub + in + strty ^ "?-> " ^ (string_of_option_row_basic tvf tail) + + and string_of_command_argument_type tvf = function | MandatoryArgumentType(ty) -> string_of_type_basic tvf ty | OptionalArgumentType(ty) -> "(" ^ (string_of_type_basic tvf ty) ^ ")?" From 832950a7ff98584ab1add12c7310c0f1cd38395e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 5 Aug 2018 18:01:15 +0900 Subject: [PATCH 09/42] fix bug of unification --- src/frontend/typechecker.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index f5077f3a9..aa61d7918 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -377,7 +377,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : and unify_option_row optrow1 optrow2 = match (optrow1, optrow2) with | (OptionRowVariable({contents = MonoORLink(optrow1)}), _) -> unify_option_row optrow1 optrow2 - | (_, OptionRowVariable({contents = MonoORLink(optrow1)})) -> unify_option_row optrow1 optrow2 + | (_, OptionRowVariable({contents = MonoORLink(optrow2)})) -> unify_option_row optrow1 optrow2 | (OptionRowCons(ty1, tail1), OptionRowCons(ty2, tail2)) -> unify_sub ty1 ty2; From e040c00095a57b6c9f690efd72fa9e1459f2fbfa Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 5 Aug 2018 19:33:19 +0900 Subject: [PATCH 10/42] improve how to display types --- src/frontend/display.ml | 230 ++++++++++++++++++++-------------------- src/frontend/main.ml | 10 +- 2 files changed, 121 insertions(+), 119 deletions(-) diff --git a/src/frontend/display.ml b/src/frontend/display.ml index cdea94d14..71be5ebc4 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -95,15 +95,22 @@ module GeneralIDHashTable end -let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) ((_, tymain) : ('a, 'b) typ) = - let iter = string_of_mono_type_sub tvf tyenv current_ht in - let iter_cmd = string_of_command_argument_type tvf tyenv current_ht in - let iter_args = string_of_type_argument_list tvf tyenv current_ht in - let iter_list = string_of_mono_type_list tvf tyenv current_ht in - let iter_or = string_of_option_row tvf tyenv current_ht in +type paren_level = + | Outmost + | DomainSide + | ProductElement + | Single + + +let rec string_of_mono_type_sub (tvf : paren_level -> 'a -> string) ortvf (tyenv : Typeenv.t) (current_ht : int GeneralIDHashTable.t) (plev : paren_level) ((_, tymain) : ('a, 'b) typ) = + let iter = string_of_mono_type_sub tvf ortvf tyenv current_ht in + let iter_cmd = string_of_command_argument_type tvf ortvf tyenv current_ht in + let iter_args = string_of_type_argument_list tvf ortvf tyenv current_ht in + let iter_prod = string_of_product tvf ortvf tyenv current_ht in + let iter_or = string_of_option_row tvf ortvf tyenv current_ht in match tymain with - | TypeVariable(tvi) -> tvf tvi + | TypeVariable(tvi) -> tvf plev tvi (* (* "${" ^ iter tyl ^ "}" (* TEMPORARY *) @@ -136,51 +143,64 @@ let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (curren | BaseType(MathType) -> "math" | BaseType(RegExpType) -> "regexp" - | VariantType(tyarglist, tyid) -> (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) + | VariantType(tyarglist, tyid) -> + let s = (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) in + begin + match (tyarglist, plev) with + | (_ :: _, Single) -> "(" ^ s ^ ")" + | _ -> s + end - | SynonymType(tyarglist, tyid, tyreal) -> (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) - ^ " (= " ^ (iter tyreal) ^ ")" + | SynonymType(tyarglist, tyid, tyreal) -> + let s = + (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) + ^ " (= " ^ (iter Single tyreal) ^ ")" + in + begin + match (tyarglist, plev) with + | (_ :: _, Single) -> "(" ^ s ^ ")" + | _ -> s + end | FuncType(optrow, ((_, tydommain) as tydom), tycod) -> let stropts = iter_or optrow in - let strdom = iter tydom in - let strcod = iter tycod in - stropts ^ - begin - match tydommain with - | FuncType(_, _, _) -> "(" ^ strdom ^ ")" - | _ -> strdom - end ^ " -> " ^ strcod + let strdom = iter DomainSide tydom in + let strcod = iter Outmost tycod in + let s = stropts ^ strdom ^ " -> " ^ strcod in + begin + match plev with + | Single | ProductElement | DomainSide -> "(" ^ s ^ ")" + | _ -> s + end - | ListType((_, tycontmain) as tycont) -> - let strcont = iter tycont in - begin - match tycontmain with - | FuncType(_, _, _) - | ProductType(_) - | ListType(_) - | RefType(_) - | VariantType(_ :: _, _) - -> "(" ^ strcont ^ ")" - | _ -> strcont - end ^ " list" - - | RefType((_, tycontmain) as tycont) -> - let strcont = iter tycont in + | ListType(tycont) -> + let strcont = iter Single tycont in + let s = strcont ^ " list" in + begin + match plev with + | Single -> "(" ^ s ^ ")" + | _ -> s + end + + | RefType(tycont) -> + let strcont = iter Single tycont in + let s = strcont ^ " ref" in begin - match tycontmain with - | FuncType(_, _, _) - | ProductType(_) - | ListType(_) - | RefType(_) - | VariantType(_ :: _, _) - -> "(" ^ strcont ^ ")" - | _ -> strcont - end ^ " ref" + match plev with + | Single -> "(" ^ s ^ ")" + | _ -> s + end - | ProductType(tylist) -> iter_list tylist + | ProductType(tylist) -> + let s = iter_prod tylist in + begin + match plev with + | Single | ProductElement -> "(" ^ s ^ ")" + | _ -> s + end - | RecordType(asc) -> string_of_record_type iter asc + | RecordType(asc) -> + string_of_record_type (iter Outmost) asc | HorzCommandType(cmdargtylist) -> let slist = List.map iter_cmd cmdargtylist in @@ -195,75 +215,49 @@ let rec string_of_mono_type_sub (tvf : 'a -> string) (tyenv : Typeenv.t) (curren "[" ^ (String.concat "; " slist) ^ "] math-cmd" -and string_of_option_row tvf tyenv current_ht = function +and string_of_option_row tvf ortvf tyenv current_ht = function | OptionRowEmpty -> "" - | OptionRowVariable(_) -> "..." (* temporary *) + | OptionRowVariable(orvi) -> ortvf orvi - | OptionRowCons((_, tymain) as ty, tail) -> - let stysub = string_of_mono_type_sub tvf tyenv current_ht ty in - let sty = - match tymain with - | FuncType(_, _, _) -> "(" ^ stysub ^ ")" - | _ -> stysub - in - sty ^ "?-> " ^ (string_of_option_row tvf tyenv current_ht tail) + | OptionRowCons(ty, tail) -> + let s = string_of_mono_type_sub tvf ortvf tyenv current_ht DomainSide ty in + s ^ "?-> " ^ (string_of_option_row tvf ortvf tyenv current_ht tail) -and string_of_command_argument_type tvf tyenv current_ht = function +and string_of_command_argument_type tvf ortvf tyenv current_ht cmdargty = + let iter = string_of_mono_type_sub tvf ortvf tyenv current_ht in + match cmdargty with | MandatoryArgumentType(ty) -> - string_of_mono_type_sub tvf tyenv current_ht ty + iter Outmost ty - | OptionalArgumentType((_, tymain) as ty) -> - let strty = string_of_mono_type_sub tvf tyenv current_ht ty in - begin - match tymain with - | ProductType(_) - | FuncType(_, _, _) - -> "(" ^ strty ^ ")?" - - | _ -> strty ^ "?" - end + | OptionalArgumentType(ty) -> + let strty = iter Outmost ty in + strty ^ "?" -and string_of_type_argument_list tvf tyenv current_ht tyarglist = - let iter = string_of_mono_type_sub tvf tyenv current_ht in - let iter_args = string_of_type_argument_list tvf tyenv current_ht in +and string_of_type_argument_list tvf ortvf tyenv current_ht tyarglist = + let iter = string_of_mono_type_sub tvf ortvf tyenv current_ht in + let iter_args = string_of_type_argument_list tvf ortvf tyenv current_ht in match tyarglist with - | [] -> "" + | [] -> + "" + | head :: tail -> - let strhd = iter head in + let strhd = iter Single head in let strtl = iter_args tail in - let (_, headmain) = head in - begin - match headmain with - | FuncType(_, _, _) - | ProductType(_) - (* | TypeSynonym(_ :: _, _, _) *) (* temporary *) - | ListType(_) - | RefType(_) - | VariantType(_ :: _, _) - -> "(" ^ strhd ^ ")" - | _ -> strhd - end ^ " " ^ strtl - - -and string_of_mono_type_list tvf tyenv current_ht tylist = - let iter = string_of_mono_type_sub tvf tyenv current_ht in - let iter_list = string_of_mono_type_list tvf tyenv current_ht in + strhd ^ " " ^ strtl + + +and string_of_product tvf ortvf tyenv current_ht tylist = + let iter = string_of_mono_type_sub tvf ortvf tyenv current_ht in + let iter_list = string_of_product tvf ortvf tyenv current_ht in match tylist with | [] -> "" | head :: tail -> - let strhead = iter head in + let strhead = iter ProductElement head in let strtail = iter_list tail in - let (_, headmain) = head in - begin - match headmain with - | ProductType(_) - | FuncType(_, _, _) - -> "(" ^ strhead ^ ")" - | _ -> strhead - end ^ + strhead ^ begin match tail with | [] -> "" @@ -271,43 +265,47 @@ and string_of_mono_type_list tvf tyenv current_ht tylist = end -let rec tvf_mono current_ht tyenv tvi = +let rec tvf_mono current_ht tyenv plev tvi = + let iter = string_of_mono_type_sub (tvf_mono current_ht tyenv) (ortvf_mono current_ht tyenv) tyenv current_ht in match !tvi with | MonoFree(tvid) -> let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) + show_type_variable (iter Outmost) s (FreeID.get_kind tvid) | MonoLink(ty) -> - "(" ^ (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty) ^ ")" - (* temporary; should omit unnecessary parentheses *) + iter plev ty + +and ortvf_mono current_ht tyenv orvi = + match !orvi with + | MonoORFree(_) -> "...?-> " + | MonoORLink(optrow) -> string_of_option_row (tvf_mono current_ht tyenv) (ortvf_mono current_ht tyenv) tyenv current_ht optrow -let rec tvf_poly current_ht tyenv ptvi = + +let rec tvf_poly current_ht tyenv plev ptvi = + let iter_poly = string_of_mono_type_sub (tvf_poly current_ht tyenv) (ortvf_poly current_ht tyenv) tyenv current_ht in match ptvi with | PolyFree(tvref) -> - begin - match !tvref with - | MonoFree(tvid) -> - let num = GeneralIDHashTable.intern_number current_ht (FreeID(tvid)) in - let s = (if FreeID.is_quantifiable tvid then "'" else "'_") ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht) s (FreeID.get_kind tvid) - - | MonoLink(ty) -> - "(" ^ (string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty) ^ ")" - end + tvf_mono current_ht tyenv plev tvref | PolyBound(bid) -> let num = GeneralIDHashTable.intern_number current_ht (BoundID(bid)) in let s = "'#" ^ (variable_name_of_number num) in - show_type_variable (string_of_mono_type_sub (tvf_poly current_ht tyenv) tyenv current_ht) s (BoundID.get_kind bid) + show_type_variable (iter_poly Outmost) s (BoundID.get_kind bid) + + +and ortvf_poly current_ht tyenv porvi = + match porvi with + | PolyORFree(orviref) -> + ortvf_mono current_ht tyenv orviref let string_of_mono_type (tyenv : Typeenv.t) (ty : mono_type) = begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in - string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht ty + string_of_mono_type_sub (tvf_mono current_ht tyenv) (ortvf_mono current_ht tyenv) tyenv current_ht Outmost ty end @@ -315,7 +313,7 @@ let string_of_mono_type_double (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in - let strf = string_of_mono_type_sub (tvf_mono current_ht tyenv) tyenv current_ht in + let strf = string_of_mono_type_sub (tvf_mono current_ht tyenv) (ortvf_mono current_ht tyenv) tyenv current_ht Outmost in let strty1 = strf ty1 in let strty2 = strf ty2 in (strty1, strty2) @@ -326,7 +324,7 @@ let string_of_poly_type (tyenv : Typeenv.t) (Poly(pty) : poly_type) = begin GeneralIDHashTable.initialize (); let current_ht = GeneralIDHashTable.create 32 in - string_of_mono_type_sub (tvf_poly current_ht tyenv) tyenv current_ht pty + string_of_mono_type_sub (tvf_poly current_ht tyenv) (ortvf_poly current_ht tyenv) tyenv current_ht Outmost pty end diff --git a/src/frontend/main.ml b/src/frontend/main.ml index d86baabea..3c6761f9c 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -46,10 +46,10 @@ let report_error (cat : error_category) (lines : line list) = match lst with | [] -> () | NormalLine(s) :: tail - | NormalLineOption(Some(s)) :: tail + | NormalLineOption(Some(s)) :: tail -> begin print_endline (" " ^ s) ; aux tail end | DisplayLine(s) :: tail - | DisplayLineOption(Some(s)) :: tail + | DisplayLineOption(Some(s)) :: tail -> begin print_endline (" " ^ s); aux tail end | _ :: tail -> aux tail in @@ -60,7 +60,7 @@ let report_error (cat : error_category) (lines : line list) = | NormalLineOption(Some(s)) :: tail -> begin print_endline s; aux tail end | DisplayLine(s) :: tail - | DisplayLineOption(Some(s)) :: tail + | DisplayLineOption(Some(s)) :: tail -> begin print_endline ("\n " ^ s); aux tail end | _ :: tail -> aux tail in @@ -621,10 +621,14 @@ let error_log_environment suspended = NormalLine("at " ^ (Range.to_string rng) ^ ":"); NormalLine("The implementation of value '" ^ varnm ^ "' has type"); DisplayLine(Display.string_of_poly_type tyenv1 pty1); +(* DisplayLine(string_of_poly_type_basic pty1); (* FOR DEBUG *) +*) NormalLine("which is inconsistent with the type required by the signature"); DisplayLine(Display.string_of_poly_type tyenv2 pty2); +(* DisplayLine(string_of_poly_type_basic pty2); (* FOR DEBUG *) +*) ] | Typechecker.ContradictionError(tyenv, ((rng1, _) as ty1), ((rng2, _) as ty2)) -> From 2c84f03f523a4001ecc6c332bae429ec273ec529 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 6 Aug 2018 00:30:09 +0900 Subject: [PATCH 11/42] fix typechecker (but find bug of level-based generalization) --- src/frontend/typechecker.ml | 24 ++++-- src/frontend/types_.cppo.ml | 166 ++++++++++++++++++++++++++---------- 2 files changed, 140 insertions(+), 50 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index aa61d7918..330396a43 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -208,8 +208,18 @@ let rec occurs (tvid : FreeID.t) (ty : mono_type) = let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : mono_type) = + + (* begin: for debug *) + let () = + match (tymain1, tymain2) with + | (TypeVariable({contents = MonoLink(_)}), _) -> () + | (_, TypeVariable({contents = MonoLink(_)})) -> () + | _ -> print_endline (" | unify " ^ (string_of_mono_type_basic ty1) ^ " == " ^ (string_of_mono_type_basic ty2)) + in + (* end: for debug *) + let unify_list = List.iter (fun (t1, t2) -> unify_sub t1 t2) in - let () = print_for_debug_typecheck (" | unify " ^ (string_of_mono_type_basic ty1) ^ " == " ^ (string_of_mono_type_basic ty2)) in (* for debug *) + match (tymain1, tymain2) with | (SynonymType(_, _, tyreal1), _) -> unify_sub tyreal1 ty2 @@ -494,9 +504,9 @@ let rec typecheck | Some((pty, evid)) -> let tyfree = instantiate lev qtfbl pty in let tyres = overwrite_range_of_type tyfree rng in -(* + let () = print_endline ("\n#Content " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty) ^ " = " ^ (string_of_mono_type_basic tyres) ^ "\n (" ^ (Range.to_string rng) ^ ")") in (* for debug *) -*) + (ContentOf(rng, evid), tyres) end @@ -608,9 +618,9 @@ let rec typecheck | _ -> let tvid1 = FreeID.fresh UniversalKind qtfbl lev () in - let beta1 = (rng, TypeVariable(ref (MonoFree(tvid1)))) in + let beta1 = (Range.dummy "UTApplyOptional:dom", TypeVariable(ref (MonoFree(tvid1)))) in let tvid2 = FreeID.fresh UniversalKind qtfbl lev () in - let beta2 = (rng, TypeVariable(ref (MonoFree(tvid2)))) in + let beta2 = (Range.dummy "UTApplyOptional:cod", TypeVariable(ref (MonoFree(tvid2)))) in let orv = OptionRowVarID.fresh lev in let optrow = OptionRowVariable(ref (MonoORFree(orv))) in let () = unify ty1 (get_range utast1, FuncType(OptionRowCons(ty2, optrow), beta1, beta2)) in @@ -1358,9 +1368,9 @@ and make_type_environment_by_letrec | [] -> (tyenv, tvtylst_forall) | (varnm, tvty, evid) :: tvtytail -> let prety = tvty in - let () = print_for_debug_typecheck ("#Generalize1 " ^ varnm ^ " : " ^ (string_of_mono_type_basic prety)) in (* for debug *) + let () = print_endline ("#Generalize1 " ^ varnm ^ " : " ^ (string_of_mono_type_basic prety)) in (* for debug *) let pty = (generalize lev (erase_range_of_type prety)) in - let () = print_for_debug_typecheck ("#Generalize2 " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty)) in (* for debug *) + let () = print_endline ("#Generalize2 " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty)) in (* for debug *) let tvtylst_forall_new = (varnm, pty, evid) :: tvtylst_forall in make_forall_type_mutual (Typeenv.add tyenv varnm (pty, evid)) tyenv_before_let tvtytail tvtylst_forall_new in diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index a0464e4b8..654761408 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -77,6 +77,7 @@ module OptionRowVarID val initialize : unit -> unit val fresh : level -> t val equal : t -> t -> bool + val get_level : t -> level end = struct type t = { @@ -96,6 +97,9 @@ module OptionRowVarID let fresh lev = incr current_number; {level = lev; number = !current_number; } + + let get_level orv = + orv.level end @@ -1017,7 +1021,7 @@ let instantiate_kind (lev : level) (qtfbl : quantifiability) (pkd : poly_kind) : instantiate_kind_aux bid_ht lev qtfbl pkd -let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = +let lift_poly_general (ptv : FreeID.t -> bool) (porv : OptionRowVarID.t -> bool) (ty : mono_type) : poly_type = let tvidht = FreeIDHashTable.create 32 in let rec iter (rng, tymain) = match tymain with @@ -1029,7 +1033,7 @@ let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = | MonoFree(tvid) -> let ptvi = - if p tvid then + if not (ptv tvid) then PolyFree(tvref) else begin @@ -1069,17 +1073,86 @@ let lift_poly_general (p : FreeID.t -> bool) (ty : mono_type) : poly_type = match optrow with | OptionRowEmpty -> OptionRowEmpty | OptionRowCons(ty, tail) -> OptionRowCons(iter ty, generalize_option_row tail) - | OptionRowVariable(orviref) -> OptionRowVariable(PolyORFree(orviref)) + + | OptionRowVariable(orviref) -> + begin + match !orviref with + | MonoORFree(orv) -> + if porv orv then + OptionRowEmpty + else + OptionRowVariable(PolyORFree(orviref)) + + | MonoORLink(optraw) -> + generalize_option_row optrow + end in Poly(iter ty) +let check_level lev (ty : mono_type) = + let rec iter (_, tymain) = + match tymain with + | TypeVariable(tvref) -> + begin + match !tvref with + | MonoLink(ty) -> iter ty + | MonoFree(tvid) -> Level.less_than lev (FreeID.get_level tvid) + end + + | ProductType(tylst) -> List.for_all iter tylst + | RecordType(tyasc) -> Assoc.fold_value (fun b ty -> b && iter ty) true tyasc + | FuncType(optrow, tydom, tycod) -> iter_or optrow && iter tydom && iter tycod + | RefType(tycont) -> iter tycont + | BaseType(_) -> true + | ListType(tycont) -> iter tycont + | VariantType(tylst, _) -> List.for_all iter tylst + | SynonymType(tylst, _, tyact) -> List.for_all iter tylst && iter tyact + + | HorzCommandType(cmdargtylst) + | VertCommandType(cmdargtylst) + | MathCommandType(cmdargtylst) + -> + List.for_all iter_cmd cmdargtylst + + and iter_cmd = function + | MandatoryArgumentType(ty) -> iter ty + | OptionalArgumentType(ty) -> iter ty + + and iter_or = function + | OptionRowEmpty -> true + + | OptionRowCons(ty, tail) -> iter ty && iter_or tail + + | OptionRowVariable(orviref) -> + begin + match !orviref with + | MonoORFree(orv) -> Level.less_than lev (OptionRowVarID.get_level orv) + | MonoORLink(optrow) -> iter_or optrow + end + + in + iter ty + + let generalize (lev : level) = - lift_poly_general (fun tvid -> not (FreeID.is_quantifiable tvid) || not (Level.less_than lev (FreeID.get_level tvid))) + let ptv tvid = + let bkd = + let kd = FreeID.get_kind tvid in + match kd with + | UniversalKind -> true + | RecordKind(asc) -> Assoc.fold_value (fun b ty -> b && (check_level lev ty)) true asc + in + FreeID.is_quantifiable tvid && Level.less_than lev (FreeID.get_level tvid) && bkd + in + let porv orv = + not (Level.less_than lev (OptionRowVarID.get_level orv)) + in + lift_poly_general ptv porv let lift_poly = - lift_poly_general (fun _ -> true) + lift_poly_general (fun _ -> false) (fun _ -> false) let rec unlift_aux pty = @@ -1343,8 +1416,8 @@ let string_of_kind (type a) (type b) (f : (a, b) typ -> string) (kdstr : (a, b) | RecordKind(asc) -> "(|" ^ (aux (Assoc.to_list asc)) ^ "|)" -let rec string_of_type_basic tvf tystr : string = - let iter = string_of_type_basic tvf in +let rec string_of_type_basic tvf orvf tystr : string = + let iter = string_of_type_basic tvf orvf in let (rng, tymain) = tystr in let qstn = if Range.is_dummy rng then "%" else "" in match tymain with @@ -1372,13 +1445,13 @@ let rec string_of_type_basic tvf tystr : string = | BaseType(RegExpType) -> "regexp" ^ qstn | VariantType(tyarglist, tyid) -> - (string_of_type_argument_list_basic tvf tyarglist) ^ (TypeID.show_direct tyid) (* temporary *) ^ "@" ^ qstn + (string_of_type_argument_list_basic tvf orvf tyarglist) ^ (TypeID.show_direct tyid) (* temporary *) ^ "@" ^ qstn | SynonymType(tyarglist, tyid, tyreal) -> - (string_of_type_argument_list_basic tvf tyarglist) ^ (TypeID.show_direct tyid) ^ "@ (= " ^ (iter tyreal) ^ ")" + (string_of_type_argument_list_basic tvf orvf tyarglist) ^ (TypeID.show_direct tyid) ^ "@ (= " ^ (iter tyreal) ^ ")" | FuncType(optrow, tydom, tycod) -> - let stropts = string_of_option_row_basic tvf optrow in + let stropts = string_of_option_row_basic tvf orvf optrow in let strdom = iter tydom in let strcod = iter tycod in stropts ^ @@ -1417,7 +1490,7 @@ let rec string_of_type_basic tvf tystr : string = end ^ " ref" ^ qstn | ProductType(tylist) -> - string_of_type_list_basic tvf tylist + string_of_type_list_basic tvf orvf tylist | TypeVariable(tvi) -> tvf qstn tvi @@ -1426,25 +1499,25 @@ let rec string_of_type_basic tvf tystr : string = string_of_record_type iter asc | HorzCommandType(tylist) -> - let slist = List.map (string_of_command_argument_type tvf) tylist in + let slist = List.map (string_of_command_argument_type tvf orvf) tylist in "[" ^ (String.concat "; " slist) ^ "] horz-command" | VertCommandType(tylist) -> - let slist = List.map (string_of_command_argument_type tvf) tylist in + let slist = List.map (string_of_command_argument_type tvf orvf) tylist in "[" ^ (String.concat "; " slist) ^ "] vert-command" | MathCommandType(tylist) -> - let slist = List.map (string_of_command_argument_type tvf) tylist in + let slist = List.map (string_of_command_argument_type tvf orvf) tylist in "[" ^ (String.concat "; " slist) ^ "] math-command" -and string_of_option_row_basic tvf = function +and string_of_option_row_basic tvf orvf = function | OptionRowEmpty -> "" - | OptionRowVariable(_) -> "..." (* TEMPORARY *) + | OptionRowVariable(orvi) -> orvf orvi | OptionRowCons(ty, tail) -> - let strtysub = string_of_type_basic tvf ty in + let strtysub = string_of_type_basic tvf orvf ty in let strty = let (_, tymain) = ty in match tymain with @@ -1457,20 +1530,20 @@ and string_of_option_row_basic tvf = function | _ -> strtysub in - strty ^ "?-> " ^ (string_of_option_row_basic tvf tail) + strty ^ "?-> " ^ (string_of_option_row_basic tvf orvf tail) -and string_of_command_argument_type tvf = function - | MandatoryArgumentType(ty) -> string_of_type_basic tvf ty - | OptionalArgumentType(ty) -> "(" ^ (string_of_type_basic tvf ty) ^ ")?" +and string_of_command_argument_type tvf orvf = function + | MandatoryArgumentType(ty) -> string_of_type_basic tvf orvf ty + | OptionalArgumentType(ty) -> "(" ^ (string_of_type_basic tvf orvf ty) ^ ")?" -and string_of_type_argument_list_basic tvf tyarglist = +and string_of_type_argument_list_basic tvf orvf tyarglist = match tyarglist with | [] -> "" | head :: tail -> - let strhd = string_of_type_basic tvf head in - let strtl = string_of_type_argument_list_basic tvf tail in + let strhd = string_of_type_basic tvf orvf head in + let strtl = string_of_type_argument_list_basic tvf orvf tail in let (_, headmain) = head in begin match headmain with @@ -1485,11 +1558,11 @@ and string_of_type_argument_list_basic tvf tyarglist = end ^ " " ^ strtl -and string_of_type_list_basic tvf tylist = +and string_of_type_list_basic tvf orvf tylist = match tylist with | [] -> "" | head :: [] -> - let strhd = string_of_type_basic tvf head in + let strhd = string_of_type_basic tvf orvf head in let (_, headmain) = head in begin match headmain with @@ -1499,8 +1572,8 @@ and string_of_type_list_basic tvf tylist = | _ -> strhd end | head :: tail -> - let strhd = string_of_type_basic tvf head in - let strtl = string_of_type_list_basic tvf tail in + let strhd = string_of_type_basic tvf orvf head in + let strtl = string_of_type_list_basic tvf orvf tail in let (_, headmain) = head in begin match headmain with @@ -1510,29 +1583,36 @@ and string_of_type_list_basic tvf tylist = | _ -> strhd end ^ " * " ^ strtl -let rec string_of_mono_type_basic ty = - let tvf qstn tvref = - match !tvref with - | MonoLink(tyl) -> "$(" ^ (string_of_mono_type_basic tyl) ^ ")" - | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn - in - string_of_type_basic tvf ty + +let rec tvf_mono qstn tvref = + match !tvref with + | MonoLink(tyl) -> "$(" ^ (string_of_mono_type_basic tyl) ^ ")" + | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn + + +and orvf_mono orvref = + match !orvref with + | MonoORFree(orv) -> "...?-> " + | MonoORLink(optrow) -> string_of_option_row_basic tvf_mono orvf_mono optrow + + +and string_of_mono_type_basic ty = + string_of_type_basic tvf_mono orvf_mono ty let rec string_of_poly_type_basic (Poly(pty)) = - let ptvf qstn ptvi = + let tvf_poly qstn ptvi = match ptvi with | PolyBound(bid) -> "'#" ^ (BoundID.show_direct (string_of_kind (fun ty -> string_of_poly_type_basic (Poly(ty)))) bid) ^ qstn - | PolyFree(tvref) -> - begin - match !tvref with - | MonoFree(tvid) -> "'" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ qstn - | MonoLink(ty) -> string_of_mono_type_basic ty - end + | PolyFree(tvref) -> tvf_mono qstn tvref + in + let ortvf orvi = + match orvi with + | PolyORFree(orvref) -> orvf_mono orvref in - string_of_type_basic ptvf pty + string_of_type_basic tvf_poly ortvf pty and string_of_kind_basic kd = string_of_kind string_of_mono_type_basic kd From d40d142ed7c1b1d433bc21c2f8e2c07c3882efca Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 6 Aug 2018 00:30:28 +0900 Subject: [PATCH 12/42] update 'cd.satyh' --- lib-satysfi/dist/packages/cd.satyh | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib-satysfi/dist/packages/cd.satyh b/lib-satysfi/dist/packages/cd.satyh index d818a94fb..fbe980ec6 100644 --- a/lib-satysfi/dist/packages/cd.satyh +++ b/lib-satysfi/dist/packages/cd.satyh @@ -1,14 +1,15 @@ @require: gr @require: color @require: geom +@require: option module CD : sig type obj val \diagram : [length; length; (| obj : point -> math -> obj; draw-obj : obj -> graphics list; - draw-arr : math -> float -> length -> obj -> obj -> graphics list; - draw-dashed-arr : math -> float -> length -> obj -> obj -> graphics list; + draw-arr : math -> float?-> length ?-> obj -> obj -> graphics list; + draw-dashed-arr : math -> float?-> length ?-> obj -> obj -> graphics list; |) -> graphics list] inline-cmd end = struct @@ -26,10 +27,10 @@ end = struct let wpad = 2pt % -- padding width for objects - let draw-arr-scheme arrowf ctx m t-name len-name (((x1r, _), _) as obj1r) (((x2r, _), _) as obj2r) = + let draw-arr-scheme arrowf ctx m ?:t-name-opt ?:len-name-opt (((x1r, _), _) as obj1r) (((x2r, _), _) as obj2r) = -% let t-name = destruct-option 0.5 t-name-opt in -% let len-name = destruct-option (get-font-size ctx *' 0.5) len-name-opt in + let t-name = Option.from 0.5 t-name-opt in + let len-name = Option.from (get-font-size ctx *' 0.5) len-name-opt in % let t-name = 0.5 in % let len-name = get-font-size ctx *' 0.5 in From d9262c2b3873704da006afe81d8a3fbb7b6013af Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 10:13:03 +0900 Subject: [PATCH 13/42] fix occurs check as to kind --- src/frontend/typechecker.ml | 46 +++++++++++++++++++++++++++++-------- 1 file changed, 37 insertions(+), 9 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 330396a43..59a62dc4f 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -154,9 +154,14 @@ let eliminate_optionals (ty : mono_type) (e : abstract_tree) : mono_type * abstr aux ty e *) -let rec occurs (tvid : FreeID.t) (ty : mono_type) = +let occurs (tvid : FreeID.t) (ty : mono_type) = + + let lev = FreeID.get_level tvid in let rec iter (_, tymain) = +(* + let () = print_endline ("==== occurs " ^ FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid ^ " in " ^ string_of_mono_type_basic ty) in (* for debug *) +*) match tymain with | TypeVariable(tvref) -> begin @@ -166,8 +171,9 @@ let rec occurs (tvid : FreeID.t) (ty : mono_type) = | Bound(_) -> false *) | MonoFree(tvidx) -> - if FreeID.equal tvidx tvid then true else - let lev = FreeID.get_level tvid in + if FreeID.equal tvidx tvid then + true + else let levx = FreeID.get_level tvidx in let () = (* -- update level -- *) @@ -176,8 +182,11 @@ let rec occurs (tvid : FreeID.t) (ty : mono_type) = else () in - false + match FreeID.get_kind tvidx with + | UniversalKind -> false + | RecordKind(tyasc) -> Assoc.fold_value (fun b ty -> b || iter ty) false tyasc end + | FuncType(optrow, tydom, tycod) -> iter_or optrow || iter tydom || iter tycod | ProductType(tylist) -> iter_list tylist | ListType(tysub) -> iter tysub @@ -207,8 +216,21 @@ let rec occurs (tvid : FreeID.t) (ty : mono_type) = iter ty -let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : mono_type) = +let set_kind_with_checking_loop (tvid : FreeID.t) (kd : mono_kind) : FreeID.t = + let () = + match kd with + | UniversalKind -> + () + + | RecordKind(tyasc) -> + let b = Assoc.fold_value (fun b ty -> b || occurs tvid ty) false tyasc in + if b then raise InternalInclusionError else () + in + FreeID.set_kind tvid kd + +let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : mono_type) = +(* (* begin: for debug *) let () = match (tymain1, tymain2) with @@ -217,7 +239,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | _ -> print_endline (" | unify " ^ (string_of_mono_type_basic ty1) ^ " == " ^ (string_of_mono_type_basic ty2)) in (* end: for debug *) - +*) let unify_list = List.iter (fun (t1, t2) -> unify_sub t1 t2) in match (tymain1, tymain2) with @@ -295,6 +317,8 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), TypeVariable({contents= MonoFree(tvid2)} as tvref2)) -> if FreeID.equal tvid1 tvid2 then () + else if occurs tvid1 ty2 || occurs tvid2 ty1 then + raise InternalInclusionError else let (tvid1q, tvid2q) = if FreeID.is_quantifiable tvid1 && FreeID.is_quantifiable tvid2 then @@ -338,7 +362,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : in begin unify_list eqnlst; - newtvref := MonoFree(FreeID.set_kind newtvid kdunion); + newtvref := MonoFree(set_kind_with_checking_loop newtvid kdunion); end | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), RecordType(tyasc2)) -> @@ -504,9 +528,9 @@ let rec typecheck | Some((pty, evid)) -> let tyfree = instantiate lev qtfbl pty in let tyres = overwrite_range_of_type tyfree rng in - +(* let () = print_endline ("\n#Content " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty) ^ " = " ^ (string_of_mono_type_basic tyres) ^ "\n (" ^ (Range.to_string rng) ^ ")") in (* for debug *) - +*) (ContentOf(rng, evid), tyres) end @@ -1368,9 +1392,13 @@ and make_type_environment_by_letrec | [] -> (tyenv, tvtylst_forall) | (varnm, tvty, evid) :: tvtytail -> let prety = tvty in +(* let () = print_endline ("#Generalize1 " ^ varnm ^ " : " ^ (string_of_mono_type_basic prety)) in (* for debug *) +*) let pty = (generalize lev (erase_range_of_type prety)) in +(* let () = print_endline ("#Generalize2 " ^ varnm ^ " : " ^ (string_of_poly_type_basic pty)) in (* for debug *) +*) let tvtylst_forall_new = (varnm, pty, evid) :: tvtylst_forall in make_forall_type_mutual (Typeenv.add tyenv varnm (pty, evid)) tyenv_before_let tvtytail tvtylst_forall_new in From e738cb2418d66941868faf0c0bb9115048f72082 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 12:55:39 +0900 Subject: [PATCH 14/42] fix occurs check as to level --- src/frontend/typechecker.ml | 165 +++++++++++++++++++++++++++++++++--- src/frontend/types_.cppo.ml | 10 ++- 2 files changed, 160 insertions(+), 15 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 59a62dc4f..909a5d780 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -96,6 +96,10 @@ let add_pattern_var_mono (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typ let add_pattern_var_poly lev (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typeenv.t = PatternVarMap.fold (fun varnm (_, evid, ty) tyenvacc -> let pty = (generalize lev (erase_range_of_type ty)) in +(* + let () = print_endline ("#Generalize1 " ^ varnm ^ " : " ^ string_of_mono_type_basic ty) in (* for debug *) + let () = print_endline ("#Generalize2 " ^ varnm ^ " : " ^ string_of_poly_type_basic pty) in (* for debug *) +*) Typeenv.add tyenvacc varnm (pty, evid) ) patvarmap tyenv @@ -158,10 +162,12 @@ let occurs (tvid : FreeID.t) (ty : mono_type) = let lev = FreeID.get_level tvid in - let rec iter (_, tymain) = + let rec iter ty = (* let () = print_endline ("==== occurs " ^ FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid ^ " in " ^ string_of_mono_type_basic ty) in (* for debug *) *) + let (_, tymain) = ty in + match tymain with | TypeVariable(tvref) -> begin @@ -182,17 +188,113 @@ let occurs (tvid : FreeID.t) (ty : mono_type) = else () in + begin + match FreeID.get_kind tvidx with + | UniversalKind -> false + | RecordKind(tyasc) -> Assoc.fold_value (fun b ty -> b || iter ty) false tyasc + end + end + + | FuncType(optrow, tydom, tycod) -> + let b0 = iter_or optrow in + let b1 = iter tydom in + let b2 = iter tycod in + b0 || b1 || b2 + + | ProductType(tylist) -> iter_list tylist + | ListType(tysub) -> iter tysub + | RefType(tysub) -> iter tysub + | VariantType(tylist, _) -> iter_list tylist + | SynonymType(tylist, _, tyact) -> let b = iter_list tylist in let ba = iter tyact in b || ba + | RecordType(tyasc) -> iter_list (Assoc.to_value_list tyasc) + | BaseType(_) -> false + | HorzCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + | VertCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + | MathCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist + + and iter_list tylst = + List.exists iter tylst + + and iter_cmd_list cmdargtylist = + List.exists (function + | MandatoryArgumentType(ty) -> iter ty + | OptionalArgumentType(ty) -> iter ty + ) cmdargtylist + + and iter_or optrow = + match optrow with + | OptionRowEmpty -> + false + + | OptionRowCons(ty, tail) -> + let b1 = iter ty in + let b2 = iter_or tail in + b1 || b2 + + | OptionRowVariable(orviref) -> + begin + match !orviref with + | MonoORLink(optrow) -> + iter_or optrow + + | MonoORFree(orvx) -> +(* + let () = print_endline ("==== occursOR " ^ (OptionRowVarID.show_direct orvx) ^ " &&&& " ^ (Level.show lev)) in (* for debug *) +*) + let levx = OptionRowVarID.get_level orvx in + let () = + (* -- update level -- *) + if Level.less_than lev levx then + orviref := MonoORFree(OptionRowVarID.set_level orvx lev) + else + () + in + false + end + + in + iter ty + + +let occurs_optional_row (orv : OptionRowVarID.t) (optrow : mono_option_row) = + + let lev = OptionRowVarID.get_level orv in + + let rec iter (_, tymain) = + match tymain with + | TypeVariable(tvref) -> + begin + match !tvref with + | MonoLink(tyl) -> + iter tyl + + | MonoFree(tvidx) -> + let levx = FreeID.get_level tvidx in + let () = + (* -- update level -- *) + if Level.less_than lev levx then + tvref := MonoFree(FreeID.set_level tvidx lev) + else + () + in + begin match FreeID.get_kind tvidx with | UniversalKind -> false - | RecordKind(tyasc) -> Assoc.fold_value (fun b ty -> b || iter ty) false tyasc + | RecordKind(tyasc) -> Assoc.fold_value (fun bacc ty -> let b = iter ty in bacc || b) false tyasc + end end - | FuncType(optrow, tydom, tycod) -> iter_or optrow || iter tydom || iter tycod + | FuncType(optrow, tydom, tycod) -> + let b0 = iter_or optrow in + let b1 = iter tydom in + let b2 = iter tycod in + b0 || b1 || b2 + | ProductType(tylist) -> iter_list tylist | ListType(tysub) -> iter tysub | RefType(tysub) -> iter tysub | VariantType(tylist, _) -> iter_list tylist - | SynonymType(tylist, _, tyreal) -> iter_list tylist || iter tyreal + | SynonymType(tylist, _, tyact) -> let b = iter_list tylist in let ba = iter tyact in b || ba | RecordType(tyasc) -> iter_list (Assoc.to_value_list tyasc) | BaseType(_) -> false | HorzCommandType(cmdargtylist) -> iter_cmd_list cmdargtylist @@ -209,11 +311,37 @@ let occurs (tvid : FreeID.t) (ty : mono_type) = ) cmdargtylist and iter_or = function - | OptionRowCons(ty, tail) -> iter ty && iter_or tail - | OptionRowEmpty | OptionRowVariable(_) -> false + | OptionRowEmpty -> + false + + | OptionRowCons(ty, tail) -> + let b1 = iter ty in + let b2 = iter_or tail in + b1 || b2 + + | OptionRowVariable(orviref) -> + begin + match !orviref with + | MonoORLink(optrow) -> + iter_or optrow + + | MonoORFree(orvx) -> + if OptionRowVarID.equal orv orvx then + true + else + let levx = OptionRowVarID.get_level orvx in + let () = + (* -- update level -- *) + if Level.less_than lev levx then + orviref := MonoORFree(OptionRowVarID.set_level orvx lev) + else + () + in + false + end in - iter ty + iter_or optrow let set_kind_with_checking_loop (tvid : FreeID.t) (kd : mono_kind) : FreeID.t = @@ -223,7 +351,7 @@ let set_kind_with_checking_loop (tvid : FreeID.t) (kd : mono_kind) : FreeID.t = () | RecordKind(tyasc) -> - let b = Assoc.fold_value (fun b ty -> b || occurs tvid ty) false tyasc in + let b = Assoc.fold_value (fun bacc ty -> let b = occurs tvid ty in bacc || b) false tyasc in if b then raise InternalInclusionError else () in FreeID.set_kind tvid kd @@ -317,9 +445,12 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), TypeVariable({contents= MonoFree(tvid2)} as tvref2)) -> if FreeID.equal tvid1 tvid2 then () - else if occurs tvid1 ty2 || occurs tvid2 ty1 then - raise InternalInclusionError else + let b1 = occurs tvid1 ty2 in + let b2 = occurs tvid2 ty1 in + if b1 || b2 then + raise InternalInclusionError + else let (tvid1q, tvid2q) = if FreeID.is_quantifiable tvid1 && FreeID.is_quantifiable tvid2 then (tvid1, tvid2) @@ -424,11 +555,17 @@ and unify_option_row optrow1 optrow2 = if OptionRowVarID.equal orv1 orv2 then () else orviref1 := MonoORLink(optrow2) - | (OptionRowVariable({contents = MonoORFree(_)} as orviref1), _) -> - orviref1 := MonoORLink(optrow2) + | (OptionRowVariable({contents = MonoORFree(orv1)} as orviref1), _) -> + if occurs_optional_row orv1 optrow2 then + raise InternalInclusionError + else + orviref1 := MonoORLink(optrow2) - | (_, OptionRowVariable({contents = MonoORFree(_)} as orviref2)) -> - orviref2 := MonoORLink(optrow1) + | (_, OptionRowVariable({contents = MonoORFree(orv2)} as orviref2)) -> + if occurs_optional_row orv2 optrow1 then + raise InternalInclusionError + else + orviref2 := MonoORLink(optrow1) | (OptionRowEmpty, OptionRowCons(_, _)) | (OptionRowCons(_, _), OptionRowEmpty) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 654761408..694736fc6 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -78,6 +78,8 @@ module OptionRowVarID val fresh : level -> t val equal : t -> t -> bool val get_level : t -> level + val set_level : t -> level -> t + val show_direct : t -> string end = struct type t = { @@ -100,6 +102,12 @@ module OptionRowVarID let get_level orv = orv.level + + let set_level orv lev = + { level = lev; number = orv.number; } + + let show_direct orv = + "$" ^ (string_of_int orv.number) ^ "[" ^ (Level.show orv.level) ^ "]" end @@ -1592,7 +1600,7 @@ let rec tvf_mono qstn tvref = and orvf_mono orvref = match !orvref with - | MonoORFree(orv) -> "...?-> " + | MonoORFree(orv) -> (OptionRowVarID.show_direct orv) ^ "?-> " | MonoORLink(optrow) -> string_of_option_row_basic tvf_mono orvf_mono optrow From 4d907c63f37c425e4402e5f0a40f3e4dd48e40e5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 13:11:28 +0900 Subject: [PATCH 15/42] arrange spacing etc. --- src/frontend/typechecker.ml | 147 ++++++++---------------------------- src/frontend/types_.cppo.ml | 2 +- 2 files changed, 32 insertions(+), 117 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 909a5d780..8b274a624 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -22,13 +22,6 @@ exception InternalInclusionError exception InternalContradictionError -let print_for_debug_typecheck msg = -(* - print_endline msg; -*) - () - - let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> @@ -48,11 +41,6 @@ let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : ( (optrow, Alist.to_list evidacc, tyenvnew) -(* -let append_optional_ids (evidlst : EvalVarID.t list) (ast : abstract_tree) = - List.fold_right (fun evid ast -> Function([PatternBranch(PVariable(evid), ast)])) evidlst ast -*) - let rec is_nonexpansive_expression e = let iter = is_nonexpansive_expression in match e with @@ -96,10 +84,6 @@ let add_pattern_var_mono (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typ let add_pattern_var_poly lev (tyenv : Typeenv.t) (patvarmap : pattern_var_map) : Typeenv.t = PatternVarMap.fold (fun varnm (_, evid, ty) tyenvacc -> let pty = (generalize lev (erase_range_of_type ty)) in -(* - let () = print_endline ("#Generalize1 " ^ varnm ^ " : " ^ string_of_mono_type_basic ty) in (* for debug *) - let () = print_endline ("#Generalize2 " ^ varnm ^ " : " ^ string_of_poly_type_basic pty) in (* for debug *) -*) Typeenv.add tyenvacc varnm (pty, evid) ) patvarmap tyenv @@ -145,37 +129,18 @@ let flatten_type (ty : mono_type) : mono_command_argument_type list * mono_type in aux Alist.empty ty -(* -let eliminate_optionals (ty : mono_type) (e : abstract_tree) : mono_type * abstract_tree = - let rec aux ty e = - match ty with - | (rng, FuncType({contents = _ :: tyopttail}, tydom, tycod)) -> - aux (rng, FuncType({contents = tyopttail}, tydom, tycod)) (Apply(e, Value(Constructor("None", UnitConstant)))) - - | _ -> - (ty, e) - in - aux ty e -*) let occurs (tvid : FreeID.t) (ty : mono_type) = let lev = FreeID.get_level tvid in - let rec iter ty = -(* - let () = print_endline ("==== occurs " ^ FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid ^ " in " ^ string_of_mono_type_basic ty) in (* for debug *) -*) - let (_, tymain) = ty in + let rec iter (_, tymain) = match tymain with | TypeVariable(tvref) -> begin match !tvref with | MonoLink(tyl) -> iter tyl - (* - | Bound(_) -> false - *) | MonoFree(tvidx) -> if FreeID.equal tvidx tvid then true @@ -238,9 +203,6 @@ let occurs (tvid : FreeID.t) (ty : mono_type) = iter_or optrow | MonoORFree(orvx) -> -(* - let () = print_endline ("==== occursOR " ^ (OptionRowVarID.show_direct orvx) ^ " &&&& " ^ (Level.show lev)) in (* for debug *) -*) let levx = OptionRowVarID.get_level orvx in let () = (* -- update level -- *) @@ -436,12 +398,6 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : | (_, TypeVariable({contents= MonoLink(tyl2)})) -> unify_sub (rng1, tymain1) tyl2 -(* - | ( (TypeVariable({contents= Bound(_)}), _) - | (_, TypeVariable({contents= Bound(_)})) ) -> - failwith ("unify_sub: bound type variable in " ^ (string_of_mono_type_basic ty1) ^ " (" ^ (Range.to_string rng1) ^ ")" ^ " or " ^ (string_of_mono_type_basic ty2) ^ " (" ^ (Range.to_string rng2) ^ ")") -*) - | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), TypeVariable({contents= MonoFree(tvid2)} as tvref2)) -> if FreeID.equal tvid1 tvid2 then () @@ -467,19 +423,12 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : else (tvid1q, tvid2q) in - let () = - begin - tvref1 := MonoFree(tvid1l); - tvref2 := MonoFree(tvid2l); - end - in + tvref1 := MonoFree(tvid1l); + tvref2 := MonoFree(tvid2l); let (oldtvref, newtvref, newtvid, newty) = if Range.is_dummy rng1 then (tvref1, tvref2, tvid2l, ty2) else (tvref2, tvref1, tvid1l, ty1) in - let _ = print_for_debug_typecheck (* for debug *) - (" substituteVV " ^ (string_of_mono_type_basic (Range.dummy "", TypeVariable(oldtvref))) (* for debug *) - ^ " with " ^ (string_of_mono_type_basic newty)) in (* for debug *) - let () = ( oldtvref := MonoLink(newty) ) in + oldtvref := MonoLink(newty); let kd1 = FreeID.get_kind tvid1l in let kd2 = FreeID.get_kind tvid2l in let (eqnlst, kdunion) = @@ -491,10 +440,9 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : let kdunion = RecordKind(Assoc.union asc1 asc2) in (Assoc.intersection asc1 asc2, kdunion) in - begin - unify_list eqnlst; - newtvref := MonoFree(set_kind_with_checking_loop newtvid kdunion); - end + unify_list eqnlst; + newtvref := MonoFree(set_kind_with_checking_loop newtvid kdunion); + () | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), RecordType(tyasc2)) -> let kd1 = FreeID.get_kind tvid1 in @@ -510,18 +458,14 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : raise InternalContradictionError else let newty2 = if Range.is_dummy rng1 then (rng2, tymain2) else (rng1, tymain2) in - let _ = print_for_debug_typecheck (* for debug *) - (" substituteVR " ^ (string_of_mono_type_basic ty1) (* for debug *) - ^ " with " ^ (string_of_mono_type_basic newty2)) in (* for debug *) let eqnlst = match kd1 with | UniversalKind -> [] | RecordKind(tyasc1) -> Assoc.intersection tyasc1 tyasc2 in - begin - unify_list eqnlst; - tvref1 := MonoLink(newty2); - end + unify_list eqnlst; + tvref1 := MonoLink(newty2); + () | (TypeVariable({contents= MonoFree(tvid1)} as tvref1), _) -> let chk = occurs tvid1 ty2 in @@ -529,10 +473,7 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : raise InternalInclusionError else let newty2 = if Range.is_dummy rng1 then (rng2, tymain2) else (rng1, tymain2) in - let _ = print_for_debug_typecheck (* for debug *) - (" substituteVX " ^ (string_of_mono_type_basic ty1) (* for debug *) - ^ " with " ^ (string_of_mono_type_basic newty2)) in (* for debug *) - tvref1 := MonoLink(newty2) + tvref1 := MonoLink(newty2) | (_, TypeVariable(_)) -> unify_sub ty2 ty1 @@ -541,9 +482,6 @@ let rec unify_sub ((rng1, tymain1) as ty1 : mono_type) ((rng2, tymain2) as ty2 : and unify_option_row optrow1 optrow2 = match (optrow1, optrow2) with - | (OptionRowVariable({contents = MonoORLink(optrow1)}), _) -> unify_option_row optrow1 optrow2 - | (_, OptionRowVariable({contents = MonoORLink(optrow2)})) -> unify_option_row optrow1 optrow2 - | (OptionRowCons(ty1, tail1), OptionRowCons(ty2, tail2)) -> unify_sub ty1 ty2; unify_option_row tail1 tail2 @@ -551,6 +489,9 @@ and unify_option_row optrow1 optrow2 = | (OptionRowEmpty, OptionRowEmpty) -> () + | (OptionRowVariable({contents = MonoORLink(optrow1)}), _) -> unify_option_row optrow1 optrow2 + | (_, OptionRowVariable({contents = MonoORLink(optrow2)})) -> unify_option_row optrow1 optrow2 + | (OptionRowVariable({contents = MonoORFree(orv1)} as orviref1), OptionRowVariable({contents = MonoORFree(orv2)})) -> if OptionRowVarID.equal orv1 orv2 then () else orviref1 := MonoORLink(optrow2) @@ -572,26 +513,8 @@ and unify_option_row optrow1 optrow2 = -> raise InternalContradictionError -(* - let rec aux tyopts1 tyopts2 = - match (tyopts1, tyopts2) with - | (_, []) -> - tyopts2r := tyopts1 - - | ([], _) -> - tyopts1r := tyopts2 - - | (ty1 :: tytail1, ty2 :: tytail2) -> - unify_sub ty1 ty2; - aux tytail1 tytail2 - in - aux (!tyopts1r) (!tyopts2r) -*) let unify_ (tyenv : Typeenv.t) (ty1 : mono_type) (ty2 : mono_type) = -(* - let () = print_endline (" ####UNIFY " ^ (string_of_mono_type_basic ty1) ^ " = " ^ (string_of_mono_type_basic ty2)) in (* for debug *) -*) try unify_sub ty1 ty2 with @@ -676,7 +599,9 @@ let rec typecheck match Typeenv.find_constructor qtfbl tyenv lev constrnm with | None -> raise (UndefinedConstructor(rng, constrnm, Typeenv.find_constructor_candidates qtfbl tyenv lev constrnm)) | Some((tyarglist, tyid, tyc)) -> - let () = print_for_debug_typecheck ("\n#Constructor " ^ constrnm ^ " of " ^ (string_of_mono_type_basic tyc) ^ " in ... " ^ (string_of_mono_type_basic (rng, VariantType([], tyid))) ^ "(" ^ (Typeenv.find_type_name tyenv tyid) ^ ")") in (* for debug *) +(* + let () = print_endline ("\n#Constructor " ^ constrnm ^ " of " ^ (string_of_mono_type_basic tyc) ^ " in ... " ^ (string_of_mono_type_basic (rng, VariantType([], tyid))) ^ "(" ^ (Typeenv.find_type_name tyenv tyid) ^ ")") in (* for debug *) +*) let (e1, ty1) = typecheck_iter tyenv utast1 in let () = unify ty1 tyc in let tyres = (rng, VariantType(tyarglist, tyid)) in @@ -727,30 +652,15 @@ let rec typecheck let (cmdargtylist, tyret) = flatten_type tyF in let () = unify tyret (Range.dummy "lambda-math-return", BaseType(MathType)) in (eF, (rng, MathCommandType(cmdargtylist))) -(* - | UTLambdaOptional(varrng, varnmctx, utast1) -> - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(ref (Free(tvid)))) in - let evid = EvalVarID.fresh varnmctx in - let ty = overwrite_range_of_type (Primitives.option_type beta) rng in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(ty), evid)) utast1 in - (Function([PatternBranch(PVariable(evid), e1)]), (rng, OptFuncType(beta, ty1))) -*) + | UTApply(utast1, utast2) -> let (e1, ty1) = typecheck_iter tyenv utast1 in let (e2, ty2) = typecheck_iter tyenv utast2 in -(* - let _ = print_for_debug_typecheck ("#Apply " ^ (string_of_utast (rng, utastmain))) in (* for debug *) -*) let eret = Apply(e1, e2) in begin match ty1 with | (_, FuncType(_, tydom, tycod)) -> let () = unify tydom ty2 in -(* - let _ = print_for_debug_typecheck ("1 " ^ (string_of_ast (Apply(e1, e2))) ^ " : " (* for debug *) - ^ (string_of_mono_type_basic tycod)) in (* for debug *) -*) let tycodnew = overwrite_range_of_type tycod rng in (eret, tycodnew) @@ -760,10 +670,7 @@ let rec typecheck let orv = OptionRowVarID.fresh lev in let optrow = OptionRowVariable(ref (MonoORFree(orv))) in let () = unify ty1 (get_range utast1, FuncType(optrow, ty2, beta)) in -(* - let _ = print_for_debug_typecheck ("2 " ^ (string_of_ast (Apply(e1, e2))) ^ " : " ^ (string_of_mono_type_basic beta) ^ " = " ^ (string_of_mono_type_basic beta)) in (* for debug *) -*) - (eret, beta) + (eret, beta) end | UTApplyOptional(utast1, utast2) -> @@ -1430,7 +1337,9 @@ and typecheck_pattern let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let evid = EvalVarID.fresh varnm in - let () = print_for_debug_typecheck ("\n#PAdd " ^ varnm ^ " : " ^ (string_of_mono_type_basic beta)) in (* for debug *) +(* + let () = print_endline ("\n#PAdd " ^ varnm ^ " : " ^ (string_of_mono_type_basic beta)) in (* for debug *) +*) (PVariable(evid), beta, PatternVarMap.empty |> PatternVarMap.add varnm (rng, evid, beta)) | UTPAsVariable(varnm, utpat1) -> @@ -1453,7 +1362,9 @@ and typecheck_pattern match Typeenv.find_constructor qtfbl tyenv lev constrnm with | None -> raise (UndefinedConstructor(rng, constrnm, Typeenv.find_constructor_candidates qtfbl tyenv lev constrnm)) | Some((tyarglist, tyid, tyc)) -> - let () = print_for_debug_typecheck ("P-find " ^ constrnm ^ " of " ^ (string_of_mono_type_basic tyc)) in (* for debug *) +(* + let () = print_endline ("P-find " ^ constrnm ^ " of " ^ (string_of_mono_type_basic tyc)) in (* for debug *) +*) let (epat1, typat1, tyenv1) = iter utpat1 in let () = unify tyc typat1 in (PConstructor(constrnm, epat1), (rng, VariantType(tyarglist, tyid)), tyenv1) @@ -1476,7 +1387,9 @@ and make_type_environment_by_letrec let rng = get_range astdef in let beta = (rng, TypeVariable(tvref)) in let pbeta = (rng, TypeVariable(PolyFree(tvref))) in - let _ = print_for_debug_typecheck ("#AddMutualVar " ^ varnm ^ " : '" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ " :: U") in (* for debug *) +(* + let () = print_endline ("#AddMutualVar " ^ varnm ^ " : '" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ " :: U") in (* for debug *) +*) let evid = EvalVarID.fresh varnm in let (tyenvfinal, tvtylst) = iter (Typeenv.add acctyenv varnm (Poly(pbeta), evid)) tailcons in (tyenvfinal, ((varnm, beta, evid) :: tvtylst)) @@ -1549,7 +1462,9 @@ and make_type_environment_by_letrec and make_type_environment_by_let_mutable (lev : level) (tyenv : Typeenv.t) varrng varnm utastI = let (eI, tyI) = typecheck Unquantifiable lev tyenv utastI in - let () = print_for_debug_typecheck ("#AddMutable " ^ varnm ^ " : " ^ (string_of_mono_type_basic (varrng, RefType(tyI)))) in (* for debug *) +(* + let () = print_endline ("#AddMutable " ^ varnm ^ " : " ^ (string_of_mono_type_basic (varrng, RefType(tyI)))) in (* for debug *) +*) let evid = EvalVarID.fresh varnm in let tyenvI = Typeenv.add tyenv varnm (lift_poly (varrng, RefType(tyI)), evid) in (tyenvI, evid, eI, tyI) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 694736fc6..06942d20d 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -98,7 +98,7 @@ module OptionRowVarID let fresh lev = incr current_number; - {level = lev; number = !current_number; } + { level = lev; number = !current_number; } let get_level orv = orv.level From 033ed1913ef4b70296008c5ceb2373637c5a1cb4 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 13:14:13 +0900 Subject: [PATCH 16/42] fix 'flatten_type' --- src/frontend/typechecker.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 8b274a624..11d9aa115 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -109,8 +109,10 @@ let apply_tree_of_list astfunc astlst = let flatten_type (ty : mono_type) : mono_command_argument_type list * mono_type = let rec aux_or = function - | OptionRowCons(ty, tail) -> OptionalArgumentType(ty) :: aux_or tail - | OptionRowEmpty | OptionRowVariable(_) -> [] + | OptionRowEmpty -> [] + | OptionRowVariable({contents = MonoORFree(_)}) -> [] + | OptionRowVariable({contents = MonoORLink(optrow)}) -> aux_or optrow + | OptionRowCons(ty, tail) -> OptionalArgumentType(ty) :: aux_or tail in let rec aux acc ty = From d535bb943476e47ec7017be7bd302dc32098b37c Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 13:18:33 +0900 Subject: [PATCH 17/42] add 'unlink' --- src/frontend/typechecker.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 11d9aa115..d287a9ebc 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -22,6 +22,12 @@ exception InternalInclusionError exception InternalContradictionError +let unlink ((_, tymain) as ty) = + match tymain with + | TypeVariable({contents = MonoLink(ty)}) -> ty + | _ -> ty + + let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> @@ -660,13 +666,13 @@ let rec typecheck let (e2, ty2) = typecheck_iter tyenv utast2 in let eret = Apply(e1, e2) in begin - match ty1 with + match unlink ty1 with | (_, FuncType(_, tydom, tycod)) -> let () = unify tydom ty2 in let tycodnew = overwrite_range_of_type tycod rng in (eret, tycodnew) - | _ -> + | ty1 -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let orv = OptionRowVarID.fresh lev in From 97b18d0c6fdebd415ca243ca2c7531271e3b71cc Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 22:13:53 +0900 Subject: [PATCH 18/42] arrange spacing and add type annotations --- src/frontend/bytecomp/ir_.cppo.ml | 38 +++++++++++++++++-------------- src/frontend/bytecomp/vm_.cppo.ml | 16 ++++++------- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 0f260b27e..3608c85d0 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -4,6 +4,7 @@ open MyUtil open LengthInterface open Types + let report_bug_ir msg = Format.printf "[Bug]@ %s:" msg; failwith ("bug: " ^ msg) @@ -35,7 +36,7 @@ let map_with_env f env lst = iter env lst Alist.empty -let rec transform_input_horz_content env (ihlst : input_horz_element list) = +let rec transform_input_horz_content (env : frame) (ihlst : input_horz_element list) : ir_input_horz_element list * frame = ihlst @|> env @|> map_with_env (fun env elem -> match elem with | InputHorzText(s) -> @@ -56,7 +57,7 @@ let rec transform_input_horz_content env (ihlst : input_horz_element list) = ) -and transform_input_vert_content env (ivlst : input_vert_element list) = +and transform_input_vert_content (env : frame) (ivlst : input_vert_element list) : ir_input_vert_element list * frame = ivlst @|> env @|> map_with_env (fun env elem -> match elem with | InputVertEmbedded(astcmd, astarglst) -> @@ -101,7 +102,7 @@ and transform_path env pathcomplst cycleopt = (irpathcomplst, ircycleopt, env) -and transform_ast (env : environment) ast = +and transform_ast (env : environment) (ast : abstract_tree) : ir * environment = let (genv, _) = env in let initvars = EvalVarIDMap.fold (fun k v acc -> @@ -113,7 +114,7 @@ and transform_ast (env : environment) ast = (ir, frame.global) -and transform_list env astlst = +and transform_list (env : frame) (astlst : abstract_tree list) : ir list * frame = map_with_env transform env astlst @@ -147,7 +148,7 @@ and transform_patsel (env : frame) (patbrs : pattern_branch list) : ir_pattern_b (irpatsel, { envnew with size = !max_size; }) -and transform_pattern_list env patlst = +and transform_pattern_list (env : frame) (patlst : pattern_tree list) : ir_pattern_tree list * frame = map_with_env transform_pattern env patlst @@ -199,14 +200,14 @@ and transform_pattern (env : frame) (pat : pattern_tree) : ir_pattern_tree * fra (IRPConstructor(cnm1, bsub), env) -and newlevel (env : frame) = - { env with level = env.level+1; size = 0; } +and new_level (env : frame) = + { env with level = env.level + 1; size = 0; } and add_to_environment (env : frame) (evid : EvalVarID.t) : frame * varloc = let (var, newglobal) = if env.level = 0 then - let loc = (ref Nil) in + let loc = ref Nil in (GlobalVar(loc, evid, ref 0), Types.add_to_environment env.global evid loc) else (LocalVar(env.level, env.size, evid, ref 0), env.global) @@ -270,7 +271,7 @@ and transform_tuple env ast = (IRTuple(len, iritems), envnew) -and check_primitive env ast = +and check_primitive (env : frame) (ast : abstract_tree) : (int * (abstract_tree list -> abstract_tree)) option = match ast with | ContentOf(_, evid) -> begin @@ -288,14 +289,17 @@ and check_primitive env ast = | _ -> None -and transform (env : frame) ast : (ir * frame) = +and transform (env : frame) (ast : abstract_tree) : ir * frame = let return ir = (ir, env) in match ast with - | Value(v) -> return (IRConstant(v)) + | Value(v) -> + return (IRConstant(v)) - | FinishHeaderFile -> return IRTerminal + | FinishHeaderFile -> + return IRTerminal - | FinishStruct -> return IRTerminal + | FinishStruct -> + return IRTerminal | InputHorz(ihlst) -> let (imihlst, env) = transform_input_horz_content env ihlst in @@ -341,10 +345,10 @@ and transform (env : frame) ast : (ir * frame) = begin match find_in_environment env evid with | Some(var) -> - return (IRContentOf(var)) + return (IRContentOf(var)) | None -> - report_bug_ir_ast ("ContentOf: variable '" ^ (EvalVarID.show_direct evid) ^ "' (at " ^ (Range.to_string rng) ^ ") not found") ast + report_bug_ir_ast ("ContentOf: variable '" ^ (EvalVarID.show_direct evid) ^ "' (at " ^ (Range.to_string rng) ^ ") not found") ast end | LetRecIn(recbinds, ast2) -> @@ -367,7 +371,7 @@ and transform (env : frame) ast : (ir * frame) = | Function([], patbrs) -> let (body, args) = flatten_function ast in - let funenv = newlevel env in + let funenv = new_level env in let (irargs, funenv) = transform_pattern_list funenv args in let (irbody, funenv) = transform funenv body in (IRFunction(funenv.size, irargs, irbody), env) @@ -375,7 +379,7 @@ and transform (env : frame) ast : (ir * frame) = | Function(_ :: _, _) -> failwith "Function with optional arguments: remains to be implemented." - | Apply(ast1, ast2) -> + | Apply(_, _) -> let (callee, args) = flatten_application ast in begin match check_primitive env callee with diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index 75425205a..f8ebcd30c 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -20,7 +20,7 @@ type compiled_nom_input_horz_element = | CompiledNomInputHorzContent of compiled_nom_input_horz_element list * vmenv -let local_get_value env lv off = +let local_get_value (env : vmenv) (lv : int) (off : int) : syntactic_value = let (_, frames) = env in if lv = 0 then (List.hd frames).(off) @@ -28,7 +28,7 @@ let local_get_value env lv off = (List.nth frames lv).(off) -let local_set_value env lv off value = +let local_set_value (env : vmenv) (lv : int) (off : int) (value : syntactic_value) : unit = let (_, frames) = env in if lv = 0 then (List.hd frames).(off) <- value @@ -36,17 +36,17 @@ let local_set_value env lv off value = (List.nth frames lv).(off) <- value -let vmenv_global env = +let vmenv_global (env : vmenv) : environment = let (global, _) = env in global -let newframe env size = +let newframe (env : vmenv) (size : int) : vmenv = let (global, local) = env in (global, (Array.make size Nil) :: local) -let newframe_recycle env preenv size = +let newframe_recycle (env : vmenv) (preenv : vmenv) (size : int) : vmenv = let (global, local) = env in match preenv with | (_, prefrm :: _) -> @@ -70,8 +70,8 @@ let popn stack n = (acc, st) else match st with - | x :: xs -> iter xs (n-1) (x::acc) - | [] -> report_bug_vm "stack underflow!" + | x :: xs -> iter xs (n - 1) (x :: acc) + | [] -> report_bug_vm "stack underflow!" in iter stack n [] @@ -194,7 +194,7 @@ and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imi ) Alist.empty |> Alist.to_list in - let rec interpret_commands env (nmihlst : compiled_nom_input_horz_element list) : HorzBox.horz_box list = + let rec interpret_commands (env : vmenv) (nmihlst : compiled_nom_input_horz_element list) : HorzBox.horz_box list = nmihlst |> List.map (fun nmih -> match nmih with | CompiledNomInputHorzEmbedded(code) -> From a2909f01ccf8e986c0ff65af2f7b3098ada2b12e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 23:09:26 +0900 Subject: [PATCH 19/42] refactor 'typecheck_pattern_branch_list' --- src/frontend/bytecomp/ir_.cppo.ml | 17 +++++++++-------- src/frontend/parser.mly | 4 ++-- src/frontend/typechecker.ml | 25 ++++++++++++++----------- src/frontend/types_.cppo.ml | 2 +- 4 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 3608c85d0..320d7234c 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -173,11 +173,11 @@ and transform_pattern (env : frame) (pat : pattern_tree) : ir_pattern_tree * fra | PWildCard -> return IRPWildCard | PVariable(evid) -> - let (env, var) = add_to_environment env evid in + let (var, env) = add_to_environment env evid in (IRPVariable(var), env) | PAsVariable(evid, psub) -> - let (env, var) = add_to_environment env evid in + let (var, env) = add_to_environment env evid in let (bsub, env) = transform_pattern env psub in (IRPAsVariable(var, bsub), env) @@ -204,7 +204,7 @@ and new_level (env : frame) = { env with level = env.level + 1; size = 0; } -and add_to_environment (env : frame) (evid : EvalVarID.t) : frame * varloc = +and add_to_environment (env : frame) (evid : EvalVarID.t) : varloc * frame = let (var, newglobal) = if env.level = 0 then let loc = ref Nil in @@ -218,7 +218,7 @@ and add_to_environment (env : frame) (evid : EvalVarID.t) : frame * varloc = | GlobalVar(_, _, _) -> var in let newvars = env.vars |> EvalVarIDMap.add evid var in - ({ env with global = newglobal; vars = newvars; size = env.size + 1; }, locvar) + (locvar, { env with global = newglobal; vars = newvars; size = env.size + 1; }) and find_in_environment (env : frame) (evid : EvalVarID.t) : varloc option = @@ -231,7 +231,7 @@ and find_in_environment (env : frame) (evid : EvalVarID.t) : varloc option = and add_letrec_bindings_to_environment (env : frame) (recbinds : letrec_binding list) : (varloc * pattern_branch list) list * frame = recbinds @|> env @|> map_with_env (fun env recbind -> let LetRecBinding(evid, patbrs) = recbind in - let (env, var) = add_to_environment env evid in + let (var, env) = add_to_environment env evid in ((var, patbrs), env) ) @@ -369,14 +369,15 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (ir2, env) = transform env ast2 in (IRLetNonRecIn(ir1, irpat, ir2), env) - | Function([], patbrs) -> + | Function([], _) -> let (body, args) = flatten_function ast in let funenv = new_level env in let (irargs, funenv) = transform_pattern_list funenv args in let (irbody, funenv) = transform funenv body in (IRFunction(funenv.size, irargs, irbody), env) - | Function(_ :: _, _) -> + | Function((_ :: _) as evids, patbrs) -> + let (vars, funenv) = map_with_env add_to_environment (new_level env) evids in failwith "Function with optional arguments: remains to be implemented." | Apply(_, _) -> @@ -426,7 +427,7 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = | LetMutableIn(evid, astini, astaft) -> let (irini, env) = transform env astini in - let (env, var) = add_to_environment env evid in + let (var, env) = add_to_environment env evid in let (iraft, env) = transform env astaft in (IRLetMutableIn(var, irini, iraft), env) diff --git a/src/frontend/parser.mly b/src/frontend/parser.mly index 671767a19..01a573e3f 100644 --- a/src/frontend/parser.mly +++ b/src/frontend/parser.mly @@ -53,7 +53,7 @@ utastdef | UTPatternArgument(argpat) :: utargtail -> - (rng, UTFunction(Alist.to_list optargacc, [UTPatternBranch(argpat, curry_lambda_abstract Alist.empty rng utargtail utastdef)])) + (rng, UTFunction(Alist.to_list optargacc, UTPatternBranch(argpat, curry_lambda_abstract Alist.empty rng utargtail utastdef))) | UTOptionalArgument(rngvar, varnm) :: utargtail -> curry_lambda_abstract (Alist.extend optargacc (rngvar, varnm)) rng utargtail utastdef @@ -291,7 +291,7 @@ let varnm = numbered_var_name i in let accnew = Alist.extend acc (Range.dummy "make_function_for_parallel:2", UTContentOf([], varnm)) in let patvar = (Range.dummy "make_function_for_parallel:3", UTPVariable(varnm)) in - (rngfull, UTFunction([], [UTPatternBranch(patvar, aux accnew (i + 1))])) + (rngfull, UTFunction([], UTPatternBranch(patvar, aux accnew (i + 1)))) in aux Alist.empty 0 diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index d287a9ebc..904408e7d 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -724,13 +724,13 @@ let rec typecheck (eret, (rng, FuncType(optrow, beta1, beta2))) end - | UTFunction(optargs, utpatbrs) -> + | UTFunction(optargs, utpatbr) -> let (optrow, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in let tvidO = FreeID.fresh UniversalKind qtfbl lev () in let betaO = (Range.dummy "UTFunction:dom", TypeVariable(ref (MonoFree(tvidO)))) in let tvidR = FreeID.fresh UniversalKind qtfbl lev () in let betaR = (Range.dummy "UTFunction:cod", TypeVariable(ref (MonoFree(tvidR)))) in - let (patbrs, _) = typecheck_pattern_branch_list qtfbl lev tyenvnew utpatbrs betaO betaR in + let patbrs = typecheck_pattern_branch_list qtfbl lev tyenvnew [utpatbr] betaO betaR in let e = Function(evids, patbrs) in (e, (rng, FuncType(optrow, betaO, betaR))) (* @@ -747,9 +747,9 @@ let rec typecheck let (eO, tyO) = typecheck_iter tyenv utastO in let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (Range.dummy "ut-pattern-match", TypeVariable(ref (MonoFree(tvid)))) in - let (patbrs, tyP) = typecheck_pattern_branch_list qtfbl lev tyenv utpatbrs tyO beta in + let patbrs = typecheck_pattern_branch_list qtfbl lev tyenv utpatbrs tyO beta in let () = Exhchecker.main rng patbrs tyO qtfbl lev tyenv in - (PatternMatch(rng, eO, patbrs), tyP) + (PatternMatch(rng, eO, patbrs), beta) | UTLetNonRecIn(mntyopt, utpat, utast1, utast2) -> let (pat, tyP, patvarmap) = typecheck_pattern qtfbl (Level.succ lev) tyenv utpat in @@ -1268,11 +1268,13 @@ and typecheck_itemize_list and typecheck_pattern_branch_list (qtfbl : quantifiability) (lev : level) - (tyenv : Typeenv.t) (utpatbrs : untyped_pattern_branch list) (tyobj : mono_type) (tyres : mono_type) = - let iter = typecheck_pattern_branch_list qtfbl lev in + (tyenv : Typeenv.t) (utpatbrs : untyped_pattern_branch list) (tyobj : mono_type) (tyres : mono_type) : pattern_branch list = + let unify = unify_ tyenv in + + let rec iter (patbracc : pattern_branch Alist.t) (utpatbrs : untyped_pattern_branch list) = match utpatbrs with - | [] -> ([], tyres) + | [] -> Alist.to_list patbracc | UTPatternBranch(utpat, utast1) :: tail -> let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in @@ -1280,8 +1282,7 @@ and typecheck_pattern_branch_list let tyenvpat = add_pattern_var_mono tyenv patvarmap in let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in let () = unify ty1 tyres in - let (patbrtail, tytail) = iter tyenv tail tyobj tyres in - (PatternBranch(epat, e1) :: patbrtail, tytail) + iter (Alist.extend patbracc (PatternBranch(epat, e1))) tail | UTPatternBranchWhen(utpat, utastB, utast1) :: tail -> let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in @@ -1291,8 +1292,10 @@ and typecheck_pattern_branch_list let () = unify tyB (Range.dummy "pattern-match-cons-when", BaseType(BoolType)) in let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in let () = unify ty1 tyres in - let (patbrtail, tytail) = iter tyenv tail tyobj tyres in - (PatternBranchWhen(epat, eB, e1) :: patbrtail, tytail) + iter (Alist.extend patbracc (PatternBranchWhen(epat, eB, e1))) tail + + in + iter Alist.empty utpatbrs and typecheck_pattern diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 06942d20d..fb97e5491 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -440,7 +440,7 @@ and untyped_abstract_tree_main = | UTLetRecIn of untyped_letrec_binding list * untyped_abstract_tree | UTLetNonRecIn of manual_type option * untyped_pattern_tree * untyped_abstract_tree * untyped_abstract_tree | UTIfThenElse of untyped_abstract_tree * untyped_abstract_tree * untyped_abstract_tree - | UTFunction of (Range.t * var_name) list * untyped_pattern_branch list + | UTFunction of (Range.t * var_name) list * untyped_pattern_branch | UTOpenIn of Range.t * module_name * untyped_abstract_tree | UTFinishHeaderFile | UTFinishStruct From 10eab41d2574398969ff97b384a0373417daebd5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 23:34:09 +0900 Subject: [PATCH 20/42] arrange spacing in 'exhchecker.ml' --- src/frontend/exhchecker.ml | 277 +++++++++++++++++++++---------------- 1 file changed, 156 insertions(+), 121 deletions(-) diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index 2d0d0a4f6..04267d178 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -2,6 +2,7 @@ module Types = Types_ open Types + type type_element = | EUnitConstant | EBooleanConstant of bool @@ -48,35 +49,40 @@ module ElementSet = Set.Make(struct | _ -> 1 end) + module IntSet = Set.Make(struct type t = int let compare i j = i - j end) + let repeat n x = let rec iter n acc = match n with | 0 -> acc - | _ -> iter (n-1) (x::acc) + | _ -> iter (n - 1) (x :: acc) in iter n [] + let one_to_n n = let rec iter n acc = match n with | 0 -> acc - | _ -> iter (n-1) (n::acc) + | _ -> iter (n - 1) (n :: acc) in iter n [] + let split_n lst n = let rec iter lst i a b = match lst with - | [] -> (List.rev a, List.rev b) - | x :: xs when n > i -> iter xs (i+1) (x::a) b - | x :: xs -> iter xs (i+1) a (x::b) + | [] -> (Alist.to_list a, Alist.to_list b) + | x :: xs when n > i -> iter xs (i + 1) (Alist.extend a x) b + | x :: xs -> iter xs (i + 1) a (Alist.extend b x) in - iter lst 0 [] [] + iter lst 0 Alist.empty Alist.empty + let is_all_wildcard mat = List.for_all (fun p -> @@ -85,14 +91,16 @@ let is_all_wildcard mat = | _ -> false ) (List.hd mat) + let flatten_tuple tup = - let rec iter ast acc = - match ast with - | PTupleCons(hd, PEndOfTuple) -> List.rev (hd::acc) - | PTupleCons(hd, tl) -> iter tl (hd::acc) - | _ -> failwith "malformed tuple(flatten_tuple)" + let rec iter pat acc = + match pat with + | PTupleCons(hd, PEndOfTuple) -> Alist.to_list (Alist.extend acc hd) + | PTupleCons(hd, tl) -> iter tl (Alist.extend acc hd) + | _ -> failwith "malformed tuple(flatten_tuple)" in - iter tup [] + iter tup Alist.empty + let instance_of_element ele = match ele with @@ -106,6 +114,7 @@ let instance_of_element ele = | ETuple -> failwith "tuple is not expected" | EWildCard -> IWildCard + let rec string_of_instance ins = match ins with | IListCons(IListCons(car, cdr), cdr2) -> @@ -149,106 +158,117 @@ let rec normalize_pat pat = | PAsVariable(_, p) -> normalize_pat p | _ -> pat + let expand_mat mat i epat ty = let rec inner_append a b acc = match (a, b) with - | (x::xs, y::ys) -> inner_append xs ys (List.append x y :: acc) - | (x::xs, []) -> inner_append xs [] (x :: acc) - | ([], y::ys) -> inner_append [] ys (y :: acc) - | ([], []) -> List.rev acc + | (x :: xs, y :: ys) -> inner_append xs ys (List.append x y :: acc) + | (x :: xs, []) -> inner_append xs [] (x :: acc) + | ([], y::ys) -> inner_append [] ys (y :: acc) + | ([], []) -> List.rev acc in let rec sub epat pat = match (epat, pat) with | (ExpandListCons, PListCons(h, t))-> - [[h]; [t]] + [[h]; [t]] | (ExpandListCons, PWildCard) -> - [[PWildCard]; [PWildCard]] + [[PWildCard]; [PWildCard]] | (ExpandConstructor(_, _), PConstructor(_, innerpat)) -> - [[innerpat]] + [[innerpat]] | (ExpandConstructor(_, _), PWildCard) -> - [[PWildCard]] + [[PWildCard]] | (ExpandTuple(_), PTupleCons(h, t)) -> - let ftup = flatten_tuple (PTupleCons(h, t)) in - List.map (fun pat -> [pat]) ftup + let ftup = flatten_tuple (PTupleCons(h, t)) in + List.map (fun pat -> [pat]) ftup | (ExpandTuple(arity), PWildCard) -> repeat arity [PWildCard] - | (_, _) -> [[pat]] + | (_, _) -> + [[pat]] in List.flatten (mat |> List.mapi (fun n col -> if i <> n then [col] else List.fold_left (fun a b -> inner_append a b []) [] (List.map (sub epat) col))) + let rec fold_left3 f a b c d = - match b, c, d with - | x::xs, y::ys, z::zs -> - fold_left3 f (f a x y z) xs ys zs - | _ -> a + match (b, c, d) with + | (x :: xs, y :: ys, z :: zs) -> fold_left3 f (f a x y z) xs ys zs + | _ -> a let rec get_specialized_mat mat patinfo ele tylst = let rec iter fst mat = let (nmat, ninfo, nomatch) = List.fold_left (fun (cols, info, no_match) col -> - let (newcol, newinfo, no_m) = (fold_left3 (fun (col, info, no_m) p q i -> - let needs_append = - match ele, p with - | EListCons, PListCons(_, _) - | EEndOfList, PEndOfList - | EUnitConstant, PUnitConstant - | ETuple, PTupleCons(_, _) - | _, PWildCard - -> true - | EBooleanConstant(b1), PBooleanConstant(b2) when b1 = b2 - -> true - | EIntegerConstant(i1), PIntegerConstant(i2) when i1 = i2 - -> true - | EStringConstant(s1), PStringConstant(Value(StringEmpty)) when String.equal s1 "" - -> true - | EStringConstant(s1), PStringConstant(Value(StringConstant(s2))) when String.equal s1 s2 - -> true - | EConstructor(nm1, _), PConstructor(nm2, _) when String.equal nm1 nm2 - -> true - | _ - -> false - in - match needs_append, i with - | true, (n, PatternBranch(_, _)) -> - (q::col, i::info, false) - | true, (n, PatternBranchWhen(_, _, _)) -> - (q::col, i::info, no_m) - | false, _ -> - (col, info, no_m) + let (newcol, newinfo, no_m) = + fold_left3 (fun (col, info, no_m) p q i -> + let needs_append = + match (ele, p) with + | (EListCons, PListCons(_, _)) + | (EEndOfList, PEndOfList) + | (EUnitConstant, PUnitConstant) + | (ETuple, PTupleCons(_, _)) + | (_, PWildCard) + -> true + + | (EBooleanConstant(b1), PBooleanConstant(b2)) when b1 = b2 + -> true + + | (EIntegerConstant(i1), PIntegerConstant(i2)) when i1 = i2 + -> true + + | (EStringConstant(s1), PStringConstant(Value(StringEmpty))) when String.equal s1 "" + -> true + + | (EStringConstant(s1), PStringConstant(Value(StringConstant(s2)))) when String.equal s1 s2 + -> true + + | (EConstructor(nm1, _), PConstructor(nm2, _)) when String.equal nm1 nm2 + -> true + + | _ + -> false + in + match (needs_append, i) with + | (true, (n, PatternBranch(_, _))) -> (q :: col, i :: info, false) + | (true, (n, PatternBranchWhen(_, _, _))) -> (q :: col, i :: info, no_m) + | (false, _) -> (col, info, no_m) ) ([], [], true) fst col patinfo - ) in ((List.rev newcol)::cols, newinfo, no_m && no_match)) ([], [], true) mat - in (List.rev nmat, List.rev ninfo, nomatch) + in + ((List.rev newcol) :: cols, newinfo, no_m && no_match)) ([], [], true) mat + in + (List.rev nmat, List.rev ninfo, nomatch) in - match ele, tylst with - | EListCons, (_, ListType(lty))::_ -> + match (ele, tylst) with + | (EListCons, (_, ListType(lty)) :: _) -> let expnd = ExpandListCons in let (nmat, ninfo, nomatch) = iter (List.hd mat) mat in - (expand_mat nmat 0 expnd tylst, ninfo, lty::tylst, expnd, nomatch) + (expand_mat nmat 0 expnd tylst, ninfo, lty :: tylst, expnd, nomatch) - | EConstructor(nm, ity), (_, VariantType(_, _))::rest -> + | (EConstructor(nm, ity), (_, VariantType(_, _)) :: rest) -> let expnd = ExpandConstructor(nm, ity) in let (nmat, ninfo, nomatch) = iter (List.hd mat) mat in - (expand_mat nmat 0 expnd tylst, ninfo, ity::rest, expnd, nomatch) + (expand_mat nmat 0 expnd tylst, ninfo, ity :: rest, expnd, nomatch) - | ETuple, (_, ProductType(ptylst))::rest -> + | (ETuple, (_, ProductType(ptylst)) :: rest) -> let expnd = ExpandTuple(List.length ptylst) in - (expand_mat mat 0 expnd tylst, patinfo, ptylst @ rest, expnd, false) + (expand_mat mat 0 expnd tylst, patinfo, List.append ptylst rest, expnd, false) | _ -> - begin match mat with - | x :: xs -> - let (nmat, ninfo, nomatch) = iter x mat in - (List.tl nmat, ninfo, List.tl tylst, NoExpand, nomatch) - | [] -> ([], [], [], NoExpand, true) + begin + match mat with + | x :: xs -> + let (nmat, ninfo, nomatch) = iter x mat in + (List.tl nmat, ninfo, List.tl tylst, NoExpand, nomatch) + + | [] -> + ([], [], [], NoExpand, true) end @@ -258,14 +278,15 @@ let list_sig = ElementSet.of_list [EListCons; EEndOfList] let product_sig = ElementSet.of_list [ETuple] let generic_sig = ElementSet.of_list [EWildCard] + let make_int_sig col = ElementSet.of_list (List.fold_left (fun acc p -> match p with - | PIntegerConstant(i) -> - EIntegerConstant(i)::EIntegerConstant(succ i)::acc - | _ -> acc + | PIntegerConstant(i) -> EIntegerConstant(i) :: EIntegerConstant(succ i) :: acc + | _ -> acc ) [] col) + let make_string_sig col = ElementSet.of_list (List.fold_left (fun acc p -> match p with @@ -274,13 +295,15 @@ let make_string_sig col = | _ -> acc ) [EWildCard] col) + let make_variant_sig qtfbl lev tyenv (tyarglst : mono_type list) tyid = let constrs = Typeenv.enumerate_constructors qtfbl tyenv lev tyid in ElementSet.of_list (constrs |> List.map (fun (nm, tyf) -> EConstructor(nm, tyf tyarglst))) -let rec complete_sig col qtfbl lev tyenv (ty : mono_type) = - match snd ty with + +let rec complete_sig col qtfbl lev tyenv ((_, tymain) : mono_type) = + match tymain with | TypeVariable({contents= MonoLink(tylink)}) -> complete_sig col qtfbl lev tyenv tylink | BaseType(UnitType) -> unit_sig | BaseType(BoolType) -> bool_sig @@ -292,89 +315,101 @@ let rec complete_sig col qtfbl lev tyenv (ty : mono_type) = | VariantType(tyarglst, tyid) -> make_variant_sig qtfbl lev tyenv tyarglst tyid | _ -> generic_sig + let tuplize_instance n ilst = let (top, btm) = split_n ilst n in ITupleCons(top) :: btm + let reduce_instance nm ty ilst = match ilst with - | x :: rest -> - IConstructor(nm, x, ty) :: rest - | _ -> failwith "reduce_instance failed" + | x :: rest -> IConstructor(nm, x, ty) :: rest + | _ -> failwith "reduce_instance failed" + let reduce_list_instance ilst = match ilst with - | car :: cdr :: rest -> - IListCons(car, cdr) :: rest - | _ -> failwith "reduce_list_instance failed" + | car :: cdr :: rest -> IListCons(car, cdr) :: rest + | _ -> failwith "reduce_list_instance failed" + let rec exhcheck_mat tylst mat patinfo qtfbl lev tyenv = let fold_instance expnd ele ins = match expnd with - | ExpandListCons -> - reduce_list_instance ins - | ExpandConstructor(nm, ty) -> - reduce_instance nm ty ins - | ExpandTuple(arity) -> - tuplize_instance arity ins - | NoExpand -> - (instance_of_element ele)::ins in + | ExpandListCons -> reduce_list_instance ins + | ExpandConstructor(nm, ty) -> reduce_instance nm ty ins + | ExpandTuple(arity) -> tuplize_instance arity ins + | NoExpand -> (instance_of_element ele)::ins + in let patinfo_extract patinfo = - patinfo |> List.map (fun (n, _) -> n) in + patinfo |> List.map (fun (n, _) -> n) + in let patinfo_until_match patinfo = fst @@ List.fold_left (fun (acc, fin) (n, patbr) -> - match fin, patbr with - | false, PatternBranch(_, _) -> (n::acc, true) - | false, PatternBranchWhen(_, _, _) -> (n::acc, false) - | true, _ -> (acc, true) - ) ([], false) patinfo in + match (fin, patbr) with + | (false, PatternBranch(_, _)) -> (n :: acc, true) + | (false, PatternBranchWhen(_, _, _)) -> (n :: acc, false) + | (true, _) -> (acc, true) + ) ([], false) patinfo + in let apply_each set = let (nonexh, nonexh_guard, used) = ElementSet.fold (fun ele (a_nonexh, a_nonexh_guard, a_used) -> let (smat, spatinfo, stylst, expnd, no_match) = get_specialized_mat mat patinfo ele tylst in - begin match no_match, smat with - | true, _ -> + match (no_match, smat) with + | (true, _) -> let used = IntSet.of_list (patinfo_extract spatinfo) in - let ins = (instance_of_element ele) :: (repeat (List.length tylst - 1) (IWildCard)) in + let ins = (instance_of_element ele) :: (repeat (List.length tylst - 1) IWildCard) in if IntSet.is_empty used then - (ins::a_nonexh, a_nonexh_guard, IntSet.union used a_used) + (ins :: a_nonexh, a_nonexh_guard, IntSet.union used a_used) else - (a_nonexh, ins::a_nonexh_guard, IntSet.union used a_used) - | false, [] -> + (a_nonexh, ins :: a_nonexh_guard, IntSet.union used a_used) + + | (false, []) -> (a_nonexh, a_nonexh_guard, IntSet.union (IntSet.of_list (patinfo_until_match spatinfo)) a_used) - | false, _ -> + + | (false, _ :: _) -> let (nonexh, nonexh_guard, used) = exhcheck_mat stylst smat spatinfo qtfbl lev tyenv in - ((List.map (fold_instance expnd ele) nonexh) @ a_nonexh, - (List.map (fold_instance expnd ele) nonexh_guard) @ a_nonexh_guard, - IntSet.union used a_used) - end) set ([], [], IntSet.empty) - in (List.rev nonexh, List.rev nonexh_guard, used) + ( + List.append (List.map (fold_instance expnd ele) nonexh) a_nonexh, + List.append (List.map (fold_instance expnd ele) nonexh_guard) a_nonexh_guard, + IntSet.union used a_used) + ) set ([], [], IntSet.empty) + in + (List.rev nonexh, List.rev nonexh_guard, used) in match tylst with - | [] -> ([], [], IntSet.empty) + | [] -> + ([], [], IntSet.empty) + | _ -> if is_all_wildcard mat then apply_each generic_sig else apply_each (complete_sig (List.hd mat) qtfbl lev tyenv (List.hd tylst)) -let non_empty lst = - match lst with + +let non_empty = function | [] -> false - | _ -> true + | _ -> true + let main (rng : Range.t) (patbrs : pattern_branch list) (ty : mono_type) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) : unit = - let patbrs = patbrs |> List.map (fun patbr -> - match patbr with - | PatternBranch(p, a) -> PatternBranch(normalize_pat p, a) - | PatternBranchWhen(p, a1, a2) -> PatternBranchWhen(normalize_pat p, a1, a2) - ) in - let mat = [patbrs |> List.map (fun patbr -> - match patbr with - | PatternBranch(p, _) -> p - | PatternBranchWhen(p, _, _) -> p - )] in + let patbrs = + patbrs |> List.map (function + | PatternBranch(p, a) -> PatternBranch(normalize_pat p, a) + | PatternBranchWhen(p, a1, a2) -> PatternBranchWhen(normalize_pat p, a1, a2) + ) + in + let mat = + [ + patbrs |> List.map (function + | PatternBranch(p, _) -> p + | PatternBranchWhen(p, _, _) -> p + ) + ] + in let patid = one_to_n (List.length patbrs) in let patinfo = List.combine patid patbrs in let (nonexh, nonexh_guard, used) = exhcheck_mat [ty] mat patinfo qtfbl lev tyenv in From 2ab21b3e72da307d9a7094a6553cd114649db1d7 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 23:38:46 +0900 Subject: [PATCH 21/42] fix small bug of exhaustiveness checker by using 'unlink' --- src/frontend/exhchecker.ml | 2 +- src/frontend/typechecker.ml | 6 ------ src/frontend/types_.cppo.ml | 6 ++++++ 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index 04267d178..eaf99c804 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -245,7 +245,7 @@ let rec get_specialized_mat mat patinfo ele tylst = in (List.rev nmat, List.rev ninfo, nomatch) in - match (ele, tylst) with + match (ele, tylst |> List.map unlink) with | (EListCons, (_, ListType(lty)) :: _) -> let expnd = ExpandListCons in let (nmat, ninfo, nomatch) = iter (List.hd mat) mat in diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 904408e7d..f011e93f3 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -22,12 +22,6 @@ exception InternalInclusionError exception InternalContradictionError -let unlink ((_, tymain) as ty) = - match tymain with - | TypeVariable({contents = MonoLink(ty)}) -> ty - | _ -> ty - - let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index fb97e5491..7650629f9 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -909,6 +909,12 @@ let rec unnormalize (ty : nom_type) : mono_type = (rng, tymainu) *) +let rec unlink ((_, tymain) as ty) = + match tymain with + | TypeVariable({contents = MonoLink(ty)}) -> unlink ty + | _ -> ty + + let rec erase_range_of_type (ty : mono_type) : mono_type = let iter = erase_range_of_type in let rng = Range.dummy "erased" in From 1fbde5d1b631cf8df2fcf84172980fbcfdcf7919 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 23:40:35 +0900 Subject: [PATCH 22/42] arrange spacing in 'exhchecker.ml' --- src/frontend/exhchecker.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/frontend/exhchecker.ml b/src/frontend/exhchecker.ml index eaf99c804..71970a814 100644 --- a/src/frontend/exhchecker.ml +++ b/src/frontend/exhchecker.ml @@ -290,8 +290,8 @@ let make_int_sig col = let make_string_sig col = ElementSet.of_list (List.fold_left (fun acc p -> match p with - | PStringConstant(Value(StringEmpty)) -> EStringConstant("")::acc - | PStringConstant(Value(StringConstant(s))) -> EStringConstant(s)::acc + | PStringConstant(Value(StringEmpty)) -> EStringConstant("") :: acc + | PStringConstant(Value(StringConstant(s))) -> EStringConstant(s) :: acc | _ -> acc ) [EWildCard] col) @@ -339,7 +339,7 @@ let rec exhcheck_mat tylst mat patinfo qtfbl lev tyenv = | ExpandListCons -> reduce_list_instance ins | ExpandConstructor(nm, ty) -> reduce_instance nm ty ins | ExpandTuple(arity) -> tuplize_instance arity ins - | NoExpand -> (instance_of_element ele)::ins + | NoExpand -> (instance_of_element ele) :: ins in let patinfo_extract patinfo = patinfo |> List.map (fun (n, _) -> n) From 5c6fcd76bff9fc3526ec92f8f7a3dce990f4e74a Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 7 Aug 2018 23:50:07 +0900 Subject: [PATCH 23/42] omit comment-out code that is no longer used --- src/frontend/types_.cppo.ml | 118 ------------------------------------ 1 file changed, 118 deletions(-) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 7650629f9..7485917e1 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -341,17 +341,6 @@ and mono_option_row = (mono_type_variable_info ref, mono_option_row_variable_inf type mono_command_argument_type = (mono_type_variable_info ref, mono_option_row_variable_info ref) command_argument_type -(* -type nom_type_variable_info = - | NomFree of nom_kind FreeID_.t_ * mono_type_variable_info ref - -and nom_kind = nom_type_variable_info kind - -and nom_type = nom_type_variable_info typ -[@@deriving show] - -type nom_option_row = nom_type_variable_info option_row -*) module FreeID = struct @@ -407,9 +396,6 @@ and untyped_abstract_tree_main = | UTInputHorz of untyped_input_horz_element list | UTInputVert of untyped_input_vert_element list | UTConcat of untyped_abstract_tree * untyped_abstract_tree -(* - | UTLambdaOptional of Range.t * var_name * untyped_abstract_tree -*) | UTLambdaHorz of Range.t * var_name * untyped_abstract_tree | UTLambdaVert of Range.t * var_name * untyped_abstract_tree | UTLambdaMath of untyped_abstract_tree @@ -828,11 +814,6 @@ type output_unit = | OShallow *) -(* -let poly_extend (fmono : mono_type -> mono_type) : (poly_type -> poly_type) = - (fun (Poly(ty)) -> Poly(fmono ty)) -*) - let get_range (rng, _) = rng @@ -848,66 +829,6 @@ let lift_manual_common f = function | MMandatoryArgumentType(mnty) -> f mnty | MOptionalArgumentType(mnty) -> f mnty -(* -(* -- 'normalize_type': eliminates 'Link(_)' -- *) -let rec normalize_mono_type (ty : mono_type) : nom_type = - let iter = normalize_mono_type in - let (rng, tymain) = ty in - match tymain with - | TypeVariable(tvref) -> - begin - match !tvref with - | MonoFree(tvid) -> (rng, TypeVariable(NomFree(FreeID.map_kind normalize_kind tvid, tvref))) - | MonoLink(tylink) -> iter tylink - end - - | VariantType(tylist, tyid) -> (rng, VariantType(List.map iter tylist, tyid)) - | SynonymType(tylist, tyid, tyreal) -> (rng, SynonymType(List.map iter tylist, tyid, iter tyreal)) - | BaseType(bt) -> (rng, BaseType(bt)) - | ListType(tycont) -> (rng, ListType(iter tycont)) - | RefType(tycont) -> (rng, RefType(iter tycont)) - | FuncType(optrow, tydom, tycod) -> (rng, FuncType(normalize_option_row optrow, iter tydom, iter tycod)) - | ProductType(tylist) -> (rng, ProductType(List.map iter tylist)) - | RecordType(tyassoc) -> (rng, RecordType(Assoc.map_value iter tyassoc)) - | HorzCommandType(tylist) -> (rng, HorzCommandType(List.map (lift_argument_type iter) tylist)) - | VertCommandType(tylist) -> (rng, VertCommandType(List.map (lift_argument_type iter) tylist)) - | MathCommandType(tylist) -> (rng, MathCommandType(List.map (lift_argument_type iter) tylist)) - - -and normalize_kind (kd : mono_kind) : nom_kind = - match kd with - | UniversalKind -> UniversalKind - | RecordKind(tyasc) -> RecordKind(Assoc.map_value normalize_mono_type tyasc) - - -and normalize_option_row (optrow : mono_option_row) : nom_option_row = - match optrow with - | OptionRowEmpty -> OptionRowEmpty - | OptionRowCons(ty, tail) -> OptionRowCons(normalize_mono_type ty, normalize_option_row tail) - | OptionRowVariable({contents = OptionRowLink(optrow)}) -> normalize_option_row optrow - | OptionRowVariable(orref) -> OptionRowVariable(orref) - - -let rec unnormalize (ty : nom_type) : mono_type = - let iter = unnormalize in - let (rng, tymain) = ty in - let tymainu = - match tymain with - | TypeVariable(NomFree(_, tvref)) -> TypeVariable(tvref) - | VariantType(tylist, tyid) -> VariantType(List.map iter tylist, tyid) - | SynonymType(tylist, tyid, tyreal) -> SynonymType(List.map iter tylist, tyid, iter tyreal) - | BaseType(bt) -> BaseType(bt) - | ListType(tycont) -> ListType(iter tycont) - | RefType(tycont) -> RefType(iter tycont) - | FuncType(tyoptsr, tydom, tycod) -> FuncType(ref (List.map iter (!tyoptsr)), iter tydom, iter tycod) - | ProductType(tylist) -> ProductType(List.map iter tylist) - | RecordType(tyassoc) -> RecordType(Assoc.map_value iter tyassoc) - | HorzCommandType(tylist) -> HorzCommandType(List.map (lift_argument_type iter) tylist) - | VertCommandType(tylist) -> VertCommandType(List.map (lift_argument_type iter) tylist) - | MathCommandType(tylist) -> MathCommandType(List.map (lift_argument_type iter) tylist) - in - (rng, tymainu) -*) let rec unlink ((_, tymain) as ty) = match tymain with @@ -1217,37 +1138,9 @@ let unlift_option_row poptrow = try Some(unlift_aux_or poptrow) with | Exit -> None -(* -let copy_environment (env : environment) : environment = - let (valenv, stenv) = env in - (Hashtbl.copy valenv, stenv) -*) - -(* -let replicate_store (env : environment) : environment = - let (valenv, stenv) = env in - let stenvnew = StoreIDHashTable.copy stenv in -(* - let stenvnew = StoreIDHashTable.create 32 in - StoreIDHashTable.iter (fun stid value -> StoreIDHashTable.add stenvnew stid value) stenv; -*) -(* - Format.printf "Types> ==== REPLICATE ====\n"; - StoreIDHashTable.iter (fun stid value -> - Format.printf "| %s %a\n" (StoreID.show_direct stid) pp_syntactic_value value) stenv; - Format.printf "Types> ==== END REPLICATE ====\n"; - - Format.printf "Types> ==== VALENV ====\n"; - EvalVarIDMap.iter (fun evid loc -> - Format.printf "| %s\n" (EvalVarID.show_direct evid)) valenv; - Format.printf "Types> ==== END VALENV ====\n"; -*) - (valenv, stenvnew) -*) let add_to_environment (env : environment) (evid : EvalVarID.t) (rfast : location) = let (valenv, stenvref) = env in - (* Format.printf "Types> add %s \n" (EvalVarID.show_direct evid); *) (valenv |> EvalVarIDMap.add evid rfast, stenvref) @@ -1260,9 +1153,6 @@ let register_location (env : environment) (value : syntactic_value) : StoreID.t let (_, stenvref) = env in let stid = StoreID.fresh () in StoreIDHashTable.add (!stenvref) stid value; -(* - Format.printf "Types> Assign %s <--- %a\n" (StoreID.show_direct stid) pp_syntactic_value value; (* for debug *) -*) stid @@ -1400,11 +1290,6 @@ module MathContext type math_context = MathContext.t -(* -(* !!!! ---- global variable ---- !!!! *) - -let global_hash_env : (string, location) Hashtbl.t = Hashtbl.create 32 -*) (* -- following are all for debugging -- *) @@ -1445,9 +1330,6 @@ let rec string_of_type_basic tvf orvf tystr : string = | BaseType(TextColType) -> "block-text" ^ qstn | BaseType(BoxRowType) -> "inline-boxes" ^ qstn | BaseType(BoxColType) -> "block-boxes" ^ qstn -(* - | BaseType(FontType) -> "font" ^ qstn -*) | BaseType(ContextType) -> "context" ^ qstn | BaseType(PrePathType) -> "pre-path" ^ qstn | BaseType(PathType) -> "path" ^ qstn From 049e882b071cf66a42b74e1b9210a7b049f2d522 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 00:22:44 +0900 Subject: [PATCH 24/42] fix type checker as to 'when ...' --- src/frontend/typechecker.ml | 48 +++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index f011e93f3..600ee9507 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -720,13 +720,9 @@ let rec typecheck | UTFunction(optargs, utpatbr) -> let (optrow, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in - let tvidO = FreeID.fresh UniversalKind qtfbl lev () in - let betaO = (Range.dummy "UTFunction:dom", TypeVariable(ref (MonoFree(tvidO)))) in - let tvidR = FreeID.fresh UniversalKind qtfbl lev () in - let betaR = (Range.dummy "UTFunction:cod", TypeVariable(ref (MonoFree(tvidR)))) in - let patbrs = typecheck_pattern_branch_list qtfbl lev tyenvnew [utpatbr] betaO betaR in - let e = Function(evids, patbrs) in - (e, (rng, FuncType(optrow, betaO, betaR))) + let (patbr, typat, tybody) = typecheck_pattern_branch qtfbl lev tyenvnew utpatbr in + let e = Function(evids, [patbr]) in + (e, (rng, FuncType(optrow, typat, tybody))) (* let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (varrng, TypeVariable(ref (Free(tvid)))) in @@ -1260,6 +1256,23 @@ and typecheck_itemize_list PrimitiveListCons(ehd, etl) +and typecheck_pattern_branch (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utpatbr : untyped_pattern_branch) : pattern_branch * mono_type * mono_type = + match utpatbr with + | UTPatternBranch(utpat, utast1) -> + let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in + let tyenvpat = add_pattern_var_mono tyenv patvarmap in + let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in + (PatternBranch(epat, e1), typat, ty1) + + | UTPatternBranchWhen(utpat, utastB, utast1) -> + let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in + let tyenvpat = add_pattern_var_mono tyenv patvarmap in + let (eB, tyB) = typecheck qtfbl lev tyenvpat utastB in + let () = unify_ tyenvpat tyB (Range.dummy "pattern-match-cons-when", BaseType(BoolType)) in + let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in + (PatternBranchWhen(epat, eB, e1), typat, ty1) + + and typecheck_pattern_branch_list (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utpatbrs : untyped_pattern_branch list) (tyobj : mono_type) (tyres : mono_type) : pattern_branch list = @@ -1268,25 +1281,14 @@ and typecheck_pattern_branch_list let rec iter (patbracc : pattern_branch Alist.t) (utpatbrs : untyped_pattern_branch list) = match utpatbrs with - | [] -> Alist.to_list patbracc - - | UTPatternBranch(utpat, utast1) :: tail -> - let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in - let () = unify typat tyobj in - let tyenvpat = add_pattern_var_mono tyenv patvarmap in - let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in - let () = unify ty1 tyres in - iter (Alist.extend patbracc (PatternBranch(epat, e1))) tail + | [] -> + Alist.to_list patbracc - | UTPatternBranchWhen(utpat, utastB, utast1) :: tail -> - let (epat, typat, patvarmap) = typecheck_pattern qtfbl lev tyenv utpat in + | utpatbr :: tail -> + let (patbr, typat, ty1) = typecheck_pattern_branch qtfbl lev tyenv utpatbr in let () = unify typat tyobj in - let tyenvpat = add_pattern_var_mono tyenv patvarmap in - let (eB, tyB) = typecheck qtfbl lev tyenvpat utastB in - let () = unify tyB (Range.dummy "pattern-match-cons-when", BaseType(BoolType)) in - let (e1, ty1) = typecheck qtfbl lev tyenvpat utast1 in let () = unify ty1 tyres in - iter (Alist.extend patbracc (PatternBranchWhen(epat, eB, e1))) tail + iter (Alist.extend patbracc patbr) tail in iter Alist.empty utpatbrs From 57b2cb8b01f61ee22973c32cf2fd797a255f78bc Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 02:28:43 +0900 Subject: [PATCH 25/42] fix and refactor interpreter mainly as to optional command arguments --- src/frontend/bytecomp/bytecomp.ml | 4 +- src/frontend/bytecomp/compiler.ml | 13 +++- src/frontend/bytecomp/ir_.cppo.ml | 44 +++++++------ src/frontend/evaluator_.cppo.ml | 100 +++++++++++++++++++----------- src/frontend/parser.mly | 4 +- src/frontend/primitives_.cppo.ml | 4 +- src/frontend/typechecker.ml | 79 +++++++++++------------ src/frontend/types_.cppo.ml | 29 +++++---- 8 files changed, 163 insertions(+), 114 deletions(-) diff --git a/src/frontend/bytecomp/bytecomp.ml b/src/frontend/bytecomp/bytecomp.ml index 37682986a..cbd001f2f 100644 --- a/src/frontend/bytecomp/bytecomp.ml +++ b/src/frontend/bytecomp/bytecomp.ml @@ -20,9 +20,9 @@ let compile_environment env = let (binds, _) = env in binds |> EvalVarIDMap.iter (fun evid loc -> match !loc with - | PrimitiveWithEnvironment(parbrs, env1, arity, astf) -> + | PrimitiveWithEnvironment(parbr, env1, arity, astf) -> begin - match compile_and_exec env (Function([], parbrs)) with + match compile_and_exec env (Function([], parbr)) with | CompiledFuncWithEnvironment(_, _, framesize, body, env1) -> loc := CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) | _ -> () diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index 5a8f33c0b..51febefa7 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -39,10 +39,13 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) = | IRInputHorzText(s) -> CompiledInputHorzText(s) - | IRInputHorzEmbedded(ircmd, irarglist) -> + | IRInputHorzEmbedded(irapp) -> + let compiled = compile irapp [] in +(* let appcode = emit_appop (List.length irarglist) [] true in let cmdcode = compile ircmd appcode in let compiled = compile_list irarglist cmdcode in +*) CompiledInputHorzEmbedded(compiled) | IRInputHorzEmbeddedMath(irmath) -> @@ -57,10 +60,13 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) = and compile_input_vert_content (ivlst : ir_input_vert_element list) = let compiled_ivlist = ivlst |> List.map (function - | IRInputVertEmbedded(ircmd, irarglist) -> + | IRInputVertEmbedded(irapp) -> + let compiled = compile irapp [] in +(* let appcode = emit_appop (List.length irarglist) [] true in let cmdcode = compile ircmd appcode in let compiled = compile_list irarglist cmdcode in +*) CompiledInputVertEmbedded(compiled) | IRInputVertContent(ir) -> @@ -144,6 +150,9 @@ and compile (ir : ir) (cont : instruction list) = else OpClosure(List.length irpatlst, framesize, optcode) :: cont + | IROptFunction(framesize, vars, irpat, irbody) -> + failwith "IROptFunction: remains to be implemented" + | IRApply(arity, ircallee, irargs) -> compile_list irargs @@ (compile ircallee @@ emit_appop (List.length irargs) cont false) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 320d7234c..06a6d3a73 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -42,10 +42,9 @@ let rec transform_input_horz_content (env : frame) (ihlst : input_horz_element l | InputHorzText(s) -> (IRInputHorzText(s), env) - | InputHorzEmbedded(astcmd, astarglst) -> - let (ircmd, env) = transform env astcmd in - let (irarglst, env) = transform_list env astarglst in - (IRInputHorzEmbedded(ircmd, irarglst), env) + | InputHorzEmbedded(astapp) -> + let (irapp, env) = transform env astapp in + (IRInputHorzEmbedded(irapp), env) | InputHorzEmbeddedMath(astmath) -> let (irmath, env) = transform env astmath in @@ -60,10 +59,9 @@ let rec transform_input_horz_content (env : frame) (ihlst : input_horz_element l and transform_input_vert_content (env : frame) (ivlst : input_vert_element list) : ir_input_vert_element list * frame = ivlst @|> env @|> map_with_env (fun env elem -> match elem with - | InputVertEmbedded(astcmd, astarglst) -> - let (ircmd, env) = transform env astcmd in - let (irarglst, env) = transform_list env astarglst in - (IRInputVertEmbedded(ircmd, irarglst), env) + | InputVertEmbedded(astapp) -> + let (irapp, env) = transform env astapp in + (IRInputVertEmbedded(irapp), env) | InputVertContent(ast) -> let (ir, env) = transform env ast in @@ -228,19 +226,19 @@ and find_in_environment (env : frame) (evid : EvalVarID.t) : varloc option = | None -> None -and add_letrec_bindings_to_environment (env : frame) (recbinds : letrec_binding list) : (varloc * pattern_branch list) list * frame = +and add_letrec_bindings_to_environment (env : frame) (recbinds : letrec_binding list) : (varloc * pattern_branch) list * frame = recbinds @|> env @|> map_with_env (fun env recbind -> - let LetRecBinding(evid, patbrs) = recbind in + let LetRecBinding(evid, patbr) = recbind in let (var, env) = add_to_environment env evid in - ((var, patbrs), env) + ((var, patbr), env) ) and flatten_function (astfun : abstract_tree) : abstract_tree * pattern_tree list = let rec iter ast acc = match ast with - | Function([], [PatternBranch(pat, body)]) -> iter body (Alist.extend acc pat) - | _ -> (ast, Alist.to_list acc) + | Function([], PatternBranch(pat, body)) -> iter body (Alist.extend acc pat) + | _ -> (ast, Alist.to_list acc) in iter astfun Alist.empty @@ -330,11 +328,13 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (pathelemlst, closingopt, env) = transform_path env pathcomplst cycleopt in (IRPath(irpt0, pathelemlst, closingopt), env) +(* | LambdaVert(evid, astdef) -> - transform env (Function([], [(PatternBranch ((PVariable(evid)), astdef))])) + transform env (Function([], PatternBranch(PVariable(evid), astdef))) | LambdaHorz(evid, astdef) -> - transform env (Function([], [(PatternBranch ((PVariable(evid)), astdef))])) + transform env (Function([], PatternBranch(PVariable(evid), astdef))) +*) | PrimitiveTupleCons(asthd, asttl) -> transform_tuple env ast @@ -355,8 +355,8 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (pairs, env) = add_letrec_bindings_to_environment env recbinds in let varir_lst = pairs |> List.map (fun pair -> - let (var, patbrs) = pair in - let (ir, _) = transform env (Function([], patbrs)) in + let (var, patbr) = pair in + let (ir, _) = transform env (Function([], patbr)) in (var, ir) ) in @@ -376,9 +376,17 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (irbody, funenv) = transform funenv body in (IRFunction(funenv.size, irargs, irbody), env) - | Function((_ :: _) as evids, patbrs) -> + | Function((_ :: _) as evids, PatternBranch(arg, body)) -> let (vars, funenv) = map_with_env add_to_environment (new_level env) evids in + let (irarg, funenv) = transform_pattern funenv arg in + let (irbody, funenv) = transform funenv body in + (IROptFunction(funenv.size, vars, irarg, irbody), env) +(* failwith "Function with optional arguments: remains to be implemented." +*) + + | Function(_, PatternBranchWhen(_, _, _)) -> + assert false | Apply(_, _) -> let (callee, args) = flatten_application ast in diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index 3caa37c06..f34648c64 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -16,7 +16,8 @@ let report_dynamic_error msg = type nom_input_horz_element = | NomInputHorzText of string - | NomInputHorzEmbedded of abstract_tree * abstract_tree list + | NomInputHorzEmbedded of abstract_tree + | NomInputHorzThunk of abstract_tree | NomInputHorzContent of nom_input_horz_element list * environment @@ -25,8 +26,14 @@ let lex_horz_text (ctx : HorzBox.context_main) (s_utf8 : string) : HorzBox.horz_ HorzBox.([HorzPure(PHCInnerString(ctx, uchlst))]) -let rec reduce_beta envf evid valuel astdef = - let envnew = add_to_environment envf evid (ref valuel) in +let rec reduce_beta evids env1 evid valuel astdef = + let env1 = + evids |> List.fold_left (fun env evid -> + let loc = ref (Constructor("None", UnitConstant)) in + add_to_environment env evid loc + ) env1 + in + let envnew = add_to_environment env1 evid (ref valuel) in interpret envnew astdef @@ -38,8 +45,14 @@ and reduce_beta_list valuef valuearglst = | valuearg :: astargtail -> begin match valuef with - | FuncWithEnvironment(_, patbrs, envf) -> - let valuefnew = select_pattern (Range.dummy "reduce_beta_list") envf valuearg patbrs in + | FuncWithEnvironment(evids, patbr, env1) -> + let env1 = + evids |> List.fold_left (fun env evid -> + let loc = ref (Constructor("None", UnitConstant)) in + add_to_environment env evid loc + ) env1 + in + let valuefnew = select_pattern (Range.dummy "reduce_beta_list") env1 valuearg [patbr] in reduce_beta_list valuefnew astargtail | _ -> report_bug_value "reduce_beta_list" valuef @@ -84,8 +97,8 @@ and interpret_input_horz_content env (ihlst : input_horz_element list) = | InputHorzText(s) -> ImInputHorzText(s) - | InputHorzEmbedded(astcmd, astarglst) -> - ImInputHorzEmbedded(astcmd, astarglst) + | InputHorzEmbedded(astabs) -> + ImInputHorzEmbedded(astabs) | InputHorzEmbeddedMath(astmath) -> ImInputHorzEmbeddedMath(astmath) @@ -103,8 +116,8 @@ and interpret_input_horz_content env (ihlst : input_horz_element list) = and interpret_input_vert_content env (ivlst : input_vert_element list) = ivlst |> List.map (function - | InputVertEmbedded(astcmd, astarglst) -> - ImInputVertEmbedded(astcmd, astarglst) + | InputVertEmbedded(astabs) -> + ImInputVertEmbedded(astabs) | InputVertContent(ast) -> let value = interpret env ast in @@ -150,9 +163,11 @@ and interpret env ast = in LengthConstant(len) +(* | LambdaVert(evid, astdef) -> LambdaVertWithEnvironment(evid, astdef, env) | LambdaHorz(evid, astdef) -> LambdaHorzWithEnvironment(evid, astdef, env) +*) (* -- fundamentals -- *) @@ -176,25 +191,25 @@ and interpret env ast = select_pattern (Range.dummy "LetNonRecIn") env value1 [PatternBranch(pat, ast2)] | Function(evids, patbrs) -> - let envor = - evids |> List.fold_left (fun env evid -> - let loc = ref (Constructor("None", UnitConstant)) in - add_to_environment env evid loc - ) env - in - FuncWithEnvironment(evids, patbrs, envor) + FuncWithEnvironment(evids, patbrs, env) | Apply(ast1, ast2) -> let value1 = interpret env ast1 in begin match value1 with - | FuncWithEnvironment(_, patbrs, env1) -> + | FuncWithEnvironment(evids, patbr, env1) -> + let env1 = + evids |> List.fold_left (fun env evid -> + let loc = ref (Constructor("None", UnitConstant)) in + add_to_environment env evid loc + ) env1 + in let value2 = interpret env ast2 in - select_pattern (Range.dummy "Apply") env1 value2 patbrs + select_pattern (Range.dummy "Apply") env1 value2 [patbr] - | PrimitiveWithEnvironment(patbrs, env1, _, _) -> + | PrimitiveWithEnvironment(patbr, env1, _, _) -> let value2 = interpret env ast2 in - select_pattern (Range.dummy "Apply") env1 value2 patbrs + select_pattern (Range.dummy "Apply") env1 value2 [patbr] | _ -> report_bug_reduction "Apply: not a function" ast1 value1 end @@ -206,8 +221,8 @@ and interpret env ast = | FuncWithEnvironment(evid :: evids, patbrs, env1) -> let value2 = interpret env ast2 in let loc = ref (Constructor("Some", value2)) in - let env1new = add_to_environment env1 evid loc in - FuncWithEnvironment(evids, patbrs, env1new) + let env1 = add_to_environment env1 evid loc in + FuncWithEnvironment(evids, patbrs, env1) | _ -> report_bug_reduction "ApplyOptional: not a function with optional parameter" ast1 value1 end @@ -217,6 +232,7 @@ and interpret env ast = begin match value1 with | FuncWithEnvironment(evid :: evids, patbrs, env1) -> + let env1 = add_to_environment env1 evid (ref (Constructor("None", UnitConstant))) in FuncWithEnvironment(evids, patbrs, env1) | _ -> report_bug_reduction "ApplyOmission: not a function with optional parameter" ast1 value1 @@ -343,12 +359,14 @@ and interpret_intermediate_input_vert env (valuectx : syntactic_value) (imivlst let rec interpret_commands env (imivlst : intermediate_input_vert_element list) = imivlst |> List.map (fun imiv -> match imiv with - | ImInputVertEmbedded(astcmd, astarglst) -> - let valuecmd = interpret env astcmd in + | ImInputVertEmbedded(astabs) -> + let valuevert = interpret env (Apply(astabs, Value(valuectx))) in + get_vert valuevert +(* begin match valuecmd with - | LambdaVertWithEnvironment(evid, astdef, envf) -> - let valuedef = reduce_beta envf evid valuectx astdef in + | LambdaVertWithEnvironment(evid, astdef, env1) -> + let valuedef = reduce_beta [] env1 evid valuectx astdef in let valuearglst = astarglst |> List.fold_left (fun acc astarg -> let valuearg = interpret env astarg in @@ -361,6 +379,7 @@ and interpret_intermediate_input_vert env (valuectx : syntactic_value) (imivlst | _ -> report_bug_reduction "interpret_intermediate_input_vert:1" astcmd valuecmd end +*) | ImInputVertContent(imivlstsub, envsub) -> interpret_commands envsub imivlstsub @@ -378,8 +397,8 @@ and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_ let rec normalize (imihlst : intermediate_input_horz_element list) = imihlst |> List.fold_left (fun acc imih -> match imih with - | ImInputHorzEmbedded(astcmd, astarglst) -> - let nmih = NomInputHorzEmbedded(astcmd, astarglst) in + | ImInputHorzEmbedded(astabs) -> + let nmih = NomInputHorzEmbedded(astabs) in Alist.extend acc nmih | ImInputHorzText(s2) -> @@ -390,7 +409,7 @@ and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_ end | ImInputHorzEmbeddedMath(astmath) -> - let nmih = NomInputHorzEmbedded(Value(valuemcmd), [astmath]) in + let nmih = NomInputHorzThunk(Apply(Apply(Value(valuemcmd), Value(valuectx)), astmath)) in Alist.extend acc nmih | ImInputHorzContent(imihlstsub, envsub) -> @@ -404,12 +423,14 @@ and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_ let rec interpret_commands env (nmihlst : nom_input_horz_element list) : HorzBox.horz_box list = nmihlst |> List.map (fun nmih -> match nmih with - | NomInputHorzEmbedded(astcmd, astarglst) -> - let valuecmd = interpret env astcmd in + | NomInputHorzEmbedded(astabs) -> + let valuehorz = interpret env (Apply(astabs, Value(valuectx))) in + get_horz valuehorz +(* begin match valuecmd with - | LambdaHorzWithEnvironment(evid, astdef, envf) -> - let valuedef = reduce_beta envf evid valuectx astdef in + | LambdaHorzWithEnvironment(evid, astdef, env1) -> + let valuedef = reduce_beta [] env1 evid valuectx astdef in let valuearglst = astarglst |> List.fold_left (fun acc astarg -> let valuearg = interpret env astarg in @@ -423,6 +444,11 @@ and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_ | _ -> report_bug_reduction "interpret_input_horz" astcmd valuecmd end +*) + + | NomInputHorzThunk(ast) -> + let valuehorz = interpret env ast in + get_horz valuehorz | NomInputHorzText(s) -> lex_horz_text ctx s @@ -510,9 +536,9 @@ and check_pattern_matching (env : environment) (pat : pattern_tree) (valueobj : and add_letrec_bindings_to_environment (env : environment) (recbinds : letrec_binding list) : environment = let trilst = - recbinds |> List.map (function LetRecBinding(evid, patbrs) -> + recbinds |> List.map (function LetRecBinding(evid, patbr) -> let loc = ref StringEmpty in - (evid, loc, patbrs) + (evid, loc, patbr) ) in let envnew = @@ -520,7 +546,7 @@ and add_letrec_bindings_to_environment (env : environment) (recbinds : letrec_bi add_to_environment envacc evid loc ) in - trilst |> List.iter (fun (evid, loc, patbrs) -> - loc := FuncWithEnvironment([], patbrs, envnew) + trilst |> List.iter (fun (evid, loc, patbr) -> + loc := FuncWithEnvironment([], patbr, envnew) ); envnew diff --git a/src/frontend/parser.mly b/src/frontend/parser.mly index 01a573e3f..e72c51435 100644 --- a/src/frontend/parser.mly +++ b/src/frontend/parser.mly @@ -53,7 +53,7 @@ utastdef | UTPatternArgument(argpat) :: utargtail -> - (rng, UTFunction(Alist.to_list optargacc, UTPatternBranch(argpat, curry_lambda_abstract Alist.empty rng utargtail utastdef))) + (rng, UTFunction(Alist.to_list optargacc, argpat, curry_lambda_abstract Alist.empty rng utargtail utastdef)) | UTOptionalArgument(rngvar, varnm) :: utargtail -> curry_lambda_abstract (Alist.extend optargacc (rngvar, varnm)) rng utargtail utastdef @@ -291,7 +291,7 @@ let varnm = numbered_var_name i in let accnew = Alist.extend acc (Range.dummy "make_function_for_parallel:2", UTContentOf([], varnm)) in let patvar = (Range.dummy "make_function_for_parallel:3", UTPVariable(varnm)) in - (rngfull, UTFunction([], UTPatternBranch(patvar, aux accnew (i + 1)))) + (rngfull, UTFunction([], patvar, aux accnew (i + 1))) in aux Alist.empty 0 diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index a9a5de219..15d836711 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -212,8 +212,8 @@ let add_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.register_type "inline-graphics" tyid_igraf (Typeenv.Alias(([], Poly(tIGR_raw)))) -let lam evid ast = Function([], [PatternBranch(PVariable(evid), ast)]) -let lamenv env evid arity ast astf = PrimitiveWithEnvironment([PatternBranch(PVariable(evid), ast)], env, arity, astf) +let lam evid ast = Function([], PatternBranch(PVariable(evid), ast)) +let lamenv env evid arity ast astf = PrimitiveWithEnvironment(PatternBranch(PVariable(evid), ast), env, arity, astf) let ( !- ) evid = ContentOf(Range.dummy "temporary", evid) let rec lambda1 astf env = diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 600ee9507..2bdfe165c 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -22,6 +22,10 @@ exception InternalInclusionError exception InternalContradictionError +let abstraction evid ast = + Function([], PatternBranch(PVariable(evid), ast)) + + let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> @@ -632,22 +636,18 @@ let rec typecheck (Concat(e1, e2), (rng, BaseType(TextRowType))) | UTLambdaHorz(varrng, varnmctx, utast1) -> - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(PolyFree(ref (MonoFree(tvid))))) in let evid = EvalVarID.fresh varnmctx in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(beta), evid)) utast1 in + let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in let () = unify tyret (Range.dummy "lambda-horz-return", BaseType(BoxRowType)) in - (LambdaHorz(evid, e1), (rng, HorzCommandType(cmdargtylist))) + (abstraction evid e1, (rng, HorzCommandType(cmdargtylist))) | UTLambdaVert(varrng, varnmctx, utast1) -> - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(PolyFree(ref (MonoFree(tvid))))) in let evid = EvalVarID.fresh varnmctx in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(beta), evid)) utast1 in + let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in let () = unify tyret (Range.dummy "lambda-vert-return", BaseType(BoxColType)) in - (LambdaVert(evid, e1), (rng, VertCommandType(cmdargtylist))) + (abstraction evid e1, (rng, VertCommandType(cmdargtylist))) | UTLambdaMath(utastF) -> let (eF, tyF) = typecheck_iter tyenv utastF in @@ -718,11 +718,12 @@ let rec typecheck (eret, (rng, FuncType(optrow, beta1, beta2))) end - | UTFunction(optargs, utpatbr) -> + | UTFunction(optargs, pat, utast1) -> + let utpatbr = UTPatternBranch(pat, utast1) in let (optrow, evids, tyenvnew) = add_optionals_to_type_environment tyenv qtfbl lev optargs in - let (patbr, typat, tybody) = typecheck_pattern_branch qtfbl lev tyenvnew utpatbr in - let e = Function(evids, [patbr]) in - (e, (rng, FuncType(optrow, typat, tybody))) + let (patbr, typat, ty1) = typecheck_pattern_branch qtfbl lev tyenvnew utpatbr in + let e = Function(evids, patbr) in + (e, (rng, FuncType(optrow, typat, ty1))) (* let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (varrng, TypeVariable(ref (Free(tvid)))) in @@ -938,48 +939,42 @@ let rec typecheck (HorzLex(ectx, ev), (rng, BaseType(BoxColType))) -and typecheck_command_arguments (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : mono_command_argument_type list) : abstract_tree list = +and typecheck_command_arguments (ecmd : abstract_tree) (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : mono_command_argument_type list) : abstract_tree = let rec aux eacc utcmdarglst cmdargtylst = match (utcmdarglst, cmdargtylst) with | ([], _) -> - let eaccnew = - cmdargtylst |> List.fold_left (fun eacc cmdargty -> - match cmdargty with - | MandatoryArgumentType(ty) -> raise (NeedsMoreArgument(rngcmdapp, tyenv, tycmd, ty)) - | OptionalArgumentType(_) -> Alist.extend eacc (Value(Constructor("None", UnitConstant))) - ) eacc - in - Alist.to_list eaccnew + cmdargtylst |> List.iter (function + | MandatoryArgumentType(ty) -> raise (NeedsMoreArgument(rngcmdapp, tyenv, tycmd, ty)) + | OptionalArgumentType(_) -> () + ); + eacc | (_ :: _, []) -> raise (TooManyArgument(rngcmdapp, tyenv, tycmd)) | (UTMandatoryArgument(_) :: _, OptionalArgumentType(_) :: cmdargtytail) -> - let enone = Value(Constructor("None", UnitConstant)) in - aux (Alist.extend eacc enone) utcmdarglst cmdargtytail + aux eacc utcmdarglst cmdargtytail | (UTMandatoryArgument(utastA) :: utcmdargtail, MandatoryArgumentType(tyreq) :: cmdargtytail) -> let (eA, tyA) = typecheck qtfbl lev tyenv utastA in let () = unify_ tyenv tyA tyreq in - aux (Alist.extend eacc eA) utcmdargtail cmdargtytail + aux (Apply(eacc, eA)) utcmdargtail cmdargtytail | (UTOptionalArgument(utastA) :: utcmdargtail, OptionalArgumentType(tyreq) :: cmdargtytail) -> let (eA, tyA) = typecheck qtfbl lev tyenv utastA in let () = unify_ tyenv tyA tyreq in - let esome = NonValueConstructor("Some", eA) in - aux (Alist.extend eacc esome) utcmdargtail cmdargtytail + aux (ApplyOptional(eacc, eA)) utcmdargtail cmdargtytail | (UTOptionalArgument((rngA, _)) :: _, MandatoryArgumentType(_) :: _) -> raise (InvalidOptionalCommandArgument(tyenv, tycmd, rngA)) | (UTOmission(_) :: utcmdargtail, OptionalArgumentType(tyreq) :: cmdargtytail) -> - let enone = Value(Constructor("None", UnitConstant)) in - aux (Alist.extend eacc enone) utcmdargtail cmdargtytail + aux (ApplyOmission(eacc)) utcmdargtail cmdargtytail | (UTOmission(rngA) :: _, MandatoryArgumentType(_) :: _) -> raise (InvalidOptionalCommandArgument(tyenv, tycmd, rngA)) in - aux Alist.empty utcmdarglst cmdargtylst + aux ecmd utcmdarglst cmdargtylst and typecheck_math qtfbl lev tyenv ((rng, utmathmain) : untyped_math) : abstract_tree = @@ -1009,7 +1004,7 @@ and typecheck_math qtfbl lev tyenv ((rng, utmathmain) : untyped_math) : abstract begin match tycmdmain with | MathCommandType(cmdargtylstreq) -> - let elstarg = typecheck_command_arguments tycmd rng qtfbl lev tyenv utcmdarglst cmdargtylstreq in + let eapp = typecheck_command_arguments ecmd tycmd rng qtfbl lev tyenv utcmdarglst cmdargtylstreq in (* let trilst = utmatharglst |> List.map (function @@ -1045,7 +1040,7 @@ and typecheck_math qtfbl lev tyenv ((rng, utmathmain) : untyped_math) : abstract raise (InvalidArityOfCommand(rng, lenreq, lenreal)) in *) - apply_tree_of_list ecmd elstarg + eapp | HorzCommandType(_) -> let (rngcmd, _) = utastcmd in @@ -1116,7 +1111,10 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) | UTOptionalArgument((rng, _)) :: _ -> Range.unite rngcmd rng | UTOmission(rng) :: _ -> Range.unite rngcmd rng in - let elstarg = typecheck_command_arguments tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in + let evid = EvalVarID.fresh "%ctx-vert" in + let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-vert", evid)) in + let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in + let eabs = abstraction evid eapp in (* let trilst = List.map (function @@ -1148,7 +1146,7 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) raise (InvalidArityOfCommand(rng, lenreq, lenreal)) in *) - aux (InputVertEmbedded(ecmd, elstarg) :: acc) tail + aux (InputVertEmbedded(eabs) :: acc) tail | _ -> assert false end @@ -1181,7 +1179,10 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) match tycmdmain with | HorzCommandType(cmdargtylstreq) -> - let elstarg = typecheck_command_arguments tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in + let evid = EvalVarID.fresh "%ctx-horz" in + let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-horz", evid)) in + let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in + let eabs = abstraction evid eapp in (* let etylst = List.map (typecheck qtfbl lev tyenv) utastarglst in let tyarglst = etylst |> List.map (fun (e, ty) -> ty) in @@ -1194,7 +1195,7 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) raise (InvalidArityOfCommand(rng, lenreq, lenreal)) in *) - aux (Alist.extend acc (InputHorzEmbedded(ecmd, elstarg))) tail + aux (Alist.extend acc (InputHorzEmbedded(eabs))) tail | MathCommandType(_) -> let (rngcmd, _) = utastcmd in @@ -1423,8 +1424,8 @@ and make_type_environment_by_letrec in begin match e1 with - | Function([], patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) - | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) + | Function([], patbr1) -> (tyenvfinal, LetRecBinding(evid, patbr1) :: recbindtail, tvtylstoutfinal) + | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) end | Some(mnty) -> @@ -1436,8 +1437,8 @@ and make_type_environment_by_letrec in begin match e1 with - | Function([], patbrs1) -> (tyenvfinal, LetRecBinding(evid, patbrs1) :: recbindtail, tvtylstoutfinal) - | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) + | Function([], patbr1) -> (tyenvfinal, LetRecBinding(evid, patbr1) :: recbindtail, tvtylstoutfinal) + | _ -> let (rng1, _) = utast1 in raise (BreaksValueRestriction(rng1)) end end diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 7485917e1..491010e8f 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -426,7 +426,7 @@ and untyped_abstract_tree_main = | UTLetRecIn of untyped_letrec_binding list * untyped_abstract_tree | UTLetNonRecIn of manual_type option * untyped_pattern_tree * untyped_abstract_tree * untyped_abstract_tree | UTIfThenElse of untyped_abstract_tree * untyped_abstract_tree * untyped_abstract_tree - | UTFunction of (Range.t * var_name) list * untyped_pattern_branch + | UTFunction of (Range.t * var_name) list * untyped_pattern_tree * untyped_abstract_tree | UTOpenIn of Range.t * module_name * untyped_abstract_tree | UTFinishHeaderFile | UTFinishStruct @@ -523,7 +523,7 @@ type untyped_let_binding = manual_type option * untyped_pattern_tree * untyped_a (* ---- typed ---- *) type letrec_binding = - | LetRecBinding of EvalVarID.t * pattern_branch list + | LetRecBinding of EvalVarID.t * pattern_branch and environment = location EvalVarIDMap.t * (syntactic_value StoreIDHashTable.t) ref [@printer (fun fmt _ -> Format.fprintf fmt "")] @@ -554,13 +554,13 @@ and compiled_intermediate_input_vert_element = and ir_input_horz_element = | IRInputHorzText of string - | IRInputHorzEmbedded of ir * ir list + | IRInputHorzEmbedded of ir | IRInputHorzContent of ir | IRInputHorzEmbeddedMath of ir and ir_input_vert_element = - | IRInputVertEmbedded of ir * ir list + | IRInputVertEmbedded of ir | IRInputVertContent of ir and 'a ir_path_component = @@ -588,6 +588,7 @@ and ir = | IRContentOf of varloc | IRIfThenElse of ir * ir * ir | IRFunction of int * ir_pattern_tree list * ir + | IROptFunction of int * varloc list * ir_pattern_tree * ir | IRApply of int * ir * ir list | IRApplyPrimitive of instruction * int * ir list | IRTuple of int * ir list @@ -622,22 +623,22 @@ and ir_pattern_tree = and input_horz_element = | InputHorzText of string - | InputHorzEmbedded of abstract_tree * abstract_tree list + | InputHorzEmbedded of abstract_tree | InputHorzContent of abstract_tree | InputHorzEmbeddedMath of abstract_tree and intermediate_input_horz_element = | ImInputHorzText of string - | ImInputHorzEmbedded of abstract_tree * abstract_tree list + | ImInputHorzEmbedded of abstract_tree | ImInputHorzContent of intermediate_input_horz_element list * environment | ImInputHorzEmbeddedMath of abstract_tree and intermediate_input_vert_element = - | ImInputVertEmbedded of abstract_tree * abstract_tree list + | ImInputVertEmbedded of abstract_tree | ImInputVertContent of intermediate_input_vert_element list * environment and input_vert_element = - | InputVertEmbedded of abstract_tree * abstract_tree list + | InputVertEmbedded of abstract_tree | InputVertContent of abstract_tree and 'a path_component = @@ -659,8 +660,8 @@ and syntactic_value = | Constructor of constructor_name * syntactic_value - | FuncWithEnvironment of EvalVarID.t list * pattern_branch list * environment - | PrimitiveWithEnvironment of pattern_branch list * environment * int * (abstract_tree list -> abstract_tree) + | FuncWithEnvironment of EvalVarID.t list * pattern_branch * environment + | PrimitiveWithEnvironment of pattern_branch * environment * int * (abstract_tree list -> abstract_tree) | CompiledFuncWithEnvironment of int * syntactic_value list * int * instruction list * vmenv | CompiledPrimitiveWithEnvironment of int * syntactic_value list * int * instruction list * vmenv * (abstract_tree list -> abstract_tree) @@ -695,8 +696,10 @@ and syntactic_value = | MathValue of math list | ImageKey of ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "")] +(* | LambdaHorzWithEnvironment of EvalVarID.t * abstract_tree * environment | LambdaVertWithEnvironment of EvalVarID.t * abstract_tree * environment +*) | Context of input_context | DocumentValue of HorzBox.page_size * HorzBox.page_content_scheme_func * HorzBox.page_parts_scheme_func * HorzBox.vert_box list @@ -719,7 +722,7 @@ and abstract_tree = | LetNonRecIn of pattern_tree * abstract_tree * abstract_tree | ContentOf of Range.t * EvalVarID.t | IfThenElse of abstract_tree * abstract_tree * abstract_tree - | Function of EvalVarID.t list * pattern_branch list + | Function of EvalVarID.t list * pattern_branch | Apply of abstract_tree * abstract_tree | ApplyOptional of abstract_tree * abstract_tree | ApplyOmission of abstract_tree @@ -734,8 +737,10 @@ and abstract_tree = (* -- module system -- *) | Module of abstract_tree * abstract_tree | BackendMathList of abstract_tree list +(* | LambdaHorz of EvalVarID.t * abstract_tree | LambdaVert of EvalVarID.t * abstract_tree +*) | PrimitiveTupleCons of abstract_tree * abstract_tree #include "__attype.gen.ml" @@ -1139,7 +1144,7 @@ let unlift_option_row poptrow = | Exit -> None -let add_to_environment (env : environment) (evid : EvalVarID.t) (rfast : location) = +let add_to_environment (env : environment) (evid : EvalVarID.t) (rfast : location) : environment = let (valenv, stenvref) = env in (valenv |> EvalVarIDMap.add evid rfast, stenvref) From 037dbfd44a06b293eb338c3d63249be06f597ffb Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 02:47:15 +0900 Subject: [PATCH 26/42] omit comment-out code --- src/frontend/evaluator_.cppo.ml | 39 +-------- src/frontend/typechecker.ml | 135 -------------------------------- src/frontend/types_.cppo.ml | 8 -- 3 files changed, 1 insertion(+), 181 deletions(-) diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index f34648c64..e772b674f 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -361,25 +361,7 @@ and interpret_intermediate_input_vert env (valuectx : syntactic_value) (imivlst match imiv with | ImInputVertEmbedded(astabs) -> let valuevert = interpret env (Apply(astabs, Value(valuectx))) in - get_vert valuevert -(* - begin - match valuecmd with - | LambdaVertWithEnvironment(evid, astdef, env1) -> - let valuedef = reduce_beta [] env1 evid valuectx astdef in - let valuearglst = - astarglst |> List.fold_left (fun acc astarg -> - let valuearg = interpret env astarg in - Alist.extend acc valuearg - ) Alist.empty |> Alist.to_list - (* -- left-to-right evaluation -- *) - in - let valueret = reduce_beta_list valuedef valuearglst in - get_vert valueret - - | _ -> report_bug_reduction "interpret_intermediate_input_vert:1" astcmd valuecmd - end -*) + get_vert valuevert | ImInputVertContent(imivlstsub, envsub) -> interpret_commands envsub imivlstsub @@ -426,25 +408,6 @@ and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_ | NomInputHorzEmbedded(astabs) -> let valuehorz = interpret env (Apply(astabs, Value(valuectx))) in get_horz valuehorz -(* - begin - match valuecmd with - | LambdaHorzWithEnvironment(evid, astdef, env1) -> - let valuedef = reduce_beta [] env1 evid valuectx astdef in - let valuearglst = - astarglst |> List.fold_left (fun acc astarg -> - let valuearg = interpret env astarg in - Alist.extend acc valuearg - ) Alist.empty |> Alist.to_list - (* -- left-to-right evaluation -- *) - in - let valueret = reduce_beta_list valuedef valuearglst in - let hblst = get_horz valueret in - hblst - - | _ -> report_bug_reduction "interpret_input_horz" astcmd valuecmd - end -*) | NomInputHorzThunk(ast) -> let valuehorz = interpret env ast in diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 2bdfe165c..9666440c9 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -724,15 +724,6 @@ let rec typecheck let (patbr, typat, ty1) = typecheck_pattern_branch qtfbl lev tyenvnew utpatbr in let e = Function(evids, patbr) in (e, (rng, FuncType(optrow, typat, ty1))) -(* - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (varrng, TypeVariable(ref (Free(tvid)))) in - let evid = EvalVarID.fresh varnm in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnm (Poly(beta), evid)) utast1 in - let tydom = beta in - let tycod = ty1 in - (LambdaAbstract(evid, e1), (rng, FuncType(tydom, tycod))) -*) | UTPatternMatch(utastO, utpatbrs) -> let (eO, tyO) = typecheck_iter tyenv utastO in @@ -756,9 +747,6 @@ let rec typecheck in let (e2, ty2) = typecheck_iter tyenvnew utast2 in (LetNonRecIn(pat, e1, e2), ty2) -(* - failwith "let nonrec" -*) | UTLetRecIn(utrecbinds, utast2) -> let (tyenvnew, _, recbinds) = make_type_environment_by_letrec qtfbl lev tyenv utrecbinds in @@ -808,51 +796,6 @@ let rec typecheck let () = unify tyC (get_range utastC, BaseType(UnitType)) in (WhileDo(eB, eC), (rng, BaseType(UnitType))) -(* -(* ---- final reference ---- *) - - | UTDeclareGlobalHash(utastK, utastI) -> - let (eK, tyK) = typecheck_iter tyenv utastK in - let () = (unify tyK (get_range utastK, BaseType(StringType))) in - let (eI, tyI) = typecheck_iter tyenv utastI in - let () = unify tyI (get_range utastI, BaseType(StringType)) in - (DeclareGlobalHash(eK, eI), (rng, BaseType(UnitType))) - - | UTOverwriteGlobalHash(utastK, utastN) -> - let (eK, tyK) = typecheck_iter tyenv utastK in - let () = unify tyK (get_range utastK, BaseType(StringType)) in - let (eN, tyN) = typecheck_iter tyenv utastN in - let () = unify tyN (get_range utastN, BaseType(StringType)) in - (OverwriteGlobalHash(eK, eN), (rng, BaseType(UnitType))) - - | UTReferenceFinal(utast1) -> - let (e1, ty1) = typecheck_iter tyenv utast1 in - let () = unify ty1 (rng, BaseType(StringType)) in - (ReferenceFinal(e1), (rng, BaseType(StringType))) - -(* ---- class/id option ---- *) - - | UTApplyClassAndID(utastcls, utastid, utast1) -> - let dr = Range.dummy "ut-apply-class-and-id" in - let evidcls = EvalVarID.for_class_name in - let tyenvmid = Typeenv.add tyenv "class-name" (Poly((dr, VariantType([(dr, BaseType(StringType))], Typeenv.find_type_id tyenv "maybe"))), evidcls) in (* temporary; `find_type_id` is vulnerable to the re-definition of a type named 'maybe' *) - let evidid = EvalVarID.for_id_name in - let tyenvnew = Typeenv.add tyenvmid "id-name" (Poly((dr, VariantType([(dr, BaseType(StringType))], Typeenv.find_type_id tyenv "maybe"))), evidid) in (* temporary; `find_type_id` is vulnerable to the re-definition of a type named 'maybe' *) - let (ecls, _) = typecheck_iter tyenv utastcls in - let (eid, _) = typecheck_iter tyenv utastid in - let (e1, ty1) = typecheck_iter tyenvnew utast1 in - (ApplyClassAndID(evidcls, evidid, ecls, eid, e1), ty1) - - | UTClassAndIDRegion(utast1) -> - let dr = Range.dummy "ut-class-and-id-region" in - let evidcls = EvalVarID.for_class_name in - let tyenvmid = Typeenv.add tyenv "class-name" (Poly((dr, VariantType([(dr, BaseType(StringType))], Typeenv.find_type_id tyenv "maybe"))), evidcls) in (* temporary; `find_type_id` is vulnerable to the re-definition of a type named 'maybe' *) - let evidid = EvalVarID.for_id_name in - let tyenvnew = Typeenv.add tyenvmid "id-name" (Poly((dr, VariantType([(dr, BaseType(StringType))], Typeenv.find_type_id tyenv "maybe"))), evidid) in (* temporary; `find_type_id` is vulnerable to the re-definition of a type named 'maybe' *) - let (e1, ty1) = typecheck_iter tyenvnew utast1 in - (e1, ty1) -*) - (* ---- lightweight itemize ---- *) | UTItemize(utitmz) -> @@ -1005,41 +948,6 @@ and typecheck_math qtfbl lev tyenv ((rng, utmathmain) : untyped_math) : abstract match tycmdmain with | MathCommandType(cmdargtylstreq) -> let eapp = typecheck_command_arguments ecmd tycmd rng qtfbl lev tyenv utcmdarglst cmdargtylstreq in -(* - let trilst = - utmatharglst |> List.map (function - | UTMMandatoryArgument((rngA, _) as utastA) -> - let (eA, tyA) = typecheck qtfbl lev tyenv utastA in - (rngA, eA, MandatoryArgumentType(tyA)) - - | UTMOptionalArgument((rngA, _) as utastA) -> - let (eA, tyA) = typecheck qtfbl lev tyenv utastA in - (rngA, NonValueConstructor("Some", eA), OptionalArgumentType(tyA)) - - | UTMOmission(rngomit) -> - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rngomit, TypeVariable(ref (Free(tvid)))) in - (rngomit, Value(Constructor("None", UnitConstant)), OptionalArgumentType(beta)) - ) in - let cmdargtylist = trilst |> List.map (fun (_, _, cmdargty) -> cmdargty) in - let () = unify_command_argument_types cmdargtylist cmdargtylistreq in - let elstarg = trilst |> List.map (fun (_, e, _) -> e) in -*) -(* - try - List.iter2 (fun caty catyreq -> - match (caty, catyreq) with - | (MandatoryArgumentType(ty), MandatoryArgumentType(tyreq)) -> unify_ tyenv ty tyreq - | (OptionalArgumentType(ty) , OptionalArgumentType(tyreq) ) -> unify_ tyenv ty tyreq - | _ -> assert false (* TEMPORARY *) - ) cmdargtylist cmdargtylistreq - with - | Invalid_argument(_) -> - let lenreq = List.length cmdargtylistreq in - let lenreal = List.length cmdargtylist in - raise (InvalidArityOfCommand(rng, lenreq, lenreal)) - in -*) eapp | HorzCommandType(_) -> @@ -1115,37 +1023,6 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-vert", evid)) in let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in let eabs = abstraction evid eapp in -(* - let trilst = - List.map (function - | UTMandatoryArgument(utastA) -> - let (eA, tyA) = typecheck qtfbl lev tyenv utastA in - (eA, MandatoryArgumentType(tyA)) - - | UTOptionalArgument(utastA) -> - let (eA, tyA) = typecheck qtfbl lev tyenv utastA in - (NonValueConstructor("Some", eA), OptionalArgumentType(tyA)) - - | UTOmission(rngomit) -> - let tvid = FreeID.fresh UniversalKind qtfbl lev () in - let beta = (rngomit, TypeVariable(ref (Free(tvid)))) in - (Value(Constructor("None", UnitConstant)), OptionalArgumentType(beta)) - - ) utcmdarglst - in - let tylstarg = etylst |> List.map (fun (e, ty) -> ty) in - let () = unify_command_argument_types tyenv in - let elstarg = etylst |> List.map (fun (e, ty) -> e) in -*) -(* - let () = - try List.iter2 (unify_ tyenv) tylstarg tylstreq with - | Invalid_argument(_) -> - let lenreq = List.length tylstreq in - let lenreal = List.length tylstarg in - raise (InvalidArityOfCommand(rng, lenreq, lenreal)) - in -*) aux (InputVertEmbedded(eabs) :: acc) tail | _ -> assert false @@ -1183,18 +1060,6 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-horz", evid)) in let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in let eabs = abstraction evid eapp in -(* - let etylst = List.map (typecheck qtfbl lev tyenv) utastarglst in - let tyarglst = etylst |> List.map (fun (e, ty) -> ty) in - let earglst = etylst |> List.map (fun (e, ty) -> e) in - let () = - try List.iter2 (unify_ tyenv) tyarglst tylstreq with - | Invalid_argument(_) -> - let lenreq = List.length tylstreq in - let lenreal = List.length tyarglst in - raise (InvalidArityOfCommand(rng, lenreq, lenreal)) - in -*) aux (Alist.extend acc (InputHorzEmbedded(eabs))) tail | MathCommandType(_) -> diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 491010e8f..efecfbd30 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -696,10 +696,6 @@ and syntactic_value = | MathValue of math list | ImageKey of ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "")] -(* - | LambdaHorzWithEnvironment of EvalVarID.t * abstract_tree * environment - | LambdaVertWithEnvironment of EvalVarID.t * abstract_tree * environment -*) | Context of input_context | DocumentValue of HorzBox.page_size * HorzBox.page_content_scheme_func * HorzBox.page_parts_scheme_func * HorzBox.vert_box list @@ -737,10 +733,6 @@ and abstract_tree = (* -- module system -- *) | Module of abstract_tree * abstract_tree | BackendMathList of abstract_tree list -(* - | LambdaHorz of EvalVarID.t * abstract_tree - | LambdaVert of EvalVarID.t * abstract_tree -*) | PrimitiveTupleCons of abstract_tree * abstract_tree #include "__attype.gen.ml" From 2eab518123a73f42476bd800db4c3450e0aec540 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 03:13:37 +0900 Subject: [PATCH 27/42] add 'MultipleFieldInRecord' and refactor --- src/frontend/main.ml | 6 ++++ src/frontend/typechecker.ml | 55 ++++++++++++++++++------------------ src/frontend/typechecker.mli | 1 + 3 files changed, 34 insertions(+), 28 deletions(-) diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 3c6761f9c..56cc04c0c 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -560,6 +560,12 @@ let error_log_environment suspended = NormalLine("pattern variable '" ^ varnm ^ "' is bound more than once."); ] + | Typechecker.MultipleFieldInRecord(rng, fldnm) -> + report_error Typechecker [ + NormalLine("at " ^ (Range.to_string rng)); + NormalLine("this record expression has more than one field for '" ^ fldnm ^ "'."); + ] + | Typeenv.IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr) -> report_error Typechecker [ NormalLine("at " ^ (Range.to_string rng) ^ ":"); diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 9666440c9..5e590f946 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -17,6 +17,7 @@ exception MultiplePatternVariable of Range.t * Range.t * var_name exception InvalidOptionalCommandArgument of Typeenv.t * mono_type * Range.t exception NeedsMoreArgument of Range.t * Typeenv.t * mono_type * mono_type exception TooManyArgument of Range.t * Typeenv.t * mono_type +exception MultipleFieldInRecord of Range.t * field_name exception InternalInclusionError exception InternalContradictionError @@ -971,20 +972,20 @@ and typecheck_path qtfbl lev tyenv (utpathcomplst : (untyped_abstract_tree untyp ept in - let pathcompacc = + let pathcomplst = utpathcomplst |> List.fold_left (fun acc utpathcomp -> match utpathcomp with | UTPathLineTo(utastpt) -> let (ept, typt) = typecheck qtfbl lev tyenv utastpt in let () = unify_ tyenv typt (Range.dummy "typecheck-path-L", point_type_main) in - PathLineTo(ept) :: acc + Alist.extend acc (PathLineTo(ept)) | UTPathCubicBezierTo(utastpt1, utastpt2, utastpt) -> let ept1 = typecheck_anchor_point utastpt1 in let ept2 = typecheck_anchor_point utastpt2 in let ept = typecheck_anchor_point utastpt in - PathCubicBezierTo(ept1, ept2, ept) :: acc - ) [] + Alist.extend acc (PathCubicBezierTo(ept1, ept2, ept)) + ) Alist.empty |> Alist.to_list in let cycleopt = utcycleopt |> option_map (function @@ -996,14 +997,14 @@ and typecheck_path qtfbl lev tyenv (utpathcomplst : (untyped_abstract_tree untyp PathCubicBezierTo(ept1, ept2, ()) ) in - (List.rev pathcompacc, cycleopt) + (pathcomplst, cycleopt) -and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utivlst : untyped_input_vert_element list) = - let rec aux (acc : input_vert_element list) (lst : untyped_input_vert_element list) = - match lst with +and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utivlst : untyped_input_vert_element list) : input_vert_element list = + let rec aux acc utivlst = + match utivlst with | [] -> - List.rev acc + Alist.to_list acc | (_, UTInputVertEmbedded((rngcmd, _) as utastcmd, utcmdarglst)) :: tail -> let (ecmd, tycmd) = typecheck qtfbl lev tyenv utastcmd in @@ -1023,7 +1024,7 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-vert", evid)) in let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in let eabs = abstraction evid eapp in - aux (InputVertEmbedded(eabs) :: acc) tail + aux (Alist.extend acc (InputVertEmbedded(eabs))) tail | _ -> assert false end @@ -1031,16 +1032,17 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) | (_, UTInputVertContent(utast0)) :: tail -> let (e0, ty0) = typecheck qtfbl lev tyenv utast0 in let () = unify_ tyenv ty0 (Range.dummy "UTInputVertContent", BaseType(TextColType)) in - aux (InputVertContent(e0) :: acc) tail + aux (Alist.extend acc (InputVertContent(e0))) tail in - aux [] utivlst + aux Alist.empty utivlst -and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utihlst : untyped_input_horz_element list) = - let rec aux (acc : input_horz_element Alist.t) (lst : untyped_input_horz_element list) = - match lst with - | [] -> Alist.to_list acc +and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (utihlst : untyped_input_horz_element list) : input_horz_element list = + let rec aux acc utihlst = + match utihlst with + | [] -> + Alist.to_list acc | (_, UTInputHorzEmbedded((rngcmd, _) as utastcmd, utcmdarglst)) :: tail -> let rngcmdapp = @@ -1064,7 +1066,7 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) | MathCommandType(_) -> let (rngcmd, _) = utastcmd in - raise (MathCommandInHorz(rngcmd)) + raise (MathCommandInHorz(rngcmd)) | _ -> assert false end @@ -1089,19 +1091,16 @@ and typecheck_record (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (flutlst : (field_name * untyped_abstract_tree) list) (rng : Range.t) = - let rec aux - (tyenv : Typeenv.t) (lst : (field_name * untyped_abstract_tree) list) - (accelst : (field_name * abstract_tree) list) (acctylst : (field_name * mono_type) list) - = - match lst with - | [] -> (List.rev accelst, List.rev acctylst) - | (fldnmX, utastX) :: tail -> + let (easc, tyasc) = + flutlst |> List.fold_left (fun (easc, tyasc) (fldnmX, utastX) -> + if Assoc.mem fldnmX easc then + raise (MultipleFieldInRecord(rng, fldnmX)) + else let (eX, tyX) = typecheck qtfbl lev tyenv utastX in - aux tyenv tail ((fldnmX, eX) :: accelst) ((fldnmX, tyX) :: acctylst) + (Assoc.add easc fldnmX eX, Assoc.add tyasc fldnmX tyX) + ) (Assoc.empty, Assoc.empty) in - let (elst, tylst) = aux tyenv flutlst [] [] in - let tylstfinal = List.map (fun (fldnm, ty) -> (fldnm, ty)) tylst in - (Record(Assoc.of_list elst), (rng, RecordType(Assoc.of_list tylstfinal))) + (Record(easc), (rng, RecordType(tyasc))) and typecheck_itemize (qtfbl : quantifiability) (lev : level) (tyenv : Typeenv.t) (UTItem(utast1, utitmzlst)) = diff --git a/src/frontend/typechecker.mli b/src/frontend/typechecker.mli index 97089c656..67dfd982d 100644 --- a/src/frontend/typechecker.mli +++ b/src/frontend/typechecker.mli @@ -15,5 +15,6 @@ exception MultiplePatternVariable of Range.t * Range.t * var_name exception InvalidOptionalCommandArgument of Typeenv.t * mono_type * Range.t exception NeedsMoreArgument of Range.t * Typeenv.t * mono_type * mono_type exception TooManyArgument of Range.t * Typeenv.t * mono_type +exception MultipleFieldInRecord of Range.t * field_name val main : Typeenv.t -> untyped_abstract_tree -> (mono_type * Typeenv.t * abstract_tree) From 0518b7103d8fd34fc501920e7a1f3d825f24ac70 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 04:10:20 +0900 Subject: [PATCH 28/42] refactor interpreter by using 'reduce_beta' --- src/frontend/evaluator_.cppo.ml | 65 ++++++++++----------------------- 1 file changed, 19 insertions(+), 46 deletions(-) diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index e772b674f..fa7c2e2a7 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -26,37 +26,26 @@ let lex_horz_text (ctx : HorzBox.context_main) (s_utf8 : string) : HorzBox.horz_ HorzBox.([HorzPure(PHCInnerString(ctx, uchlst))]) -let rec reduce_beta evids env1 evid valuel astdef = - let env1 = - evids |> List.fold_left (fun env evid -> - let loc = ref (Constructor("None", UnitConstant)) in - add_to_environment env evid loc - ) env1 - in - let envnew = add_to_environment env1 evid (ref valuel) in - interpret envnew astdef +let rec reduce_beta value1 value2 = + match value1 with + | FuncWithEnvironment(evids, patbr, env1) -> + let env1 = + evids |> List.fold_left (fun env evid -> + let loc = ref (Constructor("None", UnitConstant)) in + add_to_environment env evid loc + ) env1 + in + select_pattern (Range.dummy "Apply") env1 value2 [patbr] + | PrimitiveWithEnvironment(patbr, env1, _, _) -> + select_pattern (Range.dummy "Apply") env1 value2 [patbr] -and reduce_beta_list valuef valuearglst = - match valuearglst with - | [] -> - valuef + | _ -> + report_bug_value "reduce_beta: not a function" value1 - | valuearg :: astargtail -> - begin - match valuef with - | FuncWithEnvironment(evids, patbr, env1) -> - let env1 = - evids |> List.fold_left (fun env evid -> - let loc = ref (Constructor("None", UnitConstant)) in - add_to_environment env evid loc - ) env1 - in - let valuefnew = select_pattern (Range.dummy "reduce_beta_list") env1 valuearg [patbr] in - reduce_beta_list valuefnew astargtail - - | _ -> report_bug_value "reduce_beta_list" valuef - end + +and reduce_beta_list value1 valueargs = + List.fold_left reduce_beta value1 valueargs and interpret_point env ast = @@ -195,24 +184,8 @@ and interpret env ast = | Apply(ast1, ast2) -> let value1 = interpret env ast1 in - begin - match value1 with - | FuncWithEnvironment(evids, patbr, env1) -> - let env1 = - evids |> List.fold_left (fun env evid -> - let loc = ref (Constructor("None", UnitConstant)) in - add_to_environment env evid loc - ) env1 - in - let value2 = interpret env ast2 in - select_pattern (Range.dummy "Apply") env1 value2 [patbr] - - | PrimitiveWithEnvironment(patbr, env1, _, _) -> - let value2 = interpret env ast2 in - select_pattern (Range.dummy "Apply") env1 value2 [patbr] - - | _ -> report_bug_reduction "Apply: not a function" ast1 value1 - end + let value2 = interpret env ast2 in + reduce_beta value1 value2 | ApplyOptional(ast1, ast2) -> let value1 = interpret env ast1 in From 3f7a8d7fe432e1f97c1691bd3475d0f372616fb6 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 04:26:30 +0900 Subject: [PATCH 29/42] slight arrangement of spaces --- src/frontend/evaluator_.cppo.ml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index fa7c2e2a7..69a110ef3 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -152,12 +152,6 @@ and interpret env ast = in LengthConstant(len) -(* - | LambdaVert(evid, astdef) -> LambdaVertWithEnvironment(evid, astdef, env) - - | LambdaHorz(evid, astdef) -> LambdaHorzWithEnvironment(evid, astdef, env) -*) - (* -- fundamentals -- *) | ContentOf(rng, evid) -> @@ -208,7 +202,8 @@ and interpret env ast = let env1 = add_to_environment env1 evid (ref (Constructor("None", UnitConstant))) in FuncWithEnvironment(evids, patbrs, env1) - | _ -> report_bug_reduction "ApplyOmission: not a function with optional parameter" ast1 value1 + | _ -> + report_bug_reduction "ApplyOmission: not a function with optional parameter" ast1 value1 end | IfThenElse(astb, ast1, ast2) -> @@ -231,7 +226,8 @@ and interpret env ast = | Some(v) -> v end - | _ -> report_bug_reduction "AccessField: not a Record" ast1 value1 + | _ -> + report_bug_reduction "AccessField: not a Record" ast1 value1 end (* ---- imperatives ---- *) From dfeaad7be2085d7ef445a7c80eb35b70f7e1becd Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 05:22:53 +0900 Subject: [PATCH 30/42] begin to extend bytecode compiler --- src/frontend/bytecomp/compiler.ml | 6 ++++++ src/frontend/bytecomp/ir_.cppo.ml | 30 +++++++++++------------------- src/frontend/types_.cppo.ml | 2 ++ 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index 51febefa7..44db017cc 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -159,6 +159,12 @@ and compile (ir : ir) (cont : instruction list) = | IRApplyPrimitive(op, arity, irargs) -> compile_list irargs (op :: cont) + | IRApplyOptional(ir1, ir2) -> + failwith "IRApplyOptional: remains to be implemented" + + | IRApplyOmission(ir1) -> + failwith "IRApplyOmission: remains to be implemented" + | IRTuple(len, iritems) -> compile_list iritems (OpMakeTuple(len) :: cont) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 06a6d3a73..7b8e2d7ed 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -328,14 +328,6 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (pathelemlst, closingopt, env) = transform_path env pathcomplst cycleopt in (IRPath(irpt0, pathelemlst, closingopt), env) -(* - | LambdaVert(evid, astdef) -> - transform env (Function([], PatternBranch(PVariable(evid), astdef))) - - | LambdaHorz(evid, astdef) -> - transform env (Function([], PatternBranch(PVariable(evid), astdef))) -*) - | PrimitiveTupleCons(asthd, asttl) -> transform_tuple env ast @@ -381,9 +373,6 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (irarg, funenv) = transform_pattern funenv arg in let (irbody, funenv) = transform funenv body in (IROptFunction(funenv.size, vars, irarg, irbody), env) -(* - failwith "Function with optional arguments: remains to be implemented." -*) | Function(_, PatternBranchWhen(_, _, _)) -> assert false @@ -392,20 +381,23 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let (callee, args) = flatten_application ast in begin match check_primitive env callee with - | Some((arity, astf)) when arity = List.length args -> - transform env (astf args) + | Some((arity, astf)) when arity = List.length args -> + transform env (astf args) | _ -> - let (ircallee, env) = transform env callee in - let (irargs, env) = transform_list env args in - (IRApply(List.length irargs, ircallee, irargs), env) - end + let (ircallee, env) = transform env callee in + let (irargs, env) = transform_list env args in + (IRApply(List.length irargs, ircallee, irargs), env) + end | ApplyOptional(ast1, ast2) -> - failwith "ApplyOptional: remains to be implemented." + let (ir1, env) = transform env ast1 in + let (ir2, env) = transform env ast2 in + (IRApplyOptional(ir1, ir2), env) | ApplyOmission(ast1) -> - failwith "ApplyOmission: remains to be implemented." + let (ir1, env) = transform env ast1 in + (IRApplyOmission(ir1), env) | IfThenElse(astb, ast1, ast2) -> let (irb, env) = transform env astb in diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index efecfbd30..7e01d48a9 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -591,6 +591,8 @@ and ir = | IROptFunction of int * varloc list * ir_pattern_tree * ir | IRApply of int * ir * ir list | IRApplyPrimitive of instruction * int * ir list + | IRApplyOptional of ir * ir + | IRApplyOmission of ir | IRTuple of int * ir list | IRPatternMatch of Range.t * ir * ir_pattern_branch list | IRNonValueConstructor of constructor_name * ir From 63c789824ef9264eaf1ca908f43bb4c9f4c886db Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 21:16:29 +0900 Subject: [PATCH 31/42] slightly arrange code of bytecode compiler --- src/frontend/bytecomp/compiler.ml | 18 +++++++++--------- src/frontend/bytecomp/vm_.cppo.ml | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index 44db017cc..f147100cd 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -39,8 +39,8 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) = | IRInputHorzText(s) -> CompiledInputHorzText(s) - | IRInputHorzEmbedded(irapp) -> - let compiled = compile irapp [] in + | IRInputHorzEmbedded(irabs) -> + let compiled = compile irabs [] in (* let appcode = emit_appop (List.length irarglist) [] true in let cmdcode = compile ircmd appcode in @@ -60,8 +60,8 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) = and compile_input_vert_content (ivlst : ir_input_vert_element list) = let compiled_ivlist = ivlst |> List.map (function - | IRInputVertEmbedded(irapp) -> - let compiled = compile irapp [] in + | IRInputVertEmbedded(irabs) -> + let compiled = compile irabs [] in (* let appcode = emit_appop (List.length irarglist) [] true in let cmdcode = compile ircmd appcode in @@ -222,7 +222,7 @@ and compile (ir : ir) (cont : instruction list) = compile irpt0 (OpPath(pathelemlst, closingopt) :: cont) -and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) cont = +and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) (cont : instruction list) : instruction list = let consif cond a b = if cond then a :: b else b in @@ -247,7 +247,7 @@ and compile_patsel (rng : Range.t) (patbrs : ir_pattern_branch list) cont = iter (List.rev patbrs) [OpError("no matches (" ^ (Range.to_string rng) ^ ")")] 0 -and compile_patlist patlist cont = +and compile_patlist (patlist : ir_pattern_tree list) (cont : instruction list) : instruction list = let next = [OpError("no matches")] in let rec iter patlist cont = match patlist with @@ -258,7 +258,7 @@ and compile_patlist patlist cont = iter patlist cont -and compile_patcheck (pat : ir_pattern_tree) next cont = +and compile_patcheck (pat : ir_pattern_tree) (next : instruction list) (cont : instruction list) : instruction list = let return inst = inst :: cont in match pat with | IRPIntegerConstant(pnc) -> return (OpCheckStackTopInt(pnc, next)) @@ -270,14 +270,14 @@ and compile_patcheck (pat : ir_pattern_tree) next cont = | IRPVariable(var) -> begin match var with - | GlobalVar(loc, evid, refs) -> return (OpBindGlobal(loc, evid, !refs)) + | GlobalVar(loc, evid, refs) -> return (OpBindGlobal(loc, evid, !refs)) | LocalVar(lv, off, evid, refs) -> return (OpBindLocal(lv, off, evid, !refs)) end | IRPAsVariable(var, psub) -> let bindop = match var with - | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) + | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) in let code = compile_patcheck psub next cont in diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index f8ebcd30c..98a1004ec 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -153,7 +153,7 @@ and exec_intermediate_input_vert (env : vmenv) (valuectx : syntactic_value) (imi imivlst |> List.map (fun imiv -> match imiv with | CompiledImInputVertEmbedded(code) -> - let valueret = exec [valuectx] env (code) [] in + let valueret = exec [valuectx] env code [] in get_vert valueret | CompiledImInputVertContent(imivlstsub, envsub) -> From c80ff2806abb348f42d1f43407585d4b8fb010bf Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 8 Aug 2018 23:54:06 +0900 Subject: [PATCH 32/42] implement compilation of optional arguments (but find bugs about execution of commands) --- src/frontend/bytecomp/bytecomp.ml | 2 +- src/frontend/bytecomp/compiler.ml | 18 ++++- src/frontend/bytecomp/ir_.cppo.ml | 12 ++-- src/frontend/bytecomp/vminstdef.yaml | 101 ++++++++++++++++++++++----- src/frontend/types_.cppo.ml | 2 +- 5 files changed, 108 insertions(+), 27 deletions(-) diff --git a/src/frontend/bytecomp/bytecomp.ml b/src/frontend/bytecomp/bytecomp.ml index cbd001f2f..1a908ba87 100644 --- a/src/frontend/bytecomp/bytecomp.ml +++ b/src/frontend/bytecomp/bytecomp.ml @@ -23,7 +23,7 @@ let compile_environment env = | PrimitiveWithEnvironment(parbr, env1, arity, astf) -> begin match compile_and_exec env (Function([], parbr)) with - | CompiledFuncWithEnvironment(_, _, framesize, body, env1) -> + | CompiledFuncWithEnvironment([], _, _, framesize, body, env1) -> loc := CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) | _ -> () end diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index f147100cd..fb7fa7e1c 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -150,8 +150,14 @@ and compile (ir : ir) (cont : instruction list) = else OpClosure(List.length irpatlst, framesize, optcode) :: cont - | IROptFunction(framesize, vars, irpat, irbody) -> + | IROptFunction(framesize, optvars, irpat, irbody) -> + let body = compile irbody [] in + let patlst = compile_patlist [irpat] body in + let (optcode, n) = optimize_func_prologue patlst in + OpOptClosure(optvars, 1, framesize, optcode) :: cont +(* failwith "IROptFunction: remains to be implemented" +*) | IRApply(arity, ircallee, irargs) -> compile_list irargs @@ (compile ircallee @@ emit_appop (List.length irargs) cont false) @@ -159,11 +165,17 @@ and compile (ir : ir) (cont : instruction list) = | IRApplyPrimitive(op, arity, irargs) -> compile_list irargs (op :: cont) - | IRApplyOptional(ir1, ir2) -> + | IRApplyOptional(irabs, iroptarg) -> + compile iroptarg @@ (compile iroptarg @@ OpApplyOptional :: cont) +(* failwith "IRApplyOptional: remains to be implemented" +*) - | IRApplyOmission(ir1) -> + | IRApplyOmission(irabs) -> + compile irabs @@ OpApplyOmission :: cont +(* failwith "IRApplyOmission: remains to be implemented" +*) | IRTuple(len, iritems) -> compile_list iritems (OpMakeTuple(len) :: cont) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 7b8e2d7ed..d3eb12688 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -42,9 +42,9 @@ let rec transform_input_horz_content (env : frame) (ihlst : input_horz_element l | InputHorzText(s) -> (IRInputHorzText(s), env) - | InputHorzEmbedded(astapp) -> - let (irapp, env) = transform env astapp in - (IRInputHorzEmbedded(irapp), env) + | InputHorzEmbedded(astabs) -> + let (irabs, env) = transform env astabs in + (IRInputHorzEmbedded(irabs), env) | InputHorzEmbeddedMath(astmath) -> let (irmath, env) = transform env astmath in @@ -59,9 +59,9 @@ let rec transform_input_horz_content (env : frame) (ihlst : input_horz_element l and transform_input_vert_content (env : frame) (ivlst : input_vert_element list) : ir_input_vert_element list * frame = ivlst @|> env @|> map_with_env (fun env elem -> match elem with - | InputVertEmbedded(astapp) -> - let (irapp, env) = transform env astapp in - (IRInputVertEmbedded(irapp), env) + | InputVertEmbedded(astabs) -> + let (irabs, env) = transform env astabs in + (IRInputVertEmbedded(irabs), env) | InputVertContent(ast) -> let (ir, env) = transform env ast in diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 09d5f972b..1477b40df 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -67,7 +67,17 @@ params: - f code: | match f with - | CompiledFuncWithEnvironment(arity, pargs, framesize, body, env1) -> + | CompiledFuncWithEnvironment(optvars, arity, pargs, framesize, body, env1) -> + let body = + optvars |> List.fold_left (fun acc optvar -> + let bindop = + match optvar with + | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) + | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) + in + OpPush(Constructor("None", UnitConstant)) :: bindop :: acc + ) body + in if arity = n then begin if pargs = [] then @@ -80,7 +90,7 @@ code: | else if arity > n then let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment(arity - n, pargs @ args, framesize, body, env1) in + let applied = CompiledFuncWithEnvironment([], arity - n, pargs @ args, framesize, body, env1) in exec (applied :: stack) env code dump else @@ -89,18 +99,18 @@ code: | let allargs = List.rev (pargs @ args) in exec (allargs @ stack) (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApply(n - arity) :: code) :: dump) - | CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) -> - if arity = n then - exec stack (newframe env1 framesize) body ((env, code) :: dump) + | CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) -> + if arity = n then + exec stack (newframe env1 framesize) body ((env, code) :: dump) - else if arity > n then - let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment(arity - n, args, framesize, body, env1) in - exec (applied :: stack) env code dump + else if arity > n then + let (args, stack) = popn stack n in + let applied = CompiledFuncWithEnvironment([], arity - n, args, framesize, body, env1) in + exec (applied :: stack) env code dump - else - let (surplus, stack) = popn stack (n - arity) in - exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApply(n - arity) :: code) :: dump) + else + let (surplus, stack) = popn stack (n - arity) in + exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApply(n - arity) :: code) :: dump) | _ -> report_bug_vm "Apply: not a function" @@ -112,7 +122,17 @@ params: - f code: | match f with - | CompiledFuncWithEnvironment(arity, pargs, framesize, body, env1) -> + | CompiledFuncWithEnvironment(optvars, arity, pargs, framesize, body, env1) -> + let body = + optvars |> List.fold_left (fun acc optvar -> + let bindop = + match optvar with + | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) + | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) + in + OpPush(Constructor("None", UnitConstant)) :: bindop :: acc + ) body + in if arity = n then begin if pargs = [] then @@ -125,7 +145,7 @@ code: | else if arity > n then let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment(arity - n, pargs @ args, framesize, body, env1) in + let applied = CompiledFuncWithEnvironment([], arity - n, pargs @ args, framesize, body, env1) in exec (applied :: stack) env code dump else @@ -140,7 +160,7 @@ code: | else if arity > n then let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment(arity - n, args, framesize, body, env1) in + let applied = CompiledFuncWithEnvironment([], arity - n, args, framesize, body, env1) in exec (applied :: stack) env code dump else @@ -149,6 +169,45 @@ code: | | _ -> report_bug_vm "ApplyT: not a function" +--- +inst: ApplyOptional +fields: +params: +- f +- v +code: | + match f with + | CompiledFuncWithEnvironment(var :: vars, arity, pargs, framesize, body, env1) -> + let bindop = + match var with + | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) + | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) + in + let body = OpPush(Constructor("Some", v)) :: bindop :: body in + CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) + + | _ -> + report_bug_vm "ApplyOptional: not a function with optional arguments" + +--- +inst: ApplyOmission +fields: +params: +- f +code: | + match f with + | CompiledFuncWithEnvironment(var :: vars, arity, pargs, framesize, body, env1) -> + let bindop = + match var with + | GlobalVar(loc, evid, refs) -> OpBindGlobal(loc, evid, !refs) + | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) + in + let body = OpPush(Constructor("None", UnitConstant)) :: bindop :: body in + CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) + + | _ -> + report_bug_vm "ApplyOmission: not a function with optional arguments" + --- inst: BindGlobal fields: @@ -440,7 +499,17 @@ fields: - framesize : int - body : instruction list code: | - exec (CompiledFuncWithEnvironment(arity, [], framesize, body, env) :: stack) env code dump + exec (CompiledFuncWithEnvironment([], arity, [], framesize, body, env) :: stack) env code dump + +--- +inst: OptClosure +fields: +- optvars : varloc list +- arity : int +- framesize : int +- body : instruction list +code: | + exec (CompiledFuncWithEnvironment(optvars, arity, [], framesize, body, env) :: stack) env code dump --- inst: ClosureInputHorz diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 7e01d48a9..8e48bf189 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -664,7 +664,7 @@ and syntactic_value = | FuncWithEnvironment of EvalVarID.t list * pattern_branch * environment | PrimitiveWithEnvironment of pattern_branch * environment * int * (abstract_tree list -> abstract_tree) - | CompiledFuncWithEnvironment of int * syntactic_value list * int * instruction list * vmenv + | CompiledFuncWithEnvironment of varloc list * int * syntactic_value list * int * instruction list * vmenv | CompiledPrimitiveWithEnvironment of int * syntactic_value list * int * instruction list * vmenv * (abstract_tree list -> abstract_tree) | EvaluatedEnvironment of environment From 793496060aca487236aac8f76cc48a239db2ee01 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 00:18:45 +0900 Subject: [PATCH 33/42] fix bug of executing commands --- gen_code.rb | 2 +- src/frontend/bytecomp/vm_.cppo.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gen_code.rb b/gen_code.rb index 85b557c01..5e9143d3a 100644 --- a/gen_code.rb +++ b/gen_code.rb @@ -174,7 +174,7 @@ def gen_insttype puts " [@printer (fun fmt _ -> Format.fprintf fmt \"Op#{inst["inst"]}(...)\")]" if inst["suppress-pp"] puts " [@printer (#{inst["custom-pp"]})]" if inst["custom-pp"] end - puts " [@@deriving show]" + puts " [@@deriving show { with_path = false; }]" end def gen_attype diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index 98a1004ec..9d9591b65 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -153,7 +153,7 @@ and exec_intermediate_input_vert (env : vmenv) (valuectx : syntactic_value) (imi imivlst |> List.map (fun imiv -> match imiv with | CompiledImInputVertEmbedded(code) -> - let valueret = exec [valuectx] env code [] in + let valueret = exec [valuectx] env (List.append code [OpApplyT(1)]) [] in get_vert valueret | CompiledImInputVertContent(imivlstsub, envsub) -> @@ -198,7 +198,7 @@ and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imi nmihlst |> List.map (fun nmih -> match nmih with | CompiledNomInputHorzEmbedded(code) -> - let valueret = exec [valuectx] env code [] in + let valueret = exec [valuectx] env (List.append code [OpApplyT(1)]) [] in get_horz valueret | CompiledNomInputHorzText(s) -> From 677bd0552d309314b50bd7c86b3010902ed73c4b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 00:20:09 +0900 Subject: [PATCH 34/42] arrange indentation in 'vminstdef.yaml' --- src/frontend/bytecomp/vminstdef.yaml | 54 ++++++++++++++-------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 1477b40df..421cf1ee0 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -133,39 +133,39 @@ code: | OpPush(Constructor("None", UnitConstant)) :: bindop :: acc ) body in - if arity = n then - begin - if pargs = [] then - exec stack (newframe env1 framesize) body dump - else - let (args, stack) = popn stack n in - let allargs = List.rev (pargs @ args) in - exec (allargs @ stack) (newframe env1 framesize) body dump - end + if arity = n then + begin + if pargs = [] then + exec stack (newframe env1 framesize) body dump + else + let (args, stack) = popn stack n in + let allargs = List.rev (pargs @ args) in + exec (allargs @ stack) (newframe env1 framesize) body dump + end - else if arity > n then - let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment([], arity - n, pargs @ args, framesize, body, env1) in - exec (applied :: stack) env code dump + else if arity > n then + let (args, stack) = popn stack n in + let applied = CompiledFuncWithEnvironment([], arity - n, pargs @ args, framesize, body, env1) in + exec (applied :: stack) env code dump - else - let (surplus, stack) = popn stack (n-arity) in - let (args, stack) = popn stack arity in - let allargs = List.rev (pargs @ args) in - exec (allargs @ stack) (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) + else + let (surplus, stack) = popn stack (n-arity) in + let (args, stack) = popn stack arity in + let allargs = List.rev (pargs @ args) in + exec (allargs @ stack) (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) | CompiledPrimitiveWithEnvironment(arity, [], framesize, body, env1, astf) -> - if arity = n then - exec stack (newframe env1 framesize) body dump + if arity = n then + exec stack (newframe env1 framesize) body dump - else if arity > n then - let (args, stack) = popn stack n in - let applied = CompiledFuncWithEnvironment([], arity - n, args, framesize, body, env1) in - exec (applied :: stack) env code dump + else if arity > n then + let (args, stack) = popn stack n in + let applied = CompiledFuncWithEnvironment([], arity - n, args, framesize, body, env1) in + exec (applied :: stack) env code dump - else - let (surplus, stack) = popn stack (n-arity) in - exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) + else + let (surplus, stack) = popn stack (n-arity) in + exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) | _ -> report_bug_vm "ApplyT: not a function" From 867c91bcaeb84301d7c0467ce89cc1eb2117b5eb Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 01:47:57 +0900 Subject: [PATCH 35/42] fix evaluation order of application by VM --- src/frontend/bytecomp/compiler.ml | 22 ++++++------------- src/frontend/bytecomp/ir_.cppo.ml | 7 +++--- src/frontend/bytecomp/vm_.cppo.ml | 7 +++++- src/frontend/bytecomp/vminstdef.yaml | 33 ++++++++++++++++------------ src/frontend/evalUtil.ml | 6 +++++ src/frontend/types_.cppo.ml | 3 +-- 6 files changed, 43 insertions(+), 35 deletions(-) diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index fb7fa7e1c..8978e5b3e 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -141,32 +141,24 @@ and compile (ir : ir) (cont : instruction list) = | IRLetNonRecIn(ir1, irpat, ir2) -> compile ir1 @@ compile_patsel (Range.dummy "LetNonRecIn") [IRPatternBranch(irpat, ir2)] cont - | IRFunction(framesize, irpatlst, irbody) -> + | IRFunction(framesize, optvars, irpatlst, irbody) -> let body = compile irbody [] in let patlst = compile_patlist irpatlst body in let (optcode, n) = optimize_func_prologue patlst in if framesize - n = 0 then - OpClosure(List.length irpatlst, 0, optcode) :: cont + OpClosure(optvars, List.length irpatlst, 0, optcode) :: cont else - OpClosure(List.length irpatlst, framesize, optcode) :: cont - - | IROptFunction(framesize, optvars, irpat, irbody) -> - let body = compile irbody [] in - let patlst = compile_patlist [irpat] body in - let (optcode, n) = optimize_func_prologue patlst in - OpOptClosure(optvars, 1, framesize, optcode) :: cont -(* - failwith "IROptFunction: remains to be implemented" -*) + OpClosure(optvars, List.length irpatlst, framesize, optcode) :: cont | IRApply(arity, ircallee, irargs) -> - compile_list irargs @@ (compile ircallee @@ emit_appop (List.length irargs) cont false) + let n = List.length irargs in + compile ircallee @@ (compile_list irargs @@ OpForward(n) :: emit_appop n cont false) | IRApplyPrimitive(op, arity, irargs) -> compile_list irargs (op :: cont) - | IRApplyOptional(irabs, iroptarg) -> - compile iroptarg @@ (compile iroptarg @@ OpApplyOptional :: cont) + | IRApplyOptional(ircallee, iroptarg) -> + compile ircallee @@ (compile iroptarg @@ OpApplyOptional :: cont) (* failwith "IRApplyOptional: remains to be implemented" *) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index d3eb12688..51552c489 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -366,13 +366,14 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = let funenv = new_level env in let (irargs, funenv) = transform_pattern_list funenv args in let (irbody, funenv) = transform funenv body in - (IRFunction(funenv.size, irargs, irbody), env) + (IRFunction(funenv.size, [], irargs, irbody), env) | Function((_ :: _) as evids, PatternBranch(arg, body)) -> - let (vars, funenv) = map_with_env add_to_environment (new_level env) evids in + let funenv = new_level env in + let (optvars, funenv) = map_with_env add_to_environment funenv evids in let (irarg, funenv) = transform_pattern funenv arg in let (irbody, funenv) = transform funenv body in - (IROptFunction(funenv.size, vars, irarg, irbody), env) + (IRFunction(funenv.size, optvars, [irarg], irbody), env) | Function(_, PatternBranchWhen(_, _, _)) -> assert false diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index 9d9591b65..414c61ef9 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -17,6 +17,7 @@ let report_dynamic_error msg = type compiled_nom_input_horz_element = | CompiledNomInputHorzText of string | CompiledNomInputHorzEmbedded of instruction list + | CompiledNomInputHorzThunk of instruction list | CompiledNomInputHorzContent of compiled_nom_input_horz_element list * vmenv @@ -183,7 +184,7 @@ and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imi end | CompiledImInputHorzEmbeddedMath(mathcode) -> - let nmih = CompiledNomInputHorzEmbedded(mathcode @ [OpPush(valuemcmd); OpApplyT(2)]) in + let nmih = CompiledNomInputHorzThunk(List.append mathcode [OpPush(valuemcmd); OpApplyT(2)]) in Alist.extend acc nmih | CompiledImInputHorzContent(imihlst, envsub) -> @@ -201,6 +202,10 @@ and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imi let valueret = exec [valuectx] env (List.append code [OpApplyT(1)]) [] in get_horz valueret + | CompiledNomInputHorzThunk(code) -> + let valueret = exec [] env code [] in + get_horz valueret + | CompiledNomInputHorzText(s) -> lex_horz_text ctx s diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 421cf1ee0..591caba85 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -59,6 +59,18 @@ code: | | _ -> report_bug_vm "not a Record" +--- +inst: Forward +fields: +- n : int +code: | + let (vs, stack) = popn stack n in + match stack with + | v0 :: stack -> + exec (v0 :: List.rev_append vs stack) env code dump + | _ -> + report_bug_vm "Swap: stack underflow" + --- inst: Apply fields: @@ -112,7 +124,8 @@ code: | let (surplus, stack) = popn stack (n - arity) in exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApply(n - arity) :: code) :: dump) - | _ -> report_bug_vm "Apply: not a function" + | _ -> + report_bug_vm_value "Apply: not a function" f --- inst: ApplyT @@ -149,7 +162,7 @@ code: | exec (applied :: stack) env code dump else - let (surplus, stack) = popn stack (n-arity) in + let (surplus, stack) = popn stack (n - arity) in let (args, stack) = popn stack arity in let allargs = List.rev (pargs @ args) in exec (allargs @ stack) (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) @@ -167,7 +180,8 @@ code: | let (surplus, stack) = popn stack (n-arity) in exec stack (newframe env1 framesize) body ((env, OpInsertArgs(surplus) :: OpApplyT(n - arity) :: code) :: dump) - | _ -> report_bug_vm "ApplyT: not a function" + | _ -> + report_bug_vm_value "ApplyT: not a function" f --- inst: ApplyOptional @@ -187,7 +201,7 @@ code: | CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) | _ -> - report_bug_vm "ApplyOptional: not a function with optional arguments" + report_bug_vm_value "ApplyOptional: not a function with optional arguments" f --- inst: ApplyOmission @@ -206,7 +220,7 @@ code: | CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) | _ -> - report_bug_vm "ApplyOmission: not a function with optional arguments" + report_bug_vm_value "ApplyOmission: not a function with optional arguments" f --- inst: BindGlobal @@ -495,15 +509,6 @@ code: | --- inst: Closure fields: -- arity : int -- framesize : int -- body : instruction list -code: | - exec (CompiledFuncWithEnvironment([], arity, [], framesize, body, env) :: stack) env code dump - ---- -inst: OptClosure -fields: - optvars : varloc list - arity : int - framesize : int diff --git a/src/frontend/evalUtil.ml b/src/frontend/evalUtil.ml index 86a1956f0..30eebb317 100644 --- a/src/frontend/evalUtil.ml +++ b/src/frontend/evalUtil.ml @@ -10,6 +10,12 @@ let report_bug_vm msg = failwith ("bug: " ^ msg) +let report_bug_vm_value msg value = + Format.printf "[Bug]@ %s:" msg; + Format.printf "%a" pp_syntactic_value value; + failwith ("bug: " ^ msg) + + let report_bug_ast msg ast = Format.printf "[Bug]@ %s:" msg; Format.printf "%a" pp_abstract_tree ast; diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 8e48bf189..9a8b9ac77 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -587,8 +587,7 @@ and ir = | IRLetNonRecIn of ir * ir_pattern_tree * ir | IRContentOf of varloc | IRIfThenElse of ir * ir * ir - | IRFunction of int * ir_pattern_tree list * ir - | IROptFunction of int * varloc list * ir_pattern_tree * ir + | IRFunction of int * varloc list * ir_pattern_tree list * ir | IRApply of int * ir * ir list | IRApplyPrimitive of instruction * int * ir list | IRApplyOptional of ir * ir From 5474bacaf722e9b3626c99c38778aea86b49379b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 02:04:24 +0900 Subject: [PATCH 36/42] fix bug of VM about evaluation of 'OpApplyOptional' and 'OpApplyOmission' --- src/frontend/bytecomp/ir_.cppo.ml | 12 ++++++------ src/frontend/bytecomp/vminstdef.yaml | 6 ++++-- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/frontend/bytecomp/ir_.cppo.ml b/src/frontend/bytecomp/ir_.cppo.ml index 51552c489..8780f00ef 100644 --- a/src/frontend/bytecomp/ir_.cppo.ml +++ b/src/frontend/bytecomp/ir_.cppo.ml @@ -379,15 +379,15 @@ and transform (env : frame) (ast : abstract_tree) : ir * frame = assert false | Apply(_, _) -> - let (callee, args) = flatten_application ast in + let (astcallee, astargs) = flatten_application ast in begin - match check_primitive env callee with - | Some((arity, astf)) when arity = List.length args -> - transform env (astf args) + match check_primitive env astcallee with + | Some((arity, astf)) when arity = List.length astargs -> + transform env (astf astargs) | _ -> - let (ircallee, env) = transform env callee in - let (irargs, env) = transform_list env args in + let (ircallee, env) = transform env astcallee in + let (irargs, env) = transform_list env astargs in (IRApply(List.length irargs, ircallee, irargs), env) end diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 591caba85..bce2fc0fe 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -198,7 +198,8 @@ code: | | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) in let body = OpPush(Constructor("Some", v)) :: bindop :: body in - CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) + let fnew = CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) in + exec (fnew :: stack) env code dump | _ -> report_bug_vm_value "ApplyOptional: not a function with optional arguments" f @@ -217,7 +218,8 @@ code: | | LocalVar(lv, off, evid, refs) -> OpBindLocal(lv, off, evid, !refs) in let body = OpPush(Constructor("None", UnitConstant)) :: bindop :: body in - CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) + let fnew = CompiledFuncWithEnvironment(vars, arity, pargs, framesize, body, env1) in + exec (fnew :: stack) env code dump | _ -> report_bug_vm_value "ApplyOmission: not a function with optional arguments" f From b1eb484073408e7f0ddcefbda0e907b487759e41 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 02:39:45 +0900 Subject: [PATCH 37/42] extend 'EvalVarID' (mainly for debugging) --- src/frontend/evalVarID.ml | 24 ++++++++++++---------- src/frontend/evalVarID.mli | 2 +- src/frontend/parser.mly | 6 +++--- src/frontend/primitives_.cppo.ml | 34 +++++++++++++++++--------------- src/frontend/typechecker.ml | 22 ++++++++++----------- src/frontend/types_.cppo.ml | 2 +- 6 files changed, 48 insertions(+), 42 deletions(-) diff --git a/src/frontend/evalVarID.ml b/src/frontend/evalVarID.ml index f82853495..51ca36450 100644 --- a/src/frontend/evalVarID.ml +++ b/src/frontend/evalVarID.ml @@ -1,5 +1,9 @@ -type t = int * string +type t = { + number : int; + name : string; + range : Range.t; +} let current_id = ref 0 @@ -9,27 +13,27 @@ let initialize () = current_id := 0 -let fresh varnm = +let fresh (rng, varnm) = begin incr current_id; - (!current_id, varnm) + { number = !current_id; name = varnm; range = rng; } end -let equal (i1, _) (i2, _) = - (i1 = i2) +let equal evid1 evid2 = + (evid1.number = evid2.number) -let compare (i1, _) (i2, _) = - Pervasives.compare i1 i2 +let compare evid1 evid2 = + Pervasives.compare evid1.number evid2.number -let show_direct (i, varnm) = - "<" ^ (string_of_int i) ^ "|" ^ varnm ^ ">" +let show_direct evid = + "<" ^ (string_of_int evid.number) ^ "|" ^ evid.name ^ "|" ^ (Range.to_string evid.range) ^ ">" let pp fmt evid = Format.fprintf fmt "%s" (show_direct evid) -let get_varnm ((_, varnm) : t) = varnm +let get_varnm (evid : t) = evid.name diff --git a/src/frontend/evalVarID.mli b/src/frontend/evalVarID.mli index a3ab36f0a..4b0f643d3 100644 --- a/src/frontend/evalVarID.mli +++ b/src/frontend/evalVarID.mli @@ -3,7 +3,7 @@ type t val initialize : unit -> unit -val fresh : string -> t +val fresh : Range.t * string -> t val equal : t -> t -> bool diff --git a/src/frontend/parser.mly b/src/frontend/parser.mly index e72c51435..446c032af 100644 --- a/src/frontend/parser.mly +++ b/src/frontend/parser.mly @@ -206,7 +206,7 @@ = let (varrng, varnm) = vartok in let curried = curry_lambda_abstract_pattern varrng argpatlst utastdef in - (UTLetRecBinding(mntyopt, varnm, curried)) :: tailcons + (UTLetRecBinding(mntyopt, varrng, varnm, curried)) :: tailcons let get_range_of_arguments (patlst : untyped_pattern_tree list) : Range.t = @@ -302,11 +302,11 @@ (tailcons : untyped_letrec_binding list) : untyped_letrec_binding list = - let (_, varnm) = vartok in + let (varrng, varnm) = vartok in let (patbrs, numofargs) = unite_into_pattern_branch_list recpatbrs in let rngfull = get_range_of_pattern_branch_list recpatbrs in let abs = make_function_for_parallel rngfull numofargs patbrs in - (UTLetRecBinding(mntyopt, varnm, abs)) :: tailcons + (UTLetRecBinding(mntyopt, varrng, varnm, abs)) :: tailcons let kind_type_arguments (uktyargs : untyped_unkinded_type_argument list) (constrntcons : constraints) : untyped_type_argument list = diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 15d836711..303ae6424 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -216,46 +216,48 @@ let lam evid ast = Function([], PatternBranch(PVariable(evid), ast)) let lamenv env evid arity ast astf = PrimitiveWithEnvironment(PatternBranch(PVariable(evid), ast), env, arity, astf) let ( !- ) evid = ContentOf(Range.dummy "temporary", evid) +let dr = Range.dummy "dummy:lambda" + let rec lambda1 astf env = - let evid1 = EvalVarID.fresh "(dummy:lambda1-1)" in + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda1-1)") in lamenv env evid1 1 (astf (!- evid1)) (fun lst -> match lst with | [a1] -> astf a1 | _ -> failwith "internal error") let rec lambda2 astf env = - let evid1 = EvalVarID.fresh "(dummy:lambda2-1)" in - let evid2 = EvalVarID.fresh "(dummy:lambda2-2)" in + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda2-1)") in + let evid2 = EvalVarID.fresh (dr, "(dummy:lambda2-2)") in lamenv env evid1 2 (lam evid2 (astf (!- evid1) (!- evid2))) (fun lst -> match lst with | [a1;a2] -> astf a1 a2 | _ -> failwith "internal error") let rec lambda3 astf env = - let evid1 = EvalVarID.fresh "(dummy:lambda3-1)" in - let evid2 = EvalVarID.fresh "(dummy:lambda3-2)" in - let evid3 = EvalVarID.fresh "(dummy:lambda3-3)" in + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda3-1)") in + let evid2 = EvalVarID.fresh (dr, "(dummy:lambda3-2)") in + let evid3 = EvalVarID.fresh (dr, "(dummy:lambda3-3)") in lamenv env evid1 3 (lam evid2 (lam evid3 (astf (!- evid1) (!- evid2) (!- evid3)))) (fun lst -> match lst with | [a1;a2;a3] -> astf a1 a2 a3 | _ -> failwith "internal error") let rec lambda4 astf env = - let evid1 = EvalVarID.fresh "(dummy:lambda4-1)" in - let evid2 = EvalVarID.fresh "(dummy:lambda4-2)" in - let evid3 = EvalVarID.fresh "(dummy:lambda4-3)" in - let evid4 = EvalVarID.fresh "(dummy:lambda4-4)" in + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda4-1)") in + let evid2 = EvalVarID.fresh (dr, "(dummy:lambda4-2)") in + let evid3 = EvalVarID.fresh (dr, "(dummy:lambda4-3)") in + let evid4 = EvalVarID.fresh (dr, "(dummy:lambda4-4)") in lamenv env evid1 4 (lam evid2 (lam evid3 (lam evid4 (astf (!- evid1) (!- evid2) (!- evid3) (!- evid4))))) (fun lst -> match lst with | [a1;a2;a3;a4] -> astf a1 a2 a3 a4 | _ -> failwith "internal error") let rec lambda5 astf env = - let evid1 = EvalVarID.fresh "(dummy:lambda5-1)" in - let evid2 = EvalVarID.fresh "(dummy:lambda5-2)" in - let evid3 = EvalVarID.fresh "(dummy:lambda5-3)" in - let evid4 = EvalVarID.fresh "(dummy:lambda5-4)" in - let evid5 = EvalVarID.fresh "(dummy:lambda5-5)" in + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda5-1)") in + let evid2 = EvalVarID.fresh (dr, "(dummy:lambda5-2)") in + let evid3 = EvalVarID.fresh (dr, "(dummy:lambda5-3)") in + let evid4 = EvalVarID.fresh (dr, "(dummy:lambda5-4)") in + let evid5 = EvalVarID.fresh (dr, "(dummy:lambda5-5)") in lamenv env evid1 5 (lam evid2 (lam evid3 (lam evid4 (lam evid5 (astf (!- evid1) (!- evid2) (!- evid3) (!- evid4) (!- evid5)))))) (fun lst -> match lst with | [a1;a2;a3;a4;a5] -> astf a1 a2 a3 a4 a5 @@ -578,7 +580,7 @@ let make_environments () = let temporary_ast = StringEmpty in let (tyenvfinal, envfinal, locacc) = table |> List.fold_left (fun (tyenv, env, acc) (varnm, pty, deff) -> - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (dr, varnm) in let loc = ref temporary_ast in let tyenvnew = Typeenv.add tyenv varnm (pty, evid) in let envnew = add_to_environment env evid loc in diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 5e590f946..0e2fae49c 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -30,7 +30,7 @@ let abstraction evid ast = let add_optionals_to_type_environment (tyenv : Typeenv.t) qtfbl lev (optargs : (Range.t * var_name) list) : mono_option_row * EvalVarID.t list * Typeenv.t = let (tyenvnew, tyacc, evidacc) = optargs |> List.fold_left (fun (tyenv, tyacc, evidacc) (rng, varnm) -> - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (rng, varnm) in let tvid = FreeID.fresh UniversalKind qtfbl lev () in let tvref = ref (MonoFree(tvid)) in let beta = (rng, TypeVariable(PolyFree(tvref))) in @@ -637,14 +637,14 @@ let rec typecheck (Concat(e1, e2), (rng, BaseType(TextRowType))) | UTLambdaHorz(varrng, varnmctx, utast1) -> - let evid = EvalVarID.fresh varnmctx in + let evid = EvalVarID.fresh (varrng, varnmctx) in let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in let () = unify tyret (Range.dummy "lambda-horz-return", BaseType(BoxRowType)) in (abstraction evid e1, (rng, HorzCommandType(cmdargtylist))) | UTLambdaVert(varrng, varnmctx, utast1) -> - let evid = EvalVarID.fresh varnmctx in + let evid = EvalVarID.fresh (varrng, varnmctx) in let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in let () = unify tyret (Range.dummy "lambda-vert-return", BaseType(BoxColType)) in @@ -1020,7 +1020,7 @@ and typecheck_input_vert (rng : Range.t) (qtfbl : quantifiability) (lev : level) | UTOptionalArgument((rng, _)) :: _ -> Range.unite rngcmd rng | UTOmission(rng) :: _ -> Range.unite rngcmd rng in - let evid = EvalVarID.fresh "%ctx-vert" in + let evid = EvalVarID.fresh (Range.dummy "ctx-vert", "%ctx-vert") in let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-vert", evid)) in let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in let eabs = abstraction evid eapp in @@ -1058,7 +1058,7 @@ and typecheck_input_horz (rng : Range.t) (qtfbl : quantifiability) (lev : level) match tycmdmain with | HorzCommandType(cmdargtylstreq) -> - let evid = EvalVarID.fresh "%ctx-horz" in + let evid = EvalVarID.fresh (Range.dummy "ctx-horz", "%ctx-horz") in let ecmdctx = Apply(ecmd, ContentOf(Range.dummy "ctx-horz", evid)) in let eapp = typecheck_command_arguments ecmdctx tycmd rngcmdapp qtfbl lev tyenv utcmdarglst cmdargtylstreq in let eabs = abstraction evid eapp in @@ -1208,7 +1208,7 @@ and typecheck_pattern | UTPVariable(varnm) -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (rng, varnm) in (* let () = print_endline ("\n#PAdd " ^ varnm ^ " : " ^ (string_of_mono_type_basic beta)) in (* for debug *) *) @@ -1225,7 +1225,7 @@ and typecheck_pattern raise (MultiplePatternVariable(rngsub, rng, varnm)) | None -> - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (rng, varnm) in (PAsVariable(evid, epat1), typat1, patvarmap1 |> PatternVarMap.add varnm (rng, evid, beta)) end @@ -1253,7 +1253,7 @@ and make_type_environment_by_letrec | [] -> (acctyenv, []) - | UTLetRecBinding(_, varnm, astdef) :: tailcons -> + | UTLetRecBinding(_, varrng, varnm, astdef) :: tailcons -> let tvid = FreeID.fresh UniversalKind qtfbl (Level.succ lev) () in let tvref = ref (MonoFree(tvid)) in let rng = get_range astdef in @@ -1262,7 +1262,7 @@ and make_type_environment_by_letrec (* let () = print_endline ("#AddMutualVar " ^ varnm ^ " : '" ^ (FreeID.show_direct (string_of_kind string_of_mono_type_basic) tvid) ^ " :: U") in (* for debug *) *) - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (varrng, varnm) in let (tyenvfinal, tvtylst) = iter (Typeenv.add acctyenv varnm (Poly(pbeta), evid)) tailcons in (tyenvfinal, ((varnm, beta, evid) :: tvtylst)) in @@ -1277,7 +1277,7 @@ and make_type_environment_by_letrec match (utrecbinds, tvtylst) with | ([], []) -> (tyenvforrec, [], List.rev acctvtylstout) - | (UTLetRecBinding(mntyopt, varnm, utast1) :: tailcons, (_, beta, evid) :: tvtytail) -> + | (UTLetRecBinding(mntyopt, _, varnm, utast1) :: tailcons, (_, beta, evid) :: tvtytail) -> let (e1, ty1) = typecheck qtfbl (Level.succ lev) tyenvforrec utast1 in begin match mntyopt with @@ -1337,7 +1337,7 @@ and make_type_environment_by_let_mutable (lev : level) (tyenv : Typeenv.t) varrn (* let () = print_endline ("#AddMutable " ^ varnm ^ " : " ^ (string_of_mono_type_basic (varrng, RefType(tyI)))) in (* for debug *) *) - let evid = EvalVarID.fresh varnm in + let evid = EvalVarID.fresh (varrng, varnm) in let tyenvI = Typeenv.add tyenv varnm (lift_poly (varrng, RefType(tyI)), evid) in (tyenvI, evid, eI, tyI) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 9a8b9ac77..e3f535726 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -358,7 +358,7 @@ module BoundID = (* ---- untyped ---- *) type untyped_letrec_binding = - UTLetRecBinding of manual_type option * var_name * untyped_abstract_tree + UTLetRecBinding of manual_type option * Range.t * var_name * untyped_abstract_tree and untyped_input_horz_element = Range.t * untyped_input_horz_element_main and untyped_input_horz_element_main = From e660c821040bc789835054435cec18e318916d16 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 03:03:25 +0900 Subject: [PATCH 38/42] extend 'Range' to include filenames --- src/frontend/lexer.mll | 12 +++++++--- src/frontend/main.ml | 4 ++-- src/frontend/parserInterface.ml | 6 ++--- src/frontend/range.ml | 40 +++++++++++++++------------------ src/frontend/range.mli | 2 +- 5 files changed, 33 insertions(+), 31 deletions(-) diff --git a/src/frontend/lexer.mll b/src/frontend/lexer.mll index 3124f2f9c..2d46f81e5 100644 --- a/src/frontend/lexer.mll +++ b/src/frontend/lexer.mll @@ -29,13 +29,17 @@ | MathState (* math mode *) + let file_name_ref = ref "" + + let get_pos lexbuf = let posS = Lexing.lexeme_start_p lexbuf in let posE = Lexing.lexeme_end_p lexbuf in + let fname = !file_name_ref (* posS.Lexing.pos_fname *) in let lnum = posS.Lexing.pos_lnum in let cnumS = posS.Lexing.pos_cnum - posS.Lexing.pos_bol in let cnumE = posE.Lexing.pos_cnum - posE.Lexing.pos_bol in - Range.make lnum cnumS cnumE + Range.make fname lnum cnumS cnumE let report_error lexbuf errmsg = @@ -91,11 +95,13 @@ stack - let reset_to_progexpr () = + let reset_to_progexpr fname = + file_name_ref := fname; initialize ProgramState - let reset_to_vertexpr () = + let reset_to_vertexpr fname = + file_name_ref := fname; initialize VerticalState diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 56cc04c0c..3c460ed77 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -107,7 +107,7 @@ let rec register_library_file (dg : file_info FileDependencyGraph.t) (file_path_ Logging.begin_to_parse_file file_path_in; let curdir = Filename.dirname file_path_in in let file_in = open_in file_path_in in - let (header, utast) = ParserInterface.process (Lexing.from_channel file_in) in + let (header, utast) = ParserInterface.process (Filename.basename file_path_in) (Lexing.from_channel file_in) in FileDependencyGraph.add_vertex dg file_path_in (LibraryFile(utast)); header |> List.iter (fun headerelem -> let file_path_sub = make_absolute_path curdir headerelem in @@ -204,7 +204,7 @@ let register_document_file (dg : file_info FileDependencyGraph.t) (file_path_in Logging.begin_to_parse_file file_path_in; let file_in = open_in file_path_in in let curdir = Filename.dirname file_path_in in - let (header, utast) = ParserInterface.process (Lexing.from_channel file_in) in + let (header, utast) = ParserInterface.process (Filename.basename file_path_in) (Lexing.from_channel file_in) in FileDependencyGraph.add_vertex dg file_path_in (DocumentFile(utast)); header |> List.iter (fun headerelem -> let file_path_sub = make_absolute_path curdir headerelem in diff --git a/src/frontend/parserInterface.ml b/src/frontend/parserInterface.ml index 6511919ed..9e3c97764 100644 --- a/src/frontend/parserInterface.ml +++ b/src/frontend/parserInterface.ml @@ -15,14 +15,14 @@ let k_fail chkpt = let (lposS, lposE) = I.positions penv in let cnumS = lposS.Lexing.pos_cnum - lposS.Lexing.pos_bol in let cnumE = lposE.Lexing.pos_cnum - lposE.Lexing.pos_bol in - let rng = Range.make lposS.Lexing.pos_lnum cnumS cnumE in + let rng = Range.make lposS.Lexing.pos_fname lposS.Lexing.pos_lnum cnumS cnumE in raise (Error(rng)) | _ -> assert false -let process lexbuf = +let process fname lexbuf = (* print_endline "parserInterface.process"; (* for debug *) *) - let stack = Lexer.reset_to_progexpr () in + let stack = Lexer.reset_to_progexpr fname in let supplier = I.lexer_lexbuf_to_supplier (Lexer.cut_token stack) lexbuf in I.loop_handle k_success k_fail supplier (Parser.Incremental.main lexbuf.Lexing.lex_curr_p) diff --git a/src/frontend/range.ml b/src/frontend/range.ml index 9300f265d..d6c89a525 100644 --- a/src/frontend/range.ml +++ b/src/frontend/range.ml @@ -1,15 +1,8 @@ -type t = Dummy of string | Normal of int * int * int * int - -let pp ppf rng = - Format.fprintf ppf "" -(* - match rng with - | Dummy(msg) -> ppf "RangeDummy(%s)" msg - | Normal(ln1, pos1, ln2, pos2) -> "Range" -*) - -let show rng = "" +type t = + | Dummy of string + | Normal of string * int * int * int * int +[@@deriving show] let dummy msg = Dummy(msg) @@ -23,27 +16,30 @@ let is_dummy rng = let message rng = match rng with - | Dummy(msg) -> msg - | Normal(_, _, _, _) -> "*NORMAL*" + | Dummy(msg) -> msg + | Normal(_, _, _, _, _) -> "*NORMAL*" let to_string rng = let s = string_of_int in match rng with - | Dummy(msg) -> "dummy range '" ^ msg ^ "'" - | Normal(ln1, pos1, ln2, pos2) -> + | Dummy(msg) -> + "dummy range '" ^ msg ^ "'" + + | Normal(fname, ln1, pos1, ln2, pos2) -> if ln1 = ln2 then - "line " ^ (s ln1) ^ ", characters " ^ (s pos1) ^ "-" ^ (s pos2) + "\"" ^ fname ^ "\", line " ^ (s ln1) ^ ", characters " ^ (s pos1) ^ "-" ^ (s pos2) else - "line " ^ (s ln1) ^ ", character " ^ (s pos1) ^ " to line " ^ (s ln2) ^ ", character " ^ (s pos2) + "\"" ^ fname ^ "\", line " ^ (s ln1) ^ ", character " ^ (s pos1) ^ " to line " ^ (s ln2) ^ ", character " ^ (s pos2) let unite rng1 rng2 = match (rng1, rng2) with - | (Normal(ln1, pos1, _, _), Normal(_, _, ln2, pos2)) -> Normal(ln1, pos1, ln2, pos2) - | (Normal(_, _, _, _), _) -> rng1 - | (_, Normal(_, _, _, _)) -> rng2 - | _ -> Dummy("unite") + | (Normal(fname, ln1, pos1, _, _), Normal(_, _, _, ln2, pos2)) -> Normal(fname, ln1, pos1, ln2, pos2) + | (Normal(_, _, _, _, _), _) -> rng1 + | (_, Normal(_, _, _, _, _)) -> rng2 + | _ -> Dummy("unite") -let make ln pos1 pos2 = Normal(ln, pos1, ln, pos2) +let make fname ln pos1 pos2 = + Normal(fname, ln, pos1, ln, pos2) diff --git a/src/frontend/range.mli b/src/frontend/range.mli index ef0d43c13..9c0141c2d 100644 --- a/src/frontend/range.mli +++ b/src/frontend/range.mli @@ -12,4 +12,4 @@ val to_string : t -> string val unite : t -> t -> t -val make : int -> int -> int -> t +val make : string -> int -> int -> int -> t From 812bb9955b2b1934bae8387d6855a593badb44b2 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 03:13:54 +0900 Subject: [PATCH 39/42] fix bug of VM about evaluation of math formulae in inline texts --- src/frontend/bytecomp/vm_.cppo.ml | 2 +- src/frontend/bytecomp/vminstdef.yaml | 12 ++++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index 414c61ef9..01f6845de 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -184,7 +184,7 @@ and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imi end | CompiledImInputHorzEmbeddedMath(mathcode) -> - let nmih = CompiledNomInputHorzThunk(List.append mathcode [OpPush(valuemcmd); OpApplyT(2)]) in + let nmih = CompiledNomInputHorzThunk(List.append mathcode [OpPush(valuectx); OpForward(1); OpPush(valuemcmd); OpApplyT(2)]) in Alist.extend acc nmih | CompiledImInputHorzContent(imihlst, envsub) -> diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index bce2fc0fe..be0fa42b9 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -69,7 +69,7 @@ code: | | v0 :: stack -> exec (v0 :: List.rev_append vs stack) env code dump | _ -> - report_bug_vm "Swap: stack underflow" + report_bug_vm "Forward: stack underflow" --- inst: Apply @@ -244,10 +244,14 @@ fields: - evid : EvalVarID.t - refs : int params: -- v code: | - local_set_value env lv offset v; - exec stack env code dump + match stack with + | v :: stack -> + local_set_value env lv offset v; + exec stack env code dump + + | _ -> + report_bug_vm ("BindLocal(" ^ (EvalVarID.show_direct evid) ^ ")") --- inst: BindClosuresRec From dbe1796bfd926491b96f022a88fe69dea30ad07d Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 03:44:17 +0900 Subject: [PATCH 40/42] improve error logs as to application of non-functions --- src/frontend/main.ml | 11 ++++++++++- src/frontend/typechecker.ml | 7 ++++++- src/frontend/typechecker.mli | 1 + 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 3c460ed77..5f23e7197 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -562,10 +562,19 @@ let error_log_environment suspended = | Typechecker.MultipleFieldInRecord(rng, fldnm) -> report_error Typechecker [ - NormalLine("at " ^ (Range.to_string rng)); + NormalLine("at " ^ (Range.to_string rng) ^ ":"); NormalLine("this record expression has more than one field for '" ^ fldnm ^ "'."); ] + | Typechecker.ApplicationOfNonFunction(rng, tyenv, ty) -> + let strty = string_of_mono_type tyenv ty in + report_error Typechecker [ + NormalLine("at " ^ (Range.to_string rng) ^ ":"); + NormalLine("this expression has type"); + DisplayLine(strty); + NormalLine("and thus it cannot be applied to arguments."); + ] + | Typeenv.IllegalNumberOfTypeArguments(rng, tynm, lenexp, lenerr) -> report_error Typechecker [ NormalLine("at " ^ (Range.to_string rng) ^ ":"); diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index 0e2fae49c..ca90cb841 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -18,6 +18,7 @@ exception InvalidOptionalCommandArgument of Typeenv.t * mono_type * Range.t exception NeedsMoreArgument of Range.t * Typeenv.t * mono_type * mono_type exception TooManyArgument of Range.t * Typeenv.t * mono_type exception MultipleFieldInRecord of Range.t * field_name +exception ApplicationOfNonFunction of Range.t * Typeenv.t * mono_type exception InternalInclusionError exception InternalContradictionError @@ -667,13 +668,17 @@ let rec typecheck let tycodnew = overwrite_range_of_type tycod rng in (eret, tycodnew) - | ty1 -> + | (_, TypeVariable(_)) as ty1 -> let tvid = FreeID.fresh UniversalKind qtfbl lev () in let beta = (rng, TypeVariable(ref (MonoFree(tvid)))) in let orv = OptionRowVarID.fresh lev in let optrow = OptionRowVariable(ref (MonoORFree(orv))) in let () = unify ty1 (get_range utast1, FuncType(optrow, ty2, beta)) in (eret, beta) + + | ty1 -> + let (rng1, _) = utast1 in + raise (ApplicationOfNonFunction(rng1, tyenv, ty1)) end | UTApplyOptional(utast1, utast2) -> diff --git a/src/frontend/typechecker.mli b/src/frontend/typechecker.mli index 67dfd982d..1448296b1 100644 --- a/src/frontend/typechecker.mli +++ b/src/frontend/typechecker.mli @@ -16,5 +16,6 @@ exception InvalidOptionalCommandArgument of Typeenv.t * mono_type * Range.t exception NeedsMoreArgument of Range.t * Typeenv.t * mono_type * mono_type exception TooManyArgument of Range.t * Typeenv.t * mono_type exception MultipleFieldInRecord of Range.t * field_name +exception ApplicationOfNonFunction of Range.t * Typeenv.t * mono_type val main : Typeenv.t -> untyped_abstract_tree -> (mono_type * Typeenv.t * abstract_tree) From 82012bb160f06b0c95bd5618e23c0b1502b84e69 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 03:49:10 +0900 Subject: [PATCH 41/42] omit comment-out code --- src/frontend/bytecomp/compiler.ml | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/frontend/bytecomp/compiler.ml b/src/frontend/bytecomp/compiler.ml index 8978e5b3e..4c65d1719 100644 --- a/src/frontend/bytecomp/compiler.ml +++ b/src/frontend/bytecomp/compiler.ml @@ -41,11 +41,6 @@ and compile_input_horz_content (ihlst : ir_input_horz_element list) = | IRInputHorzEmbedded(irabs) -> let compiled = compile irabs [] in -(* - let appcode = emit_appop (List.length irarglist) [] true in - let cmdcode = compile ircmd appcode in - let compiled = compile_list irarglist cmdcode in -*) CompiledInputHorzEmbedded(compiled) | IRInputHorzEmbeddedMath(irmath) -> @@ -62,11 +57,6 @@ and compile_input_vert_content (ivlst : ir_input_vert_element list) = ivlst |> List.map (function | IRInputVertEmbedded(irabs) -> let compiled = compile irabs [] in -(* - let appcode = emit_appop (List.length irarglist) [] true in - let cmdcode = compile ircmd appcode in - let compiled = compile_list irarglist cmdcode in -*) CompiledInputVertEmbedded(compiled) | IRInputVertContent(ir) -> @@ -159,15 +149,9 @@ and compile (ir : ir) (cont : instruction list) = | IRApplyOptional(ircallee, iroptarg) -> compile ircallee @@ (compile iroptarg @@ OpApplyOptional :: cont) -(* - failwith "IRApplyOptional: remains to be implemented" -*) | IRApplyOmission(irabs) -> compile irabs @@ OpApplyOmission :: cont -(* - failwith "IRApplyOmission: remains to be implemented" -*) | IRTuple(len, iritems) -> compile_list iritems (OpMakeTuple(len) :: cont) From 50b513731731e151503e6da57c7f5579a96bfff1 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 9 Aug 2018 03:53:41 +0900 Subject: [PATCH 42/42] UPDATE VERSION TO 0.0.2 --- satysfi.opam | 2 +- src/frontend/main.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/satysfi.opam b/satysfi.opam index 695d18b9f..4f66432b1 100644 --- a/satysfi.opam +++ b/satysfi.opam @@ -1,6 +1,6 @@ opam-version: "1.2" name: "satysfi" -version: "0.0.1" +version: "0.0.2" maintainer: "gfngfn" authors: [ "gfngfn" diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 5f23e7197..cf22caa0d 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -699,7 +699,7 @@ let error_log_environment suspended = let arg_version () = begin print_string ( - " SATySFi version 0.0.1\n" + " SATySFi version 0.0.2\n" (* ^ " (in the middle of the transition from Macrodown)\n" ^ " ____ ____ ________ _____ ______\n"