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: