5.38. 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_vsprintf _
    60:   | `AST_type_match _
    61:   | `AST_noexpand _
    62:   | `AST_letin _
    63:   | `AST_cond _
    64:   | `AST_expr _
    65:   | `AST_typeof _
    66:   | `AST_product _
    67:   | `AST_void _
    68:   | `AST_sum _
    69:   | `AST_andlist _
    70:   | `AST_orlist _
    71:   | `AST_typed_case _
    72:   | `AST_case_arg _
    73:   | `AST_arrow _
    74:   | `AST_longarrow _
    75:   | `AST_superscript _
    76:   | `AST_match _
    77:   | `AST_regmatch _
    78:   | `AST_string_regmatch _
    79:   | `AST_reglex _
    80:   | `AST_ellipsis _
    81:   | `AST_parse _
    82:   | `AST_sparse _
    83:   | `AST_setunion _
    84:   | `AST_setintersection _
    85:   | `AST_macro_ctor _
    86:   | `AST_macro_statements  _
    87:   | `AST_callback _
    88:   | `AST_record_type _
    89:   | `AST_variant_type _
    90:     ->
    91:       let sr = src_of_expr e in
    92:       clierr sr "[mbind:subst] Not expected in when part of pattern"
    93: 
    94:   | `AST_case_index _ -> e
    95:   | `AST_index _  -> e
    96:   | `AST_the _  -> e
    97:   | `AST_lookup _ -> e
    98:   | `AST_suffix _ -> e
    99:   | `AST_literal _ -> e
   100:   | `AST_case_tag _ -> e
   101:   | `AST_as _ -> e
   102: 
   103:   | `AST_name (sr,name,idx) ->
   104:     if idx = [] then
   105:     if Hashtbl.mem vars name
   106:     then
   107:       let sr,extractor = Hashtbl.find vars name in
   108:       gen_extractor extractor mv
   109:     else e
   110:     else failwith "Can't use indexed name in when clause :("
   111: 
   112: 
   113: 
   114:   | `AST_deref (sr,e') -> `AST_deref (sr,subst e')
   115:   | `AST_ref (sr,e') -> `AST_ref (sr,subst e')
   116:   | `AST_lvalue (sr,e') -> `AST_lvalue (sr,subst e')
   117:   | `AST_apply (sr,(f,e)) -> `AST_apply (sr,(subst f,subst e))
   118:   | `AST_map (sr,f,e) -> `AST_map (sr,subst f,subst e)
   119:   | `AST_tuple (sr,es) -> `AST_tuple (sr,map subst es)
   120:   | `AST_record (sr,es) -> `AST_record (sr,map (fun (s,e)->s,subst e) es)
   121:   | `AST_variant (sr,(s,e)) -> `AST_variant (sr,(s,subst e))
   122:   | `AST_arrayof (sr,es) -> `AST_arrayof (sr,map subst es)
   123: 
   124: 
   125:   (* Only one of these should occur, but I can't
   126:      figure out which one at the moment
   127:   *)
   128:   | `AST_method_apply (sr,(id,e,ts)) ->
   129:     `AST_method_apply (sr,(id, subst e,ts))
   130: 
   131:   | `AST_dot (sr,(e,id,ts)) ->
   132:     `AST_dot (sr,(subst e, id,ts))
   133: 
   134:   | `AST_lambda _ -> assert false
   135: 
   136:   | `AST_match_case _
   137:   | `AST_ctor_arg _
   138:   | `AST_get_n _
   139:   | `AST_get_named_variable _
   140:   | `AST_get_named_method _
   141:   | `AST_match_ctor _
   142:     ->
   143:     let sr = src_of_expr e in
   144:     clierr sr "[subst] not implemented in when part of pattern"
   145: 
   146:   | `AST_coercion _ -> failwith "subst: coercion"
   147: 
   148: (* This routine runs through a pattern looking for
   149:   pattern variables, and adds a record to a hashtable
   150:   keyed by each variable name. The data recorded
   151:   is the list of extractors which must be applied
   152:   to 'deconstruct' the data type to get the part
   153:   which the variable denotes in the pattern
   154: 
   155:   for example, for the pattern
   156: 
   157:     | Ctor (1,(x,_))
   158: 
   159:   the extractor for x is
   160: 
   161:     [Udtor "Ctor"; Proj_n 2; Proj_n 1]
   162: 
   163:   since x is the first component of the second
   164:   component of the argument of the constructor "Ctor"
   165: *)
   166: 
   167: let rec get_pattern_vars
   168:   vars      (* Hashtable of variable -> range_srcref * extractor *)
   169:   pat       (* pattern *)
   170:   extractor (* extractor for this pattern *)
   171: =
   172:   match pat with
   173:   | `PAT_name (sr,id) -> Hashtbl.add vars id (sr,extractor)
   174: 
   175:   | `PAT_tuple (sr,pats) ->
   176:     let n = ref 0 in
   177:     List.iter
   178:     (fun pat ->
   179:       let sr = src_of_pat pat in
   180:       let extractor' = (Proj_n (sr,!n)) :: extractor in
   181:       incr n;
   182:       get_pattern_vars vars pat extractor'
   183:     )
   184:     pats
   185: 
   186:   | `PAT_regexp _ ->
   187:     failwith "[get_pattern_vars] Can't handle regexp yet"
   188: 
   189:   | `PAT_nonconst_ctor (sr,name,pat) ->
   190:     let extractor' = (Udtor (sr, name)) :: extractor in
   191:     get_pattern_vars vars pat extractor'
   192: 
   193:   | `PAT_as (sr,pat,id) ->
   194:     Hashtbl.add vars id (sr,extractor);
   195:     get_pattern_vars vars pat extractor
   196: 
   197:   | `PAT_coercion (sr,pat,_)
   198:   | `PAT_when (sr,pat,_) ->
   199:     get_pattern_vars vars pat extractor
   200: 
   201:   | `PAT_record (sr,rpats) ->
   202:     List.iter
   203:     (fun (s,pat) ->
   204:       let sr = src_of_pat pat in
   205:       let extractor' = (Proj_s (sr,s)) :: extractor in
   206:       get_pattern_vars vars pat extractor'
   207:     )
   208:     rpats
   209: 
   210:   | _ -> ()
   211: 
   212: let rec gen_match_check pat (arg:expr_t) =
   213:   let lint sr t i = `AST_literal (sr,`AST_int (t,i))
   214:   and lstr sr s = `AST_literal (sr,`AST_string s)
   215:   and lfloat sr t x = `AST_literal (sr,`AST_float (t,x))
   216:   and apl sr f x =
   217:     `AST_apply
   218:     (
   219:       sr,
   220:       (
   221:         `AST_name (sr,f,[]),
   222:         x
   223:       )
   224:     )
   225:   and apl2 sr f x1 x2 =
   226:     match f,x1,x2 with
   227:     | "land",`AST_typed_case(_,1,`TYP_unitsum 2),x -> x
   228:     | "land",x,`AST_typed_case(_,1,`TYP_unitsum 2) -> x
   229:     | _ ->
   230:     `AST_apply
   231:     (
   232:       sr,
   233:       (
   234:         `AST_name (sr,f,[]),
   235:         `AST_tuple (sr,[x1;x2])
   236:       )
   237:     )
   238:   and truth sr = `AST_typed_case (sr,1,flx_bool)
   239:   and ssrc x = short_string_of_src x
   240:   in
   241:   match pat with
   242:   | `PAT_int (sr,t,i) -> apl2 sr "eq" (lint sr t i) arg
   243:   | `PAT_string (sr,s) -> apl2 sr "eq" (lstr sr s) arg
   244:   | `PAT_nan sr -> apl sr "isnan" arg
   245:   | `PAT_none sr -> clierr sr "Empty pattern not allowed"
   246: 
   247:   (* ranges *)
   248:   | `PAT_int_range (sr,t1,i1,t2,i2) ->
   249:     let b1 = apl2 sr "le" (lint sr t1 i1) arg
   250:     and b2 = apl2 sr "le" arg (lint sr t2 i2)
   251:     in apl2 sr "land" b1 b2
   252: 
   253:   | `PAT_string_range (sr,s1,s2) ->
   254:     let b1 = apl2 sr "le" (lstr sr s1) arg
   255:     and b2 = apl2 sr "le" arg (lstr sr s2)
   256:     in apl2 sr "land" b1 b2
   257: 
   258:   | `PAT_float_range (sr,x1,x2) ->
   259:     begin match x1,x2 with
   260:     | (Float_plus (t1,v1), Float_plus (t2,v2)) ->
   261:       if t1 <> t2 then
   262:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   263:       else
   264:         let b1 = apl2 sr "le" (lfloat sr t1 v1) arg
   265:         and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
   266:         in apl2 sr "land" b1 b2
   267: 
   268:     | (Float_minus(t1,v1), Float_minus (t2,v2)) ->
   269:       if t1 <> t2 then
   270:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   271:       else
   272:         let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   273:         and b2 = apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
   274:         in apl2 sr "land" b1 b2
   275: 
   276: 
   277:     | (Float_minus (t1,v1), Float_plus (t2,v2)) ->
   278:       if t1 <> t2 then
   279:         failwith ("Inconsistent endpoint types in " ^ ssrc sr)
   280:       else
   281:         let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   282:         and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
   283:         in apl2 sr "land" b1 b2
   284: 
   285: 
   286:     | (Float_minus (t1,v1), Float_inf) ->
   287:         apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
   288: 
   289:     | (Float_plus (t1,v1), Float_inf) ->
   290:         apl2 sr "le" (lfloat sr t1 v1) arg
   291: 
   292:     | (Float_minus_inf, Float_minus (t2,v2)) ->
   293:         apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
   294: 
   295:     | (Float_minus_inf, Float_plus (t2,v2)) ->
   296:         apl2 sr "le" arg (lfloat sr t2 v2)
   297: 
   298:     | (Float_minus_inf , Float_inf ) ->
   299:        apl sr "not" (apl sr "isnan" arg)
   300: 
   301: 
   302:     | (Float_plus _, Float_minus _)
   303:     | (Float_inf, _)
   304:     | (_ , Float_minus_inf) ->
   305:       failwith ("Empty float range at " ^ ssrc sr)
   306:     end
   307: 
   308:   (* other *)
   309:   | `PAT_name (sr,_) -> truth sr
   310:   | `PAT_tuple (sr,pats) ->
   311:     let counter = ref 1 in
   312:     List.fold_left
   313:     (fun init pat ->
   314:       let sr = src_of_pat pat in
   315:       let n = !counter in
   316:       incr counter;
   317:       apl2 sr "land" init
   318:         (
   319:           gen_match_check pat (`AST_get_n (sr,(n, arg)))
   320:         )
   321:     )
   322:     (
   323:       let pat = List.hd pats in
   324:       let sr = src_of_pat pat in
   325:       gen_match_check pat (`AST_get_n (sr,(0, arg)))
   326:     )
   327:     (List.tl pats)
   328: 
   329:   | `PAT_record (sr,rpats) ->
   330:     List.fold_left
   331:     (fun init (s,pat) ->
   332:       let sr = src_of_pat pat in
   333:       apl2 sr "land" init
   334:         (
   335:           gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
   336:         )
   337:     )
   338:     (
   339:       let s,pat = List.hd rpats in
   340:       let sr = src_of_pat pat in
   341:       gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
   342:     )
   343:     (List.tl rpats)
   344: 
   345:   | `PAT_any sr -> truth sr
   346:   | `PAT_regexp _ ->
   347:     failwith "[gen_match_check] Can't handle regexp yet"
   348:   | `PAT_const_ctor (sr,name) ->
   349:     `AST_match_ctor (sr,(name,arg))
   350: 
   351:   | `PAT_nonconst_ctor (sr,name,pat) ->
   352:     let check_component = `AST_match_ctor (sr,(name,arg)) in
   353:     let tuple = `AST_ctor_arg (sr,(name,arg)) in
   354:     let check_tuple = gen_match_check pat tuple in
   355:     apl2 sr "land" check_component check_tuple
   356: 
   357:   | `PAT_coercion (sr,pat,_)
   358:   | `PAT_as (sr,pat,_) ->
   359:     gen_match_check pat arg
   360: 
   361:   | `PAT_when (sr,pat,expr) ->
   362:     let vars =  Hashtbl.create 97 in
   363:     get_pattern_vars vars pat [];
   364:     apl2 sr "land" (gen_match_check pat arg) (subst vars expr arg)
   365: 
   366: 
End ocaml section to src/flx_mbind.ml[1]