home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / par_aux.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  2.9 KB  |  106 lines  |  [TEXT/MPS ]
  1. (* Auxiliary functions for parsing *)
  2.  
  3. #open "const";;
  4. #open "misc";;
  5. #open "globals";;
  6. #open "location";;
  7. #open "syntax";;
  8. #open "modules";;
  9. #open "builtins";;
  10. #open "errors";;
  11.  
  12. let make_expr desc = Expr(desc, get_current_location())
  13. and make_pat desc = Pat(desc, get_current_location())
  14. and make_typ desc = Typexp(desc, get_current_location())
  15. and make_impl desc = Impl(desc, get_current_location())
  16. and make_intf desc = Intf(desc, get_current_location())
  17. ;;
  18.  
  19. let make_apply = function
  20.     Expr(Zconstruct0(cstr1), _), [e2] ->
  21.       make_expr(Zconstruct1(cstr1, e2))
  22.   | e1, el ->
  23.       make_expr(Zapply(e1,el))
  24. ;;
  25.  
  26. let make_unop op (Expr(_, Loc(l1,m1)) as e1) =
  27.   let (Loc(l, m) as loc) = get_current_location() in
  28.     Expr(Zapply(Expr(Zident(ref (Zlocal op)), Loc(l, l1)), [e1]), loc)
  29. and make_binop op (Expr(_, Loc(l1,m1)) as e1) (Expr(_, Loc(l2,m2)) as e2) =
  30.   make_expr(Zapply(Expr(Zident(ref (Zlocal op)), Loc(m1, l2)), [e1;e2]))
  31. and make_ternop op (Expr(_, Loc(l1,m1)) as e1) (Expr(_, Loc(l2,m2)) as e2) e3 =
  32.   make_expr(Zapply(Expr(Zident(ref (Zlocal op)), Loc(m1, l2)), [e1;e2;e3]))
  33. ;;
  34.  
  35. let make_list =
  36.   makel (make_expr(Zconstruct0(constr_nil)))
  37.   where rec makel res = function
  38.     [] ->
  39.       res
  40.   | e::l ->
  41.       makel (make_expr(Zconstruct1(constr_cons, make_expr(Ztuple [e;res])))) l
  42. ;;
  43.  
  44. let make_unary_minus = fun
  45.     "-"  (Expr(Zconstant(SCatom(ACint i)), _)) ->
  46.       make_expr(Zconstant(SCatom(ACint(minus i))))
  47.   | "-"  (Expr(Zconstant(SCatom(ACfloat f)), _)) ->
  48.       make_expr(Zconstant(SCatom(ACfloat(minus_float f))))
  49.   | "-"  e ->
  50.       make_unop "minus" e
  51.   | "-." (Expr(Zconstant(SCatom(ACfloat f)), _)) ->
  52.       make_expr(Zconstant(SCatom(ACfloat(minus_float f))))
  53.   | "-." e ->
  54.       make_unop "minus_float" e
  55.   | _ _ ->
  56.       fatal_error "make_unary_minus"
  57. ;;
  58.  
  59. let find_constructor gr =
  60.   try
  61.     find_constr_desc gr
  62.   with Desc_not_found ->
  63.     unbound_err "Constructor" gr (get_current_location())
  64. ;;
  65.  
  66. let find_label gr =
  67.   try
  68.     find_label_desc gr
  69.   with Desc_not_found ->
  70.     unbound_err "Label" gr (get_current_location())
  71. ;;
  72.  
  73. let expr_constr_or_ident = function
  74.     GRname s as gr ->
  75.       begin try
  76.         make_expr(Zconstruct0(find_constr_desc gr))
  77.       with Desc_not_found ->
  78.         make_expr(Zident(ref(Zlocal s)))
  79.       end
  80.   | GRmodname q as gr ->
  81.      try
  82.         make_expr(Zconstruct0(find_constr_desc gr))
  83.       with Desc_not_found ->
  84.         try
  85.           make_expr(Zident(ref(Zglobal(find_value_desc gr))))
  86.         with Desc_not_found ->
  87.           unbound_err "Value" gr (get_current_location())
  88. ;;
  89.  
  90. let pat_constr_or_var s =
  91.   try
  92.     make_pat(Zconstruct0pat(find_constr_desc (GRname s)))
  93.   with Desc_not_found ->
  94.     make_pat(Zvarpat s)
  95. ;;
  96.  
  97. let rec make_range_pat low high =
  98.   if low > high then
  99.     make_range_pat high low
  100.   else if low == high then
  101.     make_pat(Zconstantpat(ACchar(char_of_int low)))
  102.   else
  103.     make_pat(Zorpat(make_pat(Zconstantpat(ACchar(char_of_int low))),
  104.                     make_range_pat (succ low) high))
  105. ;;
  106.