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