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: 
    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: 
End ocaml section to src/flx_macro.ml[1]
Start ocaml section to src/flxm.ml[1 /1 ]
     1: # 1919 "./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]