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: