home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / front.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  11.0 KB  |  339 lines  |  [TEXT/MPS ]
  1. (* front.ml : translation abstract syntax -> extended lambda-calculus. *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "globals";;
  6. #open "syntax";;
  7. #open "location";;
  8. #open "builtins";;
  9. #open "modules";;
  10. #open "lambda";;
  11. #open "prim";;
  12. #open "match";;
  13. #open "tr_env";;
  14. #open "trstream";;
  15. #open "ty_error";;
  16.  
  17. (* Translation of expressions *)
  18.  
  19. exception Not_constant;;
  20.  
  21. let extract_constant = function
  22.     Lconst cst -> cst
  23.   |       _    -> raise Not_constant
  24. ;;
  25.  
  26. let rec check_letrec_expr (Expr(e,loc)) =
  27.   match e with
  28.     Zident _ -> ()
  29.   | Zconstant _ -> ()
  30.   | Ztuple el -> do_list check_letrec_expr el
  31.   | Zconstruct0 cstr -> ()
  32.   | Zconstruct1(cstr, expr) ->
  33.       check_letrec_expr expr;
  34.       begin match cstr.info.cs_kind with
  35.         Constr_superfluous n ->
  36.           begin match expr with
  37.             Expr(Ztuple _, _) -> ()
  38.           | _ -> illegal_letrec_expr loc
  39.           end
  40.       | _ -> ()
  41.       end
  42.   | Zfunction _ -> ()
  43.   | Zconstraint(e,_) -> check_letrec_expr e
  44.   | Zvector el -> do_list check_letrec_expr el
  45.   | Zrecord lbl_expr_list ->
  46.       do_list (fun (lbl,expr) -> check_letrec_expr expr) lbl_expr_list
  47.   | Zparser _ -> ()
  48.   | Zstream _ -> ()
  49.   | _ ->
  50.       illegal_letrec_expr loc
  51. ;;
  52.  
  53. let rec size_of_expr (Expr(e,loc)) =
  54.   match e with
  55.     Ztuple el ->
  56.       do_list check_letrec_expr el; list_length el
  57.   | Zconstruct1(cstr, expr) ->
  58.       check_letrec_expr expr;
  59.       begin match cstr.info.cs_kind with
  60.         Constr_superfluous n -> n | _ -> 1
  61.       end
  62.   | Zfunction _ ->
  63.       2
  64.   | Zconstraint(e,_) ->
  65.       size_of_expr e
  66.   | Zvector el ->
  67.       do_list check_letrec_expr el; list_length el
  68.   | Zrecord lbl_expr_list ->
  69.       do_list (fun (lbl,expr) -> check_letrec_expr expr) lbl_expr_list;
  70.       list_length lbl_expr_list
  71.   | Zlet(flag, pat_expr_list, body) ->
  72.       do_list (fun (pat,expr) -> check_letrec_expr expr) pat_expr_list;
  73.       size_of_expr body      
  74.   | Zstream _ ->
  75.       2
  76.   | Zparser _ ->
  77.       2
  78.   | _ ->
  79.       illegal_letrec_expr loc
  80. ;;
  81.  
  82. let partial_fun (Loc(start,stop) as loc) tsb =
  83.   let handler =
  84.     Lprim(Praise,
  85.          [Lconst(SCblock(match_failure_tag,
  86.                          [SCatom(ACstring !input_name);
  87.                           SCatom(ACint start);
  88.                           SCatom(ACint stop)]))]) in
  89.   match tsb with
  90.     True ->
  91.       prerr_location loc;
  92.       prerr_begline " Warning: pattern matching is not exhaustive";
  93.       prerr_endline2 "";
  94.       handler
  95.   | _ ->
  96.       handler
  97. ;;
  98.  
  99. let partial_try (tsb : tristate_logic) =
  100.   Lprim(Praise, [Lvar 0])
  101. ;;
  102.  
  103. let rec translate_expr env =
  104.   let rec transl (Expr(desc, loc)) =
  105.   match desc with
  106.     Zident(ref(Zlocal s)) ->
  107.       translate_access s env
  108.   | Zident(ref(Zglobal g)) ->
  109.       (match g.info.val_prim with
  110.         ValueNotPrim ->
  111.           Lprim(Pget_global g.qualid, [])
  112.       | ValuePrim(0, p) ->
  113.           Lprim(Pget_global g.qualid, [])
  114.       | ValuePrim(arity, p) ->
  115.           let rec make_fct args n =
  116.             if n >= arity
  117.             then Lprim(p, args)
  118.             else Lfunction(make_fct (Lvar n :: args) (n+1))
  119.           in
  120.             make_fct [] 0)
  121.   | Zconstant cst ->
  122.       Lconst cst
  123.   | Ztuple(args) ->
  124.       let tr_args =
  125.         map transl args in
  126.       begin try
  127.         Lconst(SCblock(ConstrRegular(0,1), map extract_constant tr_args))
  128.       with Not_constant ->
  129.         Lprim(Pmakeblock(ConstrRegular(0,1)), tr_args)
  130.       end
  131.   | Zconstruct0(c) ->
  132.       Lconst(SCblock(c.info.cs_tag, []))
  133.   | Zconstruct1(c,arg) ->
  134.       begin match c.info.cs_kind with
  135.         Constr_constant ->
  136.           Lsequence(transl arg, Lconst(SCblock(c.info.cs_tag, [])))
  137.       | Constr_regular ->
  138.           let tr_arg = transl arg in
  139.           begin match c.info.cs_mut with
  140.             Mutable ->
  141.               Lprim(Pmakeblock c.info.cs_tag, [tr_arg])
  142.           | Notmutable ->
  143.               begin try
  144.                 Lconst(SCblock(c.info.cs_tag, [extract_constant tr_arg]))
  145.               with Not_constant ->
  146.                 Lprim(Pmakeblock c.info.cs_tag, [tr_arg])
  147.               end
  148.           end
  149.       | Constr_superfluous n ->
  150.           match arg with
  151.             Expr(Ztuple argl, _) ->
  152.               let tr_argl = map transl argl in
  153.               begin try                           (* superfluous ==> pure *)
  154.                 Lconst(SCblock(c.info.cs_tag, map extract_constant tr_argl))
  155.               with Not_constant ->
  156.                 Lprim(Pmakeblock c.info.cs_tag, tr_argl)
  157.               end
  158.           | _ ->
  159.               let rec extract_fields i =
  160.                 if i >= n then [] else
  161.                   Lprim(Pfield i, [Lvar 0]) :: extract_fields (succ i) in
  162.               Llet([transl arg],
  163.                    Lprim(Pmakeblock c.info.cs_tag, extract_fields 0))
  164.       end
  165.   | Zapply(Expr(Zfunction ((patl,_)::_ as case_list), _) as funct, args) ->
  166.       if list_length patl == list_length args then
  167.         Llet(translate_let env args,
  168.              translate_match loc env (partial_fun loc) case_list)
  169.       else
  170.       Lapply(transl funct, map transl args)
  171.   | Zapply((Expr(Zident(ref (Zglobal g)), _) as fct), args) ->
  172.      (match g.info.val_prim with
  173.         ValueNotPrim ->
  174.           Lapply(transl fct, map transl args)
  175.       | ValuePrim(arity, p) ->
  176.           if arity == list_length args
  177.           then Lprim(p, map transl args)
  178.           else Lapply(transl fct, map transl args))
  179.   | Zapply(funct, args) ->
  180.       Lapply(transl funct, map transl args)
  181.   | Zlet(false, pat_expr_list, body) ->
  182.       let cas = map (fun (pat, _) -> pat) pat_expr_list in
  183.         Llet(translate_bind env pat_expr_list,
  184.              translate_match loc env (partial_fun loc) [cas, body])
  185.   | Zlet(true, pat_expr_list, body) ->
  186.       let new_env =
  187.         add_let_rec_to_env env pat_expr_list in
  188.       let translate_rec_bind = function
  189.           (Pat(Zvarpat v,_), expr) ->
  190.             translate_expr new_env expr, size_of_expr expr
  191.         | _ ->
  192.             fatal_error "translate_rec_bind" in
  193.       Lletrec(map translate_rec_bind pat_expr_list,
  194.               translate_expr new_env body)
  195.   | Zfunction [] ->
  196.       fatal_error "translate_expr: empty fun"
  197.   | Zfunction((patl1,act1)::_ as case_list) ->
  198.       let rec transl_fun = function
  199.            []  -> translate_match loc env (partial_fun loc) case_list
  200.         | a::L -> Lfunction(transl_fun L) in
  201.       transl_fun patl1
  202.   | Ztrywith(body, pat_expr_list) ->
  203.       Lhandle(transl body,
  204.               translate_simple_match loc env partial_try pat_expr_list)
  205.   | Zsequence(E1, E2) ->
  206.       Lsequence(transl E1, transl E2)
  207.   | Zcondition(Eif, Ethen, Eelse) ->
  208.       Lifthenelse(transl Eif, transl Ethen, transl Eelse)
  209.   | Zwhile(Econd, Ebody) ->
  210.       Lwhile(transl Econd, transl Ebody)
  211.   | Zfor(id, Estart, Estop, up_flag, Ebody) ->
  212.       Lfor(transl Estart,
  213.            translate_expr (Treserved env) Estop,
  214.            up_flag,
  215.            translate_expr (add_for_parameter_to_env env id) Ebody)
  216.   | Zsequand(E1, E2) ->
  217.       Lsequand(transl E1, transl E2)
  218.   | Zsequor(E1, E2) ->
  219.       Lsequor(transl E1, transl E2)
  220.   | Zconstraint(E, _) ->
  221.       transl E
  222.   | Zvector [] ->
  223.       Lconst(SCblock(ConstrRegular(0,0), []))
  224.   | Zvector args ->
  225.       Lprim(Pmakeblock (ConstrRegular(0,0)), map transl args)
  226.   | Zassign(id, E) ->
  227.       translate_update id env (transl E)
  228.   | Zrecord lbl_expr_list ->
  229.       let v = make_vect (list_length lbl_expr_list) Lstaticfail in
  230.         do_list
  231.           (fun (lbl, e) -> v.(lbl.info.lbl_pos) <- transl e)
  232.           lbl_expr_list;
  233.         begin try
  234.           if for_all
  235.                (fun (lbl, e) -> lbl.info.lbl_mut == Notmutable)
  236.                lbl_expr_list
  237.           then Lconst(SCblock(ConstrRegular(0,0),
  238.                               map_vect_list extract_constant v))
  239.           else raise Not_constant
  240.         with Not_constant ->
  241.           Lprim(Pmakeblock(ConstrRegular(0,0)), list_of_vect v)
  242.         end
  243.   | Zrecord_access (e, lbl) ->
  244.       Lprim(Pfield lbl.info.lbl_pos, [transl e])
  245.   | Zrecord_update (e1, lbl, e2) ->
  246.       Lprim(Psetfield lbl.info.lbl_pos, [transl e1; transl e2])
  247.   | Zstream stream_comp_list ->
  248.       translate_stream translate_expr env stream_comp_list
  249.   | Zparser case_list ->
  250.       translate_parser translate_expr loc env case_list
  251.   in transl
  252.  
  253. and translate_match loc env failure_code casel =
  254.   let transl_action (patlist, expr) =
  255.     let (new_env, add_lets) = add_pat_list_to_env env patlist in
  256.       (patlist, add_lets (translate_expr new_env expr)) in
  257.   translate_matching failure_code loc (map transl_action casel)
  258.  
  259. and translate_simple_match loc env failure_code pat_expr_list =
  260.   let transl_action (pat, expr) =
  261.     let (new_env, add_lets) = add_pat_to_env env pat in
  262.       ([pat], add_lets (translate_expr new_env expr)) in
  263.   translate_matching failure_code loc (map transl_action pat_expr_list)
  264.  
  265. and translate_let env = function
  266.      [] ->  []
  267.   | a::L -> translate_expr env a :: translate_let (Treserved env) L
  268.  
  269. and translate_bind env = function
  270.     [] -> []
  271.   | (pat, expr) :: rest ->
  272.       translate_expr env expr :: translate_bind (Treserved env) rest
  273. ;;
  274.  
  275. (* Translation of toplevel expressions and let bindings *)
  276.  
  277. let translate_expression = translate_expr Tnullenv
  278. ;;
  279.  
  280. let rec make_sequence f = function
  281.     [] -> Lconst(SCatom(ACint 0))
  282.   | [x] -> f x
  283.   | x::rest -> Lsequence(f x, make_sequence f rest)
  284. ;;
  285.  
  286. exception Complicated_definition;;
  287.  
  288. let translate_letdef loc pat_expr_list =
  289.   let modname = (!defined_module).mod_name in
  290.   match pat_expr_list with
  291.     [Pat(Zvarpat i, _), expr] ->         (* The simple case first *)
  292.       Lprim(Pset_global {qual=modname; id=i}, [translate_expression expr])
  293.   | _ ->                                 (* The general case *)
  294.     let pat_list =
  295.       map (fun (p, _) -> p) pat_expr_list in
  296.     let vars =
  297.       flat_map free_vars_of_pat pat_list in
  298.     let env =
  299.       env_for_toplevel_let pat_list in
  300.     let store_global var =
  301.       Lprim(Pset_global {qual=modname; id=var},
  302.             [translate_access var env]) in
  303.     Llet(translate_bind Tnullenv pat_expr_list,
  304.          translate_matching
  305.            (partial_fun loc) loc
  306.            [pat_list, make_sequence store_global vars])
  307. ;;
  308.  
  309. let translate_letdef_rec loc pat_expr_list =
  310.   let modname = (!defined_module).mod_name in
  311.   try                                   (* The simple case first *)
  312.     make_sequence
  313.       (function
  314.           (Pat(Zvarpat i, _), (Expr(Zfunction _,_) as expr)) ->
  315.             Lprim(Pset_global {qual=modname; id=i},
  316.                   [translate_expression expr])
  317.         | _ ->
  318.           raise Complicated_definition)
  319.       pat_expr_list
  320.   with Complicated_definition ->        (* The general case *)
  321.     let make_dummy = function
  322.         (Pat (Zvarpat i, _), expr) ->
  323.           Lprim (Pset_global {qual=modname; id=i},
  324.                  [Lprim(Pdummy(size_of_expr expr), [])])
  325.       | (Pat (pat,loc), _) ->
  326.           illegal_letrec_pat loc in
  327.     let dummies =
  328.       make_sequence make_dummy pat_expr_list in
  329.     let translate_bind = function
  330.         (Pat (Zvarpat i, _), expr) ->
  331.           Lprim(Pupdate, [Lprim(Pget_global {qual=modname;id=i}, []);
  332.                           translate_expression expr])
  333.       | _ ->
  334.           fatal_error "translate_letdef_rec" in
  335.     let updates =
  336.       make_sequence translate_bind pat_expr_list in
  337.     Lsequence(dummies, updates)
  338. ;;
  339.