(***********************************************************************)
(*                                                                     *)
(*                              F90ast                                 *)
(*                                                                     *)
(*                  Jason L. Eckhardt, Rice University                 *)
(*                                                                     *)
(*  Copyright 2004  Jason L. Eckhardt.  All rights reserved.           *)
(*  This file is distributed under the terms of the Q Public License   *)
(*  version 1.0.                                                       *)
(*                                                                     *)
(***********************************************************************)

(*
 * This is an AST for a large subset of Fortran90. 
 *
 * Some f90 features it does not currently describe include:
 * I/O, some intrinsics, etc.
 *
 * Also, some of the archaic F77 constructs are not implemented (e.g, 
 * alternate entry points, assigned goto, etc.).
 *)

(*
 * Short-term TODO:
 *  - Finish all intrinsics.
 *  - Add WHERE statement.
 *  - Old-style specification statements (common, data, etc).
 *
 * Longer-term TODO:
 *  - Update to Fortran95 or Fortran2000 standard.
 *  - Add Co-Array Fortran extensions for data-parallel programming.
 *)

let version_f90abs = "f90abs v0.1 (Jason Eckhardt)"

type fbasic_type =  (* The argument is the optional KIND expression.  *)
    Ftype_character of fexpression option (* Length.  *)
  | Ftype_complex of fexpression option 
  | Ftype_dbl_prec
  | Ftype_integer of fexpression option
  | Ftype_logical of fexpression option
  | Ftype_real of fexpression option
  | Ftype_type of string               (* User-defined type.  *)

and fspec_attr =
    Fattr_allocatable
  | Fattr_common
  | Fattr_data
  | Fattr_dimension of fsubscript list
  | Fattr_equivalence
  | Fattr_extent
  | Fattr_external
  | Fattr_intent_in
  | Fattr_intent_out
  | Fattr_intent_inout
  | Fattr_intrinsic
  | Fattr_optional
  | Fattr_parameter
  | Fattr_pointer
  | Fattr_private
  | Fattr_public
  | Fattr_save
  | Fattr_target

and fbinary_oper =
    Fbinop_add                          (* "+"      *)
  | Fbinop_sub                          (* "-"      *)
  | Fbinop_mul                          (* "*"      *)
  | Fbinop_div                          (* "/"      *)
  | Fbinop_pow                          (* "**"     *)
  | Fbinop_concat                       (* "//"     *)
  | Fbinop_and                          (* ".and."  *)
  | Fbinop_or                           (* ".or."   *)
  | Fbinop_eqv                          (* ".eqv."  *)
  | Fbinop_neqv                         (* ".neqv." *)
  | Fbinop_eq                           (* ".eq."   *)
  | Fbinop_ne                           (* ".ne."   *)
  | Fbinop_lt                           (* ".lt."   *)
  | Fbinop_le                           (* ".le."   *)
  | Fbinop_gt                           (* ".gt."   *)
  | Fbinop_ge                           (* ".ge."   *)

and funary_oper =
    Funop_minus                         (* "-"      *)
  | Funop_not                           (* ".not."  *)

and fintrinsic =
  (* Unary.  *)
    Fintrin_abs
  | Fintrin_cos
  | Fintrin_sin
  | Fintrin_tan
  | Fintrin_asin
  | Fintrin_acos
  | Fintrin_atan
  | Fintrin_sinh
  | Fintrin_cosh
  | Fintrin_tanh
  | Fintrin_sqrt
  | Fintrin_exp
  | Fintrin_log
  | Fintrin_log10
  | Fintrin_int
  | Fintrin_aint
  | Fintrin_anint
  | Fintrin_nint
  | Fintrin_real
  | Fintrin_dble
  | Fintrin_cmplx
  | Fintrin_not 
  | Fintrin_floor
  | Fintrin_ceiling
  | Fintrin_present
  | Fintrin_kind
  | Fintrin_selected_int_kind
  | Fintrin_allocate
  | Fintrin_deallocate
  | Fintrin_allocated
  | Fintrin_nullify
  (* Binary.  *)
  | Fintrin_lbound
  | Fintrin_ubound 
  | Fintrin_selected_real_kind
  | Fintrin_ior
  | Fintrin_iand
  | Fintrin_ieor
  | Fintrin_ishft
  | Fintrin_mod
  | Fintrin_modulo
  | Fintrin_dot_product
  | Fintrin_matmul
  (* N-ary or variable.  *)
  | Fintrin_max
  | Fintrin_min
  | Fintrin_associated

and fconstant =
  (* Constants are represented as strings, except logical.  The second
     argument is the optional KIND parameter (e.g., "2_akind").  *)
    Fconst_int of string * string option
  | Fconst_real of string * string option
  | Fconst_realdbl of string
  | Fconst_char of string
  | Fconst_logical of bool
  | Fconst_star         (* Special "constant" used for array specs.  *)

and fexpression =
    Fexp_nop
  | Fexp_variable of fvar_expression
  | Fexp_const of fconstant
  | Fexp_binary of fbinary_oper * fexpression * fexpression
  | Fexp_unary of funary_oper * fexpression
  | Fexp_intrinsic of fintrinsic * fexpression list
  | Fexp_fcall of string * fexpression list

and fvar_expression =
    Fvar_ident of string
  | Fvar_arrayref of string * fsubscript list
  | Fvar_pathref of fvar_expression list

and fsubscript = 
    Fsub_simple of fexpression
  | Fsub_triplet of fexpression option * fexpression option * fexpression option

and fstatement =
    Fstmt_assign of fvar_expression * fexpression
  | Fstmt_assignptr of fexpression * fexpression
  | Fstmt_call of string * fexpression list
  | Fstmt_do of string * fexpression * fexpression * fexpression option * fstatement list
  | Fstmt_do_while of fexpression * fstatement list
  | Fstmt_if of fexpression * fstatement
  | Fstmt_ifthenelse of fexpression * fstatement list * fstatement list option
  | Fstmt_goto of string     (* Gotos: Line numbers repr. as strings.  *)
  | Fstmt_computed_goto of string list * fexpression
  | Fstmt_return of fexpression option
  | Fstmt_continue
  | Fstmt_stop
  | Fstmt_end
  | Fstmt_select of fexpression * fselect_body list
  | Fstmt_cycle          (* Note: Only un-named form for now.  *)
  | Fstmt_exit           (* Note: Only un-named form for now.  *)

and fselect_body = 
    Fsel_case of fexpression list * fstatement list
  | Fsel_default of fstatement list

(* Note: USE and IMPLICIT NONE actually precede specs, but we treat them
   as specs for convenience.  *)
and fspecification =
    Fspec_decl of fbasic_type * fspec_attr list * (string * fexpression option) list
  | Fspec_udtdecl of string * fspecification list
  | Fspec_implicit_none
  | Fspec_use of string * (string * string) list option  (* Name and optional rename list. *)
  (* Block name, subprogs, module procedure names.  *)
  | Finterface_blk of string option * finterface_subprog list * string list 

and finterface_subprog =
    Finterface_subprog of fsubprog_header * fspecification list

and fsubprog_body =
  { specs: fspecification list;
    fstmts: fstatement list;
    contained: fsubprog_def list; }

and fsubprog_def =
    Fsubprog of fsubprog_header * fsubprog_body

and fsubprog_header =
    Fhdr_function of string * string list
  | Fhdr_recfunction of string * string list * string
  | Fhdr_subroutine of string * string list
  | Fhdr_program of string
  | Fhdr_module of string

and fcompilation_unit =
  { topdefs: fsubprog_def list }
 
(*********************************************************************)
(* Fortran pretty printer                                            *)
(*********************************************************************)

(*********************************************************************)
(*********************************************************************)

(* F90 "free-form" allows up to 132 characters before a continuation.  *)
let min_indent = 6
let max_linelen = 76

let output_string = ref ""
let curr_str = ref ""

exception ErrorInFPP of string;;
let error s = raise (ErrorInFPP s)

let printstr s =
  curr_str := !curr_str ^ s;
  let len = (String.length !curr_str) in 
  let maxline = 76 in
  if len > maxline then
    begin
    output_string := !output_string ^ (String.sub (!curr_str) 0 max_linelen)
                      ^ "&\n";
    curr_str := ("     &" ^ (String.sub (!curr_str) max_linelen (len-max_linelen)))
    end

let indent n =
  curr_str := !curr_str ^ (String.make n ' ')

(* Do not use embedded newline characters, use this.  *)
let newln _ =
  output_string := (!output_string ^ !curr_str ^ "\n");
  curr_str := ""

let prt_delimited_list action del li =
  for i = 1 to (List.length li) do
    action (List.nth li (i-1));
    if i < (List.length li) then
      printstr del;
  done

let get_expr_prio fexp =
  match fexp with
    Fexp_nop -> 0
  | Fexp_variable(_) -> 100
  | Fexp_const(_) -> 100
  | Fexp_binary(op, _, _) ->
      begin
      match op with 
        Fbinop_add -> 78
      | Fbinop_sub -> 78
      | Fbinop_mul -> 79 
      | Fbinop_div -> 79 
      | Fbinop_pow -> 80
      | Fbinop_concat -> 70
      | Fbinop_and -> 49
      | Fbinop_or -> 48
      | Fbinop_eqv -> 47 
      | Fbinop_neqv -> 47
      | Fbinop_eq -> 60
      | Fbinop_ne -> 60
      | Fbinop_lt -> 60
      | Fbinop_le -> 60
      | Fbinop_gt -> 60
      | Fbinop_ge ->  60
      end
  | Fexp_unary(op, _) ->
      begin
      match op with
        Funop_minus -> 78
      | Funop_not -> 50
      end
  | Fexp_intrinsic(_, _) -> 99
  | Fexp_fcall(_, _) -> 99

let string_of_fbinop binop =
  match binop with
    Fbinop_add -> "+"
  | Fbinop_sub -> "-"
  | Fbinop_mul -> "*"
  | Fbinop_div -> "/"
  | Fbinop_pow -> "**"
  | Fbinop_concat -> "//"
  | Fbinop_and -> ".and."
  | Fbinop_or -> ".or."
  | Fbinop_eqv -> ".eqv."
  | Fbinop_neqv -> ".neqv."
  | Fbinop_eq -> ".eq."
  | Fbinop_ne -> ".ne."
  | Fbinop_lt -> ".lt."
  | Fbinop_le -> ".le."
  | Fbinop_gt -> ".gt."
  | Fbinop_ge -> ".ge."

let string_of_funop unop =
  match unop with
    Funop_minus -> "-"
  | Funop_not -> ".not."

let string_of_fintrinsic fintr =
  match fintr with
    Fintrin_abs -> "ABS"
  | Fintrin_cos -> "COS"
  | Fintrin_sin -> "SIN"
  | Fintrin_tan -> "TAN"
  | Fintrin_asin -> "ASIN"
  | Fintrin_acos -> "ACOS"
  | Fintrin_atan -> "ATAN"
  | Fintrin_sinh -> "SINH"
  | Fintrin_cosh -> "COSH"
  | Fintrin_tanh -> "TANH"
  | Fintrin_sqrt -> "SQRT"
  | Fintrin_exp -> "EXP"
  | Fintrin_log -> "LOG"
  | Fintrin_log10 -> "LOG10"
  | Fintrin_int -> "INT"
  | Fintrin_aint -> "AINT"
  | Fintrin_anint -> "ANINT"
  | Fintrin_nint -> "NINT"
  | Fintrin_real -> "REAL"
  | Fintrin_dble -> "DBLE"
  | Fintrin_cmplx -> "CMPLX"
  | Fintrin_not -> "NOT"
  | Fintrin_floor -> "FLOOR"
  | Fintrin_ceiling -> "CEILING"
  | Fintrin_present -> "PRESENT"
  | Fintrin_kind -> "KIND"
  | Fintrin_selected_int_kind -> "SELECTED_INT_KIND"
  | Fintrin_allocate -> "ALLOCATE"
  | Fintrin_deallocate -> "DEALLOCATE"
  | Fintrin_allocated -> "ALLOCATED"
  | Fintrin_nullify -> "NULLIFY"
  (* Binary.  *)
  | Fintrin_lbound -> "LBOUND"
  | Fintrin_ubound  -> "UBOUND"
  | Fintrin_selected_real_kind -> "SELECTED_REAL_KIND"
  | Fintrin_ior -> "IOR"
  | Fintrin_iand -> "IAND"
  | Fintrin_ieor -> "IEOR"
  | Fintrin_ishft -> "ISHFT"
  | Fintrin_mod -> "MOD"
  | Fintrin_modulo -> "MODULO"
  | Fintrin_dot_product -> "DOT_PRODUCT"
  | Fintrin_matmul -> "MATMUL"
  | Fintrin_max -> "MAX"
  | Fintrin_min -> "MIN"
  | Fintrin_associated -> "ASSOCIATED"

let assert_nargs fintr n arglist =
  if (List.length arglist) <> n then
    error ("incorrect number of arguments for intrinsic: "
           ^ (string_of_fintrinsic fintr))
 
(* Check that an intrinsic was constructed with the proper number of args.  *)
let check_intrin_argcnt fintr arglist =
  match fintr with
    Fintrin_abs -> assert_nargs fintr 1 arglist
  | Fintrin_cos -> assert_nargs fintr 1 arglist
  | Fintrin_sin -> assert_nargs fintr 1 arglist
  | Fintrin_tan -> assert_nargs fintr 1 arglist
  | Fintrin_asin -> assert_nargs fintr 1 arglist
  | Fintrin_acos -> assert_nargs fintr 1 arglist
  | Fintrin_atan -> assert_nargs fintr 1 arglist
  | Fintrin_sinh -> assert_nargs fintr 1 arglist
  | Fintrin_cosh -> assert_nargs fintr 1 arglist
  | Fintrin_tanh -> assert_nargs fintr 1 arglist
  | Fintrin_sqrt -> assert_nargs fintr 1 arglist
  | Fintrin_exp -> assert_nargs fintr 1 arglist
  | Fintrin_log -> assert_nargs fintr 1 arglist
  | Fintrin_log10 -> assert_nargs fintr 1 arglist
  | Fintrin_int -> assert_nargs fintr 1 arglist
  | Fintrin_aint -> assert_nargs fintr 1 arglist
  | Fintrin_anint -> assert_nargs fintr 1 arglist
  | Fintrin_nint -> assert_nargs fintr 1 arglist
  | Fintrin_real -> assert_nargs fintr 1 arglist
  | Fintrin_dble -> assert_nargs fintr 1 arglist
  | Fintrin_cmplx -> assert_nargs fintr 1 arglist
  | Fintrin_not  -> assert_nargs fintr 1 arglist
  | Fintrin_floor  -> assert_nargs fintr 1 arglist
  | Fintrin_ceiling  -> assert_nargs fintr 1 arglist
  | Fintrin_present  -> assert_nargs fintr 1 arglist
  | Fintrin_kind -> assert_nargs fintr 1 arglist
  | Fintrin_selected_int_kind -> assert_nargs fintr 1 arglist
  | Fintrin_allocate -> assert_nargs fintr 1 arglist
  | Fintrin_deallocate -> assert_nargs fintr 1 arglist
  | Fintrin_allocated -> assert_nargs fintr 1 arglist
  | Fintrin_nullify -> assert_nargs fintr 1 arglist
  (* Binary.  *)
  | Fintrin_lbound -> assert_nargs fintr 2 arglist
  | Fintrin_ubound  -> assert_nargs fintr 2 arglist
  | Fintrin_selected_real_kind -> assert_nargs fintr 2 arglist
  | Fintrin_ior -> assert_nargs fintr 2 arglist
  | Fintrin_iand -> assert_nargs fintr 2 arglist
  | Fintrin_ieor -> assert_nargs fintr 2 arglist
  | Fintrin_ishft -> assert_nargs fintr 2 arglist
  | Fintrin_mod -> assert_nargs fintr 2 arglist
  | Fintrin_modulo -> assert_nargs fintr 2 arglist
  | Fintrin_dot_product -> assert_nargs fintr 2 arglist
  | Fintrin_matmul -> assert_nargs fintr 2 arglist
  | Fintrin_max -> 
      if (List.length arglist) < 2 then
        error "too few arguments for intrinsic: MAX"
  | Fintrin_min ->
      if (List.length arglist) < 2 then
        error "too few arguments for intrinsic: MIN"
  | Fintrin_associated ->
      if ((List.length arglist) = 1) || ((List.length arglist) = 2) then
        error "incorrect number of arguments for intrinsic: ASSOCIATED"

let rec fpp_fexpression (fexp: fexpression) prio = 
  let newprio = get_expr_prio fexp in 
  (if prio > newprio then printstr "(");
  begin
  match fexp with
    Fexp_nop -> printstr "C <Fexp_nop>"
  | Fexp_variable(varexp) -> fpp_fvar_expression varexp
  | Fexp_const(con) ->
      begin
      match con with
        Fconst_int(str, str_kindo) ->
          printstr str;
          printstr (match str_kindo with None -> "" | Some(sss) -> ("_" ^ sss))
      | Fconst_real(str, str_kindo) ->
          printstr str;
          printstr (match str_kindo with None -> "" | Some(sss) -> ("_" ^ sss))
      | Fconst_realdbl(str) ->
          (* The string may have "e[sign]int" embedded; change it to "D".
             If there is no suffix, add "D0".  *)
          let tmpstr = String.copy str in
          let changed = ref false in
          let len = String.length tmpstr in
          let i = ref 0 in
          while (!i < len) && (!changed = false) do 
            if tmpstr.[!i] = 'e' || tmpstr.[!i] = 'E' then
              (tmpstr.[!i] <- 'D'; changed := true);
            incr i
          done;
          printstr (tmpstr ^ (if !changed then "" else "D0"))
      | Fconst_char(str) -> printstr ("'" ^ str ^ "'")
      | Fconst_logical(bv) ->
          printstr (if bv then ".true." else ".false.")
      | Fconst_star -> printstr "*"
      end
  | Fexp_binary(oper, exp1, exp2) ->
      fpp_fexpression exp1 newprio;
      printstr (" " ^ (string_of_fbinop oper) ^ " ");
      fpp_fexpression exp2 newprio
  | Fexp_unary(oper, exp) -> 
      printstr (" " ^ (string_of_funop oper));
      fpp_fexpression exp newprio
  | Fexp_intrinsic(fintr, exp_arglist) ->
      check_intrin_argcnt fintr exp_arglist;
      printstr ((string_of_fintrinsic fintr) ^ "(");
      let prtit = (fun item -> fpp_fexpression item 0) in
      prt_delimited_list prtit ", " exp_arglist;
      printstr ")"
  | Fexp_fcall(str_name, exp_arglist) ->
      printstr (str_name ^ "(");
      let prtit = (fun item -> fpp_fexpression item 0) in
      prt_delimited_list prtit ", " exp_arglist;
      printstr ")"
  end;
  (if prio > newprio then printstr ")")

and fpp_fbasic_type btype = 
  let kindprt = (fun k -> match k with None -> ();
         | Some(fe) -> printstr "(kind="; fpp_fexpression fe 0; printstr ")") in
  match btype with 
    Ftype_character(expleno) ->
      printstr "character";
      (match expleno with None -> ()
      | Some(fe) -> printstr "(len="; fpp_fexpression fe 0; printstr ")") 
  | Ftype_complex(expkindo) -> printstr "complex"; kindprt expkindo
  | Ftype_dbl_prec -> printstr "double precision"
  | Ftype_integer(expkindo) -> printstr "integer"; kindprt expkindo
  | Ftype_logical(expkindo) -> printstr "logical"; kindprt expkindo
  | Ftype_real(expkindo) -> printstr "real"; kindprt expkindo
  | Ftype_type(str_name) -> printstr ("type(" ^ str_name ^ ")")

and fpp_fsubscript fsub =
  match fsub with
    Fsub_simple(fexp) -> fpp_fexpression fexp 0
  | Fsub_triplet(expo_lb, expo_ub, expo_stride) ->
      (match expo_lb with None -> () | Some(lb) -> fpp_fexpression lb 0);
      printstr ":";
      (match expo_ub with None -> () | Some(ub) -> fpp_fexpression ub 0);
      (match expo_stride with None -> ()
        | Some(st) -> printstr ":"; fpp_fexpression st 0)

and fpp_fvar_expression fvarexp =
  match fvarexp with
    Fvar_ident(str_name) ->
      printstr str_name
  | Fvar_arrayref(str_name, sublist) -> 
      printstr (str_name ^ "(");
      prt_delimited_list fpp_fsubscript ", " sublist;
      printstr ")"
  | Fvar_pathref(varexp_list) ->
      prt_delimited_list fpp_fvar_expression "%" varexp_list

and fpp_fspec_attr btype = 
  match btype with 
    Fattr_allocatable -> printstr "allocatable"
  | Fattr_common -> printstr "common"
  | Fattr_data -> printstr "data"
  | Fattr_dimension(sublist) ->
      printstr "dimension(";
      prt_delimited_list fpp_fsubscript ", " sublist;
      printstr ")"
  | Fattr_equivalence -> printstr "equivalence"
  | Fattr_extent -> printstr "extent"
  | Fattr_external -> printstr "external"
  | Fattr_intent_in -> printstr "intent(in)"
  | Fattr_intent_out -> printstr "intent(out)"
  | Fattr_intent_inout -> printstr "intent(inout)"
  | Fattr_intrinsic -> printstr "intrinsic"
  | Fattr_optional -> printstr "optional"
  | Fattr_parameter -> printstr "parameter"
  | Fattr_pointer -> printstr "pointer"
  | Fattr_private -> printstr "private"
  | Fattr_public -> printstr "public"
  | Fattr_save -> printstr "save"
  | Fattr_target -> printstr "target"

let rec fpp_fstatement (fstmt : fstatement) ind =
  match fstmt with
    Fstmt_assign(varexp, exp_rhs) ->
      indent ind;
      fpp_fvar_expression varexp;
      printstr " = ";
      fpp_fexpression exp_rhs 0;
      newln ()
  | Fstmt_assignptr(exp_lhs, exp_rhs) ->
      indent ind;
      fpp_fexpression exp_lhs 0;
      printstr " => ";
      fpp_fexpression exp_rhs 0;
      newln ()
  | Fstmt_call(str_name, explist_args) ->
      indent ind;
      printstr ("call " ^ str_name);
      (if (explist_args <> []) then
        printstr "(";
        let prtit = (fun item -> fpp_fexpression item 0) in
        prt_delimited_list prtit ", " explist_args;
        printstr ")");
      newln ()
  | Fstmt_do(str_ivar, exp_lb, exp_ub, exp_stepo, do_stmts) ->
      indent ind;
      printstr ("do " ^ str_ivar ^ " = ");
      fpp_fexpression exp_lb 0;
      printstr ", ";
      fpp_fexpression exp_ub 0;
      (match exp_stepo with
        None -> () 
      | Some(zzz) -> printstr ", "; fpp_fexpression zzz 0);
      newln ();
      List.iter (fun item -> fpp_fstatement item (ind+2)) do_stmts;
      indent ind;
      printstr "enddo";
      newln ()
  | Fstmt_do_while(exp_cond, do_stmts) ->
      indent ind;
      printstr "do while (";
      fpp_fexpression exp_cond 0;
      printstr ")";
      newln ();
      List.iter (fun item -> fpp_fstatement item (ind+2)) do_stmts;
      indent ind;
      printstr "enddo";
      newln ()
  | Fstmt_if(exp_cond, if_stmt) ->
      indent ind;
      printstr "if (";
      fpp_fexpression exp_cond 0;
      printstr ")";
      newln ();
      fpp_fstatement if_stmt (ind+2)
  | Fstmt_ifthenelse(exp_cond, then_stmts, else_stmtso) ->
      indent ind;
      printstr "if (";
      fpp_fexpression exp_cond 0;
      printstr ") then";
      newln ();
      List.iter (fun item -> fpp_fstatement item (ind+2)) then_stmts;
      (match else_stmtso with
        None -> () 
      | Some(estmts) ->
          indent ind; printstr "else"; newln ();
          List.iter (fun item -> fpp_fstatement item (ind+2)) estmts);
      indent ind;
      printstr "endif";
      newln () 
  | Fstmt_goto(str_lineno) ->
      indent ind;
      printstr ("goto " ^ str_lineno);
      newln ()
  | Fstmt_computed_goto(str_linelist, exp_goto) ->
      indent ind;
      printstr "goto (";
      prt_delimited_list printstr ", " str_linelist;
      printstr "), ";
      fpp_fexpression exp_goto 0;
      newln ()
  | Fstmt_return(exp_reto) ->
      indent ind;
      printstr "return ";
      (match exp_reto with
        None -> () 
      | Some(exp_ret) -> fpp_fexpression exp_ret 0); (* Alternate return.  *)
      newln ()
  | Fstmt_continue -> indent ind; printstr "continue"; newln ()
  | Fstmt_stop -> indent ind; printstr "stop"; newln ()
  | Fstmt_end -> indent ind; printstr "end"; newln ()
  | Fstmt_select(exp_sel, selbody_list) ->
      indent ind;
      printstr "select case (";
      fpp_fexpression exp_sel 0;
      printstr ")";
      newln ();
      if (selbody_list = []) then
        error "Fstmt_select with no cases";
      for i = 1 to (List.length selbody_list) do
        match (List.nth selbody_list (i-1)) with
          Fsel_case(exp_list, cstmts) ->
            indent ind;
            printstr "case(";
            let prtit = (fun item -> fpp_fexpression item 0) in
            prt_delimited_list prtit ", " exp_list;
            printstr ")";
            newln ();
            List.iter (fun item -> fpp_fstatement item (ind+2)) cstmts;
        | Fsel_default(cstmts) ->
            indent ind;
            printstr "case default";
            newln ();
            List.iter (fun item -> fpp_fstatement item (ind+2)) cstmts;
      done;
      indent ind;
      printstr "end select";
      newln ()
  | Fstmt_cycle -> indent ind; printstr "cycle"; newln ()
  | Fstmt_exit -> indent ind; printstr "exit"; newln ()

let rec fpp_fspecification fspec ind =
  match fspec with
    Fspec_decl(btype, attrlist, name_init_pairlist) ->
      indent ind;
      fpp_fbasic_type btype;
      if attrlist <> [] then 
        (printstr ", ";
        prt_delimited_list fpp_fspec_attr ", " attrlist);
      printstr " :: ";
      let print_nm_init_pair = fun (itemstr, itemexpr) ->
        printstr itemstr;
        match itemexpr with
          None -> () 
        | Some(exp) -> printstr "="; fpp_fexpression exp 0
      in
      prt_delimited_list print_nm_init_pair ", " name_init_pairlist;
      newln ()
  | Fspec_udtdecl(str_name, speclist) ->
      (* Declaration of user-defined type.  *)
      indent ind; printstr ("type " ^ str_name);
      newln ();
      for i = 1 to (List.length speclist) do
        fpp_fspecification (List.nth speclist (i-1)) (ind+2);
      done;
      indent ind; printstr "end type"; newln ()
  | Fspec_implicit_none -> indent ind; printstr "implicit none"; newln ()
  | Fspec_use(str_name, orenamel) ->
      indent ind; printstr ("use " ^ str_name);
      (match orenamel with None -> ()
       | Some(renamel) ->
          printstr ", ";
          let prtit = (function (localname, mname) ->
                       printstr (localname ^ " => " ^ mname)) in
          prt_delimited_list prtit ", " renamel);
      newln ()
  | Finterface_blk(strnameo, subproglist, str_modproclist) ->
      let name = (match strnameo with None -> "" | Some(ss) -> ss) in 
      indent ind; printstr ("interface" ^ name);
      newln ();
      let dosub = (fun (Finterface_subprog(hdr, specl)) ->
        fpp_fsubprog_header hdr (ind+2);
        List.iter (fun item -> fpp_fspecification item (ind+2)) specl;
        fpp_finalize_subprog hdr (ind+2)) in
      List.iter dosub subproglist;
      if str_modproclist <> [] then
        (indent (ind+2); printstr "module procedure ";
        prt_delimited_list printstr ", " str_modproclist;
        newln ());
      indent ind; printstr "end interface"; newln ()

and fpp_fsubprog_body body ind =
  List.iter (fun item -> fpp_fspecification item ind) body.specs;
  List.iter (fun item -> fpp_fstatement item ind) body.fstmts;
  if body.contained <> [] then
    (indent ind; printstr "contains"; newln (); 
    List.iter (fun item -> fpp_fsubprog_def item (ind+2)) body.contained)

and fpp_fsubprog_def topdef ind =
  let Fsubprog(hdr, body) = topdef in
  fpp_fsubprog_header hdr ind;
  fpp_fsubprog_body body ind;
  fpp_finalize_subprog hdr ind;

and fpp_fsubprog_header hdr ind =
  match hdr with
    Fhdr_function(str_name, str_formals) -> 
      indent ind; printstr ("function " ^ str_name ^ "(");
      prt_delimited_list printstr ", " str_formals;
      printstr ")";
      newln ()
  | Fhdr_recfunction(str_name, str_formals, str_resname) ->
      indent ind; printstr ("recursive function " ^ str_name ^ "(");
      prt_delimited_list printstr ", " str_formals;
      printstr (") result (" ^ str_resname ^ ")");
      newln ()
  | Fhdr_subroutine(str_name, str_formals) ->
      indent ind; printstr ("subroutine " ^ str_name);
      if str_formals <> [] then
        (printstr "(";
        prt_delimited_list printstr ", " str_formals;
        printstr ")");
      newln ()
  | Fhdr_program(str_name) -> 
      indent ind; printstr ("program " ^ str_name);
      newln ()
  | Fhdr_module(str_name) -> 
      indent ind; printstr ("module " ^ str_name);
      newln ()

and fpp_finalize_subprog hdr ind =
  indent ind;
  match hdr with
    Fhdr_function(str_name, str_formals) -> 
      printstr "end function"; newln ()
  | Fhdr_recfunction(str_name, str_formals, str_resname) ->
      printstr "end function"; newln ()
  | Fhdr_subroutine(str_name, str_formals) ->
      printstr "end subroutine"; newln ()
  | Fhdr_program(str_name) -> 
      printstr "end program"; newln ()
  | Fhdr_module(str_name) -> 
      (* (if body.fstmts <> [] then
        error "Fhdr_module cannot have statements"); *)
      printstr "end module"; newln ()

let fpp_fcompilation_unit pu =
  output_string := "";
  curr_str := "";
  printstr ("! This file was automatically generated: " ^ version_f90abs);
  newln ();
  List.iter (fun item -> fpp_fsubprog_def item min_indent; newln ()) pu.topdefs;
  !output_string

(*********************************************************************)
(*********************************************************************)
(* Unit testing of fabs.                                             *)
let mksimpvar str =
  Fexp_variable(Fvar_ident(str));;

let aryref = Fexp_variable(Fvar_arrayref("ary",
              [Fsub_simple(mksimpvar "I");
               Fsub_triplet(Some(Fexp_const(Fconst_int("1", None))), Some(mksimpvar("M")), 
                            Some(Fexp_const(Fconst_int("2", None))));
               Fsub_triplet(Some(Fexp_const(Fconst_int("J", None))), Some(mksimpvar("K")), 
                            None)]));;
let ein1 = Fexp_intrinsic(Fintrin_cos, [aryref]);;
let ein2 = Fexp_intrinsic(Fintrin_ishft, [mksimpvar("u"); mksimpvar("sc")]);;
let einN = Fexp_intrinsic(Fintrin_max, [mksimpvar("p1"); mksimpvar("p2"); mksimpvar("p3")]);;
let e1 = Fexp_binary(Fbinop_add, ein1, ein2);;
let e2 = Fexp_binary(Fbinop_add, einN, 
            Fexp_binary(Fbinop_and, mksimpvar("g"), mksimpvar("h")));;
let ecall = Fexp_fcall("somefunc", [mksimpvar("arg")])
let seq = [Fstmt_assign(Fvar_ident("a"), e1);
            Fstmt_call("somesubrt",[ecall; mksimpvar("arg2")])];;
let sbody = [Fsel_case([Fexp_const(Fconst_int("0",Some("mykind")))], [Fstmt_stop]);
             Fsel_case([Fexp_const(Fconst_int("2", Some("8"))); Fexp_const(Fconst_int("8", None))], [Fstmt_stop]);
             Fsel_default(seq)]
let s0 = Fstmt_select(mksimpvar("g"), sbody);;
let s1 = Fstmt_do("j", Fexp_const(Fconst_int("1", None)), 
                            Fexp_const(Fconst_int("8", None)), None, [s0]);;
let s2 = Fstmt_do("i", Fexp_const(Fconst_int("4", None)), 
                            Fexp_const(Fconst_int("64", None)), Some(Fexp_const(Fconst_int("4", None))), [s1]);;
let s3 = Fstmt_do_while(Fexp_const(Fconst_logical(false)), [s2]);;

let subs= [Fsub_simple(Fexp_const(Fconst_int("5", None)));
           Fsub_triplet(Some(Fexp_const(Fconst_int("1", None))), (* Some(mksimpvar("M")) *) Some(Fexp_const(Fconst_star)), 
                        None)];;
let specs0 = [Fspec_decl(Ftype_integer(None), [Fattr_dimension(subs)], [("glob1", None); ("glob2", None)])];;
let conts0 = [Fsubprog(Fhdr_function("innerfunc1", []), { specs = []; fstmts = [Fstmt_goto("fake")] ; contained = []})];;
let body0 = { specs = specs0; fstmts = []; contained = conts0; };;
let subprog0 = Fsubprog(Fhdr_module("ModName"), body0);;

let spintblk0 = (Fspec_decl(Ftype_character(None), [], [("ch1", None)])) ;;
let intblk0 = Finterface_blk(None, [Finterface_subprog(Fhdr_subroutine("SubName", ["ch1"]), [spintblk0])], ["modproc1"; "modproc2"]);;
let udtdecl = Fspec_udtdecl("a_udt", [Fspec_decl(Ftype_character(Some(Fexp_const(Fconst_int("13", None)))), [], [("ccc", None)]); Fspec_decl(Ftype_real(Some(Fexp_const(Fconst_int("2", None)))), [], [("ua", Some(Fexp_const(Fconst_real("3.14", Some("rkind"))))); ("ub", None)])]);;
let udt1 = Fspec_decl(Ftype_type("a_udt"), [], [("name1", None)]);;
let body1 = { specs = [Fspec_use("ModName", None (* Some([("loc1","m1"); ("loc2","m2")]) *)); Fspec_implicit_none; intblk0; Fspec_decl(Ftype_integer(None), [Fattr_target; Fattr_save], [("a", Some(Fexp_const(Fconst_int("5", None)))); ("b", Some(Fexp_const(Fconst_int("256", None))))]); udtdecl; udt1]; fstmts = [Fstmt_cycle]; contained = []; }
let subprog1 = Fsubprog(Fhdr_program("ProgName"), body1);;

let body2 = { specs = [Fspec_decl(Ftype_real(None), [], [("x", None)]); Fspec_decl(Ftype_dbl_prec, [Fattr_save], [("d1", None); ("d2", None); ("d3", None)]); Fspec_decl(Ftype_complex(None), [], [("cpx", None)])]; fstmts = [s3]; contained = []; }
let subprog2 = Fsubprog(Fhdr_function("FuncName", ["x"; "cpx"]), body2);;

let body3 = { specs = [Fspec_decl(Ftype_logical(None), [], [("gl1", Some(Fexp_const(Fconst_logical(true))))])]; fstmts = [Fstmt_exit]; contained = []; }
let subprog3 = Fsubprog(Fhdr_recfunction("RecFuncName", ["n"], "fRes"), body3);;

let cont4 = Fsubprog(Fhdr_function("innerfunc4", ["gh1"; "gh2"]), { specs = [Fspec_decl(Ftype_dbl_prec, [], [("dbl00", None)])]; fstmts = [Fstmt_continue] ; contained = []});;
let cont45 = Fsubprog(Fhdr_subroutine("innersub45", []), { specs = [Fspec_decl(Ftype_real(None), [], [("real00", None)])]; fstmts = [Fstmt_cycle] ; contained = []});;
let body4 = { specs = [Fspec_decl(Ftype_character(None), [], [("ch1", None)])]; fstmts = [Fstmt_assign((Fvar_arrayref("uary", [Fsub_simple(mksimpvar "L")])), Fexp_const(Fconst_char("A")))]; contained = [cont4; cont45]; }
let subprog4 = Fsubprog(Fhdr_subroutine("SubName", ["ch1"]), body4);;

let pu = { topdefs = [subprog0; subprog1; subprog2; subprog3; subprog4]; };;
(* Printf.printf "%s" (fpp_fcompilation_unit pu);;  *)

(*********************************************************************)
(*********************************************************************)