5.42. Downgrade Abstract types

Convert newtype abstractions to their representations.
Start ocaml section to src/flx_strabs.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_strabs.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: 
     7: val strabs:
     8:   sym_state_t ->
     9:   fully_bound_symbol_table_t ->
    10:   fully_bound_symbol_table_t
    11: 
End ocaml section to src/flx_strabs.mli[1]
Start ocaml section to src/flx_strabs.ml[1 /1 ]
     1: # 18 "./lpsrc/flx_strabs.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_mtypes1
     7: open Flx_mtypes2
     8: open Flx_typing
     9: open Flx_mbind
    10: open Flx_srcref
    11: open List
    12: open Flx_unify
    13: open Flx_treg
    14: open Flx_generic
    15: open Flx_maps
    16: open Flx_exceptions
    17: 
    18: let check_inst bbdfns i ts =
    19:   let id,_,_,entry = Hashtbl.find bbdfns i in
    20:   match entry with
    21:   | `BBDCL_newtype (vs,t) -> tsubst vs ts t
    22:   | _ -> `BTYP_inst (i,ts)
    23: 
    24: let fixtype bbdfns t =
    25:   let chk i ts = check_inst bbdfns i ts in
    26:   let rec aux t = match map_btype aux t with
    27:   | `BTYP_inst (i,ts) ->
    28:     let ts = map aux ts in
    29:     chk i ts
    30:   | x -> x
    31:   in aux t
    32: 
    33: let id x = x
    34: 
    35: let isident bbdfns i = match Hashtbl.find bbdfns i with
    36:   | _,_,_,`BBDCL_fun (_,_,_,_,`Identity,_,_) -> true
    37:   | _ -> false
    38: 
    39: let fixexpr bbdfns e : tbexpr_t =
    40:   let rec aux e =
    41:     match map_tbexpr id aux (fixtype bbdfns) e with
    42:     | `BEXPR_apply ( (`BEXPR_closure(i,_),_),a),_
    43:     | `BEXPR_apply_direct (i,_,a),_
    44:     | `BEXPR_apply_prim (i,_,a),_
    45:       when isident bbdfns i -> a
    46:     | x -> x
    47:   in aux e
    48: 
    49: let fixbexe bbdfns x =
    50:   map_bexe id (fixexpr bbdfns) (fixtype bbdfns) id id x
    51: 
    52: let fixbexes bbdfns bexes = map (fixbexe bbdfns) bexes
    53: 
    54: let fixps bbdfns (ps,traint) =
    55:   map
    56:   (fun {pkind=i;pid=s; pindex=j; ptyp=t} ->
    57:     {pkind=i; pid=s; pindex=j; ptyp=fixtype bbdfns t}
    58:   )
    59:   ps,
    60:   (
    61:   match traint with
    62:   | None -> None
    63:   | Some t -> Some (fixexpr bbdfns t)
    64:   )
    65: 
    66: let fixupmember bbdfns mem =
    67:   let ft t = fixtype bbdfns t in
    68:   match mem with
    69:   | `BMemberVal (id,t) -> `BMemberVal (id, ft t)
    70:   | `BMemberVar (id,t) -> `BMemberVar (id, ft t)
    71:   | `BMemberFun (id,vs,t) -> `BMemberFun (id, vs, ft t)
    72:   | `BMemberProc (id,vs,t) -> `BMemberProc (id, vs, ft t)
    73:   | `BMemberCtor (id,t) -> `BMemberCtor (id, ft t)
    74: 
    75: let strabs syms (bbdfns: fully_bound_symbol_table_t) =
    76:   let ft t = fixtype bbdfns t in
    77:   let fts ts = map (fixtype bbdfns) ts in
    78:   let fe e = fixexpr bbdfns e in
    79:   let fxs xs = fixbexes bbdfns xs in
    80:   let fp bps = fixps bbdfns bps in
    81:   let fkm m = fixupmember bbdfns m in
    82:   let fkms ms = map (fixupmember bbdfns) ms in
    83: 
    84:   let nutab = Hashtbl.create 97 in
    85:   Hashtbl.iter
    86:   (fun i (id,parent,sr,entry) ->
    87:      let h x = Hashtbl.add nutab i (id,parent,sr,x) in
    88:      match entry with
    89:   | `BBDCL_function ( props, bvs, bps, ret, bexes) ->
    90:     h (`BBDCL_function ( props, bvs, fp bps, ft ret, fxs bexes) )
    91: 
    92:   | `BBDCL_procedure (  props, bvs, bps, bexes) ->
    93:     h (`BBDCL_procedure (  props, bvs, fp bps, fxs bexes) )
    94: 
    95:   | `BBDCL_val (  bvs, t) ->
    96:     h (`BBDCL_val (  bvs, ft t) )
    97: 
    98:   | `BBDCL_var (  bvs, t) ->
    99:     h (`BBDCL_var (  bvs, ft t) )
   100: 
   101:   | `BBDCL_ref (  bvs, t) ->
   102:     h (`BBDCL_ref (  bvs, ft t) )
   103: 
   104:   | `BBDCL_tmp (  bvs, t) ->
   105:     h (`BBDCL_tmp (  bvs, ft t) )
   106: 
   107:   | `BBDCL_glr (  props, bvs, t, (bprod, bexes)) ->
   108:     let bexes = fxs bexes in
   109:     h (`BBDCL_glr (  props, bvs, ft t, (bprod, bexes)) )
   110: 
   111:   | `BBDCL_regmatch ( props, bvs, bps , t, regular_args) ->
   112:     let alpha,cnt, sem, tr = regular_args in
   113:     let nusem = Hashtbl.create 97 in
   114:     Hashtbl.iter
   115:     (fun k e -> Hashtbl.add nusem k (fe e))
   116:     sem
   117:     ;
   118:     let regular_args = alpha,cnt,nusem,tr in
   119:     h (`BBDCL_regmatch ( props, bvs, fp bps, ft t, regular_args) )
   120: 
   121:   | `BBDCL_reglex ( props, bvs, bps, j, t, regular_args) ->
   122:     let alpha,cnt, sem, tr = regular_args in
   123:     let nusem = Hashtbl.create 97 in
   124:     Hashtbl.iter
   125:     (fun k e -> Hashtbl.add nusem k (fe e))
   126:     sem
   127:     ;
   128:     let regular_args = alpha,cnt,nusem,tr in
   129:     h (`BBDCL_reglex ( props, bvs, fp bps, j, ft t, regular_args) )
   130: 
   131:   | `BBDCL_newtype (  bvs, t) -> ()
   132: 
   133:   | `BBDCL_abs (  bvs, btqs, c, breqs) ->
   134:     h (`BBDCL_abs (  bvs, btqs, c, breqs) )
   135: 
   136:   | `BBDCL_const (  bvs, t, c, breqs) ->
   137:     h (`BBDCL_const (  bvs, ft t, c, breqs) )
   138: 
   139:   | `BBDCL_fun (  props, bvs, ts, t, c, breqs, prec) ->
   140:     if c = `Identity then () else
   141:     h (`BBDCL_fun (  props, bvs, fts ts, ft t, c, breqs, prec) )
   142: 
   143:   | `BBDCL_callback ( props, bvs, ts1, ts2, j, t, breqs, prec) ->
   144:     h (`BBDCL_callback ( props, bvs, fts ts1, fts ts2, j, ft t, breqs, prec) )
   145: 
   146:   | `BBDCL_proc ( props, bvs, ts, c, breqs) ->
   147:     h (`BBDCL_proc ( props, bvs, fts ts, c, breqs) )
   148: 
   149:   | `BBDCL_insert ( bvs, c, ikind, breqs) ->
   150:     h (`BBDCL_insert ( bvs, c, ikind, breqs) )
   151: 
   152:   | `BBDCL_union (  bvs, cts) ->
   153:     let cts = map (fun (s,j,t) -> s,j,ft t) cts in
   154:     h (`BBDCL_union (  bvs, cts) )
   155: 
   156:   | `BBDCL_struct ( bvs, cts) ->
   157:     let cts = map (fun (s,t) -> s,ft t) cts in
   158:     h (`BBDCL_struct ( bvs, cts) )
   159: 
   160:   | `BBDCL_cstruct (  bvs, cts) ->
   161:     let cts = map (fun (s,t) -> s,ft t) cts in
   162:     h (`BBDCL_cstruct (  bvs, cts) )
   163: 
   164:   | `BBDCL_cclass ( bvs, bclass_members) ->
   165:     h (`BBDCL_cclass ( bvs, fkms bclass_members) )
   166: 
   167:   | `BBDCL_class (  props, bvs) ->
   168:     h (`BBDCL_class (  props, bvs) )
   169: 
   170:   | `BBDCL_typeclass (  props, bvs) ->
   171:     h (`BBDCL_typeclass (  props, bvs) )
   172: 
   173:   | `BBDCL_instance ( props, bvs, t, j, ts) ->
   174:     h (`BBDCL_instance ( props, bvs, ft t, j, fts ts) )
   175: 
   176:   | `BBDCL_nonconst_ctor ( bvs, j, t1, k,t2, evs, etraint) ->
   177:     h (`BBDCL_nonconst_ctor ( bvs, j, ft t1, k, ft t2, evs, ft etraint) )
   178:   )
   179:   bbdfns
   180:   ;
   181:   nutab
End ocaml section to src/flx_strabs.ml[1]