5.12. Compile time exceptions

Start ocaml section to src/flx_exceptions.ml[1 /1 ]
     1: # 4822 "./lpsrc/flx_types.ipk"
     2: 
     3: # 4822 "./lpsrc/flx_types.ipk"
     4: open Flx_ast
     5: # 4822 "./lpsrc/flx_types.ipk"
     6: open Flx_types
     7: # 4822 "./lpsrc/flx_types.ipk"
     8: exception RDP_match_fail of range_srcref * range_srcref * string
     9: # 4822 "./lpsrc/flx_types.ipk"
    10: exception RDP_alternatives_exhausted of range_srcref * string
    11: # 4822 "./lpsrc/flx_types.ipk"
    12: exception SyntaxError of string
    13: # 4822 "./lpsrc/flx_types.ipk"
    14: exception ParseError of string
    15: # 4822 "./lpsrc/flx_types.ipk"
    16: exception LexError of string
    17: # 4822 "./lpsrc/flx_types.ipk"
    18: exception TokenError of string
    19: # 4822 "./lpsrc/flx_types.ipk"
    20: exception ClientErrorn of range_srcref list * string
    21: # 4822 "./lpsrc/flx_types.ipk"
    22: exception ClientError of range_srcref * string
    23: # 4822 "./lpsrc/flx_types.ipk"
    24: exception ClientError2 of range_srcref * range_srcref * string
    25: # 4822 "./lpsrc/flx_types.ipk"
    26: exception SystemError of range_srcref * string
    27: # 4822 "./lpsrc/flx_types.ipk"
    28: exception Exit of int
    29: # 4822 "./lpsrc/flx_types.ipk"
    30: exception Bad_recursion
    31: # 4822 "./lpsrc/flx_types.ipk"
    32: exception Expr_recursion of expr_t
    33: # 4822 "./lpsrc/flx_types.ipk"
    34: exception Free_fixpoint of btypecode_t
    35: # 4822 "./lpsrc/flx_types.ipk"
    36: exception Unresolved_return of range_srcref * string
    37: # 4822 "./lpsrc/flx_types.ipk"
    38: 
    39: let clierrn srs s = raise (ClientErrorn (srs,s))
    40: let clierr2 sr sr2 s = raise (ClientError2 (sr,sr2,s))
    41: let clierr sr s = raise (ClientError (sr,s))
    42: let syserr sr s = raise (SystemError (sr,s))
    43: let catch s f = try f() with _ -> failwith s
    44: let rdp_match_fail sr1 sr2 s = raise (RDP_match_fail (sr1,sr2,s))
    45: let rdp_alternatives_exhausted sr s = raise (RDP_alternatives_exhausted (sr,s))
    46: 
End ocaml section to src/flx_exceptions.ml[1]
Start ocaml section to src/flx_exceptions.mli[1 /1 ]
     1: # 4833 "./lpsrc/flx_types.ipk"
     2: 
     3: # 4833 "./lpsrc/flx_types.ipk"
     4: open Flx_ast
     5: # 4833 "./lpsrc/flx_types.ipk"
     6: open Flx_types
     7: # 4833 "./lpsrc/flx_types.ipk"
     8: exception RDP_match_fail of range_srcref * range_srcref * string
     9: # 4833 "./lpsrc/flx_types.ipk"
    10: exception RDP_alternatives_exhausted of range_srcref * string
    11: # 4833 "./lpsrc/flx_types.ipk"
    12: exception SyntaxError of string
    13: # 4833 "./lpsrc/flx_types.ipk"
    14: exception ParseError of string
    15: # 4833 "./lpsrc/flx_types.ipk"
    16: exception LexError of string
    17: # 4833 "./lpsrc/flx_types.ipk"
    18: exception TokenError of string
    19: # 4833 "./lpsrc/flx_types.ipk"
    20: exception ClientErrorn of range_srcref list * string
    21: # 4833 "./lpsrc/flx_types.ipk"
    22: exception ClientError of range_srcref * string
    23: # 4833 "./lpsrc/flx_types.ipk"
    24: exception ClientError2 of range_srcref * range_srcref * string
    25: # 4833 "./lpsrc/flx_types.ipk"
    26: exception SystemError of range_srcref * string
    27: # 4833 "./lpsrc/flx_types.ipk"
    28: exception Exit of int
    29: # 4833 "./lpsrc/flx_types.ipk"
    30: exception Bad_recursion
    31: # 4833 "./lpsrc/flx_types.ipk"
    32: exception Expr_recursion of expr_t
    33: # 4833 "./lpsrc/flx_types.ipk"
    34: exception Free_fixpoint of btypecode_t
    35: # 4833 "./lpsrc/flx_types.ipk"
    36: exception Unresolved_return of range_srcref * string
    37: # 4833 "./lpsrc/flx_types.ipk"
    38: 
    39: val clierrn: range_srcref list -> string -> 'a
    40: val clierr: range_srcref -> string -> 'a
    41: val clierr2: range_srcref -> range_srcref -> string -> 'a
    42: val syserr: range_srcref -> string -> 'a
    43: val catch: string -> (unit -> 'a) -> 'a
    44: val rdp_match_fail: range_srcref -> range_srcref -> string -> 'a
    45: val rdp_alternatives_exhausted: range_srcref -> string -> 'a
    46: 
End ocaml section to src/flx_exceptions.mli[1]
Start ocaml section to src/flx_typing.mli[1 /1 ]
     1: # 4844 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: exception UnificationError of btypecode_t * btypecode_t
     5: val flx_bool : typecode_t
     6: val flx_bbool : btypecode_t
     7: 
     8: val is_unitsum: btypecode_t -> bool
     9: val int_of_unitsum : btypecode_t -> int
    10: val all_units0 : b0typecode_t list -> bool
    11: val all_units : btypecode_t list -> bool
    12: val all_voids : btypecode_t list -> bool
    13: 
    14: val cmp_literal: literal_t -> literal_t -> bool
    15: val cmp_tbexpr: tbexpr_t -> tbexpr_t -> bool
    16: 
    17: val type_of_argtypes :
    18:   typecode_t list ->
    19:   typecode_t
    20: 
    21: val funparamtype : 'a * 'b -> 'b
    22: 
    23: val typeoflist:
    24:   btypecode_t list ->
    25:   btypecode_t
    26: 
    27: val lift:
    28:   btypecode_t -> btypecode_t
    29: 
    30: val lower:
    31:   btypecode_t -> btypecode_t
    32: 
    33: val qualified_name_of_expr:
    34:   expr_t -> qualified_name_t
    35: 
    36: module FuntypeSet : Set.S with type elt = typecode_t
    37: 
    38: module FunInstSet : Set.S with type elt = bid_t * btypecode_t list
    39: 
End ocaml section to src/flx_typing.mli[1]
Start ocaml section to src/flx_typing.ml[1 /1 ]
     1: # 4884 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_srcref
     5: open List
     6: open Flx_maps
     7: 
     8: let all_voids ls =
     9:     fold_left
    10:     (fun acc t -> acc && (t = `BTYP_void))
    11:     true ls
    12: 
    13: let all_units0 ls =
    14:     fold_left
    15:     (fun acc t -> acc && (t = `BTYP_tuple []))
    16:     true ls
    17: 
    18: let all_units ls = all_units0 ls
    19: 
    20: let is_unitsum (t:btypecode_t) = match t with
    21:   | `BTYP_unitsum _ -> true
    22:   | `BTYP_sum ls ->  all_units ls
    23:   | _ -> false
    24: 
    25: 
    26: let int_of_unitsum t = match t with
    27:   | `BTYP_tuple [] -> 1
    28:   | `BTYP_unitsum k -> k
    29:   | `BTYP_sum ls ->
    30:     if all_units ls then length ls
    31:     else raise Not_found
    32: 
    33:   | _ -> raise Not_found
    34: 
    35: exception UnificationError of btypecode_t * btypecode_t
    36: 
    37: (* unbound type *)
    38: let type_of_argtypes ls = match ls with
    39:  | [x] -> x
    40:  | _ -> `TYP_tuple ls
    41: 
    42: let funparamtype x = snd x
    43: 
    44: module FuntypeSet = Set.Make(
    45:   struct type t=typecode_t let compare = compare end
    46: )
    47: 
    48: module FunInstSet = Set.Make(
    49:   struct
    50:     type t= bid_t * btypecode_t list
    51:     let compare = compare
    52:   end
    53: )
    54: 
    55: (* bound type! *)
    56: let typeoflist typlist = match typlist with
    57:   | [] -> `BTYP_tuple []
    58:   | [t] -> t
    59:   | h :: t ->
    60:     try
    61:       iter
    62:       (fun t -> if t <> h then raise Not_found)
    63:       t;
    64:       `BTYP_array (h,`BTYP_unitsum (length typlist))
    65:     with Not_found ->
    66:       `BTYP_tuple typlist
    67: 
    68: let lift t = t
    69: let lower t = t (* CHANGE THIS WHEN ABSTRACT TYPES IMPLEMENTED *)
    70: 
    71: let flx_bool = `TYP_unitsum 2
    72: let flx_bbool = `BTYP_unitsum 2
    73: 
    74: let qualified_name_of_expr e =
    75:   match e with
    76:   | #qualified_name_t as x -> x
    77:   | _ ->
    78:     failwith
    79:     (
    80:       "Qualified name expected in\n" ^
    81:       short_string_of_src (src_of_expr e)
    82:     )
    83: 
    84: (* Note floats are equal iff they're textually identical,
    85:    we don't make any assumptions about the target machine FP model.
    86:    OTOH, int comparisons are infinite precision, for the same
    87:    int kind, even if the underlying machine model is not
    88: *)
    89: 
    90: let cmp_literal (l:literal_t) (l':literal_t) = match l, l' with
    91:   | `AST_int (a,b), `AST_int (a',b') -> a = a' && Big_int.eq_big_int b b'
    92:   | `AST_float (a,b), `AST_float (a',b') -> a = a' && b = b'
    93:   | `AST_string s, `AST_string s' -> s = s'
    94:   | `AST_cstring s, `AST_cstring s' -> s = s'
    95:   | `AST_wstring s, `AST_wstring s' -> s = s'
    96:   | `AST_ustring s, `AST_ustring s' -> s = s'
    97:   | _ -> false
    98: 
    99: (* Note that we don't bother comparing the type subterm:
   100:   this had better be equal for equal expressions: the value
   101:   is merely the cached result of a synthetic context
   102:   independent type calculation
   103: *)
   104: 
   105: let rec cmp_tbexpr (a,_) (b,_) =
   106:   let ecmp = cmp_tbexpr in match a,b with
   107:   | `BEXPR_parse (e,ii), `BEXPR_parse (e',ii') ->
   108:     ecmp e e' && ii = ii'
   109: 
   110:   | `BEXPR_coerce (e,t),`BEXPR_coerce (e',t') ->
   111:     (* not really right .. *)
   112:     ecmp e e'
   113: 
   114:   | `BEXPR_record ts,`BEXPR_record ts' ->
   115:     length ts = length ts' &&
   116:     let rcmp (s,t) (s',t') = compare s s' in
   117:     let ts = sort rcmp ts in
   118:     let ts' = sort rcmp ts' in
   119:     map fst ts = map fst ts' &&
   120:     fold_left2 (fun r a b -> r && a = b) true (map snd ts) (map snd ts')
   121: 
   122:   | `BEXPR_variant (s,e),`BEXPR_variant (s',e') ->
   123:     s = s' && ecmp e e'
   124: 
   125:   | `BEXPR_deref e,`BEXPR_deref e' -> ecmp e e'
   126: 
   127:   | `BEXPR_name (i,ts),`BEXPR_name (i',ts')
   128:   | `BEXPR_ref (i,ts),`BEXPR_ref (i',ts')
   129:   | `BEXPR_closure (i,ts),`BEXPR_closure (i',ts') ->
   130:      i = i' &&
   131:      fold_left2 (fun r a b -> r && a = b) true ts ts'
   132: 
   133:   | `BEXPR_method_closure (e,i,ts),`BEXPR_method_closure (e',i',ts') ->
   134:      ecmp e e' &&
   135:      i = i' &&
   136:      fold_left2 (fun r a b -> r && a = b) true ts ts'
   137: 
   138:   | `BEXPR_literal a,`BEXPR_literal a' -> cmp_literal a a'
   139: 
   140:   | `BEXPR_apply (a,b),`BEXPR_apply (a',b') ->  ecmp a a' && ecmp b b'
   141: 
   142:   | `BEXPR_apply_prim (i,ts,b),`BEXPR_apply_prim (i',ts',b')
   143:   | `BEXPR_apply_direct (i,ts,b),`BEXPR_apply_direct (i',ts',b')
   144:   | `BEXPR_apply_struct (i,ts,b),`BEXPR_apply_struct (i',ts',b')
   145:   | `BEXPR_apply_stack (i,ts,b),`BEXPR_apply_stack (i',ts',b') ->
   146:      i = i' &&
   147:      fold_left2 (fun r a b -> r && a = b) true ts ts' &&
   148:      ecmp b b'
   149: 
   150:   | `BEXPR_apply_method_direct (e,i,ts,b),`BEXPR_apply_method_direct (e',i',ts',b') ->
   151:      ecmp e e' &&
   152:      i = i' &&
   153:      fold_left2 (fun r a b -> r && a = b) true ts ts' &&
   154:      ecmp b b'
   155: 
   156:   | `BEXPR_apply_method_stack (e,i,ts,b),`BEXPR_apply_method_stack (e',i',ts',b') ->
   157:      ecmp e e' &&
   158:      i = i' &&
   159:      fold_left2 (fun r a b -> r && a = b) true ts ts' &&
   160:      ecmp b b'
   161: 
   162:   | `BEXPR_tuple ls,`BEXPR_tuple ls' ->
   163:      fold_left2 (fun r a b -> r && ecmp a b) true ls ls'
   164: 
   165:   | `BEXPR_case_arg (i,e),`BEXPR_case_arg (i',e')
   166: 
   167:   | `BEXPR_match_case (i,e),`BEXPR_match_case (i',e')
   168:   | `BEXPR_get_n (i,e),`BEXPR_get_n (i',e') ->
   169:     i = i' && ecmp e e'
   170: 
   171:   (* this is probably wrong: says x.y = x'.y' iff x = x && y = y',
   172:   however, x.y should unify with a simple value .. oh well..
   173:   hmm .. this should REALLY be a pointer to member, that is,
   174:   an actual projection function
   175:   *)
   176:   | `BEXPR_get_named (i,e),`BEXPR_get_named (i',e') ->
   177:     i = i' && ecmp e e'
   178: 
   179:   | `BEXPR_case_index e,`BEXPR_case_index e' -> ecmp e e'
   180: 
   181:   | `BEXPR_case (i,t),`BEXPR_case (i',t') -> i = i' && t = t'
   182:   | `BEXPR_expr (s,t),`BEXPR_expr (s',t') -> s = s' && t = t'
   183:   | `BEXPR_range_check (e1,e2,e3), `BEXPR_range_check (e1',e2',e3') ->
   184:     ecmp e1 e1' && ecmp e2 e2' && ecmp e3 e3'
   185: 
   186:   | _ -> false
   187: 
   188: 
End ocaml section to src/flx_typing.ml[1]
Start ocaml section to src/flx_typing2.mli[1 /1 ]
     1: # 5073 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: val typecode_of_expr:
     4:   expr_t -> typecode_t
     5: 
     6: val typeof_list:
     7:   typecode_t list -> typecode_t
     8: 
     9: val paramtype:
    10:   (string * typecode_t) list -> typecode_t
    11: 
    12: 
End ocaml section to src/flx_typing2.mli[1]
Start ocaml section to src/flx_typing2.ml[1 /1 ]
     1: # 5086 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_print
     5: open Flx_srcref
     6: open Flx_exceptions
     7: open List
     8: 
     9: let typeof_list = function
    10:   | [x] -> x
    11:   | x -> `TYP_tuple x
    12: 
    13: let paramtype params =
    14:   let typlist params = map snd params in
    15:   typeof_list (typlist params)
    16: 
    17: let all_tunits ts =
    18:   try
    19:     iter
    20:     (fun t ->
    21:       if t <> `TYP_tuple []
    22:       then raise Not_found
    23:     )
    24:     ts;
    25:     true
    26:   with Not_found -> false
    27: 
    28: let rec typecode_of_expr (e:expr_t) :typecode_t =
    29:   let te e = typecode_of_expr e in
    30:   match e with
    31:   | `AST_name (_,"TYPE",[]) -> `TYP_type
    32:   | `AST_ellipsis _ -> `TYP_ellipsis
    33:   | #suffixed_name_t as x -> (x:>typecode_t)
    34:   | `AST_tuple (sr,ls) ->
    35:     `TYP_type_tuple (map te ls)
    36:   | `AST_record_type (sr,es) -> `TYP_record es
    37:   | `AST_variant_type (sr,es) -> `TYP_variant es
    38: 
    39:   | `AST_product (_,ts) -> `TYP_tuple (map te ts)
    40:   | `AST_setintersection (_,ts) -> `TYP_setintersection (map te ts)
    41:   | `AST_setunion (_,ts) -> `TYP_setunion (map te ts)
    42:   | `AST_arrow (_,(a,b)) -> `TYP_function (te a, te b)
    43:   | `AST_longarrow (_,(a,b)) -> `TYP_cfunction (te a, te b)
    44:   | `AST_superscript (_,(a,b)) -> `TYP_array (te a, te b)
    45:   | `AST_lvalue (sr,e) -> `TYP_lvalue (te e)
    46:   | `AST_ref (sr,e) -> `TYP_pointer (te e)
    47:   | `AST_sum (_,ts) ->
    48:     let ts = map te ts in
    49:     if all_tunits ts then
    50:       `TYP_unitsum (length ts)
    51:     else
    52:       `TYP_sum ts
    53: 
    54:   | `AST_orlist (sr,ts) ->
    55:     begin match ts with
    56:     | [] -> assert false
    57:     | [x] -> assert false
    58:     | h :: t ->
    59:       let llor = `AST_name (sr,"lor",[]) in
    60:       fold_left (fun sum t -> `TYP_apply (llor,`TYP_type_tuple[sum; te t])) (te h) t
    61:     end
    62: 
    63:   | `AST_andlist (sr,ts) ->
    64:     begin match ts with
    65:     | [] -> assert false
    66:     | [x] -> assert false
    67:     | h :: t ->
    68:       let lland = `AST_name (sr,"land",[]) in
    69:       fold_left (fun sum t -> `TYP_apply (lland,`TYP_type_tuple [sum; te t])) (te h) t
    70:     end
    71: 
    72:   | `AST_typeof (_,e) -> `TYP_typeof e
    73:   | `AST_as (sr,(t,x)) -> `TYP_as (te t,x)
    74: 
    75:   | `AST_literal (sr,`AST_int (enc,v)) ->
    76:     if enc <> "int"
    77:     then
    78:       clierr sr
    79:       (
    80:         "Only plain integer can be used as a type, code= '" ^
    81:         enc ^
    82:         "'"
    83:       )
    84:     else
    85:     let v = ref
    86:       begin try Big_int.int_of_big_int v
    87:       with _ -> clierr sr "Integer used as type out of range"
    88:       end
    89:     in
    90:       if !v <0 then clierr sr "Negative int not allowed as type"
    91:       else if !v = 0 then ((`AST_void sr) :> typecode_t)
    92:       else if !v = 1 then `TYP_tuple[]
    93:       else `TYP_unitsum !v
    94: 
    95:   (* NOTE SPECIAL NAME HANDLING HACKS!! *)
    96:   | `AST_apply(sr,(e1,e2)) ->
    97:     begin match e1 with
    98:     | `AST_name (_,name,[]) ->
    99:       let name' = name ^ "          " (* 10 chars *) in
   100:       if name = "typeof" then `TYP_typeof e2
   101:       else let arg = typecode_of_expr e2 in
   102:       if name = "_isin" then
   103:       begin
   104:         match arg with
   105:         | `TYP_type_tuple [memt; sett] ->
   106:            `TYP_isin (memt, sett)
   107:         | _ ->
   108:           (* this can be fixed by taking projections but I can't be bothered atm *)
   109:           failwith
   110:            "Implementation limitation, 'isin' operator requires two explicit arguments"
   111:       end
   112:       else if name = "typesetof" then
   113:       begin
   114:         match arg with
   115:         | `TYP_type_tuple ls -> `TYP_typeset ls
   116:         | x -> `TYP_typeset [x]
   117:       end
   118:       else if name = "compl" then `TYP_dual arg
   119:       else if String.sub name' 0 5 = "proj_"
   120:       then
   121:         begin
   122:           let acc = ref 0 in
   123:           for i = 5 to String.length name - 1 do
   124:           if name.[i] <= '9' && name.[i] >='0'
   125:           then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
   126:           else
   127:             clierr sr
   128:             (
   129:               "Digits expected in name '" ^ name ^ "' in\n" ^
   130:               short_string_of_src sr
   131:             )
   132:           done;
   133:           `TYP_proj (!acc, arg)
   134:          end
   135: 
   136:       else if String.sub name' 0 9 = "case_arg_"
   137:       then
   138:         begin
   139:           let acc = ref 0 in
   140:           for i = 9 to String.length name - 1 do
   141:           if name.[i] <= '9' && name.[i] >='0'
   142:           then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
   143:           else
   144:             clierr sr
   145:             (
   146:               "Digits expected in name '" ^ name ^ "' in\n" ^
   147:               short_string_of_src sr
   148:             )
   149:           done;
   150:           `TYP_case_arg (!acc, arg)
   151:          end
   152:       else
   153:         `TYP_apply (typecode_of_expr e1,arg)
   154: 
   155:     | _ ->
   156:       `TYP_apply (typecode_of_expr e1,typecode_of_expr e2)
   157:     end
   158: 
   159:   | `AST_lambda (sr,(paramss,ret,body)) ->
   160:      begin match paramss with
   161:      | [params,traint] ->
   162:        (* constraint is ignored for now!! *)
   163:        begin match body with
   164:        | [`AST_fun_return (_,e)] ->
   165:          begin
   166:            try
   167:              let t = typecode_of_expr e in
   168:              match paramss,ret with
   169:              (* special case, allows {t} to mean 1 -> t *)
   170:              | [[],None],`TYP_none ->
   171:               `TYP_function (`TYP_tuple [],t)
   172:              | _ ->
   173:              `TYP_typefun
   174:              (
   175:                params,
   176:                ret,
   177:                t
   178:              )
   179:            with _ ->
   180:              clierr sr
   181:              "Type lambda must return type expression"
   182:          end
   183: 
   184:        | _ ->
   185:          clierr sr
   186:          "Type lambda must just be 'return type_expr'"
   187:        end
   188:      | _ ->
   189:        clierr sr
   190:        "Type lambda only allowed one argument (arity=1)"
   191:      end
   192: 
   193:   | `AST_type_match (sr,(e,ps)) ->
   194:     `TYP_type_match (e,ps)
   195: 
   196:   | `AST_noexpand (sr,e) -> te e
   197: 
   198:   | #expr_t ->
   199:     let sr = src_of_expr e in
   200:     clierr sr ("Type expression expected, got " ^ string_of_expr e)
   201: 
End ocaml section to src/flx_typing2.ml[1]