mcc-0.5.4rta03/front/pasqual/ast/pasqual_pascal_compat.ml

   1 (*
   2  * Maintain compatibility with Pascal.
   3  *
   4  * Replace "variables" with function-calls if a function with
   5  * that name exists in scope and it is the last declaration for that
   6  * identifier.
   7  *
   8  * Insert Return's in functions and procedures.
   9  * ----------------------------------------------------------------
  10  *
  11  * Copyright (C) 2001 Adam Granicz, Caltech
  12  *
  13  * This program is free software; you can redistribute it and/or
  14  * modify it under the terms of the GNU General Public License
  15  * as published by the Free Software Foundation; either version 2
  16  * of the License, or (at your option) any later version.
  17  *
  18  * This program is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU General Public License for more details.
  22  *
  23  * You should have received a copy of the GNU General Public License
  24  * along with this program; if not, write to the Free Software
  25  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26  *
  27  * Author: Adam Granicz, granicz@cs.caltech.edu
  28  *
  29  *)
  30
  31 open Symbol
  32 open Fc_parse_type
  33 open Fc_config
  34
  35 (************************************************************************
  36  * FUNCTIONS
  37  ************************************************************************)
  38
  39 let apply_sym = Symbol.add "()"
  40 let bogus_label = Symbol.add "bogus_var_label"
  41
  42 (*
  43  * Keep track of functions in scope.
  44  *)
  45 type fenv = symbol SymbolTable.t
  46
  47 let fenv_empty = SymbolTable.empty
  48
  49 let fenv_add = SymbolTable.add
  50
  51 let is_function fenv f =
  52     try
  53         let _ = SymbolTable.find fenv f in
  54             true
  55     with
  56         Not_found ->
  57             false
  58
  59 (*
  60  * Keep track of functions we are inside of.
  61  *)
  62 let fbenv_empty = SymbolTable.empty
  63
  64 let fbenv_add = SymbolTable.add
  65
  66 let inside_function fbenv f =
  67     try
  68         let _ = SymbolTable.find fbenv f in
  69             true
  70     with
  71         Not_found ->
  72             false
  73
  74 let return_var fbenv f =
  75     try SymbolTable.find fbenv f with
  76         Not_found ->
  77             raise (Invalid_argument ("return_var: Can not find function name [" ^ Symbol.to_string f ^ "]"))
  78
  79 (************************************************************************
  80  * EXPRESSIONS
  81  ************************************************************************)
  82
  83 (*
  84  * Convert an expression.
  85  *)
  86 let rec pascal_expr fenv fbenv is_pascal e =
  87     match e with
  88           WithExpr _ ->
  89                 raise (Invalid_argument "pascal_expr: WithExpr: Not implemented")
  90         | UnitExpr _
  91         | CharExpr _
  92         | IntExpr _
  93         | FloatExpr _
  94         | StringExpr _ ->
  95             fenv, fbenv, e
  96         | VarExpr (pos, v, label) ->
  97             if is_pascal = false then
  98                 fenv, fbenv, e
  99             else
 100             if is_function fenv v then
 101                 fenv, fbenv, OpExpr (pos, PreOp, apply_sym, apply_sym, VarExpr (pos, v, label) :: [VarExpr (pos, label, label)])
 102             else
 103                 fenv, fbenv, e
 104         | OpExpr (pos, op_class, v, label, elist) ->
 105             if is_pascal = true then
 106             (* Be careful with assignments and function applications *)
 107             (match v, List.hd elist with
 108                   sym, VarExpr (vpos, vv, _)
 109                     when sym = Symbol.add "=" ->
 110                     let elist_hd = List.hd elist in
 111                     let fenv, fbenv, elist_tail = pascal_expr_list fenv fbenv is_pascal (List.tl elist) in
 112                     let elist_hd =
 113                         if inside_function fbenv vv then begin
 114                             let f_ret_var = return_var fbenv vv in
 115                                 VarExpr (vpos, f_ret_var, bogus_label)
 116                         end else
 117                             elist_hd
 118                     in
 119                     let elist = elist_hd :: elist_tail in
 120                         fenv, fbenv, OpExpr (pos, op_class, v, label, elist)
 121                 | sym, VarExpr (vpos, vv, _)
 122                     when sym = Symbol.add "()" ->
 123                         let elist_hd = List.hd elist in
 124                         let elist_hd2 = List.hd (List.tl elist) in
 125                         let fenv, fbenv, elist_tail = pascal_expr_list fenv fbenv is_pascal (List.tl (List.tl elist)) in
 126                         let elist = elist_hd :: elist_hd2 :: elist_tail in
 127                             fenv, fbenv, OpExpr (pos, op_class, v, label, elist)
 128                 | _ ->
 129                     let fenv, fbenv, elist = pascal_expr_list fenv fbenv is_pascal elist in
 130                         fenv, fbenv, OpExpr (pos, op_class, v, label, elist)
 131             )
 132             else
 133                 fenv, fbenv, e
 134         | IfExpr (pos, e1, e2, e3_opt) ->
 135             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 136             let fenv, fbenv, e2 = pascal_expr fenv fbenv is_pascal e2 in
 137             let fenv, fbenv, e3_opt = pascal_expr_option fenv fbenv is_pascal e3_opt in
 138                 fenv, fbenv, IfExpr (pos, e1, e2, e3_opt)
 139         | ForExpr (pos, e1, e2, e3, e4) ->
 140             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 141             let fenv, fbenv, e2 = pascal_expr fenv fbenv is_pascal e2 in
 142             let fenv, fbenv, e3 = pascal_expr fenv fbenv is_pascal e3 in
 143             let fenv, fbenv, e4 = pascal_expr fenv fbenv is_pascal e4 in
 144                 fenv, fbenv, ForExpr (pos, e1, e2, e3, e4)
 145         | WhileExpr (pos, e1, e2) ->
 146             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 147             let fenv, fbenv, e2 = pascal_expr fenv fbenv is_pascal e2 in
 148                 fenv, fbenv, WhileExpr (pos, e1, e2)
 149         | DoExpr (pos, e1, e2) ->
 150             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 151             let fenv, fbenv, e2 = pascal_expr fenv fbenv is_pascal e2 in
 152                 fenv, fbenv, DoExpr (pos, e1, e2)
 153         | BreakExpr _
 154         | ContinueExpr _ ->
 155             fenv, fbenv, e
 156         | ReturnExpr (pos, e) ->
 157             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 158                 fenv, fbenv, ReturnExpr (pos, e)
 159         | RaiseExpr (pos, e) ->
 160             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 161                 fenv, fbenv, RaiseExpr (pos, e)
 162         | SwitchExpr (pos, e, cases) ->
 163             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 164             let cases = List.map (fun (patt, elist) ->
 165                 let fenv, fbenv, elist = pascal_expr_list fenv fbenv is_pascal elist in
 166                     patt, elist) cases
 167             in
 168                 fenv, fbenv, SwitchExpr (pos, e, cases)
 169         | TryExpr (pos, e1, cases, e_opt) ->
 170             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 171             let cases = List.map (fun (patt, elist) ->
 172                 let fenv, fbenv, elist = pascal_expr_list fenv fbenv is_pascal elist in
 173                     patt, elist) cases
 174             in
 175             let fenv, fbenv, e_opt = pascal_expr_option fenv fbenv is_pascal e_opt in
 176                 fenv, fbenv, TryExpr (pos, e1, cases, e_opt)
 177         | SeqExpr (pos, el) ->
 178             let fenv, fbenv, el = pascal_expr_list fenv fbenv is_pascal el in
 179                 fenv, fbenv, SeqExpr (pos, el)
 180         | PascalExpr (pos, el) ->
 181             let fenv, fbenv, el = pascal_expr_list fenv fbenv true el in
 182                 fenv, fbenv, SeqExpr (pos, el)
 183         | PasqualExpr (pos, el) ->
 184             let fenv, fbenv, el = pascal_expr_list fenv fbenv false el in
 185                 fenv, fbenv, SeqExpr (pos, el)
 186         | CaseExpr _
 187         | DefaultExpr _
 188         | GotoExpr _
 189         | LabelExpr _ ->
 190             fenv, fbenv, e
 191         | ProjectExpr (pos, e, v) ->
 192             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 193                 fenv, fbenv, ProjectExpr (pos, e, v)
 194         | SizeofExpr (pos, e) ->
 195             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 196                 fenv, fbenv, SizeofExpr (pos, e)
 197         | SizeofType _ ->
 198             fenv, fbenv, e
 199         | CastExpr (pos, ty, e) ->
 200             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 201                 fenv, fbenv, CastExpr (pos, ty, e)
 202         | VarDefs (pos, defs) ->
 203             let fenv' = List.fold_left (fun fenv (pos, sc, patt, ty, init_exp) ->
 204                 match ty, patt with
 205                       TypeFun (_, _, ty_vars, ty_res), VarPattern (_, f, _, _) ->
 206                         fenv_add fenv f (ty_vars, ty_res)
 207                     | _ ->
 208                         fenv) fenv defs
 209             in
 210                 fenv', fbenv, VarDefs (pos, defs)
 211         | TypeDefs _ ->
 212             fenv, fbenv, e
 213         | FunDef (pos, sc, f, label, ty_vars, ty_res, e) ->
 214             let ty_vars' = List.map (fun (_, _, ty) -> ty) ty_vars in
 215             let fenv' = fenv_add fenv f (ty_vars', ty_res) in
 216             let ret_var = new_symbol_string "ret_var" in
 217             let fbenv' =
 218                 match ty_res with
 219                   TypeUnit (_, _, 1) ->
 220                     fbenv
 221                 | _ ->
 222                     fbenv_add fbenv f ret_var
 223             in
 224             let fenv, fbenv, e = pascal_expr fenv' fbenv' is_pascal e in
 225             let expr =
 226                 match ty_res, is_pascal with
 227                   TypeUnit (_, _, 1), true ->
 228                     let e_return = ReturnExpr (pos, UnitExpr (pos, 1, 0)) in
 229                         FunDef (pos, sc, f, label, ty_vars, ty_res, SeqExpr (pos, [e] @ [e_return]))
 230                 | _, true ->
 231                     let e_var_decl = VarDefs (pos, [pos, StoreAuto, VarPattern (pos, ret_var, ret_var, None), ty_res, InitNone]) in
 232                     let e_return = ReturnExpr (pos, VarExpr (pos, ret_var, bogus_label)) in
 233                         FunDef (pos, sc, f, label, ty_vars, ty_res, SeqExpr (pos, [e_var_decl] @ [e] @ [e_return]))
 234                 | _, false ->
 235                     FunDef (pos, sc, f, label, ty_vars, ty_res, e)
 236             in
 237                 fenv', fbenv, expr
 238 (* This match case is unused -- jyh 1/11/02
 239         | WithExpr (pos, e1, e2) ->
 240             let fenv, fbenv, e1 = pascal_expr fenv fbenv is_pascal e1 in
 241             let fenv, fbenv, e2 = pascal_expr fenv fbenv is_pascal e2 in
 242                 fenv, fbenv, WithExpr (pos, e1, e2)
 243 *)
 244
 245 and pascal_expr_option fenv fbenv is_pascal e =
 246     match e with
 247           Some e ->
 248             let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 249                 fenv, fbenv, Some e
 250         | None ->
 251             fenv, fbenv, None
 252
 253 and pascal_expr_list fenv fbenv is_pascal el =
 254     let fenv, fbenv, el = List.fold_left (fun (fenv, fbenv, el) e ->
 255         let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 256             fenv, fbenv, e :: el) (fenv, fbenv, []) el
 257     in
 258         fenv, fbenv, List.rev el
 259
 260 (*
 261  * Finally...
 262  *)
 263 let compat_expr e is_pascal =
 264     (* All the functions in scope *)
 265     let fenv = fenv_empty in
 266     (* All the functions we are inside of, with their return variables *)
 267     let fbenv = fbenv_empty in
 268     let fenv, fbenv, e = pascal_expr fenv fbenv is_pascal e in
 269         e