5.32. Desugaring

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