1: # 44 "./lpsrc/flx_macro.ipk"
2: open Flx_ast
3: open Flx_mtypes2
4: open Flx_print
5: open Flx_exceptions
6: open List
7: open Flx_constfld
8: open Flx_srcref
9: open Flx_typing2
10: open Flx_util
11:
12: exception Macro_return
13: let dfltvs = [],{ raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]}
14:
15: let truthof x = match x with
16: | `AST_typed_case (_,0,`TYP_unitsum 2) -> Some false
17: | `AST_typed_case (_,1,`TYP_unitsum 2) -> Some true
18: | _ -> None
19:
20: (*
21: There are no type macros: use typedef facility.
22: There are no regexp macros: use regdef facility.
23: *)
24:
25: type macro_t =
26: | MVar of expr_t ref
27: | MVal of expr_t
28: | MVals of expr_t list
29: | MExpr of macro_parameter_t list * expr_t
30: | MStmt of macro_parameter_t list * statement_t list
31: | MName of id_t
32: | MNames of id_t list
33:
34: type macro_dfn_t = id_t * macro_t
35:
36: let print_mpar (id,t) =
37: id ^ ":" ^
38: (
39: match t with
40: | Expr -> "fun"
41: | Stmt -> "proc"
42: | Ident -> "ident"
43: )
44:
45: let print_mpars x =
46: "(" ^ String.concat ", " (map print_mpar x) ^ ")"
47:
48: let print_macro (id,t) =
49: match t with
50: | MVar v -> "MVar " ^ id ^ " = " ^ string_of_expr !v
51: | MVal v -> "MVal " ^ id ^ " = " ^ string_of_expr v
52: | MVals vs -> "MVals " ^ id ^ " = " ^ catmap "," string_of_expr vs
53: | MExpr (ps,e) ->
54: "MExpr " ^ id ^
55: print_mpars ps ^
56: " = " ^
57: string_of_expr e
58:
59: | MStmt (ps,sts) ->
60: "MStmt " ^ id ^
61: print_mpars ps ^
62: " = " ^
63: String.concat "\n" (map (string_of_statement 1) sts)
64:
65: | MName id' -> "MName " ^ id ^ " = " ^ id'
66: | MNames ids -> "MNames " ^ id ^ " = " ^ cat "," ids
67:
68: let upper = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
69: let lower = "abcdefghijklmnopqrstuvwxyz"
70: let digits = "0123456789"
71:
72: let idstart = upper ^ lower ^ "_"
73: let idmore = idstart ^ digits ^ "'"
74: let quotes = "\"'`"
75:
76: let starts_id ch = String.contains idstart ch
77: let continues_id ch = String.contains idmore ch
78: let is_quote ch = String.contains quotes ch
79:
80: let string_of_macro_env x = String.concat "\n" (map print_macro x)
81:
82: (* ident expansion: guarranteed to terminate,
83: expansion of x given x -> x is just x
84: *)
85: let rec expand_ident sr macros noexpand id =
86: try
87: if mem id noexpand then id else
88: match assoc id macros with
89: | MName id2 -> expand_ident sr macros (id::noexpand) id2
90: | _ -> id
91: with Not_found -> id
92:
93: (* Find variable names in patterns so as to protect them *)
94: let rec get_pattern_vars pat =
95: match pat with
96: | `PAT_name (_,v) -> [v]
97: | `PAT_as (_,p,v) -> v :: get_pattern_vars p
98: | `PAT_when (_,p,_) -> get_pattern_vars p
99: | `PAT_nonconst_ctor (_,_,p) -> get_pattern_vars p
100: | `PAT_tuple (_,ps) -> concat (map get_pattern_vars ps)
101: | _ -> []
102:
103: (* protect parameter names, to prevent gratuitous substitions *)
104: let protect sr (ps:id_t list) : macro_dfn_t list =
105: let rec aux t macs =
106: match t with
107: | [] -> macs
108: | h :: t ->
109: let mac = h, MVal (`AST_noexpand (sr,`AST_name (sr,h,[]))) in
110: aux t (mac::macs)
111: in
112: aux ps []
113:
114: let build_args sr ps args =
115: map2
116: (fun (p,t) a ->
117: match t with
118: | Ident ->
119: begin match a with
120: | `AST_name (_,name,[]) -> (p,MName name)
121: | _ ->
122: clierr sr
123: (
124: "[build_args] Wrong argument type, expected Identifier, got:\n" ^
125: string_of_expr a
126: )
127: end
128:
129: | Expr -> (p,MVal a)
130: | Stmt ->
131: begin match a with
132: | `AST_lambda (_,(dfltvs,[[],_],`TYP_none,sts)) -> (p,MStmt ([],sts))
133: | `AST_name(_,name,[]) ->(p,MVal a)
134: | _ ->
135: clierr sr
136: (
137: "[build_args] Wrong argument type, expected {} enclosed statement list or macro procedure name, got\n" ^
138: string_of_expr a
139: )
140: end
141: )
142: ps args
143:
144: let rec parse_expr sr s =
145: let filename = match sr with filename,_,_,_,_ -> "_string_in_"^filename in
146: let pre_tokens = Flx_pretok.pre_tokens_of_string s filename expand_expression in
147: let pre_tokens =
148: match pre_tokens with
149: | Flx_parse.HASH_INCLUDE_FILES _ :: tail -> tail
150: | _ -> assert false
151: in
152: let tokens = Flx_lex1.translate pre_tokens in
153: let toker = (new Flx_tok.tokeniser tokens) in
154: begin try
155: Flx_parse.expr
156: (toker#token_src)
157: (Lexing.from_string "dummy" )
158: with _ ->
159: toker#report_syntax_error;
160: raise (Flx_exceptions.ParseError "Parsing String as Expression")
161: end
162:
163: and interpolate sr s : expr_t =
164: let out = ref "" in
165: let b = ref 0 in
166: let args = ref [] in
167: let arg = ref "" in
168: let apa ch = arg := !arg ^ String.make 1 ch in
169: let aps ch = out := !out ^ String.make 1 ch in
170: let mode = ref `Text in
171: let end_expr () =
172: args := !arg :: !args;
173: arg := "";
174: out := !out ^ "%S";
175: mode := `Text
176: in
177: for i = 0 to String.length s - 1 do
178: let ch = s.[i] in
179: match !mode with
180: | `Text ->
181: begin match ch with
182: | '$' -> mode := `Dollar
183: | _ -> aps ch
184: end
185:
186: | `Dollar ->
187: begin match ch with
188: | '(' ->
189: incr b; apa ch; mode := `Expr
190:
191: | _ when is_quote ch ->
192: mode := `Quote ch
193:
194: | _ when starts_id ch ->
195: apa ch;
196: mode := `Ident
197:
198: | _ -> aps '$'; aps ch; mode := `Text
199: end
200:
201: | `Quote q ->
202: begin match ch with
203: | _ when ch = q -> end_expr()
204: | _ -> apa ch
205: end
206:
207: | `Ident ->
208: begin match ch with
209: | _ when continues_id ch -> apa ch
210: | _ -> end_expr (); aps ch
211: end
212:
213: | `Expr ->
214: begin match ch with
215: | '(' -> incr b; apa ch
216: | ')' ->
217: decr b;
218: apa ch;
219: if !b = 0 then end_expr ()
220: | _ -> apa ch
221: end
222: done
223: ;
224: if !mode = `Expr then end_expr ();
225: let args = rev !args in
226: let args = map (parse_expr sr) args in
227: let str = `AST_name (sr,"str",[]) in
228: let args = map (fun e -> `AST_apply (sr,(str,e))) args in
229: match args with
230: | [] -> `AST_literal (sr,`AST_string !out)
231: | [x] ->
232: `AST_apply (sr,(`AST_vsprintf (sr,!out),x))
233: | _ ->
234: let x = `AST_tuple (sr,args) in
235: `AST_apply (sr,(`AST_vsprintf (sr,!out),x))
236:
237: (* alpha convert parameter names *)
238: and alpha_expr sr local_prefix seq ps e =
239: let psn, pst = split ps in
240: let psn' = (* new parameter names *)
241: map
242: (fun _ -> let b = !seq in incr seq; "_" ^ string_of_int b)
243: psn
244: in
245: let remap =
246: map2
247: (fun x y -> (x,MName y))
248: psn psn'
249: in
250: let e = expand_expr 50 local_prefix seq remap e in
251: let ps = combine psn' pst in
252: ps,e
253:
254: and alpha_stmts sr local_prefix seq ps sts =
255: let psn, pst = split ps in
256: let psn' = (* new parameter names *)
257: map
258: (fun _ -> let b = !seq in incr seq; "_" ^ local_prefix ^ "_" ^ string_of_int b)
259: psn
260: in
261: let remap =
262: map2
263: (fun x y -> (x,MName y))
264: psn psn'
265: in
266: let sts = subst_statements 50 local_prefix seq (ref true) remap sts in
267: let ps = combine psn' pst in
268: ps,sts
269:
270: and expand_type_expr sr recursion_limit local_prefix seq (macros:macro_dfn_t list) (t:typecode_t):typecode_t=
271: if recursion_limit < 1
272: then failwith "Recursion limit exceeded expanding macros";
273: let recursion_limit = recursion_limit - 1 in
274: let me e = expand_expr recursion_limit local_prefix seq macros e in
275: let mt t : typecode_t = expand_type_expr sr recursion_limit local_prefix seq macros t in
276: let mi sr i =
277: let out = expand_ident sr macros [] i in
278: out
279: in
280: match Flx_maps.map_type mt t with
281:
282: (* Name expansion *)
283: | `AST_name (sr, name,[]) as t ->
284: begin try
285: match List.assoc name macros with
286: | MVar b -> typecode_of_expr (me !b)
287: | MVal b -> typecode_of_expr (me b)
288: | MExpr(ps,b) -> t
289: | MName _ -> `AST_name (sr,mi sr name,[])
290: | MStmt (ps,b) -> t
291: | MVals xs -> t
292: | MNames idts -> t
293: with
294: | Not_found -> t
295: end
296:
297: | `AST_name (sr, name,ts) as t ->
298: let ts = map mt ts in
299: begin try
300: match List.assoc name macros with
301: | MName _ -> `AST_name (sr,mi sr name,ts)
302: | _ -> `AST_name (sr,name,ts)
303: with
304: | Not_found -> t
305: end
306:
307: | `TYP_typeof e -> `TYP_typeof (me e)
308:
309: | x -> x
310:
311: (* expand expression *)
312: and expand_expr recursion_limit local_prefix seq (macros:macro_dfn_t list) (e:expr_t):expr_t =
313: (*
314: print_endline ("expand expr " ^ string_of_expr e);
315: *)
316: if recursion_limit < 1
317: then failwith "Recursion limit exceeded expanding macros";
318: let recursion_limit = recursion_limit - 1 in
319: let me e = expand_expr recursion_limit local_prefix seq macros e in
320: let mt sr e = expand_type_expr sr recursion_limit local_prefix seq macros e in
321: let mi sr i =
322: let out = expand_ident sr macros [] i in
323: out
324: in
325: let cf e = const_fold e in
326: let e = cf e in
327: match e with
328:
329: (* This CAN happen: typecase is an ordinary expression
330: with no meaning except as a proxy for a type, however
331: at a macro level, it is an ordinary expression .. hmm
332: *)
333: | `AST_case (sr,pat,ls,res) -> `AST_case (sr, me pat, ls, me res)
334: | `AST_patvar _
335: | `AST_patany _ -> print_endline "HACK.. AST_pat thing in expr"; e
336:
337: (* Expansion block: don't even fold constants *)
338: | `AST_noexpand _ -> e
339: | `AST_vsprintf _ -> e
340: | `AST_interpolate (sr,s) ->
341: let e = interpolate sr s in
342: me e
343:
344: (* and desugaring: x and y and z and ... *)
345: | `AST_andlist (sr, es) ->
346: begin match es with
347: | [] -> failwith "Unexpected empty and list"
348: | h::t ->
349: List.fold_left
350: (fun x y ->
351: me
352: (
353: `AST_apply
354: (
355: sr,
356: (
357: `AST_name ( sr,"land",[]),
358: `AST_tuple (sr,[me x; me y])
359: )
360: )
361: )
362: )
363: h t
364: end
365:
366: (* or desugaring: x or y or z or ... *)
367: | `AST_orlist (sr, es) ->
368: begin match es with
369: | [] -> failwith "Unexpected empty alternative list"
370: | h::t ->
371: List.fold_left
372: (fun x y ->
373: me
374: (
375: `AST_apply
376: (
377: sr,
378: (
379: `AST_name ( sr,"lor",[]),
380: `AST_tuple (sr,[me x; me y])
381: )
382: )
383: )
384: )
385: h t
386: end
387:
388: (* Sum desugaring: x+y+z+ ... *)
389: | `AST_sum (sr, es) ->
390: begin match es with
391: | [] -> failwith "Unexpected empty addition"
392: | h::t ->
393: List.fold_left
394: (fun x y ->
395: me
396: (
397: `AST_apply
398: (
399: sr,
400: (
401: `AST_name ( sr,"add",[]),
402: `AST_tuple (sr,[me x; me y])
403: )
404: )
405: )
406: )
407: h t
408: end
409:
410: (* Product desugaring: x*y*z* ... *)
411: | `AST_product (sr, es) ->
412: begin match es with
413: | [] -> failwith "Unexpected empty multiply"
414: | h::t ->
415: List.fold_left
416: (fun x y ->
417: me
418: (
419: `AST_apply
420: (
421: sr,
422: (
423: `AST_name ( sr,"mul",[]),
424: `AST_tuple (sr,[me x; me y])
425: )
426: )
427: )
428: )
429: h t
430: end
431:
432: (* Setunion desugaring: x || y || z || ... *)
433: | `AST_setunion (sr, es) ->
434: begin match es with
435: | [] -> failwith "Unexpected empty setunion "
436: | h::t ->
437: List.fold_left
438: (fun x y ->
439: me
440: (
441: `AST_apply
442: (
443: sr,
444: (
445: `AST_name ( sr,"setunion",[]),
446: `AST_tuple (sr,[me x; me y])
447: )
448: )
449: )
450: )
451: h t
452: end
453:
454: (* Setintersection desugaring: x && y && z && ... *)
455: | `AST_setintersection (sr, es) ->
456: begin match es with
457: | [] -> failwith "Unexpected empty set intersection"
458: | h::t ->
459: List.fold_left
460: (fun x y ->
461: me
462: (
463: `AST_apply
464: (
465: sr,
466: (
467: `AST_name ( sr,"setintersect",[]),
468: `AST_tuple (sr,[me x; me y])
469: )
470: )
471: )
472: )
473: h t
474: end
475:
476: (* Name expansion *)
477: | `AST_name (sr, name,[]) ->
478: (*
479: print_endline ("EXPANDING NAME " ^ name);
480: *)
481: let mac = try Some (List.assoc name macros) with Not_found -> None in
482: begin match mac with
483: | None -> e
484: | Some mac -> match mac with
485: | MVar b -> me !b
486: | MVal b -> me b
487: | MVals bs -> `AST_tuple (sr,(map me bs))
488: | MExpr(ps,b) ->
489: (*
490: clierr sr ("Name "^name^" expands to unapplied macro function");
491: *)
492: e
493:
494: | MName _ -> `AST_name (sr,mi sr name,[])
495: | MNames _ -> clierr sr "Cannot use macro name list here"
496: | MStmt (ps,b) ->
497: (*
498: clierr sr ("Name "^name^" expands to unapplied macro procedure");
499: *)
500: e
501: end
502:
503: | `AST_name (sr, name,ts) ->
504: let ts = map (mt sr) ts in
505: begin try
506: match List.assoc name macros with
507: | MName _ -> `AST_name (sr,mi sr name,ts)
508: | _ -> `AST_name (sr,name,ts)
509: with
510: | Not_found -> e
511: end
512:
513:
514: (* artificially make singleton tuple *)
515: | `AST_apply (sr,(`AST_name(_,"_tuple",[]),x)) ->
516: (*
517: print_endline "Making singleton tuple";
518: *)
519: `AST_tuple (sr,[me x])
520:
521: | `AST_apply (sr,(`AST_name(_,"_str",[]),x)) ->
522: let x = me x in
523: let x = string_of_expr x in
524: `AST_literal (sr,`AST_string x)
525:
526: | `AST_apply (sr,(`AST_name(_,"_parse_expr",[]),x)) ->
527: let x = me x in
528: let x = cf x in
529: begin match x with
530: | `AST_literal (_,`AST_string s) ->
531: parse_expr sr s
532:
533: | _ -> clierr sr "_parse_expr requires string argument"
534: end
535:
536:
537: (* _tuple_cons (a,t) ->
538: a,t if t is not a tuple
539: tuple t with a prepended otherwise
540:
541: NOTE .. not sure if this should be done
542: before or after expansion ..
543: *)
544: | `AST_apply (sr,
545: (
546: `AST_name(_,"_tuple_cons",[]),
547: `AST_tuple (_,[h;t])
548: )
549: ) ->
550: begin match me t with
551: | `AST_tuple (_,tail) ->
552: (*
553: print_endline "Packing tuple";
554: *)
555: `AST_tuple (sr,me h :: tail)
556: | tail ->
557: (*
558: print_endline "Making pair";
559: *)
560: `AST_tuple (sr, [me h; tail])
561: end
562:
563: (* Name application *)
564: (* NOTE: Felix doesn't support shortcut applications
565: for executable expressions, however these
566: ARE available for macro expansion: this is in
567: fact completely basic: the expression
568: id
569: is indeed expanded and is of course
570: equivalent to
571: id ()
572: *)
573: | `AST_apply (sr, (e1', e2')) ->
574: let
575: e1 = me e1' and
576: e2 = me e2'
577: in
578: begin match e1 with
579: | `AST_name(srn,name,[]) ->
580: begin try
581: match List.assoc name macros with
582: | MName _
583: | MNames _
584: | MVar _
585: | MVal _
586: | MVals _ -> assert false
587:
588: | MExpr(ps,b) ->
589: let args =
590: match e2 with
591: | `AST_tuple (_,ls) -> ls
592: | x -> [x]
593: in
594: let np = length ps and na = length args in
595: if na = np
596: then
597: begin
598: let args = map me args in
599: let args = build_args sr ps args in
600: let b = expand_expr recursion_limit local_prefix (ref 0) args b in
601: me b
602: end
603: else
604: clierr sr
605: (
606: "[expand_expr:apply] In application:\n" ^
607: " fun = " ^string_of_expr e1'^" --> "^string_of_expr e1^"\n"^
608: " arg = " ^string_of_expr e2'^" --> "^string_of_expr e2^"\n"^
609: "Macro "^name^
610: " requires "^string_of_int np^" arguments," ^
611: " got " ^ string_of_int na
612: )
613: | MStmt (ps,b) ->
614: (* replace the application with a lambda wrapping
615: of the corresponding procedure call
616: *)
617: let sts = [`AST_call (sr,e1, e2)] in
618: let sts = expand_statements recursion_limit local_prefix seq (ref true) macros sts in
619: `AST_lambda(sr,(dfltvs,[[],None],`TYP_none,sts))
620: (*
621: clierr sr
622: (
623: "[expand_expr:apply] In application:\n" ^
624: " fun = " ^string_of_expr e1'^" --> "^string_of_expr e1^"\n"^
625: " arg = " ^string_of_expr e2'^" --> "^string_of_expr e2^"\n"^
626: "Macro "^name^
627: " is a procedure macro"
628: )
629: *)
630: with
631: | Not_found ->
632: cf (`AST_apply(sr,(e1, e2)))
633: end
634: | _ ->
635: `AST_apply(sr,(e1, e2))
636: end
637:
638: | `AST_cond (sr, (e1, e2, e3)) ->
639: let cond = me e1 in
640: begin match cond with
641: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
642: if c=1 then me e2 else me e3
643: | _ ->
644: `AST_cond (sr,(cond,me e2,me e3))
645: end
646:
647: | `AST_expr (sr,s,t) -> `AST_expr (sr,s,t)
648:
649: (* Lambda hook *)
650: | `AST_lambda (sr, (vs,pss, t, sts)) ->
651: let pr = concat (map (map (fun(x,y,z)->y)) (map fst pss)) in
652: let pr = protect sr pr in
653: let sts =
654: expand_statements recursion_limit local_prefix seq (ref true)
655: (pr @ macros) sts
656: in
657: `AST_lambda (sr, (vs,pss, t, sts))
658:
659: (* Name lookup *)
660: | `AST_the (sr, qn) ->
661: let qn = Flx_typing.qualified_name_of_expr (me (qn:>expr_t)) in
662: `AST_the (sr,qn)
663:
664: (* the name here is just for diagnostics *)
665: | `AST_index (sr, n, i) -> `AST_index (sr,n,i)
666:
667: | `AST_lookup (sr, (e1, name,ts)) -> `AST_lookup (sr,(me e1, mi sr name,map (mt sr) ts))
668:
669: | `AST_case_tag (sr, i) -> e
670: | `AST_typed_case (sr, i, t) -> e
671: | `AST_case_index (sr,e) -> `AST_case_index (sr,me e)
672:
673: | `AST_macro_ctor (sr,(name,e)) -> `AST_macro_ctor (sr,(name,me e))
674: | `AST_macro_statements (sr,sts) ->
675: let sts =
676: expand_statements recursion_limit local_prefix seq (ref true)
677: macros sts
678: in
679: `AST_macro_statements (sr,sts)
680:
681: | `AST_tuple (sr, es) -> `AST_tuple (sr, map me es)
682: | `AST_record (sr, es) ->
683: `AST_record (sr, map (fun (s,e)-> s, me e) es)
684:
685: | `AST_variant (sr, (s,e)) ->
686: `AST_variant (sr, ( s, me e))
687:
688: | `AST_record_type (sr,ts)
689: | `AST_variant_type (sr,ts) ->
690: clierr sr "Anonymous struct or record type cannot be used as an expression"
691:
692: | `AST_arrayof (sr, es) -> `AST_arrayof (sr, map me es)
693: | `AST_coercion (sr, (e1, t)) -> `AST_coercion (sr, (me e1,mt sr t))
694: | `AST_suffix (sr, (qn, t)) ->
695: let qn = Flx_typing.qualified_name_of_expr (me (qn:>expr_t)) in
696: `AST_suffix (sr, (qn,t))
697:
698: | `AST_callback (sr,qn) ->
699: let qn = Flx_typing.qualified_name_of_expr (me (qn:>expr_t)) in
700: `AST_callback (sr, qn)
701:
702: | `AST_arrow (sr, (e1, e2)) -> `AST_arrow (sr,(me e1, me e2))
703: | `AST_longarrow (sr, (e1, e2)) -> `AST_longarrow (sr,(me e1, me e2))
704: | `AST_superscript (sr, (e1, e2)) -> `AST_superscript (sr,(me e1, me e2))
705:
706: | `AST_literal (sr, literal) -> e
707: | `AST_map (sr, f, e) -> `AST_map (sr, me f, me e)
708: | `AST_deref (sr, e1) -> `AST_deref (sr, me e1)
709: | `AST_ref (sr, e1) -> `AST_ref (sr, me e1)
710: | `AST_new (sr, e1) -> `AST_new (sr, me e1)
711: | `AST_method_apply (sr, (id, e1,ts)) -> `AST_method_apply (sr,(mi sr id, me e1,map (mt sr) ts))
712: (*
713: | `AST_dot (sr, (e1, id, ts)) -> `AST_dot (sr,(me e1,mi sr id, ts))
714: *)
715: | `AST_dot (sr, (e1, e2)) -> `AST_dot (sr,(me e1, me e2))
716: | `AST_match_ctor (sr, (qn, e1)) -> `AST_match_ctor (sr,(qn,me e1))
717: | `AST_match_case (sr, (i, e1)) -> `AST_match_case (sr,(i, me e1))
718: | `AST_ctor_arg (sr, (qn, e1)) -> `AST_ctor_arg (sr,(qn, me e1))
719: | `AST_case_arg (sr, (i, e1)) -> `AST_case_arg (sr,(i,me e1))
720: | `AST_letin (sr, (pat, e1, e2)) -> `AST_letin (sr, (pat, me e1, me e2))
721:
722: | `AST_get_n (sr, (i, e1)) -> `AST_get_n (sr,(i,me e1))
723: | `AST_get_named_variable (sr, (i, e1)) -> `AST_get_named_variable (sr,(i,me e1))
724: | `AST_get_named_method (sr, (i,j,ts, e1)) ->
725: `AST_get_named_method (sr,(i,j,map (mt sr) ts,me e1))
726: | `AST_as (sr, (e1, id)) -> `AST_as (sr,(me e1, mi sr id))
727:
728: | `AST_parse (sr, e1, ms) ->
729: let ms = map (fun (sr,p,e) -> sr,p,me e) ms in
730: `AST_parse (sr, me e1, ms)
731:
732: | `AST_sparse _ -> assert false
733:
734: | `AST_match (sr, (e1, pes)) ->
735: let pes =
736: map
737: (fun (pat,e) ->
738: pat,
739: let pvs = get_pattern_vars pat in
740: let pr = protect sr pvs in
741: expand_expr recursion_limit local_prefix seq (pr @ macros) e
742: )
743: pes
744: in
745: `AST_match (sr,(me e1, pes))
746:
747: | `AST_regmatch (sr, (p1, p2, res)) ->
748: let res = map (fun (rexp,e) -> rexp, me e) res in
749: `AST_regmatch (sr,(me p1, me p2, res))
750:
751: | `AST_string_regmatch (sr, (s, res)) ->
752: let res = map (fun (rexp,e) -> rexp, me e) res in
753: `AST_string_regmatch (sr,(me s, res))
754:
755: | `AST_reglex (sr, (e1, e2, res)) ->
756: let res = map (fun (rexp,e) -> rexp, me e) res in
757: `AST_reglex (sr,(me e1, me e2, res))
758:
759: | `AST_type_match (sr, (e,ps)) ->
760: let ps = map (fun (pat,e) -> pat, mt sr e) ps in
761: `AST_type_match (sr,(mt sr e,ps))
762:
763: | `AST_ellipsis _
764: | `AST_void _ -> e
765:
766: | `AST_lvalue (sr,e) -> `AST_lvalue (sr, me e)
767: | `AST_lift (sr,e) -> `AST_lift (sr, me e)
768:
769: | `AST_typeof (sr,e) -> `AST_typeof (sr, me e)
770:
771: (*
772: -> syserr (Flx_srcref.src_of_expr e) ("Expand expr: expected expresssion, got type: " ^ string_of_expr e)
773: *)
774:
775: (* ---------------------------------------------------------------------
776: do the common work of both subst_statement and expand_statement,
777: recursion to the appropriate one as indicated by the argument 'recurse'
778:
779: The flag 'reachable' is set to false on exit if the instruction
780: does not drop through. The flag may be true or false on entry.
781: Whilst the flag is false, no code is generated. Once the flag
782: is false, a label at the low level can cause subsequent code to become
783: reachble.
784: *)
785: and rqmap me reqs =
786: let r req = rqmap me req in
787: match reqs with
788: | `RREQ_or (a,b) -> `RREQ_or (r a, r b)
789: | `RREQ_and (a,b) -> `RREQ_and (r a, r b)
790: | `RREQ_true -> `RREQ_true
791: | `RREQ_false -> `RREQ_false
792: | `RREQ_atom x -> match x with
793: | `Named_req qn ->
794: let qn = Flx_typing.qualified_name_of_expr (me (qn:>expr_t)) in
795: `RREQ_atom (`Named_req qn)
796: | x -> `RREQ_atom x
797:
798: and subst_or_expand recurse recursion_limit local_prefix seq reachable macros (st:statement_t):statement_t list =
799: (*
800: print_endline ("Subst or expand: " ^ string_of_statement 0 st);
801: *)
802: let recurion_limit = recursion_limit - 1 in
803: let mt sr e = expand_type_expr sr recursion_limit local_prefix seq macros e in
804: let me e = expand_expr recursion_limit local_prefix seq macros e in
805: let rqmap req = rqmap me req in
806: let ms s = recurse recursion_limit local_prefix seq (ref true) macros s in
807: let ms' reachable s = recurse recursion_limit local_prefix seq reachable macros s in
808: let msp sr ps ss =
809: let pr = protect sr ps in
810: recurse recursion_limit local_prefix seq (ref true) (pr @ macros) ss
811: in
812: let mi sr id = expand_ident sr macros [] id in
813: let mq qn = match qn with
814: | `AST_lookup (sr, (e1, name,ts)) ->
815: `AST_lookup (sr,(me e1, mi sr name,map (mt sr) ts))
816: | `AST_name (sr, name, ts) ->
817: `AST_name (sr, mi sr name, map (mt sr) ts)
818: | x -> x
819: in
820: let result = ref [] in
821: let tack x = result := x :: !result in
822: let ctack x = if !reachable then tack x in
823: let cf e = const_fold e in
824:
825: begin match st with
826: (* cheat for now and ignore public and private decls *)
827: (*
828: | `AST_public (_,_,st) -> iter tack (ms [st])
829: *)
830: | `AST_private (sr,st) ->
831: iter (fun st -> tack (`AST_private (sr,st))) (ms [st])
832:
833: | `AST_seq (_,sts) ->
834: iter tack (ms sts)
835:
836: | `AST_include (sr, s) -> tack st
837: | `AST_cparse (sr, s) -> tack st
838:
839: (* FIX TO SUPPORT IDENTIFIER RENAMING *)
840: | `AST_open (sr, vs, qn) ->
841: tack (`AST_open (sr, vs, mq qn))
842:
843: | `AST_inject_module (sr, qn) -> tack st
844:
845: (* FIX TO SUPPORT IDENTIFIER RENAMING *)
846: | `AST_use (sr, id, qn) -> tack (`AST_use (sr,mi sr id,qn))
847:
848: | `AST_cassign (sr,l,r) -> tack (`AST_cassign (sr, me l, me r))
849:
850: | `AST_assign (sr,name,l,r) ->
851: let l = match l with
852: | `Expr (sr,e),t -> `Expr (sr,me e),t
853: | l -> l
854: in
855: tack (`AST_assign (sr, name, l, me r))
856:
857: | `AST_comment _ -> tack st
858:
859: (* IDENTIFIER RENAMING NOT SUPPORTED IN REGDEF *)
860: | `AST_regdef (sr, id, re) -> tack st
861:
862: | `AST_glr (sr, id, t, ms ) ->
863: (* add protection code later .. see AST_match *)
864: let ms = map (fun (sr',p,e) -> sr',p,me e) ms in
865: tack (`AST_glr (sr, mi sr id, mt sr t, ms ))
866:
867: | `AST_union (sr, id, vs, idts ) ->
868: let idts = map (fun (id,v,vs,t) -> id,v,vs,mt sr t) idts in
869: tack (`AST_union (sr, mi sr id, vs, idts))
870:
871: | `AST_struct (sr, id, vs, idts) ->
872: let idts = map (fun (id,t) -> id,mt sr t) idts in
873: tack (`AST_struct (sr, mi sr id, vs, idts))
874:
875: | `AST_cstruct (sr, id, vs, idts) ->
876: let idts = map (fun (id,t) -> id,mt sr t) idts in
877: tack (`AST_cstruct (sr, mi sr id, vs, idts))
878:
879: | `AST_cclass (sr, id, vs, idts) ->
880: let idts = map (function
881: | `MemberVar (id,t,cc) -> `MemberVar (id,mt sr t,cc)
882: | `MemberVal (id,t,cc) -> `MemberVal (id,mt sr t,cc)
883: | `MemberFun (id,mix,vs,t,cc) -> `MemberFun (id,mix,vs,mt sr t,cc)
884: | `MemberProc (id,mix,vs,t,cc) -> `MemberProc (id,mix,vs,mt sr t,cc)
885: | `MemberCtor (id,mix,t,cc) -> `MemberCtor (id,mix,mt sr t,cc)
886: ) idts
887: in
888: tack (`AST_cclass (sr, mi sr id, vs, idts))
889:
890: | `AST_typeclass (sr, id, vs, sts) ->
891: tack (`AST_typeclass (sr, mi sr id, vs, ms sts))
892:
893: | `AST_type_alias (sr, id, vs, t) ->
894: tack (`AST_type_alias (sr,mi sr id,vs, mt sr t))
895:
896: | `AST_inherit (sr, id, vs, t) -> tack st
897: | `AST_inherit_fun (sr, id, vs, t) -> tack st
898:
899: | `AST_ctypes (sr, ids, qs, reqs) ->
900: iter
901: (fun (sr,id) ->
902: let id = mi sr id in
903: let sr = slift sr in
904: let st = `AST_abs_decl (sr,id, dfltvs, qs, `Str id, rqmap reqs) in
905: tack st
906: )
907: ids
908:
909: | `AST_abs_decl (sr,id,vs,typs,v,rqs) ->
910: tack (`AST_abs_decl (sr,mi sr id,vs,typs,v, rqmap rqs))
911:
912: | `AST_newtype (sr,id,vs,t) ->
913: tack (`AST_newtype (sr,mi sr id,vs,mt sr t))
914:
915: | `AST_callback_decl (sr,id,args,ret,rqs) ->
916: tack (`AST_callback_decl (sr,mi sr id,map (mt sr) args,mt sr ret,rqmap rqs))
917:
918: | `AST_const_decl (sr, id, vs, t, c, reqs) ->
919: tack (`AST_const_decl (sr, mi sr id, vs, mt sr t, c, rqmap reqs))
920:
921: | `AST_fun_decl (sr, id, vs, ts, t, c, reqs,prec) ->
922: tack (`AST_fun_decl (sr, mi sr id, vs, map (mt sr) ts, mt sr t, c, rqmap reqs,prec))
923:
924: | `AST_insert (sr, n, vs, s, ikind, reqs) ->
925: tack (`AST_insert (sr,n,vs,s, ikind, rqmap reqs))
926:
927: (*
928: NOTE: c code is embedded even though it isn't
929: reachable because it might contain declarations or
930: even labels
931: *)
932: | `AST_code (sr, s) ->
933: tack st;
934: reachable := true
935:
936: | `AST_noreturn_code (sr, s) ->
937: tack st;
938: reachable := false
939:
940: (* IDENTIFIER RENAMING NOT SUPPORTED IN EXPORT *)
941: | `AST_export_fun (sr, sn, s) -> tack st
942: | `AST_export_type (sr, sn, s) -> tack st
943:
944: | `AST_label (sr, id) ->
945: reachable:=true;
946: tack (`AST_label (sr, mi sr id))
947:
948: | `AST_goto (sr, id) ->
949: ctack (`AST_goto (sr, mi sr id));
950: reachable := false
951:
952: | `AST_svc (sr, id) -> ctack (`AST_svc (sr, mi sr id))
953: | `AST_proc_return (sr) -> ctack st; reachable := false
954: | `AST_halt (sr,s) -> ctack st; reachable := false
955: | `AST_nop (sr, s) -> ()
956:
957: | `AST_reduce (sr, id, vs, ps, e1, e2) ->
958: let ps = map (fun (id,t) -> id,mt sr t) ps in
959: tack(`AST_reduce (sr, mi sr id, vs, ps, me e1, me e2))
960:
961: | `AST_axiom (sr, id, vs, (ps,pre), e1) ->
962: let ps = map (fun (k,id,t) -> k,id,mt sr t) ps in
963: let pre = match pre with | None -> None | Some x -> Some (me x) in
964: let e1 = match e1 with
965: | `Predicate e -> `Predicate (me e)
966: | `Equation (l,r) -> `Equation (me l, me r)
967: in
968: tack(`AST_axiom (sr, mi sr id, vs, (ps,pre), e1))
969:
970: | `AST_lemma (sr, id, vs, (ps,pre), e1) ->
971: let ps = map (fun (k,id,t) -> k,id,mt sr t) ps in
972: let pre = match pre with | None -> None | Some x -> Some (me x) in
973: let e1 = match e1 with
974: | `Predicate e -> `Predicate (me e)
975: | `Equation (l,r) -> `Equation (me l, me r)
976: in
977: tack(`AST_lemma (sr, mi sr id, vs, (ps,pre), e1))
978:
979: | `AST_function (sr, id, vs, (ps,pre), (t,post), props, sts ) ->
980: let pr = map (fun (x,y,z)->y) ps in
981: let post = match post with | None -> None | Some x -> Some (me x) in
982: let pre = match pre with | None -> None | Some x -> Some (me x) in
983: let ps = map (fun (k,id,t) -> k,id,mt sr t) ps in
984: tack(`AST_function (sr, mi sr id, vs, (ps,pre), (mt sr t, post), props, msp sr pr sts ))
985:
986: | `AST_curry (sr,id,vs,pss,(ret,post),kind,sts) ->
987: let pr = map (fun(x,y,z)->y) (concat (map fst pss)) in
988: let post = match post with | None -> None | Some x -> Some (me x) in
989: let pss =
990: map (fun (ps,traint) ->
991: (
992: map (fun (k,id,t) -> k,id,mt sr t)) ps,
993: match traint with | None -> None | Some x -> Some (me x)
994: )
995: pss
996: in
997: tack(`AST_curry(sr, mi sr id, vs, pss, (ret,post),kind, msp sr pr sts ))
998:
999: | `AST_object (sr, id, vs, ps, sts ) ->
1000: let pr = map (fun(x,y,z)->y) (fst ps) in
1001: let ps = map (fun (k,id,t) -> k,id,mt sr t) (fst ps),snd ps in
1002: tack(`AST_object (sr, mi sr id, vs, ps, msp sr pr sts ))
1003:
1004: | `AST_val_decl (sr, id, vs, optt, opte) ->
1005: let opte = match opte with
1006: | Some x -> Some (me x)
1007: (*
1008: this *will be* an error if unreachable,
1009: provided the containing function is used
1010: *)
1011: | None -> None
1012: (* this is actually a syntax error in a module,
1013: but not in an interface: unfortunately,
1014: we can't tell the difference here
1015: *)
1016: in
1017: let optt = match optt with
1018: | Some t -> Some (mt sr t)
1019: | None -> None
1020: in
1021: tack (`AST_val_decl (sr, mi sr id, vs, optt, opte))
1022:
1023: | `AST_ref_decl (sr, id, vs, optt, opte) ->
1024: let opte = match opte with
1025: | Some x -> Some (me x)
1026: (*
1027: this *will be* an error if unreachable,
1028: provided the containing function is used
1029: *)
1030: | None -> None
1031: (* this is actually a syntax error in a module,
1032: but not in an interface: unfortunately,
1033: we can't tell the difference here
1034: *)
1035: in
1036: let optt = match optt with
1037: | Some t -> Some (mt sr t)
1038: | None -> None
1039: in
1040: tack (`AST_ref_decl (sr, mi sr id, vs, optt, opte))
1041:
1042: | `AST_lazy_decl (sr, id, vs, optt, opte) ->
1043: let opte = match opte with
1044: | Some x -> Some (me x)
1045: (*
1046: this *will be* an error if unreachable,
1047: provided the containing function is used
1048: *)
1049: | None -> None
1050: (* this is actually a syntax error in a module,
1051: but not in an interface: unfortunately,
1052: we can't tell the difference here
1053: *)
1054: in
1055: let optt = match optt with
1056: | Some t -> Some (mt sr t)
1057: | None -> None
1058: in
1059: tack (`AST_lazy_decl (sr, mi sr id, vs, optt, opte))
1060:
1061: | `AST_var_decl (sr, id, vs, optt, opte) ->
1062: let opte =
1063: match opte with
1064: | Some x -> Some (me x)
1065: (* unreachable var initialisations are legal *)
1066:
1067: | None -> None
1068: (* vars don't have to be initialised *)
1069: in
1070: let optt = match optt with
1071: | Some t -> Some (mt sr t)
1072: | None -> None
1073: in
1074: tack (`AST_var_decl (sr, mi sr id, vs, optt, opte))
1075:
1076: | `AST_untyped_module (sr, id, vs, sts) ->
1077: tack (`AST_untyped_module (sr, mi sr id, vs, ms sts))
1078:
1079: | `AST_namespace (sr, id, vs, sts) ->
1080: tack (`AST_namespace (sr, mi sr id, vs, ms sts))
1081:
1082:
1083: | `AST_class (sr, id, vs, sts) ->
1084: tack (`AST_class (sr, mi sr id, vs, ms sts))
1085:
1086: | `AST_instance (sr, vs, qn, sts) ->
1087: tack (`AST_instance (sr, vs, mq qn, ms sts))
1088:
1089: | `AST_ifgoto (sr, e , id) ->
1090: let e = me e in
1091: let e = cf e in
1092: begin match e with
1093: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
1094: if c = 1 then
1095: (
1096: ctack (`AST_goto (sr,mi sr id));
1097: reachable := false
1098: )
1099: | _ ->
1100: ctack (`AST_ifgoto (sr, e, mi sr id))
1101: end
1102:
1103: | `AST_apply_ctor (sr,i,f,a) ->
1104: let i = mi sr i in
1105: let f = me f in
1106: let a = me a in
1107: ctack (`AST_apply_ctor (sr, i, f, a))
1108:
1109: | `AST_init (sr,v,e) ->
1110: ctack (`AST_init (sr, mi sr v, me e))
1111:
1112: | `AST_assert (sr,e) ->
1113: let e = me e in
1114: begin match e with
1115: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
1116: if c = 1 (* assertion proven true *)
1117: then ()
1118: else (* assertion proven false *)
1119: begin
1120: reachable := false;
1121: ctack (`AST_assert (sr,e))
1122: end
1123:
1124: | _ -> (* check at run time *)
1125: ctack (`AST_assert (sr,e))
1126: end
1127:
1128: | `AST_ifnotgoto (sr, e, id) ->
1129: let e = me e in
1130: let e = cf e in
1131: begin match e with
1132: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
1133: if c = 0 then
1134: (
1135: ctack (`AST_goto (sr,mi sr id));
1136: reachable := false
1137: )
1138: | _ ->
1139: ctack (`AST_ifnotgoto (sr, e, mi sr id))
1140: end
1141:
1142: | `AST_ifreturn (sr, e) ->
1143: let e = me e in
1144: begin match e with
1145: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
1146: if c = 1 then
1147: (
1148: ctack (`AST_proc_return sr);
1149: reachable := false
1150: )
1151: | _ ->
1152: let n = !seq in incr seq;
1153: let lab = "_ifret_" ^ string_of_int n in
1154: ctack (`AST_ifnotgoto (sr, e, lab));
1155: ctack (`AST_proc_return sr);
1156: ctack (`AST_label (sr,lab))
1157: end
1158:
1159: | `AST_ifdo (sr, e, sts1, sts2) ->
1160: let e = me e in
1161: let e = cf e in
1162: begin match e with
1163: | `AST_typed_case (_,c,`TYP_unitsum 2) ->
1164: if c = 1 then
1165: iter ctack (ms sts1)
1166: else
1167: iter ctack (ms sts2)
1168:
1169: | _ ->
1170: let n1 = !seq in incr seq;
1171: let n2 = !seq in incr seq;
1172: let lab1 = "_ifdoend_" ^ string_of_int n1 in
1173: let lab2 = "_ifdoelse_" ^ string_of_int n2 in
1174: (*
1175: print_endline ("Assigned labels " ^ lab1 ^ " and " ^ lab2);
1176: *)
1177:
1178: (* each branch has the initial reachability we start with.
1179: NOTE! Labels are allowed inside primitive conditionals!
1180: So even if the initial condition is 'unreachable',
1181: the end of a branch can still be reachable!!
1182:
1183: So we must tack, not ctack, the code of the inner
1184: compound statements, they're NOT blocks.
1185: *)
1186: ctack (`AST_ifnotgoto (sr, e, lab1));
1187: let r1 = ref !reachable in
1188: iter tack (ms' r1 sts1);
1189: if !r1 then tack (`AST_goto (sr,lab2));
1190:
1191: (* this is a ctack, because it can only be targetted by prior ifnotgoto *)
1192: ctack (`AST_label (sr,lab1));
1193: let r2 = ref !reachable in
1194: iter tack (ms' r2 sts2);
1195: if !r1 then tack (`AST_label (sr,lab2));
1196: reachable := !r1 or !r2
1197: end
1198:
1199:
1200: | `AST_jump (sr, e1, e2) ->
1201: ctack (`AST_jump (sr, me e1, me e2));
1202: reachable := false
1203:
1204: | `AST_loop (sr, id, e2) ->
1205: ctack (`AST_loop (sr, mi sr id, me e2));
1206: reachable := false
1207:
1208: | `AST_fun_return (sr, e) ->
1209: ctack (`AST_fun_return (sr, me e));
1210: reachable := false
1211:
1212: | `AST_yield (sr, e) ->
1213: ctack (`AST_yield (sr, me e))
1214:
1215: | st -> failwith ("[subst_or_expand] Unhandled case " ^ string_of_statement 0 st)
1216: end
1217: ;
1218: rev !result
1219:
1220:
1221: (* ---------------------------------------------------------------------
1222: expand, without defining new macros
1223: this routine is used to replace parameters
1224: in statement macros with already expanded arguments
1225: prior to expansion, therefore neither the arguments
1226: nor context in which they're used need any expansion
1227: *)
1228: and subst_statement recursion_limit local_prefix seq reachable macros (st:statement_t):statement_t list =
1229: (*
1230: print_endline ("subst statement " ^ string_of_statement 0 st);
1231: print_endline ("Macro context length " ^ si (length macros));
1232: print_endline (string_of_macro_env macros);
1233: *)
1234: if recursion_limit < 1
1235: then failwith "Recursion limit exceeded expanding macros";
1236: let recurion_limit = recursion_limit - 1 in
1237: let me e = expand_expr recursion_limit local_prefix seq macros e in
1238: let ms ss = subst_statement recursion_limit local_prefix seq (ref true) macros ss in
1239: let mss ss = subst_statements recursion_limit local_prefix seq (ref true) macros ss in
1240: let mi sr id =
1241: let out = expand_ident sr macros [] id in
1242: out
1243: in
1244: let result = ref [] in
1245: let tack x = result := x :: !result in
1246: let ctack x = if !reachable then tack x in
1247: let cf e = const_fold e in
1248:
1249: begin match st with
1250: | `AST_expr_macro (sr, id, ps, e) ->
1251: let ps,e = alpha_expr sr local_prefix seq ps e in
1252: tack (`AST_expr_macro (sr, mi sr id, ps, me e))
1253:
1254: | `AST_stmt_macro (sr, id, ps, sts) ->
1255: let ps,sts = alpha_stmts sr local_prefix seq ps sts in
1256: let sts = expand_statements recursion_limit local_prefix seq (ref true) macros sts in
1257: tack (`AST_stmt_macro (sr,id,ps,sts))
1258:
1259: | `AST_macro_block (sr, sts) ->
1260: (*
1261: let sts = expand_statements recursion_limit local_prefix seq (ref true) macros sts in
1262: *)
1263: let sts = mss sts in
1264: tack (`AST_macro_block (sr,sts))
1265:
1266: | `AST_macro_name (sr, id1, id2) ->
1267: (* IN THIS SPECIAL CASE THE LHS NAME IS NOT MAPPED *)
1268: tack (`AST_macro_name (sr, id1, mi sr id2))
1269:
1270: | `AST_macro_names (sr, id1, id2) ->
1271: (* IN THIS SPECIAL CASE THE LHS NAME IS NOT MAPPED *)
1272: tack (`AST_macro_names (sr, id1, map (mi sr) id2))
1273:
1274: | `AST_macro_val (sr, ids, e) ->
1275: tack (`AST_macro_val (sr, map (mi sr) ids, me e))
1276:
1277: | `AST_macro_vals (sr, id, e) ->
1278: tack (`AST_macro_vals (sr,mi sr id, map me e))
1279:
1280: | `AST_macro_var (sr, ids, e) ->
1281: tack (`AST_macro_var (sr, map (mi sr) ids, me e))
1282:
1283: | `AST_macro_assign (sr, ids, e) ->
1284: tack (`AST_macro_assign (sr, map (mi sr) ids, me e))
1285:
1286: | `AST_macro_ifor (sr,id,ids,sts) ->
1287: (* IN THIS SPECIAL CASE THE LHS NAME IS NOT MAPPED *)
1288: tack (`AST_macro_ifor (sr,id,map (mi sr) ids,mss sts))
1289:
1290: | `AST_macro_vfor (sr,ids,e,sts) ->
1291: tack (`AST_macro_vfor (sr,map (mi sr) ids,me e,mss sts))
1292:
1293: (* during parameter replacement,
1294: we don't know if a call is executable or not,
1295: so we can't elide it even if unreachable:
1296: it might expand to declarations or macros
1297: *)
1298: | `AST_call (sr, (`AST_name(srn,name,[]) as e1), e2) ->
1299: (* let e1 = `AST_name(srn, name,[]) in *)
1300: begin try
1301: match assoc name macros with
1302: | MStmt ([],b) ->
1303: print_endline ("EXPANDING call to macro " ^ name);
1304: iter tack (mss b)
1305: | _ ->
1306: tack (`AST_call (sr, me e1, me e2))
1307: with Not_found ->
1308: tack (`AST_call (sr, me e1, me e2))
1309: end
1310:
1311: | `AST_call (sr, e1, e2) ->
1312: tack (`AST_call (sr, me e1, me e2))
1313:
1314: | `AST_user_statement (sr,name,term) ->
1315: (*
1316: print_endline ("Replacing into user statement call " ^ name);
1317: *)
1318: let rec aux term = match term with
1319: | `Statement_term s -> `Statements_term (ms s)
1320: | `Statements_term ss -> `Statements_term (mss ss)
1321: | `Expression_term e -> `Expression_term (me e)
1322: | `Identifier_term s -> `Identifier_term (mi sr s)
1323:
1324: (* ONLY SUBSTITUTE INTO PARAMETERS? *)
1325: | `Apply_term (t,ts) -> `Apply_term (t, map aux ts)
1326:
1327: (* invariant -- for the moment *)
1328: | `Keyword_term _ -> term
1329: in
1330: tack (`AST_user_statement (sr,name,aux term))
1331:
1332: | `AST_macro_ifgoto (sr,e,id) ->
1333: (*
1334: print_endline ("Substituting if/goto " ^ string_of_expr e);
1335: *)
1336: tack (`AST_macro_ifgoto (sr, cf (me e), mi sr id))
1337:
1338: | `AST_macro_label _
1339: | `AST_macro_goto _
1340: | `AST_macro_proc_return _
1341: | `AST_macro_forget _
1342: -> tack st
1343:
1344: | st ->
1345: iter tack
1346: (
1347: subst_or_expand subst_statements recursion_limit local_prefix seq reachable macros st
1348: )
1349: end
1350: ;
1351: rev !result
1352:
1353: and subst_statements recursion_limit local_prefix seq reachable macros (ss:statement_t list) =
1354: concat (map (subst_statement recursion_limit local_prefix seq reachable macros) ss)
1355:
1356: (* ---------------------------------------------------------------------
1357: expand statement : process macros
1358: *)
1359: and expand_statement recursion_limit local_prefix seq reachable ref_macros macros (st:statement_t) =
1360: (*
1361: print_endline ("Expand statement " ^ string_of_statement 0 st);
1362: print_endline ("Macro context length " ^ si (length macros));
1363: print_endline (string_of_macro_env macros);
1364: *)
1365: if recursion_limit < 1
1366: then failwith "Recursion limit exceeded expanding macros";
1367: let recurion_limit = recursion_limit - 1 in
1368: let me e = expand_expr recursion_limit local_prefix seq (!ref_macros @ macros) e in
1369: let ms ss = expand_statements recursion_limit local_prefix seq (ref true) (!ref_macros @ macros) ss in
1370: let mi sr id =
1371: let out = expand_ident sr (!ref_macros @ macros) [] id in
1372: out
1373: in
1374: let result = ref [] in
1375: let tack x = result := x :: !result in
1376: let ctack x = if !reachable then tack x in
1377: let ses ss =
1378: special_expand_statements recursion_limit local_prefix seq (ref true) ref_macros macros ss
1379: in
1380: let rec expand_names sr (names:string list):string list =
1381: concat
1382: (
1383: map
1384: (fun name ->
1385: let name = mi sr name in
1386: let d =
1387: try Some (assoc name (!ref_macros @ macros))
1388: with Not_found -> None
1389: in
1390: match d with
1391: | Some (MNames es) -> expand_names sr es
1392: | Some (MName x) -> [x]
1393: | Some(_) -> [name] (* clierr sr "Name list required" *)
1394: | None -> [name]
1395: )
1396: names
1397: )
1398: in
1399: let rec expand_exprs sr (exprs: expr_t list):expr_t list =
1400: (*
1401: print_endline ("Expand exprs: [" ^ catmap ", " string_of_expr exprs ^ "]");
1402: *)
1403: concat
1404: (
1405: map
1406: (fun expr -> match expr with
1407: | `AST_name (sr',name,[]) ->
1408: print_endline ("Name " ^ name);
1409: let name = mi sr name in
1410: let d =
1411: try Some (assoc name (!ref_macros @ macros))
1412: with Not_found -> None
1413: in
1414: begin match d with
1415: | Some (MNames es) ->
1416: expand_exprs sr
1417: (map (fun name -> `AST_name (sr,name,[])) es)
1418:
1419: | Some (MName x) ->
1420: expand_exprs sr [`AST_name(sr,x,[])]
1421:
1422: | Some(MVals xs) -> xs
1423: | Some(_) -> [expr]
1424: | None -> [expr]
1425: end
1426:
1427: | `AST_tuple (sr',xs) -> map me xs
1428: | x -> [me x]
1429: )
1430: exprs
1431: )
1432: in
1433: begin match st with
1434: | `AST_macro_forget (sr,ids) ->
1435: begin
1436: match ids with
1437: | [] -> ref_macros := []
1438: | _ ->
1439: ref_macros := filter (fun (x,_) -> not (mem x ids)) !ref_macros
1440: end
1441:
1442: | `AST_expr_macro (sr, id, ps, e) ->
1443: let ps,e = alpha_expr sr local_prefix seq ps e in
1444: ref_macros := (id,MExpr (ps, e)) :: !ref_macros
1445:
1446: | `AST_macro_val (sr, ids, e) ->
1447: let e = me e in
1448: let n = length ids in
1449: if n = 1 then
1450: ref_macros := (hd ids,MVal e) :: !ref_macros
1451: else begin
1452: let vs =
1453: match e with
1454: | `AST_tuple (_,ls) -> ls
1455: | _ -> clierr sr "Unpack non-tuple"
1456: in
1457: let m = length vs in
1458: if m <> n then
1459: clierr sr
1460: (
1461: "Tuple is wrong length, got " ^
1462: si n ^ " variables, only " ^
1463: si m ^ " values"
1464: )
1465: else
1466: let ides = combine ids vs in
1467: iter (fun (id,v) ->
1468: ref_macros := (id,MVal v) :: !ref_macros
1469: )
1470: ides
1471: end
1472:
1473: | `AST_macro_vals (sr, id, es) ->
1474: ref_macros := (id,MVals (map me es)) :: !ref_macros
1475:
1476: | `AST_macro_var (sr, ids, e) ->
1477: let e = me e in
1478: let n = length ids in
1479: if n = 1 then
1480: ref_macros := (hd ids,MVar (ref e)) :: !ref_macros
1481: else begin
1482: let vs =
1483: match e with
1484: | `AST_tuple (_,ls) -> ls
1485: | _ -> clierr sr "Unpack non-tuple"
1486: in
1487: let m = length vs in
1488: if m <> n then
1489: clierr sr
1490: (
1491: "Tuple is wrong length, got " ^
1492: si n ^ " variables, only " ^
1493: si m ^ " values"
1494: )
1495: else
1496: let ides = combine ids vs in
1497: iter (fun (id,v) ->
1498: ref_macros := (id,MVar (ref v)) :: !ref_macros
1499: )
1500: ides
1501: end
1502:
1503: | `AST_macro_assign (sr, ids, e) ->
1504: let assign id e =
1505: try
1506: let r = assoc id (!ref_macros @ macros) in
1507: match r with
1508: | MVar p -> p := e
1509: | _ -> clierr sr "Assignment to wrong kind of macro"
1510: with Not_found -> clierr sr "Assignment requires macro var"
1511: in
1512: let e = me e in
1513: let n = length ids in
1514: if n = 1 then assign (hd ids) e
1515: else begin
1516: let vs =
1517: match e with
1518: | `AST_tuple (_,ls) -> ls
1519: | _ -> clierr sr "Unpack non-tuple"
1520: in
1521: let m = length vs in
1522: if m <> n then
1523: clierr sr
1524: (
1525: "Tuple is wrong length, got " ^
1526: si n ^ " variables, only " ^
1527: si m ^ " values"
1528: )
1529: else
1530: let ides = combine ids vs in
1531: iter (fun (id,v) -> assign id v) ides
1532: end
1533:
1534: | `AST_macro_ifor (sr, id, names, sts) ->
1535: let names = expand_names sr names in
1536: iter (fun name ->
1537: let saved_macros = !ref_macros in
1538: ref_macros := (id,MName name) :: saved_macros;
1539: iter tack (ms sts);
1540: ref_macros := saved_macros
1541: ) names
1542:
1543: | `AST_macro_vfor (sr, ids, e, sts) ->
1544: (*
1545: print_endline "Expanding vfor";
1546: *)
1547: let e = me e in
1548: let vals = match e with
1549: | `AST_tuple (_,vals) -> vals
1550: | x -> [x]
1551: in
1552: iter (fun e ->
1553: let saved_macros = !ref_macros in
1554: begin
1555: let n = length ids in
1556: if n = 1 then begin
1557: (*
1558: print_endline ("Setting " ^ hd ids ^ " to " ^ string_of_expr e);
1559: *)
1560: ref_macros := (hd ids,MVal e) :: !ref_macros
1561: end else begin
1562: let vs =
1563: match e with
1564: | `AST_tuple (_,ls) -> ls
1565: | _ -> clierr sr ("Unpack non-tuple " ^ string_of_expr e)
1566: in
1567: let m = length vs in
1568: if m <> n then
1569: clierr sr
1570: (
1571: "Tuple is wrong length, got " ^
1572: si n ^ " variables, only " ^
1573: si m ^ " values"
1574: )
1575: else
1576: let ides = combine ids vs in
1577: iter (fun (id,v) ->
1578: (*
1579: print_endline ("Setting " ^ id ^ " to " ^ string_of_expr v);
1580: *)
1581: ref_macros := (id,MVal v) :: !ref_macros
1582: )
1583: ides
1584: end
1585: end
1586: ;
1587: iter tack (ms sts);
1588: ref_macros := saved_macros
1589: ) vals
1590:
1591: | `AST_stmt_macro (sr, id, ps, sts) ->
1592: let ps,sts = alpha_stmts sr local_prefix seq ps sts in
1593: ref_macros := (id, MStmt (ps,sts)) :: !ref_macros
1594:
1595: | `AST_macro_name (sr, id1, id2) ->
1596: let id2 = mi sr id2 in
1597: let id2 =
1598: match id2 with
1599: | "" ->
1600: let n = !seq in incr seq;
1601: "_" ^ local_prefix^ "_" ^ string_of_int n
1602: | _ -> id2
1603: in
1604: ref_macros := (id1,MName id2) :: !ref_macros
1605:
1606: | `AST_macro_names (sr, id, ids) ->
1607: let ids = map (mi sr) ids in
1608: ref_macros := (id,MNames ids) :: !ref_macros
1609:
1610: | `AST_macro_block (sr,sts) ->
1611: let b = subst_statements recursion_limit local_prefix seq reachable [] sts in
1612: let b = ses b in
1613: iter ctack b
1614:
1615: | `AST_call (sr, `AST_macro_statements (srs,sts), arg) ->
1616: begin match arg with
1617: | `AST_tuple (_,[]) ->
1618: let sts = ms sts in
1619: iter ctack sts
1620:
1621: | _ -> clierr sr "Apply statements requires unit arg"
1622: end
1623:
1624: | `AST_call (sr, e1', e2') ->
1625: let
1626: e1 = me e1' and
1627: e2 = me e2'
1628: in
1629: begin match e1 with
1630: | `AST_name(srn,name,[]) ->
1631: begin try
1632: match List.assoc name (!ref_macros @ macros) with
1633: | MName _
1634: -> failwith ("Unexpected MName " ^ name)
1635: | MNames _
1636: -> failwith ("Unexpected MNames " ^ name)
1637: | MVar _
1638: -> failwith ("Unexpected MVar " ^ name)
1639: | MVal _
1640: ->
1641: failwith
1642: (
1643: "Unexpected MVal " ^ name ^ " expansion\n" ^
1644: string_of_expr e1' ^ " --> " ^ string_of_expr e1
1645: )
1646:
1647: | MVals _
1648: ->
1649: failwith
1650: (
1651: "Unexpected MVals " ^ name ^ " expansion\n" ^
1652: string_of_expr e1' ^ " --> " ^ string_of_expr e1
1653: )
1654:
1655:
1656: (*
1657: The executable syntax allows the statement
1658:
1659: <atom>;
1660:
1661: to mean
1662:
1663: call <atom> ();
1664:
1665: which means <atom> here must be a procedure
1666: of type unit->void. The case:
1667:
1668: <atom1> <atom2>;
1669:
1670: however requires <atom1> to be a procedure,
1671: it can't be a function even if the application
1672:
1673: <atom1> <atom2>
1674:
1675: would return a procedure: the insertion of the
1676: trailing () is purely syntactic.
1677:
1678: This isn't the case for the macro processor,
1679: since it does 'type' analysis. We can allow
1680: <atom1> to be a function which when applied
1681: to <atom2> returns an expression denoting
1682: a procedure, and apply it to ().
1683: *)
1684:
1685: | MExpr (ps,b) ->
1686: (*
1687: print_endline ("Expanding statement, MExpr " ^ name);
1688: *)
1689: let result = me (`AST_apply (sr,(e1,e2))) in
1690: let u = `AST_tuple (sr,[]) in
1691: iter tack (ms [`AST_call(sr,result,u)])
1692:
1693: | MStmt(ps,b) ->
1694: (*
1695: print_endline ("Expanding statement, MStmt " ^ name);
1696: *)
1697: let args =
1698: match e2 with
1699: | `AST_tuple (_,ls) -> ls
1700: | x -> [x]
1701: in
1702: let np = length ps and na = length args in
1703: if na = np
1704: then
1705: begin
1706: let args= map me args in
1707: let args = build_args sr ps args in
1708: let b = subst_statements recursion_limit local_prefix seq reachable args b in
1709: let b = ses b in
1710: (* ?? ctack ?? *)
1711: iter ctack b
1712: end
1713: else
1714: clierr sr
1715: (
1716: "[expand_expr:call] Statement Macro "^name^
1717: " requires "^string_of_int np^" arguments," ^
1718: " got " ^ string_of_int na
1719: )
1720: with
1721: | Not_found ->
1722: ctack (`AST_call (sr, e1, e2))
1723: end
1724:
1725: | _ -> ctack (`AST_call (sr,e1,e2))
1726: end
1727:
1728: | `AST_user_statement (sr,name,term) ->
1729: (*
1730: print_endline ("Expanding statement " ^ name);
1731: *)
1732: let string_of_statements sts =
1733: String.concat "\n" (map (string_of_statement 1) sts)
1734: in
1735: let wrap_stmts ss = `AST_macro_statements (sr,ss) in
1736: let rec eval_arg (id:string) (h:ast_term_t) : macro_dfn_t option =
1737: match h with
1738: | `Expression_term e -> Some (id,MVal e)
1739: | `Identifier_term s -> Some (id,MName s)
1740: (*
1741: | `Statement_term s -> Some (id,MStmt ([],[s]))
1742: | `Statements_term ss -> Some (id,MStmt ([],ss))
1743: *)
1744: | `Statement_term s -> Some (id,MVal (wrap_stmts [s]))
1745: | `Statements_term ss -> Some (id,MVal (wrap_stmts ss))
1746: | `Keyword_term _ ->
1747: (*
1748: print_endline ("[substitute statement terms] Keyword arg dropped " ^ id);
1749: *)
1750: None
1751: | `Apply_term (body,args) ->
1752: let body = eval_apply sr body args in
1753: eval_arg id body
1754:
1755: and eval_args sr (ts: ast_term_t list) : macro_dfn_t list =
1756: let rec aux terms res count =
1757: let id = "_" ^ si count in
1758: match terms with
1759: | h :: t ->
1760: let mac = eval_arg id h in
1761: begin match mac with
1762: | Some m -> aux t (m::res) (count+1)
1763: | None -> aux t res (count+1)
1764: end
1765: | [] -> res
1766: in aux ts [] 1
1767:
1768: and eval_apply sr (body:ast_term_t) (args:ast_term_t list) : ast_term_t =
1769: (*
1770: print_endline "Processing Application .. evaluating args";
1771: *)
1772: let args = eval_args sr args in
1773: (*
1774: print_endline "[apply] Got arguments ..";
1775: print_endline (string_of_macro_env args);
1776: print_endline "[apply] WE SHOULD EXPAND THE ARGS BUT AREN'T AT THE MOMENT";
1777: print_endline ("[apply] Body is " ^ string_of_ast_term 0 body);
1778: print_endline "[apply] APPLYING TERM TO EVALUATED ARGUMENTS ";
1779: *)
1780: let term = eval_term_apply sr body args in
1781: (*
1782: print_endline ("Term after evaluation is " ^ string_of_ast_term 0 term);
1783: *)
1784: term
1785:
1786: and eval_term_apply sr (body:ast_term_t) (args:macro_dfn_t list) : ast_term_t =
1787: match body with
1788: | `Expression_term e ->
1789: (*
1790: print_endline ("EXPANDING EXPRESSION " ^ string_of_expr e);
1791: *)
1792: let e = expand_expr (recursion_limit-1) local_prefix seq args e in
1793: `Expression_term e
1794:
1795: | `Identifier_term id ->
1796: let id = expand_ident sr args [] id in
1797: `Identifier_term id
1798:
1799: | `Statement_term s ->
1800: let ss = subst_statements recursion_limit local_prefix seq reachable args [s] in
1801: (*
1802: print_endline ("[apply:statement] Body after substitution is" ^ string_of_statements ss);
1803: print_endline "[apply:statement] EXECUTING STATEMENTS NOW";
1804: *)
1805: let ss = ses ss in
1806: `Statements_term ss
1807:
1808: | `Statements_term ss ->
1809: let ss = subst_statements recursion_limit local_prefix seq reachable args ss in
1810: (*
1811: print_endline ("[apply:statements] Body after substitution is " ^ string_of_statements ss);
1812: print_endline "[apply:statements] EXECUTING STATEMENTS NOW";
1813: *)
1814: let ss = ses ss in
1815: `Statements_term ss
1816:
1817: | `Keyword_term _ -> body
1818: | `Apply_term (body',args') ->
1819: (*
1820: print_endline "[apply] Inner application";
1821: *)
1822: (* Inner application -- substitute into its arguments first *)
1823: let args' = map (fun body -> eval_term_apply sr body args) args' in
1824: eval_apply sr body' args'
1825: in
1826: let substitute_statement_terms sr ss ts =
1827: (*
1828: print_endline "[statement] Substitute statements terms!";
1829: print_endline "[statement] Original argument term list (the parse tree) is";
1830: iter (fun term -> print_endline (string_of_ast_term 0 term)) ts;
1831: *)
1832: let args = eval_args sr ts in
1833: (*
1834: print_endline "[statement] Got arguments ..";
1835: print_endline (string_of_macro_env args);
1836: *)
1837: (*
1838: print_endline "[statement] WE SHOULD EXPAND THE ARGS BUT AREN'T AT THE MOMENT";
1839: print_endline ("[statement] Body is " ^ string_of_statements ss);
1840: print_endline "[statement] SUBSTITUTING";
1841: *)
1842: let ss = subst_statements recursion_limit local_prefix seq reachable args ss in
1843: (*
1844: print_endline ("[statement] Body after substitution is" ^ string_of_statements ss);
1845: print_endline "[statement] EXECUTING STATEMENTS NOW";
1846: *)
1847: let ss = ses ss in
1848: (*
1849: print_endline ("[statement] Body after execution is" ^ string_of_statements ss);
1850: *)
1851: iter ctack ss
1852: in
1853: (*
1854: print_endline ("Expand Statement: Processing user defined statement " ^ name);
1855: *)
1856: let aux term = match term with
1857: | `Statement_term s -> ctack s
1858: | `Statements_term ss -> iter ctack ss (* reverse order is correct *)
1859: | `Expression_term e -> clierr sr ( "User statement: expected statement got expression " ^ string_of_expr e)
1860: | `Identifier_term s -> clierr sr ( "User statement: expected statement got identifier " ^ s)
1861: | `Keyword_term s -> clierr sr ( "User statement: expected statement got keyword " ^ s)
1862: | `Apply_term (t,ts) ->
1863: begin match t with
1864: | `Statement_term s ->
1865: substitute_statement_terms sr [s] ts
1866:
1867: | `Statements_term ss ->
1868: substitute_statement_terms sr ss ts
1869:
1870: | _ ->
1871: clierr sr
1872: (
1873: "User statement: In application, expected statement "
1874: )
1875: end
1876: in aux term
1877:
1878:
1879: | st ->
1880: iter tack
1881: (
1882: subst_or_expand expand_statements recursion_limit local_prefix seq reachable (!ref_macros @ macros) st
1883: )
1884: end
1885: ;
1886: rev !result
1887:
1888:
1889:
1890:
1891: and expand_statements recursion_limit local_prefix seq reachable macros (ss:statement_t list) =
1892: let ref_macros = ref [] in
1893: let r = special_expand_statements recursion_limit local_prefix seq reachable ref_macros macros ss in
1894: r
1895:
1896: and special_expand_statements recursion_limit local_prefix seq
1897: reachable ref_macros macros ss
1898: =
1899: (*
1900: iter (fun st -> print_endline (string_of_statement 0 st)) ss;
1901: *)
1902: if ss = [] then []
1903: else
1904: let sr =
1905: rsrange
1906: (src_of_stmt (List.hd ss))
1907: (src_of_stmt (Flx_util.list_last ss))
1908: in
1909:
1910: let cf e = const_fold e in
1911: let expansion = ref [] in
1912: let tack x = expansion := x :: !expansion in
1913: let tacks xs = iter tack xs in
1914: let pc = ref 0 in
1915: let label_map = Hashtbl.create 23 in
1916: let count =
1917: fold_left
1918: (fun count x ->
1919: match x with
1920: | `AST_macro_label (sr,s) ->
1921: Hashtbl.add label_map s (sr,count) ; count
1922: | _ -> count+1
1923: )
1924: 0
1925: ss
1926: in
1927: let program =
1928: Array.of_list
1929: (
1930: filter
1931: (function | `AST_macro_label _ -> false | _ -> true)
1932: ss
1933: )
1934: in
1935: assert (count = Array.length program);
1936: try
1937: for i = 1 to 100000 do
1938: let st =
1939: if !pc >=0 && !pc < Array.length program
1940: then program.(!pc)
1941: else syserr sr
1942: (
1943: "Program counter "^si !pc^
1944: " out of range 0.." ^
1945: si (Array.length program - 1)
1946: )
1947: in
1948: begin match st with
1949: | `AST_macro_goto (sr,label) ->
1950: begin
1951: try
1952: pc := snd (Hashtbl.find label_map label)
1953: with
1954: | Not_found ->
1955: clierr sr ("Undefined macro label " ^ label)
1956: end
1957:
1958: | `AST_macro_proc_return _ -> raise Macro_return
1959:
1960: | `AST_macro_ifgoto (sr,e,label) ->
1961: (*
1962: print_endline ("Expanding if/goto " ^ string_of_expr e);
1963: *)
1964: let result =
1965: expand_expr
1966: recursion_limit
1967: local_prefix
1968: seq
1969: (!ref_macros @ macros)
1970: e
1971: in
1972: let result = cf result in
1973: begin match truthof result with
1974: | Some false -> incr pc
1975: | Some true ->
1976: begin
1977: try
1978: pc := snd (Hashtbl.find label_map label);
1979: with
1980: | Not_found ->
1981: clierr sr ("Undefined macro label " ^ label)
1982: end
1983:
1984: | None ->
1985: clierr sr
1986: ("Constant expression required, got " ^ string_of_expr e)
1987: end
1988:
1989: | st ->
1990: let sts =
1991: expand_statement
1992: recursion_limit
1993: local_prefix
1994: seq
1995: reachable
1996: ref_macros
1997: macros
1998: st
1999: in
2000: tacks sts;
2001: incr pc
2002: end
2003: ;
2004: if !pc = count then raise Macro_return
2005: done;
2006: clierr sr "macro execution step limit exceeded"
2007: with
2008: Macro_return -> rev !expansion
2009:
2010: and expand_macros local_prefix recursion_limit ss =
2011: expand_statements recursion_limit local_prefix (ref 1) (ref true) [] ss
2012:
2013:
2014: and expand_expression local_prefix e =
2015: let seq = ref 1 in
2016: expand_expr 20 local_prefix seq [] e
2017:
2018:
2019: