5.29.2. Implementation

Start ocaml section to src/flx_macro.mli[1 /1 ]
     1: # 29 "./lpsrc/flx_macro.ipk"
     2: open Flx_ast
     3: val expand_macros:
     4:   string ->
     5:   int ->
     6:   statement_t list ->
     7:   statement_t list
     8: 
     9: (** [expand_expr] is a special hook used to perform
    10:   constant folding and desugaring in the preprocessor
    11: *)
    12: val expand_expression:
    13:   string -> expr_t -> expr_t
    14: 
End ocaml section to src/flx_macro.mli[1]
Start ocaml section to src/flx_macro.ml[1 /1 ]
     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: 
End ocaml section to src/flx_macro.ml[1]
Start ocaml section to src/flxm.ml[1 /1 ]
     1: # 2064 "./lpsrc/flx_macro.ipk"
     2: open Flx_util
     3: open Flx_macro
     4: open Flx_print
     5: open Flx_ast
     6: open Flx_getopt
     7: open Flx_version
     8: open Flx_flxopt
     9: open Flx_types
    10: open Flx_mtypes1
    11: open Flx_mtypes2
    12: 
    13: let print_help () = print_options(); exit(0)
    14: ;;
    15: let reverse_return_parity = ref false
    16: ;;
    17: try
    18:   let argc = Array.length Sys.argv in
    19:   if argc <= 1
    20:   then begin
    21:     print_endline "usage: flxg --key=value ... filename; -h for help";
    22:     exit 0
    23:   end
    24:   ;
    25:   let raw_options = parse_options Sys.argv in
    26:   let compiler_options = get_felix_options raw_options in
    27:   reverse_return_parity := compiler_options.reverse_return_parity
    28:   ;
    29:   let syms = make_syms compiler_options in
    30: 
    31:   if check_keys raw_options ["h"; "help"]
    32:   then print_help ()
    33:   ;
    34:   if check_key raw_options "version"
    35:   then (print_endline ("Felix Version " ^ !version_data.version_string))
    36:   ;
    37:   if compiler_options.print_flag then begin
    38:     print_string "//Include directories = ";
    39:     List.iter (fun d -> print_string (d ^ " "))
    40:     compiler_options.include_dirs;
    41:     print_endline ""
    42:   end
    43:   ;
    44: 
    45:   let filename =
    46:     match get_key_value raw_options "" with
    47:     | Some s -> s
    48:     | None -> exit 0
    49:   in
    50:   let filebase = filename in
    51:   let input_file_name = filebase ^ ".flx"
    52:   and iface_file_name = filebase ^ ".fix"
    53:   and module_name =
    54:     let n = String.length filebase in
    55:     let i = ref (n-1) in
    56:     while !i <> -1 && filebase.[!i] <> '/' do decr i done;
    57:     String.sub filebase (!i+1) (n - !i - 1)
    58:   in
    59: 
    60:   (* PARSE THE IMPLEMENTATION FILE *)
    61:   print_endline ("//Parsing Implementation " ^ input_file_name);
    62:   let hash_include_files,parse_tree =
    63:     Flx_parse_ctrl.parse_file
    64:       input_file_name
    65:       (Filename.dirname input_file_name)
    66:       compiler_options.include_dirs
    67:       expand_expression
    68:   in
    69:   print_endline (Flx_print.string_of_compilation_unit parse_tree);
    70:   print_endline "//PARSE OK";
    71: 
    72:   print_endline "//----------------------------";
    73:   print_endline "//IMPLEMENTATION EXPANDED:";
    74: 
    75:   let local_prefix = module_name in
    76:   let expanded = expand_macros local_prefix 5000 parse_tree in
    77:   print_endline (Flx_print.string_of_compilation_unit expanded);
    78:   print_endline "//----------------------------";
    79: 
    80: with x -> Flx_terminate.terminate !reverse_return_parity x
    81: ;;
    82: 
End ocaml section to src/flxm.ml[1]