home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / ty_decl.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  6.8 KB  |  231 lines  |  [TEXT/MPS ]
  1. (* Typing toplevel phrases *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "globals";;
  6. #open "builtins";;
  7. #open "location";;
  8. #open "syntax";;
  9. #open "modules";;
  10. #open "types";;
  11. #open "typing";;
  12. #open "ty_error";;
  13.  
  14. let enter_new_variant is_extensible loc (ty_constr, ty_res, constrs) =
  15.   let nbr_constrs =
  16.     list_length constrs in
  17.   let rec make_constrs constr_idx = function
  18.     [] -> []
  19.   | Zconstr0decl constr_name :: rest ->
  20.       let constr_tag =
  21.         if is_extensible then
  22.           ConstrExtensible({qual=compiled_module_name(); id=constr_name},
  23.                            new_exc_stamp())
  24.         else
  25.           ConstrRegular(constr_idx, nbr_constrs) in
  26.       let constr_glob =
  27.         defined_global constr_name
  28.           { cs_res = ty_res;
  29.             cs_arg = type_unit;
  30.             cs_mut = Notmutable;
  31.             cs_tag = constr_tag;
  32.             cs_kind = Constr_constant }
  33.       in
  34.         add_constr constr_glob;
  35.         constr_glob :: make_constrs (succ constr_idx) rest
  36.   | Zconstr1decl(constr_name, arg, mut_flag) :: rest ->
  37.       let ty_arg =
  38.         type_of_type_expression true arg
  39.       and constr_tag =
  40.         if is_extensible then
  41.           ConstrExtensible({qual=compiled_module_name(); id=constr_name},
  42.                            new_exc_stamp())
  43.         else
  44.           ConstrRegular(constr_idx, nbr_constrs) in
  45.       let kind =
  46.         match type_repr ty_arg with
  47.           {typ_desc = Tproduct tylist} ->
  48.             begin match mut_flag with
  49.               Notmutable -> Constr_superfluous (list_length tylist)
  50.             | Mutable    -> Constr_regular
  51.             end
  52.         | _ ->
  53.             Constr_regular in
  54.       let constr_glob =
  55.         defined_global constr_name
  56.           { cs_res = ty_res;
  57.             cs_arg = ty_arg;
  58.             cs_mut = mut_flag;
  59.             cs_tag = constr_tag;
  60.             cs_kind = kind }
  61.       in
  62.         add_constr constr_glob;
  63.         if mut_flag == Mutable or dangerous_vars ty_arg != [] then begin
  64.           ty_constr.info.ty_dang <- true; ()
  65.         end;
  66.         constr_glob :: make_constrs (succ constr_idx) rest
  67.   in
  68.     let constr_descs = make_constrs 0 constrs in
  69.       pop_type_level();
  70.       generalize_type_constr ty_res;
  71.       do_list
  72.         (fun cstr -> generalize_type_constr cstr.info.cs_arg)
  73.         constr_descs;
  74.       Variant_type constr_descs
  75. ;;
  76.  
  77. let enter_new_record loc (ty_constr, ty_res, labels) =
  78.   let rec make_labels i = function
  79.     [] -> []
  80.   | (name, typexp, mut_flag) :: rest ->
  81.       let ty_arg = type_of_type_expression true typexp in
  82.       let lbl_glob =
  83.         defined_global name
  84.           { lbl_res = ty_res; lbl_arg = ty_arg;
  85.             lbl_mut = mut_flag; lbl_pos = i }
  86.       in
  87.         add_label lbl_glob;
  88.         if mut_flag == Mutable or dangerous_vars ty_arg != [] then
  89.           begin ty_constr.info.ty_dang <- true; () end;
  90.         lbl_glob :: make_labels (succ i) rest in
  91.   let label_descs = make_labels 0 labels in
  92.     pop_type_level();
  93.     generalize_type_constr ty_res;
  94.     do_list
  95.       (function lbl -> generalize_type_constr lbl.info.lbl_arg)
  96.       label_descs;
  97.     Record_type label_descs
  98. ;;
  99.     
  100. let enter_new_abbrev (ty_constr, ty_params, body) =
  101.   let ty_body = type_of_type_expression true body in
  102.     pop_type_level();
  103.     generalize_type_constr ty_body;
  104.     do_list generalize_type_constr ty_params;
  105.     ty_constr.info.ty_abbr <- Tabbrev(ty_params, ty_body);
  106.     Abbrev_type(ty_params, ty_body)
  107. ;;
  108.  
  109. let enter_new_type (ty_name, params, def) =
  110.   let ty_constr =
  111.     defined_global ty_name
  112.       { ty_stamp = new_type_stamp();
  113.         ty_dang = false;
  114.         ty_abbr = Tnotabbrev } in
  115.   let ty_desc =
  116.     defined_global ty_name
  117.       { ty_constr = ty_constr;
  118.         ty_arity = list_length params;
  119.         ty_desc  = Abstract_type } in
  120.   add_type ty_desc;
  121.   (ty_desc, params, def)
  122. ;;
  123.  
  124. type external_type =
  125.   { et_descr: type_desc global;
  126.     et_manifest: bool;
  127.     mutable et_defined: bool };;
  128.  
  129. let external_types =
  130.   ref ([] : (string * external_type) list);;
  131.  
  132. let define_new_type loc (ty_desc, params, def) =
  133.   push_type_level();
  134.   let ty_params =
  135.     try
  136.       bind_type_expression_vars params
  137.     with Failure "bind_type_expression_vars" ->
  138.       duplicate_param_in_type_decl_err loc in
  139.   let ty_res =
  140.     { typ_desc = Tconstr(ty_desc.info.ty_constr, ty_params);
  141.       typ_level = notgeneric} in
  142.   let type_comp =
  143.     match def with
  144.       Zabstract_type mut_flag ->
  145.         if mut_flag == Mutable then begin
  146.           ty_desc.info.ty_constr.info.ty_dang <- true; ()
  147.         end;
  148.         pop_type_level(); Abstract_type
  149.     | Zvariant_type constrs ->
  150.         enter_new_variant false loc (ty_desc.info.ty_constr, ty_res, constrs)
  151.     | Zrecord_type labels ->
  152.         enter_new_record loc (ty_desc.info.ty_constr, ty_res, labels)
  153.     | Zabbrev_type body ->
  154.         enter_new_abbrev (ty_desc.info.ty_constr, ty_params, body) in
  155.   ty_desc.info.ty_desc <- type_comp;
  156.   begin try
  157.     let extdef = assoc ty_desc.qualid.id !external_types in
  158.     if extdef.et_manifest or extdef.et_defined then
  159.       illegal_type_redefinition loc extdef.et_descr;
  160.     extdef.et_defined <- true;
  161.     let extconstr = extdef.et_descr.info.ty_constr
  162.     and intconstr = ty_desc.info.ty_constr in
  163.     intconstr.info.ty_stamp <- extconstr.info.ty_stamp;
  164.     extconstr.info.ty_abbr  <- intconstr.info.ty_abbr
  165.   with Not_found ->
  166.     ()
  167.   end;
  168.   (ty_res, type_comp)
  169. ;;
  170.  
  171. let type_typedecl loc decl =
  172.   map (define_new_type loc) (map enter_new_type decl)
  173. ;;
  174.  
  175. let type_excdecl loc decl =
  176.   push_type_level();
  177.   reset_type_expression_vars ();
  178.   enter_new_variant true loc (constr_type_exn, type_exn, decl)
  179. ;;
  180.  
  181. let fully_generalize_type loc ty =
  182.   generalize_type ty;
  183.   match free_type_vars ty with
  184.      []  -> ()
  185.   | vars -> cannot_generalize_err loc vars ty
  186. ;;
  187.  
  188. let type_valuedecl loc decl =
  189.   let enter_val (name, typexp, prim) =
  190.     push_type_level();
  191.     reset_type_expression_vars ();
  192.     let ty = type_of_type_expression false typexp in
  193.       pop_type_level();
  194.       fully_generalize_type loc ty;
  195.       add_value (defined_global name { val_typ = ty; val_prim = prim })
  196.   in
  197.     do_list enter_val decl
  198. ;;
  199.  
  200. let type_letdef loc rec_flag pat_expr_list =
  201.   push_type_level();
  202.   let (pat_ty_list, expr_ty_list) =
  203.     it_list
  204.      (fun (pt, et) (pat,expr) ->
  205.         let alpha = new_type_var () in
  206.           (pat,alpha,Notmutable)::pt, (expr,alpha)::et)
  207.      ([],[])
  208.      pat_expr_list in
  209.   let env =
  210.     type_pattern_list2 pat_ty_list in
  211.   let enter_val =
  212.     do_list
  213.       (fun (name,(ty,mut_flag)) ->
  214.         add_value (defined_global name {val_typ=ty; val_prim=ValueNotPrim})) in
  215.   if rec_flag then enter_val env;
  216.   do_list (type_expr []) expr_ty_list;
  217.   pop_type_level();
  218.   do_list (fun (_, (ty, _)) -> fully_generalize_type loc ty) env;
  219.   if not rec_flag then enter_val env;
  220.   env
  221. ;;
  222.   
  223. let type_expression loc expr =
  224.   push_type_level();
  225.   let ty = new_type_var () in
  226.   type_expr [] (expr,ty);
  227.   pop_type_level();
  228.   fully_generalize_type loc ty;
  229.   ty
  230. ;;
  231.