5.39. Name Binding

Name binding pass 2.
Start ocaml section to src/flx_mbind.mli[1 /1 ]
     1: # 6 "./lpsrc/flx_mbind.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: 
     5: type extract_t =
     6:   | Proj_n of range_srcref * int             (* tuple projections 1 .. n *)
     7:   | Udtor of range_srcref * qualified_name_t (* argument of union component s *)
     8:   | Proj_s of range_srcref * string          (* record projection name *)
     9: 
    10: val gen_match_check:
    11:   pattern_t ->
    12:   expr_t ->
    13:   expr_t
    14: 
    15: val get_pattern_vars:
    16:   (string, range_srcref * extract_t list) Hashtbl.t ->
    17:                               (* Hashtable of variable -> extractor *)
    18:   pattern_t ->      (* pattern *)
    19:   extract_t list -> (* extractor for this pattern *)
    20:   unit
    21: 
    22: val gen_extractor:
    23:   extract_t list ->
    24:   expr_t ->
    25:   expr_t
    26: 
End ocaml section to src/flx_mbind.mli[1]
Start ocaml section to src/flx_mbind.ml[1 /1 ]
     1: # 33 "./lpsrc/flx_mbind.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_print
     6: open Flx_typing
     7: open Flx_lookup
     8: open Flx_srcref
     9: open Flx_typing
    10: open Flx_exceptions
    11: open List
    12: 
    13: type extract_t =
    14:   | Proj_n of range_srcref * int             (* tuple projections 1 .. n *)
    15:   | Udtor of range_srcref * qualified_name_t (* argument of union component s *)
    16:   | Proj_s of range_srcref * string          (* record projection name *)
    17: 
    18: (* the extractor is a function to be applied to
    19:    the argument to extract the value of the identifier;
    20:    it is represented here as a list of functions
    21:    to be applied, with the function at the top
    22:    of the list to be applied last.
    23: 
    24:    Note that the difference between an abstract
    25:    extractor and a concrete one is that the
    26:    abstract one isn't applied to anything,
    27:    while the concrete one is applied to a specific
    28:    expression.
    29: *)
    30: 
    31: let gen_extractor
    32:   (extractor : extract_t list)
    33:   (mv : expr_t)
    34: : expr_t =
    35:   List.fold_right
    36:   (fun x marg -> match x with
    37:     | Proj_n (sr,n) -> `AST_get_n (sr,(n,marg))
    38:     | Udtor (sr,qn) -> `AST_ctor_arg (sr,(qn,marg))
    39:     | Proj_s (sr,s) -> `AST_get_named_variable (sr,(s,marg))
    40:   )
    41:   extractor
    42:   mv
    43: 
    44: (* this routine is used to substitute match variables
    45:    in a when expression with their bindings ..
    46:    it needs to be completed!!!
    47: *)
    48: let rec subst vars (e:expr_t) mv : expr_t =
    49:   let subst e = subst vars e mv in
    50:   (* FIXME: most of these cases are legal, the when clause should
    51:      be made into a function call to an arbitrary function, passing
    52:      the match variables as arguments.
    53: 
    54:      We can do this now, since we have type extractors matching
    55:      the structure extractors Proj_n and Udtor (ie, we can
    56:      name the types of the arguments now)
    57:   *)
    58:   match e with
    59:   | `AST_patvar _
    60:   | `AST_patany _
    61:   | `AST_case _
    62:   | `AST_vsprintf _
    63:   | `AST_interpolate _
    64:   | `AST_type_match _
    65:   | `AST_noexpand _
    66:   | `AST_letin _
    67:   | `AST_cond _
    68:   | `AST_expr _
    69:   | `AST_typeof _
    70:   | `AST_product _
    71:   | `AST_void _
    72:   | `AST_sum _
    73:   | `AST_andlist _
    74:   | `AST_orlist _
    75:   | `AST_typed_case _
    76:   | `AST_case_arg _
    77:   | `AST_arrow _
    78:   | `AST_longarrow _
    79:   | `AST_superscript _
    80:   | `AST_match _
    81:   | `AST_regmatch _
    82:   | `AST_string_regmatch _
    83:   | `AST_reglex _
    84:   | `AST_ellipsis _
    85:   | `AST_parse _
    86:   | `AST_sparse _
    87:   | `AST_setunion _
    88:   | `AST_setintersection _
    89:   | `AST_macro_ctor _
    90:   | `AST_macro_statements  _
    91:   | `AST_callback _
    92:   | `AST_record_type _
    93:   | `AST_variant_type _
    94:   | `AST_lift  _
    95:     ->
    96:       let sr = src_of_expr e in
    97:       clierr sr "[mbind:subst] Not expected in when part of pattern"
    98: 
    99:   | `AST_case_index _ -> e
   100:   | `AST_index _  -> e
   101:   | `AST_the _  -> e
   102:   | `AST_lookup _ -> e
   103:   | `AST_suffix _ -> e
   104:   | `AST_literal _ -> e
   105:   | `AST_case_tag _ -> e
   106:   | `AST_as _ -> e
   107: 
   108:   | `AST_name (sr,name,idx) ->
   109:     if idx = [] then
   110:     if Hashtbl.mem vars name
   111:     then
   112:       let sr,extractor = Hashtbl.find vars name in
   113:       gen_extractor extractor mv
   114:     else e
   115:     else failwith "Can't use indexed name in when clause :("
   116: 
   117: 
   118: 
   119:   | `AST_deref (sr,e') -> `AST_deref (sr,subst e')
   120:   | `AST_ref (sr,e') -> `AST_ref (sr,subst e')
   121:   | `AST_new (sr,e') -> `AST_new (sr,subst e')
   122:   | `AST_lvalue (sr,e') -> `AST_lvalue (sr,subst e')
   123:   | `AST_apply (sr,(f,e)) -> `AST_apply (sr,(subst f,subst e))
   124:   | `AST_map (sr,f,e) -> `AST_map (sr,subst f,subst e)
   125:   | `AST_tuple (sr,es) -> `AST_tuple (sr,map subst es)
   126:   | `AST_record (sr,es) -> `AST_record (sr,map (fun (s,e)->s,subst e) es)
   127:   | `AST_variant (sr,(s,e)) -> `AST_variant (sr,(s,subst e))
   128:   | `AST_arrayof (sr,es) -> `AST_arrayof (sr,map subst es)
   129: 
   130: 
   131:   (* Only one of these should occur, but I can't
   132:      figure out which one at the moment
   133:   *)
   134:   | `AST_method_apply (sr,(id,e,ts)) ->
   135:     `AST_method_apply (sr,(id, subst e,ts))
   136: 
   137:   (*
   138:   | `AST_dot (sr,(e,id,ts)) ->
   139:     `AST_dot (sr,(subst e, id,ts))
   140:   *)
   141: 
   142:   | `AST_dot (sr,(e,e2)) ->
   143:     `AST_dot (sr,(subst e, subst e2))
   144: 
   145:   | `AST_lambda _ -> assert false
   146: 
   147:   | `AST_match_case _
   148:   | `AST_ctor_arg _
   149:   | `AST_get_n _
   150:   | `AST_get_named_variable _
   151:   | `AST_get_named_method _
   152:   | `AST_match_ctor _
   153:     ->
   154:     let sr = src_of_expr e in
   155:     clierr sr "[subst] not implemented in when part of pattern"
   156: 
   157:   | `AST_coercion _ -> failwith "subst: coercion"
   158: 
   159: (* This routine runs through a pattern looking for
   160:   pattern variables, and adds a record to a hashtable
   161:   keyed by each variable name. The data recorded
   162:   is the list of extractors which must be applied
   163:   to 'deconstruct' the data type to get the part
   164:   which the variable denotes in the pattern
   165: 
   166:   for example, for the pattern
   167: 
   168:     | Ctor (1,(x,_))
   169: 
   170:   the extractor for x is
   171: 
   172:     [Udtor "Ctor"; Proj_n 2; Proj_n 1]
   173: 
   174:   since x is the first component of the second
   175:   component of the argument of the constructor "Ctor"
   176: *)
   177: 
   178: let rec get_pattern_vars
   179:   vars      (* Hashtable of variable -> range_srcref * extractor *)
   180:   pat       (* pattern *)
   181:   extractor (* extractor for this pattern *)
   182: =
   183:   match pat with
   184:   | `PAT_name (sr,id) -> Hashtbl.add vars id (sr,extractor)
   185: 
   186:   | `PAT_tuple (sr,pats) ->
   187:     let n = ref 0 in
   188:     List.iter
   189:     (fun pat ->
   190:       let sr = src_of_pat pat in
   191:       let extractor' = (Proj_n (sr,!n)) :: extractor in
   192:       incr n;
   193:       get_pattern_vars vars pat extractor'
   194:     )
   195:     pats
   196: 
   197:   | `PAT_regexp _ ->
   198:     failwith "[get_pattern_vars] Can't handle regexp yet"
   199: 
   200:   | `PAT_nonconst_ctor (sr,name,pat) ->
   201:     let extractor' = (Udtor (sr, name)) :: extractor in
   202:     get_pattern_vars vars pat extractor'
   203: 
   204:   | `PAT_as (sr,pat,id) ->
   205:     Hashtbl.add vars id (sr,extractor);
   206:     get_pattern_vars vars pat extractor
   207: 
   208:   | `PAT_coercion (sr,pat,_)
   209:   | `PAT_when (sr,pat,_) ->
   210:     get_pattern_vars vars pat extractor
   211: 
   212:   | `PAT_record (sr,rpats) ->
   213:     List.iter
   214:     (fun (s,pat) ->
   215:       let sr = src_of_pat pat in
   216:       let extractor' = (Proj_s (sr,s)) :: extractor in
   217:       get_pattern_vars vars pat extractor'
   218:     )
   219:     rpats
   220: 
   221:   | _ -> ()
   222: 
   223: let rec gen_match_check pat (arg:expr_t) =
   224:   let lint sr t i = `AST_literal (sr,`AST_int (t,i))
   225:   and lstr sr s = `AST_literal (sr,`AST_string s)
   226:   and lfloat sr t x = `AST_literal (sr,`AST_float (t,x))
   227:   and apl sr f x =
   228:     `AST_apply
   229:     (
   230:       sr,
   231:       (
   232:         `AST_name (sr,f,[]),
   233:         x
   234:       )
   235:     )
   236:   and apl2 sr f x1 x2 =
   237:     match f,x1,x2 with
   238:     | "land",`AST_typed_case(_,1,`TYP_unitsum 2),x -> x
   239:     | "land",x,`AST_typed_case(_,1,`TYP_unitsum 2) -> x
   240:     | _ ->
   241:     `AST_apply
   242:     (
   243:       sr,
   244:       (
   245:         `AST_name (sr,f,[]),
   246:         `AST_tuple (sr,[x1;x2])
   247:       )
   248:     )
   249:   and truth sr = `AST_typed_case (sr,1,flx_bool)
   250:   and ssrc x = short_string_of_src x
   251:   in
   252:   match pat with
   253:   | `PAT_int (sr,t,i) -> apl2 sr "eq" (lint sr t i) arg
   254:   | `PAT_string (sr,s) -> apl2 sr "eq" (lstr sr s) arg
   255:   | `PAT_nan sr -> apl sr "isnan" arg
   256:   | `PAT_none sr -> clierr sr "Empty pattern not allowed"
   257: 
   258:   (* ranges *)
   259:   | `PAT_int_range (sr,t1,i1,t2,i2) ->
   260:     let b1 = apl2 sr "le" (lint sr t1 i1) arg
   261:     and b2 = apl2 sr "le" arg (lint sr t2 i2)
   262:     in apl2 sr "land" b1 b2
   263: 
   264:   | `PAT_string_range (sr,s1,s2) ->
   265:     let b1 = apl2 sr "le" (lstr sr s1) arg
   266:     and b2 = apl2 sr "le" arg (lstr sr s2)
   267:     in apl2 sr "land" b1 b2
   268: 
   269:   | `PAT_float_range (sr,x1,x2) ->
   270:     begin match x1,x2 with
   271:     | (Float_plus (t1,v1), Float_plus (t2,v2)) ->
   272:       if t1 <> t2 then
   273:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   274:       else
   275:         let b1 = apl2 sr "le" (lfloat sr t1 v1) arg
   276:         and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
   277:         in apl2 sr "land" b1 b2
   278: 
   279:     | (Float_minus(t1,v1), Float_minus (t2,v2)) ->
   280:       if t1 <> t2 then
   281:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   282:       else
   283:         let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   284:         and b2 = apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
   285:         in apl2 sr "land" b1 b2
   286: 
   287: 
   288:     | (Float_minus (t1,v1), Float_plus (t2,v2)) ->
   289:       if t1 <> t2 then
   290:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   291:       else
   292:         let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   293:         and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
   294:         in apl2 sr "land" b1 b2
   295: 
   296: 
   297:     | (Float_minus (t1,v1), Float_inf) ->
   298:         apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   299: 
   300:     | (Float_plus (t1,v1), Float_inf) ->
   301:         apl2 sr "le" (lfloat sr t1 v1) arg
   302: 
   303:     | (Float_minus_inf, Float_minus (t2,v2)) ->
   304:         apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
   305: 
   306:     | (Float_minus_inf, Float_plus (t2,v2)) ->
   307:         apl2 sr "le" arg (lfloat sr t2 v2)
   308: 
   309:     | (Float_minus_inf , Float_inf ) ->
   310:        apl sr "not" (apl sr "isnan" arg)
   311: 
   312: 
   313:     | (Float_plus _, Float_minus _)
   314:     | (Float_inf, _)
   315:     | (_ , Float_minus_inf) ->
   316:       failwith ("Empty float range at " ^ ssrc sr)
   317:     end
   318: 
   319:   (* other *)
   320:   | `PAT_name (sr,_) -> truth sr
   321:   | `PAT_tuple (sr,pats) ->
   322:     let counter = ref 1 in
   323:     List.fold_left
   324:     (fun init pat ->
   325:       let sr = src_of_pat pat in
   326:       let n = !counter in
   327:       incr counter;
   328:       apl2 sr "land" init
   329:         (
   330:           gen_match_check pat (`AST_get_n (sr,(n, arg)))
   331:         )
   332:     )
   333:     (
   334:       let pat = List.hd pats in
   335:       let sr = src_of_pat pat in
   336:       gen_match_check pat (`AST_get_n (sr,(0, arg)))
   337:     )
   338:     (List.tl pats)
   339: 
   340:   | `PAT_record (sr,rpats) ->
   341:     List.fold_left
   342:     (fun init (s,pat) ->
   343:       let sr = src_of_pat pat in
   344:       apl2 sr "land" init
   345:         (
   346:           gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
   347:         )
   348:     )
   349:     (
   350:       let s,pat = List.hd rpats in
   351:       let sr = src_of_pat pat in
   352:       gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
   353:     )
   354:     (List.tl rpats)
   355: 
   356:   | `PAT_any sr -> truth sr
   357:   | `PAT_regexp _ ->
   358:     failwith "[gen_match_check] Can't handle regexp yet"
   359:   | `PAT_const_ctor (sr,name) ->
   360:     `AST_match_ctor (sr,(name,arg))
   361: 
   362:   | `PAT_nonconst_ctor (sr,name,pat) ->
   363:     let check_component = `AST_match_ctor (sr,(name,arg)) in
   364:     let tuple = `AST_ctor_arg (sr,(name,arg)) in
   365:     let check_tuple = gen_match_check pat tuple in
   366:     apl2 sr "land" check_component check_tuple
   367: 
   368:   | `PAT_coercion (sr,pat,_)
   369:   | `PAT_as (sr,pat,_) ->
   370:     gen_match_check pat arg
   371: 
   372:   | `PAT_when (sr,pat,expr) ->
   373:     let vars =  Hashtbl.create 97 in
   374:     get_pattern_vars vars pat [];
   375:     apl2 sr "land" (gen_match_check pat arg) (subst vars expr arg)
   376: 
   377: 
End ocaml section to src/flx_mbind.ml[1]