5.31. Desugaring

Two routines: one to build interfaces from modules, and one to lift lambdas and also blocks.
Start ocaml section to src/flx_desugar.mli[1 /1 ]
     1: # 7 "./lpsrc/flx_desugar.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes2
     5: val desugar_program:
     6:   sym_state_t ->
     7:   string ->
     8:   statement_t list ->
     9:   asm_t list
    10: 
    11: val include_file:
    12:   sym_state_t ->
    13:   string ->
    14:   bool ->
    15:   statement_t list
    16: 
End ocaml section to src/flx_desugar.mli[1]
Start ocaml section to src/flx_desugar.ml[1 /1 ]
     1: # 24 "./lpsrc/flx_desugar.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_typing2
    10: open List
    11: open Flx_pat
    12: open Flx_srcref
    13: open Flx_exceptions
    14: open Flx_macro
    15: open Flx_filesys
    16: 
    17: let generated = ("Generated by desugaring",0,0,0,0)
    18: 
    19: let include_file syms inspec lookup =
    20:   let force = syms.compiler_options.force_recompile in
    21:   let this_version = !Flx_version.version_data in
    22:   let basename =
    23:     let n = String.length inspec in
    24:     if n <= 3 then inspec
    25:     else
    26:       let x = String.sub inspec (n-4) 4 in
    27:       match x with
    28:       | ".flx" | ".par" -> String.sub inspec 0 (n-4)
    29:       | _ -> inspec
    30: 
    31:   in
    32:   let include_dirs = syms.compiler_options.include_dirs in
    33:   let tf = find_file lookup include_dirs (basename ^ ".flx") in
    34:   let pf = find_file lookup include_dirs (basename ^ ".par") in
    35:   let tf_mt = filetime tf in
    36:   let pf_mt = filetime pf in
    37:   let cbt = this_version.build_time_float in
    38:   let saveit hash_include_files sts =
    39:       let pf =
    40:         if pf = "" then
    41:           (try Filename.chop_extension tf with | _ -> tf) ^ ".par"
    42:         else pf
    43:       in
    44:         let x = try Some (open_out_bin pf) with _ -> None in
    45:         match x with
    46:         | Some x ->
    47:           if syms.compiler_options.print_flag then
    48:           print_endline ("Written " ^ pf);
    49:           Marshal.to_channel x this_version [];
    50:           Marshal.to_channel x (hash_include_files,sts) [];
    51:           close_out x
    52:         | None -> () (* can't write, don't worry *)
    53:   in
    54:   let parseit() =
    55:     let hash_include_files, sts =
    56:       if syms.compiler_options.print_flag then
    57:       print_endline ("Parsing " ^ tf);
    58:       Flx_parse_ctrl.parse_file
    59:         tf
    60:         (Filename.dirname tf)
    61:         include_dirs
    62:         expand_expression
    63:     in
    64:       let local_prefix = Filename.basename basename in
    65:       let tree = expand_macros local_prefix 5000 sts in
    66:       hash_include_files, tree
    67:   in
    68:   let sts =
    69:       (* -- no file ----------------------------------------- *)
    70:     if tf_mt = 0.0 && pf_mt = 0.0 then
    71:         failwith
    72:         (
    73:           "No .flx or .par file for name " ^
    74:           basename ^
    75:           " found in path:\n" ^
    76:           String.concat "; " include_dirs
    77:         )
    78: 
    79:       (* -- parsed file is newer or text doesn't exist ------- *)
    80:     else
    81:     let include_name =
    82:       Filename.chop_extension
    83:       (if tf <> "" then tf else pf)
    84:     in
    85:       if mem include_name !(syms.include_files) then [] else
    86:       begin (* file not already included *)
    87:         syms.include_files := include_name :: !(syms.include_files)
    88:         ;
    89:         if cbt < pf_mt && (not force) && tf_mt < pf_mt then
    90:         begin (* top level time stamps OK *)
    91:           let x = open_in_bin pf in
    92:           let that_version = Marshal.from_channel x in
    93:           if this_version = that_version then begin
    94:             let (hash_include_files,tree) = Marshal.from_channel x in
    95:             close_in x;
    96: 
    97:             let hash_includes_agree = fold_left
    98:               (fun acc f ->
    99:                 let ft = filetime f in
   100:                 acc && ft <> 0.0 && ft < pf_mt
   101:               )
   102:               true
   103:               hash_include_files
   104:             in
   105:             if hash_includes_agree then begin (* all time stamps OK *)
   106:               if syms.compiler_options.print_flag then
   107:               print_endline ("Loaded " ^ pf);
   108:               tree
   109:             end else begin (* include file timestamps wrong *)
   110:               let hash_include_files, sts = parseit() in
   111:               saveit hash_include_files sts;
   112:               sts
   113:             end
   114:           end (* right version of compiler *)
   115:           else
   116:           begin (* wrong version of compiler *)
   117:             close_in x;
   118:             let hash_include_files, sts = parseit() in
   119:             saveit hash_include_files sts;
   120:             sts
   121:           end
   122:         end
   123:         else
   124:         begin (* time stamps wrong *)
   125:           let hash_include_files,sts = parseit() in
   126:           saveit hash_include_files sts;
   127:           sts
   128:         end
   129:       end (* process inclusion first time *)
   130:   in
   131:     sts
   132: 
   133: let fix_params seq (ps:params_t):vs_list_t * params_t =
   134:   let rec aux (ps:parameter_t list) :vs_list_t * parameter_t list =
   135:     match ps with
   136:     | (x,`TYP_none) :: t ->
   137:       let v = "_v"^si (seq()) in
   138:       let vt: typecode_t = `AST_name(generated,v,[]) in
   139:       let vs,ps = aux t in
   140:       ((v,`TPAT_any)::vs),((x,vt)::ps) (* a bit HACKY *)
   141: 
   142:     | h :: t ->
   143:       let vs,ps = aux t in
   144:       vs, (h::ps)
   145:     | [] -> [],[]
   146:   in
   147:   let ps, traint = ps in
   148:   let vs,ps = aux ps in
   149:   vs,(ps,traint)
   150: 
   151: let arglist x =
   152:   match x with
   153:   | `AST_tuple (_,ts) -> ts
   154:   | _ -> [x]
   155: 
   156: let mkcurry seq sr name vs (args:params_t list) return_type kind body props =
   157:   let return_type, postcondition = return_type in
   158:   let vss',(args:params_t list)= split (map (fix_params seq) args) in
   159:   let vs = concat (vs :: vss') in
   160:   let mkfuntyp d c = `TYP_function (d,c)
   161:   and typeoflist lst = match lst with
   162:     | [x] -> x
   163:     | _ -> `TYP_tuple lst
   164:   in
   165:   let mkret arg ret = mkfuntyp (typeoflist (List.map snd (fst arg))) ret in
   166:   let arity = List.length args in
   167:   let rettype args =
   168:     match return_type with
   169:     | `TYP_none -> `TYP_none
   170:     | _ -> List.fold_right mkret args return_type
   171:   in
   172: 
   173:   let rec aux (args:params_t list) vs =
   174:     let n = List.length args in
   175:     let name n =
   176:       if n = arity
   177:       then name
   178:       else name^"'" ^ si (arity-n+1)
   179:     in
   180:     match args with
   181:     | [] ->
   182:         (match kind with
   183:         | `NoInlineFunction
   184:         | `InlineFunction
   185:         | `Ctor
   186:         | `Function ->
   187:           let props = match kind with
   188:           | `InlineFunction -> `Inline::props
   189:           | `NoInlineFunction -> `NoInline::props
   190:           | `Ctor -> `Ctor::props
   191:           | _ -> props
   192:           in
   193:           begin match return_type with
   194:           | `AST_void _ ->
   195:             `AST_function (sr, name n, vs, ([],None), (return_type,postcondition), props, body)
   196:           | _ ->
   197:             (* allow functions with no arguments now .. *)
   198:             begin match body with
   199:             | [`AST_fun_return (_,e)] ->
   200:               let rt = match return_type with
   201:               | `TYP_none -> None
   202:               | x -> Some x
   203:               in
   204:               `AST_lazy_decl (sr, name n, vs, rt, Some e)
   205:             | _ ->
   206:             clierr sr "Function with no arguments"
   207:             end
   208:           end
   209: 
   210:         | `Object ->
   211:           `AST_object (sr, name n, vs, ([],None), body)
   212:         )
   213: 
   214:     | h :: [] -> (* bottom level *)
   215:         (match kind with
   216:         | `NoInlineFunction
   217:         | `InlineFunction
   218:         | `Ctor
   219:         | `Function ->
   220:           let props = match kind with
   221:           | `InlineFunction -> `Inline::props
   222:           | `NoInlineFunction -> `NoInline::props
   223:           | `Ctor -> `Ctor::props
   224:           | _ -> props
   225:           in
   226:           `AST_function (sr, name n, vs, h, (return_type,postcondition), props, body)
   227:         | `Object ->
   228:           `AST_object (sr, name n, vs, h, body)
   229:         )
   230:     | h :: t ->
   231:       let argt =
   232:         let hdt = hd t in
   233:         let xargs,traint = hdt in
   234:         typeoflist (map snd xargs)
   235:       in
   236:       let m = List.length args in
   237:       let body =
   238:         [
   239:           aux t [];
   240:           `AST_fun_return
   241:           (
   242:             sr,
   243:             `AST_suffix
   244:             (
   245:               sr,
   246:               (
   247:                 `AST_name (sr,name (m-1),[]),argt
   248:               )
   249:             )
   250:           )
   251:         ]
   252:       in
   253:         `AST_function (sr, name m, vs, h, (rettype t,None), [`Generated "curry";`Inline], body)
   254:    in aux args vs
   255: 
   256: (* model binary operator as procedure call *)
   257: let assign sr op l r =
   258:   match op with
   259:   | "_set" -> `AST_cassign (sr,l,r)
   260:   | _ ->
   261:   `AST_call
   262:   (
   263:     sr,
   264:     `AST_name (sr, op,[]),
   265:     `AST_tuple ( sr, [ l; r ])
   266:   )
   267: 
   268: 
   269: 
   270: let find_methods seq sr sts =
   271:   let methods = ref [] in
   272:   let rec check = function
   273:     | `AST_curry (sr,mname,vs,pss,ret,kind,sts) ->
   274:       check (mkcurry seq sr mname vs pss ret kind sts [])
   275: 
   276:     (*
   277:     | `AST_object (sr,mname, vs, ps, sts) ->
   278:        check (`AST_function (sr,mname,vs,ps,(`TYP_none,None),props,sts))
   279:     *)
   280: 
   281:     | `AST_function (sr,mname, vs, ps, (ret,postcondition),props,sts) ->
   282:       if vs <> [] then
   283:       clierr sr "[process_object] Object methods may not be generic"
   284:       ;
   285:       let argtyp = match map snd (fst ps) with
   286:         | [] -> `TYP_tuple []
   287:         | [a] -> a
   288:         | x -> `TYP_tuple x
   289:       in
   290:       let typ = `TYP_function (argtyp, ret) in
   291:       methods := (mname, typ) :: !methods
   292:     | _ -> ()
   293:   in
   294:   iter check sts
   295:   ;
   296:   rev !methods
   297: 
   298: (* split lambdas out. Each lambda is replaced by a
   299:    reference to a synthesised name in the original
   300:    statement, which is prefixed by the definition.
   301: 
   302:    Blocks are replaced by a procedure definition
   303:    and a call.
   304: 
   305:    The match statement requires all case bodies
   306:    be replaced by calls as well.
   307: 
   308:    Actual lambdas in expressions are replaced
   309:    by a reference and function or procedure definition.
   310: 
   311:    Attempt handler bodies are requires all handlers
   312:    to be replaced by a call as well.
   313: *)
   314: 
   315: (* convert an expression into a list of assembly instructions,
   316:    plus an expression: basically, this means removing lambdas
   317: *)
   318: 
   319: (*
   320:   ARGGG! rex guarrantees to lift lambdas out of expressions,
   321:   but the lifted lambda declarations also have bodies
   322:   which might contain expression containing lambdas,
   323:   so we have to apply rsts to these bodies..
   324: *)
   325: 
   326: let rec rex syms name (e:expr_t) : asm_t list * expr_t =
   327:   let rex e = rex syms name e in
   328:   let rsts sts = concat (map (rst syms name `Private []) sts) in
   329:   let sr = src_of_expr e in
   330:   let seq () = let n = !(syms.counter) in incr (syms.counter); n in
   331:   match e with
   332: 
   333:   | `AST_sparse _
   334:   | `AST_match_ctor _
   335:   | `AST_match_case _
   336:   | `AST_ctor_arg _
   337:   | `AST_case_arg _
   338:   | `AST_void _
   339:   | `AST_arrow _
   340:   | `AST_longarrow _
   341:   | `AST_superscript _
   342:   | `AST_as _
   343:   | `AST_product _
   344:   | `AST_sum _
   345:   | `AST_andlist _
   346:   | `AST_orlist _
   347:   | `AST_ellipsis _
   348:   | `AST_lvalue _
   349:   | `AST_setunion  _
   350:   | `AST_setintersection _
   351:   | `AST_macro_ctor _
   352:   | `AST_macro_statements _
   353:     ->
   354:     clierr sr ("[rex] Unexpected " ^ string_of_expr e)
   355: 
   356:   | `AST_type_match _ -> [],e
   357: 
   358:   | `AST_noexpand (_,e) -> rex e
   359:   | `AST_name (sr,name,_) -> [],e
   360: 
   361:   | `AST_deref (sr,e) ->
   362:     let l1,x1 = rex e in
   363:     l1, `AST_deref (sr,x1)
   364: 
   365:   | `AST_ref (sr,e) ->
   366:     let l1,x1 = rex e in
   367:     l1, `AST_ref (sr,x1)
   368: 
   369:   | `AST_suffix _ -> [],e  (* ?? *)
   370:   | `AST_callback _ -> [],e  (* ?? *)
   371: 
   372:   | `AST_the (_,_) -> [],e
   373:   | `AST_index (_,_,_) -> [],e
   374: 
   375:   | `AST_lookup (sr,(e,id,ts)) ->
   376:     let l1,x1 = rex e in
   377:     l1, `AST_lookup (sr,(x1,id,ts))
   378: 
   379:   | `AST_case_tag _ -> [],e
   380:   | `AST_typed_case _ -> [],e
   381:   | `AST_literal _ -> [],e
   382: 
   383:   | `AST_expr _ -> [],e
   384: 
   385:   | `AST_vsprintf (sr,s) ->
   386:     let ix = seq () in
   387:     let id = si ix in
   388:     let str = `AST_name (sr,"string",[]) in
   389:     let ts = Flx_cformat.types_of_cformat_string sr s in
   390:     let ss = Flx_print.string_of_string s in
   391:     let fs = "flx::rtl::strutil::flx_asprintf("^ss^",$a)" in
   392:     let req = `NREQ_atom (`AST_name (sr,"flx_strutil",[])) in
   393:     let f = `DCL_fun([],ts,str,`StrTemplate fs,req,"primary") in
   394:     let x=`AST_index (sr,id,ix) in
   395:     [
   396:       Dcl (sr,id,Some ix,`Private,[],f);
   397:     ],x
   398: 
   399:   | `AST_cond (sr,(e,b1,b2)) ->
   400:      rex
   401:      (
   402:        `AST_match
   403:        (
   404:          sr,
   405:          (
   406:            e,
   407:            [
   408:              `PAT_const_ctor (sr,`AST_case_tag (sr,1)),b1; (* true *)
   409:              `PAT_any sr,b2 (* false *)
   410:            ]
   411:          )
   412:        )
   413:      )
   414: 
   415:   (* we have to lift lambdas out of typeof exprs,
   416:      even though they're never called,
   417:      so the typing works correctly
   418:   *)
   419:   | `AST_typeof (sr,e') ->
   420:     let l1,x1 = rex e' in
   421:     l1, `AST_typeof (sr,(x1))
   422: 
   423:   | `AST_get_n (sr,(n,e')) ->
   424:     let l1,x1 = rex e' in
   425:     l1, `AST_get_n (sr,(n,x1))
   426: 
   427:   | `AST_get_named_variable (sr,(n,e')) ->
   428:     let l1,x1 = rex e' in
   429:     l1, `AST_get_named_variable (sr,(n,x1))
   430: 
   431:   | `AST_get_named_method (sr,(n,mix,ts,e')) ->
   432:     let l1,x1 = rex e' in
   433:     l1, `AST_get_named_method (sr,(n,mix,ts,x1))
   434: 
   435:   | `AST_case_index (sr,e) ->
   436:     let l,x = rex e in
   437:     l,`AST_case_index (sr,x)
   438: 
   439:   | `AST_apply (sr,(fn,arg)) ->
   440:     let l1,x1 = rex fn in
   441:     let l2,x2 = rex arg in
   442:     l1 @ l2, `AST_apply (sr,(x1,x2))
   443: 
   444:   | `AST_map (sr,fn,arg) ->
   445:     let l1,x1 = rex fn in
   446:     let l2,x2 = rex arg in
   447:     l1 @ l2, `AST_map (sr,x1,x2)
   448: 
   449:   | `AST_method_apply (sr,(fn,arg,ts)) ->
   450:     let l2,x2 = rex arg in
   451:     l2, `AST_method_apply (sr,(fn,x2,ts))
   452: 
   453:   | `AST_tuple (sr,t) ->
   454:     let lss,xs = split (map rex t) in
   455:     concat lss,`AST_tuple (sr,xs)
   456: 
   457:   | `AST_record (sr,es) ->
   458:     let ss,es = split es in
   459:     let lss,xs = split (map rex es) in
   460:     concat lss,`AST_record (sr,combine ss xs)
   461: 
   462:   | `AST_record_type _ -> assert false
   463: 
   464:   | `AST_variant (sr,(s,e)) ->
   465:     let l,x = rex e in
   466:     l,`AST_variant (sr,(s,x))
   467: 
   468:   | `AST_variant_type _ -> assert false
   469: 
   470:   | `AST_arrayof (sr,t) ->
   471:     let lss,xs = split (map rex t) in
   472:     concat lss,`AST_arrayof(sr,xs)
   473: 
   474:   | `AST_lambda (sr,(pps,ret,sts)) ->
   475:     let kind = `InlineFunction in
   476:     let n = seq() in
   477:     let name' = "_lam_" ^ si n in
   478:     let access = `Private in
   479:     let vs = [] in
   480:     let sts =
   481:       rst syms name access [] (mkcurry seq sr name' vs pps (ret,None) kind sts [`Generated "lambda"])
   482:     in
   483:     if length pps = 0 then syserr sr "[rex] Lambda with no arguments?" else
   484:     let t = type_of_argtypes (map snd (fst (hd pps))) in
   485:     let e =
   486:       `AST_suffix
   487:       (
   488:         sr,
   489:         (
   490:           `AST_name (sr,name',[]), t
   491:         )
   492:       )
   493:     in
   494:     sts,e
   495: 
   496:   | `AST_dot (sr,(obj,comp,ts)) ->
   497:     let l1,x1 = rex obj in
   498:     l1 , `AST_dot (sr,(x1,comp,ts))
   499: 
   500:   | `AST_coercion (sr,(e,t)) ->
   501:     let l1,x1 = rex e in
   502:     l1, `AST_coercion (sr,(x1,t))
   503: 
   504:   | `AST_parse (sr,e,ms) ->
   505:     (* SIMPLIFY TO ONE SYMBOL PLUS DUMMY NONTERMS *)
   506:     let l,e = rex e in
   507:     let n = seq() in
   508:     let nt = "_nt_"^si n in
   509:     let nt_name = `AST_index (sr,nt,n) in
   510:     let l,glr_ixs =
   511:       fold_left
   512:       (fun (ll,glr_ixs) (sr,p,e) ->
   513:         let t = `TYP_none in
   514:         let glr_idx = seq() in
   515:         let dcls = handle_glr seq rex sr p e glr_idx t nt in
   516:         dcls @ l @ ll,
   517:         (*
   518:         Dcl(sr,nt,Some n',`Private,[],`DCL_glr(t,(p,x))) :: l @ ll,
   519:         *)
   520:         glr_idx::glr_ixs
   521:       )
   522:       (l,[])
   523:       ms
   524:     in
   525:     l,`AST_sparse (sr,e,nt,glr_ixs)
   526: 
   527:   | `AST_regmatch (sr,(p1,p2,cls')) ->
   528:     let dcls = ref [] in
   529:     let cls = ref [] in
   530:     iter
   531:     (fun (re,e) ->
   532:       let l,x = rex e in
   533:       dcls := l @ !dcls;
   534:       cls := (re,x) :: !cls
   535:     )
   536:     cls'
   537:     ;
   538: 
   539:     let n = seq() in
   540:     let fname = "regmatch" ^ si n in
   541:     let l1,p1 = rex p1 in
   542:     let l2,p2 = rex p2 in
   543:     let rfun = Dcl(sr,fname,Some n,`Private,[], `DCL_regmatch !cls) in
   544:     let pp = `AST_tuple (sr,[p1;p2]) in
   545:     rfun :: l1 @ l2 @ !dcls,
   546:     `AST_apply(sr,(`AST_index(sr,fname,n),pp))
   547: 
   548:   | `AST_string_regmatch (sr,(s,cls)) ->
   549:     let l1,s = rex s in
   550:     let ssr = src_of_expr s in
   551:     let vix = seq() in
   552:     let vid = "_me_" ^ si vix in
   553:     let v = `AST_index(sr,vid,vix) in
   554:     let pa = `PAT_as (sr,`PAT_any sr,"_a") in
   555:     let pb = `PAT_as (sr,`PAT_any sr,"_b") in
   556:     let p = `PAT_tuple (sr,[pa;pb]) in
   557:     let a = `AST_name (sr,"_a",[]) in
   558:     let b = `AST_name (sr,"_b",[]) in
   559:     let lexmod = `AST_name(sr,"Lexer",[]) in
   560:     let sb = `AST_lookup(sr,(lexmod,"bounds",[])) in
   561:     let se = `AST_apply(sr,(sb,v)) in
   562:     let r =
   563:       `AST_letin (sr,(p,se,
   564:         `AST_regmatch (sr,(a,b,cls)))
   565:       )
   566:     in
   567:       let l2,x = rex r in
   568:       let d1 =
   569:         Dcl (ssr,vid,Some vix,`Private,[], `DCL_var (`TYP_typeof(s)))
   570:       in
   571:       let d2 =
   572:         Exe (ssr,`EXE_iinit ((vid, vix),s))
   573:       in
   574:       d1 :: d2 :: l1 @ l2, x
   575: 
   576: 
   577:   | `AST_reglex (sr,(p1,p2,cls')) ->
   578:     let dcls = ref [] in
   579:     let cls = ref [] in
   580:     let le = `AST_name (sr,"lexeme_end",[]) in
   581:     iter
   582:     (fun (re,e) ->
   583:       let l,x = rex e in
   584:       let x = `AST_tuple (sr,[le;x]) in
   585:       dcls := l @ !dcls;
   586:       cls := (re,x) :: !cls
   587:     )
   588:     cls'
   589:     ;
   590: 
   591:     let n = seq() in
   592:     let fname = "reglex" ^ si n in
   593:     let l1,p1 = rex p1 in
   594:     let l2,p2 = rex p2 in
   595:     let rfun = Dcl(sr,fname,Some n,`Private,[], `DCL_reglex !cls) in
   596:     let pp = `AST_tuple (sr,[p1;p2]) in
   597:     rfun :: l1 @ l2 @ !dcls,
   598:     `AST_apply(sr,(`AST_index(sr,fname,n),pp))
   599: 
   600:   | `AST_letin (sr,(pat,e1,e2)) ->
   601:     rex (`AST_match (sr,(e1,[pat,e2])))
   602: 
   603:   (* MATCH HANDLING NEEDS TO BE REWORKED, THE SWITCHING SHOULD BE
   604:      DELAYED TO ALLOW TYPE BASED OPTIMISATION WHERE THE TOP
   605:      LEVEL MATCH ON A UNION CAN USE A SWITCH.
   606: 
   607:      ALSO, TO ALLOW MULTIPLE PATTERNS WITH ONE HANDLER,
   608:      GIVE THE HANDLER PARAMETERS, AND HAVE THE TOP LEVEL
   609:      MATCH HANDLERS FOR EACH CASE FOR THAT CODE CALL IT:
   610: 
   611:      eg:
   612: 
   613:      match x with | A x | B x => x endmatch
   614:   *)
   615: 
   616: 
   617:   | `AST_match (sr,(e,pss)) ->
   618:     if length pss = 0 then clierr sr "Empty Pattern";
   619: 
   620:     (* step 1: evaluate e *)
   621:     let d,x = rex e in
   622:     let match_function_index = seq() in
   623:     let match_var_index = seq() in
   624:     (*
   625:     print_endline ("Match function index = " ^ si match_function_index );
   626:     print_endline ("Match variable index = " ^ si match_var_index );
   627:     *)
   628: 
   629:     let match_var_name = name^ "_mv_"^si match_function_index in
   630:     let match_function_id = name^ "_mf_"^ si match_function_index in
   631:     let match_function = `AST_index (sr,match_function_id,match_function_index) in
   632:     let match_seq = ref (seq()) in
   633: 
   634:     let expr_src = src_of_expr e in
   635: 
   636:     (* WOE. The expr may contain a lambda, which stuffs up
   637:        bind_expression which is called by bind_type ..
   638:     *)
   639:     let evl =
   640:       [
   641:         Dcl (expr_src,match_var_name,Some match_var_index,`Private,[],`DCL_val (`TYP_typeof x));
   642:         Exe (expr_src,`EXE_iinit ((match_var_name,match_var_index),x))
   643:       ]
   644:     in
   645:     let pats,_ = split pss in
   646:     Flx_pat.validate_patterns pats
   647:     ;
   648:     let ematch_seq = seq() in
   649:     (*
   650:     let end_match_label = "_em" ^ si ematch_seq in
   651:     *)
   652:     let matches = ref [Exe (generated,`EXE_comment "begin match")] in
   653:     let match_caseno = ref 1 in
   654:     let iswild = ref false in
   655:     iter
   656:     (fun (pat,e) ->
   657:       let n1 = !match_seq in
   658:       let n2 = seq() in
   659:       let mh_idx = seq () in
   660:       let mc_idx = seq () in
   661:       if !iswild then
   662:         print_endline "WARNING, matches after wildcard ignored"
   663:       else begin
   664:         iswild := is_universal pat;
   665:         let patsrc = src_of_pat pat in
   666:         let expr_src = src_of_expr e in
   667:         let match_checker_id = name ^ "_mc" ^ si n1 in
   668:         let match_handler_id = name ^ "_mh" ^ si n1 in
   669:         let match_checker = `AST_index (patsrc,match_checker_id,mc_idx) in
   670:         let match_handler = `AST_index (expr_src,match_handler_id,mh_idx) in
   671:         (*
   672:         print_endline ("Match checker index = " ^ si mc_idx);
   673:         print_endline ("Match handler index = " ^ si mh_idx);
   674:         *)
   675:         let sts,result_expr = rex e in
   676:         let body =
   677:           sts @
   678:           [Exe (expr_src,`EXE_fun_return (result_expr))]
   679:         in
   680:         matches := !matches @
   681:         [
   682:           Dcl (patsrc,match_checker_id,Some mc_idx,`Private,[],
   683:           `DCL_match_check (pat,(match_var_name,match_var_index)));
   684:           Dcl
   685:           (
   686:             expr_src,
   687:             match_handler_id,Some mh_idx,
   688:             `Private,
   689:             [],
   690:             `DCL_match_handler
   691:             (
   692:               pat,
   693:               (match_var_name,match_var_index),
   694:               body
   695:             )
   696:           )
   697:         ]
   698:         @
   699:         [
   700:         Exe (patsrc,`EXE_comment ("match case " ^ si !match_caseno^":" ^ string_of_pattern pat))
   701:         ]
   702:         @
   703:         (
   704:         (* we dont need a label for the first case *)
   705:         if !match_caseno <> 1 then
   706:         [
   707:         Exe (patsrc,`EXE_label ("_ml" ^ si n1))
   708:         ]
   709:         else []
   710:         )
   711:         @
   712: 
   713:         (* This code checks the match condition, it can be
   714:            elided if the match is wildcard
   715:         *)
   716:         (if !iswild then [] else
   717:         [
   718:           Exe
   719:           (
   720:             patsrc,
   721:             `EXE_ifnotgoto
   722:             (
   723:               `AST_apply
   724:               (
   725:                 patsrc,
   726:                 (
   727:                   match_checker,
   728:                   `AST_tuple (patsrc,[])
   729:                 )
   730:               ),
   731:               "_ml" ^ si n2
   732:             )
   733:           )
   734:         ]
   735:         )
   736:         @
   737:         [
   738:         Exe
   739:         (
   740:           patsrc,
   741:           `EXE_fun_return
   742:           (
   743:             `AST_apply
   744:             (
   745:               patsrc,
   746:               (
   747:                 match_handler,
   748:                 `AST_tuple (patsrc,[])
   749:               )
   750:             )
   751:           )
   752:         )
   753:         (*
   754:         ;
   755:         Exe (patsrc,`EXE_goto end_match_label)
   756:         *)
   757:         ]
   758:         ;
   759:         incr match_caseno;
   760:         match_seq := n2
   761:       end
   762:     )
   763:     pss
   764:     ;
   765:     let failure_label = "_ml" ^ si !match_seq in
   766: 
   767:     let match_function_body =
   768:     d
   769:     @
   770:     evl
   771:     @
   772:     !matches
   773:     @
   774:     (if !iswild then [] else
   775:       let f,sl,sc,el,ec = sr in
   776:       let s = Flx_print.string_of_string f ^"," ^
   777:         si sl ^ "," ^ si sc ^ "," ^
   778:         si el ^ "," ^ si ec
   779:       in
   780:       [
   781:         Exe (sr,`EXE_comment "match failure");
   782:         Exe (sr,`EXE_label failure_label);
   783:         Exe (sr,`EXE_noreturn_code (`Str ("      FLX_MATCH_FAILURE("^s^");\n")));
   784:       ]
   785:     )
   786:     in
   787:     [
   788:       Dcl
   789:       (
   790:         sr,
   791:         match_function_id,Some match_function_index,
   792:         `Private,
   793:         [],
   794:         `DCL_function
   795:         (
   796:           ([],None),
   797:           `TYP_none,
   798:           [`Inline;`Generated "desugar:match fun"],
   799:           match_function_body
   800:         )
   801:       )
   802:     ]
   803:     ,
   804:     `AST_apply
   805:     (
   806:       sr,
   807:       (
   808:         match_function,
   809:         `AST_tuple (sr,[])
   810:       )
   811:     )
   812: 
   813: (* remove blocks *)
   814: (* parent vs is containing module vs .. only for modules *)
   815: 
   816: and maybe_tpat = function
   817:   | `TPAT_any -> ""
   818:   | tp -> ": " ^ string_of_tpattern tp
   819: 
   820: and string_of_vs (vs:vs_list_t) =
   821:   cat "," (map (fun (v,tp) -> v ^ maybe_tpat tp) vs)
   822: 
   823: and rst syms name access (parent_vs:vs_list_t) st : asm_t list =
   824:   (* construct an anonymous name *)
   825:   let parent_ts sr : typecode_t list =
   826:     map (fun (s,tp)-> `AST_name (sr,s,[])) parent_vs
   827:   in
   828:   let rqname' sr = `AST_name (sr,"_rqs_" ^ name,parent_ts sr) in
   829: 
   830:   (* Add a root to child named 'n'.
   831:      All root requirements in the child go to this symbol,
   832:      and it requires our root in turn.
   833: 
   834:      parent_vs is the vs list required for us,
   835:      it is always empty for a function.
   836:   *)
   837:   let bridge n sr : asm_t =
   838:     (*
   839:     print_endline ("Making bridge for " ^ n ^ " -> " ^ name ^"["^string_of_vs _vs ^"]");
   840:     *)
   841:     let ts = map (fun (s,_)-> `AST_name (sr,s,[])) parent_vs in
   842:     let us = `NREQ_atom (`AST_name (sr,"_rqs_" ^ name,ts)) in
   843:     let body = `DCL_insert (`Str "",`Body,us) in
   844:     Dcl (sr,"_rqs_"^n,None,`Public,[],body)
   845:   in
   846: 
   847:   (* rename _root requirements *)
   848:   let map_reqs sr (reqs : named_req_expr_t) : named_req_expr_t =
   849:     `NREQ_and (`NREQ_atom (rqname' sr), reqs)
   850:   in
   851: 
   852:   (* name literal requirements *)
   853:   let mkprop sr s = match s with
   854:     | "needs_gc" -> `Uses_gc
   855:     | "needs_ptf" -> `Requires_ptf
   856:     | x -> clierr sr ("Unknown property " ^ x)
   857:   in
   858:   let mkreqs sr (rqs :raw_req_expr_t) : property_t list * asm_t list * named_req_expr_t =
   859:     let ix = None in
   860:     let props = ref [] in
   861:     let decls = ref [] in
   862:     let rec aux rqs = match rqs with
   863:     | `RREQ_or (a,b) -> `NREQ_or (aux a, aux b)
   864:     | `RREQ_and (a,b) -> `NREQ_and (aux a, aux b)
   865:     | `RREQ_true -> `NREQ_true
   866:     | `RREQ_false -> `NREQ_false
   867:     | `RREQ_atom x -> match x with
   868:       | `Body_req s ->
   869:         let n = !(syms.counter) in incr syms.counter;
   870:         let n = "_req_" ^ si n in
   871:         let dcl = Dcl (sr,n,ix,access,[],`DCL_insert (s,`Body,`NREQ_true)) in
   872:         decls := dcl :: !decls;
   873:         `NREQ_atom (`AST_name (sr,n,parent_ts sr))
   874: 
   875:       | `Header_req s ->
   876:         let n = !(syms.counter) in incr syms.counter;
   877:         let n = "_req_" ^ si n in
   878:         let dcl = Dcl (sr,n,ix,access,[],`DCL_insert (s,`Header,`NREQ_true)) in
   879:         decls := dcl :: !decls;
   880:         `NREQ_atom (`AST_name (sr,n,parent_ts sr))
   881: 
   882:       | `Package_req s ->
   883:         let n = !(syms.counter) in incr syms.counter;
   884:         let n = "_req_" ^ si n in
   885:         let dcl = Dcl (sr,n,ix,access,[],`DCL_insert (s,`Package,`NREQ_true)) in
   886:         decls := dcl :: !decls;
   887:         `NREQ_atom (`AST_name (sr,n,parent_ts sr))
   888: 
   889:       | `Named_req n -> `NREQ_atom n
   890:       | `Property_req s ->
   891:         props := mkprop sr s :: !props;
   892:         `NREQ_true
   893:     in
   894:     let r = aux rqs in
   895:     !props, !decls, r
   896:   in
   897: 
   898:   (* rename _root headers *)
   899:   let map_req n = if n = "_root" then "_rqs_" ^ name else n in
   900: 
   901:   let rex x = rex syms name x in
   902:   let rsts name vs access sts = concat (map (rst syms name access vs) sts) in
   903:   let seq () = let n = !(syms.counter) in incr (syms.counter); n in
   904:   (* add _root headers and bodies as requirements for all
   905:     bindings defined in this entity
   906:   *)
   907:   match st with
   908:   | `AST_seq _ -> assert false
   909:   | `AST_private (sr,st) ->
   910:      rst syms name `Private parent_vs st
   911: 
   912:   | `AST_include (sr,inspec) ->
   913:     let sts = include_file syms inspec true in
   914:     rsts name parent_vs  access sts
   915: 
   916:   | `AST_regdef (sr,name,regexp) ->
   917:     [Dcl (sr,name,None,access,[],`DCL_regdef regexp)]
   918:   | `AST_label (sr,s) -> [Exe (sr,`EXE_label s)]
   919:   | `AST_proc_return sr -> [Exe (sr,`EXE_proc_return)]
   920:   | `AST_goto (sr,s) -> [Exe (sr,`EXE_goto s)]
   921:   | `AST_open (sr,name) -> [Dir (sr,DIR_open name)]
   922:   | `AST_inject_module (sr,name) -> [Dir (sr,DIR_inject_module name)]
   923:   | `AST_use (sr,n,qn) -> [Dir (sr,DIR_use (n,qn))]
   924:   | `AST_comment s -> [Exe (generated,`EXE_comment s)]
   925: 
   926:   (* objects *)
   927:   | `AST_export_fun (sr,name,cpp_name) ->
   928:     [Iface (sr,`IFACE_export_fun (name,cpp_name))]
   929: 
   930:   | `AST_export_type (sr,typ,cpp_name) ->
   931:     [Iface (sr,`IFACE_export_type (typ,cpp_name))]
   932: 
   933:   | `AST_var_decl (sr,name,vs,typ,expr) ->
   934:     begin match typ,expr with
   935:     | Some t, Some e ->
   936:       let d,x = rex e in
   937:       d @ [Dcl (sr,name,None,access,vs,`DCL_var t); Exe (sr,`EXE_init (name,x))]
   938:     | None, Some e ->
   939:       let d,x = rex e in
   940:       d @ [Dcl (sr,name,None,access,vs,`DCL_var (`TYP_typeof x)); Exe (sr,`EXE_init (name,x))]
   941:     | Some t,None -> [Dcl (sr,name,None,access,vs,`DCL_var t)]
   942:     | None,None -> failwith "Expected variable to have type or initialiser"
   943:     end
   944: 
   945:   | `AST_val_decl (sr,name,vs,typ,expr) ->
   946:     begin match typ,expr with
   947:     | Some t, Some e ->
   948:       let d,x = rex e in
   949:       d @ [Dcl (sr,name,None,access,vs,`DCL_val t); Exe (sr,`EXE_init (name,x))]
   950:     | None, Some e ->
   951:       let d,x = rex e in
   952:       d @ [Dcl (sr,name,None,access,vs,`DCL_val (`TYP_typeof x)); Exe (sr,`EXE_init (name,x))]
   953:     | Some t, None -> [Dcl (sr,name,None,access,vs,`DCL_val t)] (* allowed in interfaces *)
   954:     | None,None -> failwith "Expected value to have type or initialiser"
   955:     end
   956: 
   957:   | `AST_lazy_decl (sr,name,vs,typ,expr) ->
   958:     begin match typ,expr with
   959:     | Some t, Some e ->
   960:       let d,x = rex e in
   961:       d @ [Dcl (sr,name,None,access,vs,`DCL_lazy (t,x))]
   962:     | None, Some e ->
   963:       let d,x = rex e in
   964:       d @ [Dcl (sr,name,None,access,vs,`DCL_lazy (`TYP_typeof x,x))]
   965:     | _,None -> failwith "Expected lazy value to have initialiser"
   966:     end
   967: 
   968:   | `AST_const_decl (sr,name, vs,typ, s, reqs) ->
   969:     let props,dcls, reqs = mkreqs sr reqs in
   970:     Dcl (sr,name,None,access,vs,`DCL_const (typ,s, map_reqs sr reqs))
   971:     :: dcls
   972: 
   973:   (* types *)
   974:   | `AST_abs_decl (sr,name,vs,quals,s, reqs) ->
   975:     let props,dcls, reqs = mkreqs sr reqs in
   976:     Dcl (sr,name,None,access,vs,`DCL_abs (quals,s,map_reqs sr reqs))
   977:     :: dcls
   978: 
   979:   | `AST_union (sr,name, vs, components) -> [Dcl (sr,name,None,access,vs,`DCL_union (components))]
   980:   | `AST_struct (sr,name, vs, components) ->  [Dcl (sr,name,None,access,vs,`DCL_struct (components))]
   981:   | `AST_cstruct (sr,name, vs, components) ->  [Dcl (sr,name,None,access,vs,`DCL_cstruct (components))]
   982:   | `AST_cclass (sr,name, vs, components) ->  [Dcl (sr,name,None,access,vs,`DCL_cclass (components))]
   983: 
   984:   | `AST_class (sr,name', vs', sts) ->
   985:     (* let asms = rsts name' (parent_vs @ vs') sts in *)
   986:     let asms = rsts name' [] `Public sts in
   987:     let asms = bridge name' sr :: asms in
   988:     let mdcl =
   989:       [ Dcl (sr,name',None,access,vs', `DCL_class asms) ]
   990:     in mdcl
   991: 
   992: 
   993:   | `AST_type_alias (sr,name,vs,typ) -> [Dcl (sr,name,None,access,vs,`DCL_type_alias (typ))]
   994:   | `AST_inherit (sr,name,vs,qn) -> [Dcl (sr,name,None,access,vs,`DCL_inherit qn)]
   995:   | `AST_inherit_fun (sr,name,vs,qn) -> [Dcl (sr,name,None,access,vs,`DCL_inherit_fun qn)]
   996: 
   997:   | `AST_curry (sr,name',vs,pps,ret,kind,sts) ->
   998:     rst syms name access parent_vs (mkcurry seq sr name' vs pps ret kind sts [])
   999: 
  1000:   (* The object *)
  1001:   (* THIS IS HACKY AND DOESN'T WORK PROPERLY --
  1002:     need a real object construction --
  1003:     the constructor name and object type should
  1004:     be the same .. at present the exported type
  1005:     may refer to typedefs in the constructor function,
  1006:     and these cant be found by lookup .. really
  1007:     we need to use a proper construction that will
  1008:     be bound correctly without lookup
  1009:   *)
  1010:   | `AST_object (sr,name,vs,params,sts) ->
  1011:     let vs',params = fix_params seq params in
  1012:     let vs = vs @ vs' in
  1013:     let methods = find_methods seq sr sts in
  1014:     let mtuple =
  1015:       `AST_tuple
  1016:       (
  1017:         sr,
  1018:         map
  1019:           (fun (n,t) ->
  1020:             match t with
  1021:             | `TYP_function (d,_) ->
  1022:               `AST_suffix ( sr, ( `AST_name (sr,n,[]), d))
  1023:             | _ -> assert false
  1024:           )
  1025:           methods
  1026:       )
  1027:     in
  1028:     let otname = "_ot_" ^ name in
  1029:     let rtyp = `AST_name (sr,otname,[]) in
  1030:     let retval:expr_t = `AST_apply (sr,(rtyp, mtuple)) in
  1031:     let sts = sts @ [`AST_fun_return (sr,retval)] in
  1032:     let asms = rsts name [] `Public sts in
  1033:     let asms = bridge name sr :: asms in
  1034:     [
  1035:       Dcl (sr,otname,None,access,vs,`DCL_struct methods);
  1036:       Dcl (sr,name,None,access,vs,`DCL_function (params,rtyp,[],asms))
  1037:     ]
  1038: 
  1039:   (* functions *)
  1040:   | `AST_reduce (sr,name,vs,params, rsrc,rdst) ->
  1041:     [ Dcl (sr,name,None,access,vs,`DCL_reduce (params,rsrc,rdst)) ]
  1042: 
  1043:   | `AST_axiom (sr,name,vs,params, rsrc) ->
  1044:     [ Dcl (sr,name,None,access,vs,`DCL_axiom (params,rsrc)) ]
  1045: 
  1046:   | `AST_function (sr,name', vs, params, (res,postcondition), props, sts) ->
  1047:     let ps,traint = params in
  1048:     begin match traint,postcondition with
  1049:     | None,None ->
  1050:       let vs',params = fix_params seq params in
  1051:       let vs = vs @ vs' in
  1052:       let asms = rsts name' [] `Public sts in
  1053:       let asms = bridge name' sr :: asms in
  1054:       [
  1055:         Dcl (sr,name',None,access,vs,
  1056:           `DCL_function (params, res, props, asms)
  1057:         )
  1058:       ]
  1059:     | pre,post ->
  1060:       let name'' = "_wrap_" ^ name' in
  1061:       let inner = `AST_name (sr,name'',[]) in
  1062:       let un = `AST_tuple (sr,[]) in
  1063:       let sts =
  1064:         (match pre with
  1065:         | None -> []
  1066:         | Some x -> [`AST_assert (src_of_expr x,x)]
  1067:         )
  1068:         @
  1069:         [
  1070:           `AST_function (sr,name'', [],([],None),(res,None),props,sts);
  1071:         ]
  1072:         @
  1073:         begin match res with
  1074:         | `AST_void _ ->
  1075:            [`AST_call (sr,inner,un) ] @
  1076:            begin match post with
  1077:            | None -> []
  1078:            | Some y -> [`AST_assert (src_of_expr y,y)]
  1079:            end
  1080:           | _ ->
  1081:             let retval:expr_t = `AST_apply(sr,(inner,un)) in
  1082:             begin match post with
  1083:             | None ->
  1084:               [`AST_fun_return (sr,retval)]
  1085:             | Some y ->
  1086:               [
  1087:                 `AST_val_decl (sr,"result",[],None,Some retval);
  1088:                 `AST_assert (src_of_expr y,y);
  1089:                 `AST_fun_return (sr,`AST_name (sr,"result",[]))
  1090:               ]
  1091:             end
  1092:         end
  1093:       in
  1094:       let st =
  1095:         `AST_function (sr,name',vs,(ps,None),(res,None),props,sts)
  1096:       in
  1097:       rst syms name access parent_vs st
  1098:     end
  1099: 
  1100:   | `AST_fun_decl (sr,name',vs,args,result,code, reqs,prec) ->
  1101:     let props, dcls, reqs = mkreqs sr reqs in
  1102:     (* hackery *)
  1103:     let vs,args = fold_left (fun (vs,args) arg -> match arg with
  1104:         | `TYP_apply
  1105:           (
  1106:             `AST_name (_,"excl",[]),
  1107:             `AST_name (sr,name,[])
  1108:           ) ->
  1109:             let n = seq() in
  1110:             let var = "T"^si n in
  1111:             (*
  1112:             print_endline ("Implicit var " ^ var);
  1113:             *)
  1114:             let v = var,`TPAT_name (name,[]) in
  1115:             let arg = `AST_name (sr,var,[]) in
  1116:             v::vs, arg:: args
  1117:         | x -> vs,x::args
  1118:       )
  1119:       (rev vs,[])
  1120:       args
  1121:     in
  1122:     Dcl (sr,name',None,access,rev vs,
  1123:       `DCL_fun (props,rev args,result,code,map_reqs sr reqs,prec))
  1124:     :: dcls
  1125: 
  1126:   | `AST_callback_decl (sr,name',args,result,reqs) ->
  1127:     let props, dcls, reqs = mkreqs sr reqs in
  1128:     Dcl (sr,name',None,access,[],
  1129:       `DCL_callback (props,args,result,map_reqs sr reqs))
  1130:     :: dcls
  1131: 
  1132:   (* misc *)
  1133:   | `AST_untyped_module (sr,name', vs', sts) ->
  1134:     let asms = rsts name' (parent_vs @ vs') `Public sts in
  1135:     let asms = bridge name' sr :: asms in
  1136:     let mdcl =
  1137:       [ Dcl (sr,name',None,access,vs', `DCL_module asms) ]
  1138:     in
  1139:       (* HACK !!!! *)
  1140:     if vs' = [] then
  1141:     (
  1142:       Exe
  1143:       (
  1144:         sr,
  1145:         `EXE_call
  1146:         (
  1147:           `AST_suffix
  1148:           (
  1149:             sr,
  1150:             (
  1151:               `AST_lookup
  1152:               (
  1153:                 sr,
  1154:                 (
  1155:                   `AST_name (sr,name',[]),
  1156:                   "_init_",
  1157:                   []
  1158:                 )
  1159:               ),
  1160:               `TYP_tuple []
  1161:             )
  1162:           ),
  1163:           `AST_tuple (generated,[])
  1164:         )
  1165:       )
  1166:     ) :: mdcl else mdcl
  1167: 
  1168:   | `AST_insert (sr,name',vs,s,kind,reqs) ->
  1169:     let props, dcls, reqs = mkreqs sr reqs in
  1170:     (* SPECIAL case: insertion requires insertion use filo order *)
  1171:     dcls @ [
  1172:       Dcl (sr,map_req name',None,access,vs,`DCL_insert (s, kind, map_reqs sr reqs))
  1173:     ]
  1174: 
  1175:   (* executable *)
  1176:   | `AST_fun_return (sr,e) ->
  1177:     let d,x = rex e in d @ [Exe (sr,`EXE_fun_return x)]
  1178: 
  1179:   | `AST_assert (sr,e) ->
  1180:     let d,x = rex e in d @ [Exe (sr,`EXE_assert x)]
  1181: 
  1182:   | `AST_nop _ -> []
  1183: 
  1184:   | `AST_cassign (sr,l,r) ->
  1185:      let l1,x1 = rex l in
  1186:      let l2,x2 = rex r in
  1187:      l1 @ l2 @ [Exe (sr,`EXE_assign (x1,x2))]
  1188: 
  1189:   | `AST_assign (sr,fid,l,r) ->
  1190:     let rec aux (l,t) r =
  1191:       match l with
  1192:       | `Expr (sr,e) ->
  1193:         begin match e with
  1194:         | `AST_tuple (_,ls) ->
  1195:           let n = seq() in
  1196:           let vn = "_" ^ si n in
  1197:           let sts = ref [] in
  1198:           let count = ref 0 in
  1199:           iter
  1200:           (fun l ->
  1201:             let r' = `AST_get_n (sr,(!count,`AST_name (sr,vn,[]))) in
  1202:             let l' = `Expr (sr,l),None in
  1203:             let asg = aux l' r' in
  1204:             sts := !sts @ asg;
  1205:             incr count
  1206:           )
  1207:           ls
  1208:           ;
  1209:           `AST_val_decl (sr,vn,[],t,Some r) :: !sts
  1210:         | _ ->
  1211:           if fid = "_init"
  1212:           then
  1213:             match e with
  1214:             | `AST_coercion (_,(`AST_name (_,n,[]),t')) ->
  1215:               let t = match t with
  1216:                 | None -> Some t'
  1217:                 | t -> t
  1218:               in
  1219:               [`AST_val_decl (sr,n,[],t,Some r)]
  1220: 
  1221:             | `AST_name (_,n,[]) ->
  1222:               [`AST_val_decl (sr,n,[],t,Some r)]
  1223:             | _ -> clierr sr "identifier required in val init"
  1224:           else
  1225:             [assign sr fid e r]
  1226:         end
  1227:       | `Val (sr,n) ->
  1228:           [`AST_val_decl (sr,n,[],t,Some r)]
  1229:       | `Var (sr,n) ->
  1230:           [`AST_var_decl (sr,n,[],t,Some r)]
  1231:       | `Skip (sr) ->  []
  1232:       | `Name (sr,n) ->
  1233:         let n = `AST_name(sr,n,[]) in
  1234:           [assign sr fid n r]
  1235:       | `List ls ->
  1236:           let n = seq() in
  1237:           let vn = "_" ^ si n in
  1238:           let sts = ref [] in
  1239:           let count = ref 0 in
  1240:           iter
  1241:           (fun l ->
  1242:             let r' = `AST_get_n (sr,(!count,`AST_name (sr,vn,[]))) in
  1243:             let asg = aux l r' in
  1244:             sts := !sts @ asg;
  1245:             incr count
  1246:           )
  1247:           ls
  1248:           ;
  1249:           `AST_val_decl (sr,vn,[],t,Some r) :: !sts
  1250:     in
  1251:       let sts = aux l r in
  1252:       rsts name parent_vs access sts
  1253: 
  1254:   | `AST_call (sr,proc, arg) ->
  1255:     let d1,x1 = rex proc in
  1256:     let d2,x2 = rex arg in
  1257:     d1 @ d2 @ [Exe (sr,`EXE_call (x1,x2))]
  1258: 
  1259:   | `AST_apply_ctor (sr,name,f,a) ->
  1260:     let d1,f1 = rex f in
  1261:     let d2,a1 = rex a in
  1262:     let t = `TYP_typeof(f1) in
  1263:     let vs = [] in
  1264:     d1 @ d2 @ [
  1265:       Dcl (sr,name,None,access,vs,`DCL_var t);
  1266:       Exe (sr,`EXE_apply_ctor (name,f1,a1))
  1267:     ]
  1268: 
  1269:   | `AST_init (sr,v,e) ->
  1270:     let d,x = rex e in
  1271:     d @ [Exe (sr,`EXE_init (v,e))]
  1272: 
  1273:   | `AST_jump (sr,proc, arg) ->
  1274:     let d1,x1 = rex proc in
  1275:     let d2,x2 = rex arg in
  1276:     d1 @ d2 @ [Exe (sr,`EXE_jump (x1,x2))]
  1277: 
  1278:   | `AST_loop (sr,proc, arg) ->
  1279:     let d2,x2 = rex arg in
  1280:     d2 @ [Exe (sr,`EXE_loop (proc,x2))]
  1281: 
  1282:   | `AST_ifgoto (sr,e,lab)->
  1283:     let d,x = rex e in
  1284:     d @ [Exe (sr,`EXE_ifgoto (x,lab))]
  1285: 
  1286:   | `AST_ifnotgoto (sr,e,lab)->
  1287:     let d,x = rex e in
  1288:     d @ [Exe (sr,`EXE_ifnotgoto (x,lab))]
  1289: 
  1290: 
  1291:   | `AST_svc (sr,name) ->  [Exe (sr,`EXE_svc name)]
  1292:   | `AST_code (sr,s) -> [Exe (sr,`EXE_code s)]
  1293:   | `AST_noreturn_code (sr,s) -> [Exe (sr,`EXE_noreturn_code s)]
  1294: 
  1295:   (* split into multiple declarations *)
  1296:   | `AST_glr (sr, id, t, ms )  ->
  1297:     let rec aux dcls ms = match ms with
  1298:     | [] ->dcls
  1299:     | (sr',p,e)::ta ->
  1300:        let glr_idx = seq() in
  1301:        let dcls' = handle_glr seq rex sr' p e glr_idx t id in
  1302:        aux (dcls' @ dcls) ta
  1303:     in aux [] ms
  1304: 
  1305:   | `AST_user_statement _
  1306:   | `AST_ctypes _
  1307:   | `AST_expr_macro _
  1308:   | `AST_ifdo _
  1309:   | `AST_ifreturn _
  1310:   | `AST_macro_assign _
  1311:   | `AST_macro_forget _
  1312:   | `AST_macro_goto _
  1313:   | `AST_macro_ifgoto _
  1314:   | `AST_macro_label _
  1315:   | `AST_macro_proc_return _
  1316:   | `AST_macro_val _
  1317:   | `AST_macro_vals _
  1318:   | `AST_macro_var _
  1319:   | `AST_macro_name _
  1320:   | `AST_macro_names _
  1321:   (*
  1322:   | `AST_public _
  1323:   *)
  1324:   | `AST_stmt_macro _
  1325:   | `AST_macro_block _
  1326:   (*
  1327:   | `AST_until _
  1328:   | `AST_whilst _
  1329:   *)
  1330:   | `AST_macro_ifor _
  1331:   | `AST_macro_vfor _
  1332:     -> assert false
  1333: 
  1334: and handle_glr seq rex sr' p e glr_idx t nt_id =
  1335:   (* p can contain expressions now, we have to
  1336:     create dummy glr's for them
  1337:   *)
  1338:   let new_glrs = ref [] in
  1339:   let new_ast (qn:qualified_name_t) : qualified_name_t =
  1340:     (* qs = qn qs | epsilon -- right recursive *)
  1341:     let qt = `TYP_glr_attr_type qn in
  1342:     let typ =
  1343:       `TYP_as
  1344:       (
  1345:         `TYP_sum
  1346:         [
  1347:           `TYP_tuple [];
  1348:           `TYP_tuple [qt; `AST_name (sr',"__fix__",[])]
  1349:         ],
  1350:         "__fix__"
  1351:       )
  1352:     in
  1353:     let glr_idx = seq() in
  1354:     let nt_id = "_ast_" ^ si glr_idx in
  1355:     let nt_name = `AST_name (sr',nt_id,[]) in
  1356:     let p = [(Some "_1",qn); (Some "_2",nt_name)] in
  1357:     let e =
  1358:       `AST_apply
  1359:       (sr',
  1360:         (
  1361:          `AST_typed_case (sr',1,typ),
  1362:          `AST_tuple
  1363:            (
  1364:              sr',
  1365:              [
  1366:                `AST_name (sr',"_1",[]);
  1367:                `AST_name (sr',"_2",[])
  1368:              ]
  1369:           )
  1370:         )
  1371:       )
  1372:     in
  1373:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1374: 
  1375:     let e = `AST_typed_case (sr',0,typ) in
  1376:     let p = [] in
  1377:     let glr_idx = seq() in
  1378:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1379:     `AST_name (sr',nt_id,[])
  1380:   in
  1381:   let new_plus (qn:qualified_name_t) : qualified_name_t =
  1382:     (* qs = qn qs | qn -- right recursive *)
  1383:     let qt = `TYP_glr_attr_type qn in
  1384:     let typ =
  1385:       `TYP_as
  1386:       (
  1387:         `TYP_sum
  1388:         [
  1389:           `TYP_tuple [];
  1390:           `TYP_tuple [qt; `AST_name (sr',"__fix__",[])]
  1391:         ],
  1392:         "__fix__"
  1393:       )
  1394:     in
  1395:     let glr_idx = seq() in
  1396:     let nt_id = "_plus_" ^ si glr_idx in
  1397:     let nt_name = `AST_name (sr',nt_id,[]) in
  1398:     let p = [(Some "_1",qn); (Some "_2",nt_name)] in
  1399:     let e =
  1400:       `AST_apply
  1401:       (sr',
  1402:         (
  1403:          `AST_typed_case (sr',1,typ),
  1404:          `AST_tuple
  1405:            (
  1406:              sr',
  1407:              [
  1408:                `AST_name (sr',"_1",[]);
  1409:                `AST_name (sr',"_2",[])
  1410:              ]
  1411:           )
  1412:         )
  1413:       )
  1414:     in
  1415:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1416: 
  1417:     let e =
  1418:       `AST_apply
  1419:       (sr',
  1420:         (
  1421:          `AST_typed_case (sr',1,typ),
  1422:          `AST_tuple
  1423:            (
  1424:              sr',
  1425:              [
  1426:                `AST_name (sr',"_1",[]);
  1427:                `AST_typed_case (sr',0,typ)
  1428:              ]
  1429:           )
  1430:         )
  1431:       )
  1432:     in
  1433: 
  1434:     let p = [(Some "_1",qn)] in
  1435:     let glr_idx = seq() in
  1436:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1437:     `AST_name (sr',nt_id,[])
  1438:   in
  1439:   let new_opt (qn:qualified_name_t) : qualified_name_t =
  1440:     (* qs = qn | epsilon *)
  1441:     let qt = `TYP_glr_attr_type qn in
  1442:     let typ = `TYP_sum [ `TYP_tuple []; qt] in
  1443:     let glr_idx = seq() in
  1444:     let nt_id = "_opt_" ^ si glr_idx in
  1445:     let nt_name = `AST_name (sr',nt_id,[]) in
  1446:     let p = [(Some "_1",qn)] in
  1447:     let e =
  1448:       `AST_apply
  1449:       (sr',
  1450:         (
  1451:          `AST_typed_case (sr',1,typ),
  1452:          `AST_name (sr',"_1",[])
  1453:         )
  1454:       )
  1455:     in
  1456:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1457: 
  1458:     let e = `AST_typed_case (sr',0,typ) in
  1459:     let p = [] in
  1460:     let glr_idx = seq() in
  1461:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1462:     `AST_name (sr',nt_id,[])
  1463:   in
  1464: 
  1465:   let new_seq (qs:qualified_name_t list) : qualified_name_t =
  1466:     let n = length qs in
  1467:     let typ = `TYP_tuple (map (fun qn -> `TYP_glr_attr_type qn) qs) in
  1468:     let glr_idx = seq() in
  1469:     let nt_id = "_seq_" ^ si glr_idx in
  1470:     let nt_name = `AST_name (sr',nt_id,[]) in
  1471:     let p = combine (map (fun n -> Some ("_"^ si n)) (nlist n)) qs in
  1472:     let e =
  1473:       `AST_tuple
  1474:       (
  1475:         sr',
  1476:         map
  1477:         (fun n -> `AST_name (sr',"_"^si n,[]))
  1478:         (nlist n)
  1479:       )
  1480:     in
  1481:     new_glrs := (p,e,glr_idx,typ,nt_id) :: !new_glrs;
  1482:     `AST_name (sr',nt_id,[])
  1483:   in
  1484: 
  1485:   let new_alt t = failwith "can't handle glr alt yet" in
  1486:   let rec unravel t: qualified_name_t = match t with
  1487:   | `GLR_name qn -> qn
  1488:   | `GLR_ast t -> new_ast (unravel t)
  1489:   | `GLR_plus t -> new_plus (unravel t)
  1490:   | `GLR_opt t -> new_opt (unravel t)
  1491:   | `GLR_seq ts -> new_seq (map unravel ts)
  1492:   | `GLR_alt ts -> new_alt (map unravel ts)
  1493:   in
  1494:   let p = map (fun (name,t) -> name,unravel t) p in
  1495:   let dcls = inner_handle_glr seq rex sr' p e glr_idx t nt_id in
  1496:   dcls @
  1497:   concat
  1498:   (
  1499:     map
  1500:     (fun (p,e,glr_idx,t,nt_id) ->
  1501:       inner_handle_glr seq rex sr' p e glr_idx t nt_id
  1502:     )
  1503:     !new_glrs
  1504:   )
  1505: 
  1506: 
  1507: and inner_handle_glr seq rex sr' p e glr_idx t nt_id =
  1508:    (* we turn the expression into a call to a function
  1509:     so any lambdas lifted out are nested in the
  1510:     function, and rely on the call to bind to the
  1511:     arguments, and we mark the function noinline,
  1512:     to stop it being inlined into the C wrapper code
  1513:   *)
  1514: 
  1515:   let fun_idx = seq() in
  1516:   let fun_id = nt_id ^ "_" ^ si fun_idx in
  1517:   let fun_ref = `AST_index (sr',fun_id,fun_idx) in
  1518:   let params : (string * typecode_t) list =
  1519:     let rec aux params prod = match prod with
  1520:     | [] -> rev params
  1521:     | (None,_):: tail -> aux params tail
  1522:     | (Some n,qn) :: tail ->
  1523:       let typ = `TYP_glr_attr_type qn in
  1524:       aux ((n,typ)::params) tail
  1525:     in aux [] p
  1526:   in
  1527:   let lams,x = rex e in
  1528:   let d: asm_t = Dcl
  1529:     (
  1530:       sr',
  1531:       fun_id, Some fun_idx,
  1532:       `Private,
  1533:       [],
  1534:       `DCL_function
  1535:       (
  1536:         (params,None),
  1537:         `TYP_none,
  1538:         [`NoInline],
  1539:         (Exe (sr',`EXE_fun_return x) :: lams)
  1540:        )
  1541:     )
  1542:   in
  1543:   let args = map (fun (n,_) -> `AST_name (sr',n,[])) params in
  1544:   let invoke = `AST_apply(sr',(fun_ref,`AST_tuple (sr',args))) in
  1545:   let dcl =   `DCL_glr (t,(p,invoke)) in
  1546:   let dcl =   Dcl (sr',nt_id,Some glr_idx,`Public,[],dcl) in
  1547:   [d; dcl]
  1548: 
  1549: let typeofargs a =
  1550:       match map snd a with
  1551:       | [x] -> x
  1552:       | lst -> `TYP_tuple lst
  1553: 
  1554: 
  1555: let desugar_program syms name sts =
  1556:   let sts = match sts with
  1557:     | [] -> [`AST_nop (generated, "empty module")]
  1558:     | _ -> sts
  1559:   in
  1560:   let sr =
  1561:     rsrange
  1562:       (src_of_stmt (hd sts))
  1563:       (src_of_stmt (list_last sts))
  1564:   in
  1565:   let sts = expand_macros name 5000 sts in
  1566:   (*
  1567:   let sts = `AST_body(sr,"_rqs__top",[],"",[]) :: sts in
  1568:   *)
  1569:   rst syms name `Public [] (`AST_untyped_module (sr,name,[],sts))
  1570: 
End ocaml section to src/flx_desugar.ml[1]
Start ocaml section to src/flxd.ml[1 /1 ]
     1: # 1595 "./lpsrc/flx_desugar.ipk"
     2: open Flx_util
     3: open Flx_desugar
     4: open Flx_print
     5: open Flx_types
     6: open Flx_getopt
     7: open Flx_flxopt
     8: open Flx_version
     9: open Flx_mtypes1
    10: open Flx_mtypes2
    11: 
    12: let print_help () = print_options(); exit(0)
    13: ;;
    14: 
    15: let reverse_return_parity = ref false
    16: ;;
    17: try
    18:   let argc = Array.length Sys.argv in
    19:   if argc <= 1
    20:   then begin
    21:     print_endline "usage: flxg --key=value ... filename; -h for help";
    22:     exit 0
    23:   end
    24:   ;
    25:   let raw_options = parse_options Sys.argv in
    26:   let compiler_options = get_felix_options raw_options in
    27:   reverse_return_parity := compiler_options.reverse_return_parity
    28:   ;
    29:   let syms = make_syms compiler_options in
    30: 
    31:   if check_keys raw_options ["h"; "help"]
    32:   then print_help ()
    33:   ;
    34:   if check_key raw_options "version"
    35:   then (print_endline ("Felix Version " ^ !version_data.version_string))
    36:   ;
    37:   if compiler_options.print_flag then begin
    38:     print_string "//Include directories = ";
    39:     List.iter (fun d -> print_string (d ^ " "))
    40:     compiler_options.include_dirs;
    41:     print_endline ""
    42:   end
    43:   ;
    44: 
    45:   let filename =
    46:     match get_key_value raw_options "" with
    47:     | Some s -> s
    48:     | None -> exit 0
    49:   in
    50:   let filebase = filename in
    51:   let input_file_name = filebase ^ ".flx"
    52:   and iface_file_name = filebase ^ ".fix"
    53:   and module_name =
    54:     let n = String.length filebase in
    55:     let i = ref (n-1) in
    56:     while !i <> -1 && filebase.[!i] <> '/' do decr i done;
    57:     String.sub filebase (!i+1) (n - !i - 1)
    58:   in
    59: 
    60:   (* PARSE THE IMPLEMENTATION FILE *)
    61:   print_endline ("//Parsing Implementation " ^ input_file_name);
    62:   let parse_tree =
    63:     Flx_desugar.include_file syms input_file_name false
    64:   in
    65:   print_endline (Flx_print.string_of_compilation_unit parse_tree);
    66:   print_endline "//PARSE OK";
    67: 
    68:   print_endline "//----------------------------";
    69:   print_endline "//IMPLEMENTATION DESUGARED:";
    70: 
    71:   let include_dirs =  (* (Filename.dirname input_file_name) :: *) compiler_options.include_dirs in
    72:   let compiler_options = { compiler_options with include_dirs = include_dirs } in
    73:   let syms = { syms with compiler_options = compiler_options } in
    74:   let deblocked = desugar_program syms module_name parse_tree in
    75:   print_endline (Flx_print.string_of_desugared deblocked);
    76:   print_endline "//----------------------------";
    77: 
    78: with x -> Flx_terminate.terminate !reverse_return_parity x
    79: ;;
    80: 
End ocaml section to src/flxd.ml[1]