Skip to content
This repository
tag: v1020
Fetching contributors…

Cannot retrieve contributors at this time

file 433 lines (376 sloc) 14.698 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF mli *)

(* depends *)
module Array = Base.Array
module Format = Base.Format
module List = Base.List

(* shorthands *)
module B = BslTypes
module Q = QmlAst
module QC = QmlAstCons.UntypedExpr
module V = OpaTopValue
module P = OpaTopProperties

(* debug *)
let debug fmt =
  OManager.printf ("@{<cyan>[Eval]@}@ @[<2>"^^fmt^^"@]@.")

(* Error managment *)
let fail fmt = OManager.error ("@[<2>@{<bright>Eval@}:@\n"^^fmt^^"@]@\n")

(* template *)
(*
let _ =
#<If:OPATOP_EVAL $minlevel 1>
debug "do some %s of level %d@\n" "debug" 1
#<End>
in
*)

(* printer *)
let pp =
  #<If:OPATOP_ANNOT>
    QmlPrint.pp_annotation
  #<Else>
    (QmlPrint.pp :> QmlPrint.base_printer_with_sugared_types)
  #<End>

type env = V.t IdentMap.t

type ('a, 'b) ignored_directive = [
| QmlAst.type_directive
| `async
| `atomic
| `fun_action of 'a
| `nonexpansive
| `spawn
| `tracker of 'b
| `unsafe_cast
| `may_cps
| `wait
]

let rec traverse_ignore expr =
  match expr with
  | Q.Directive (_, #ignored_directive, [expr], _)
  | Q.Coerce (_, expr, _) -> traverse_ignore expr
  | _ -> expr

let make_bypass skey = QC.bypass (BslKey.normalize skey)

(* global annotmaps *)
let valueOfAnnot = ref AnnotMap.empty
let getValueOfAnnot x = AnnotMap.find_opt x !valueOfAnnot
let setValueOfAnnot x t = valueOfAnnot := AnnotMap.add x t !valueOfAnnot; ()
let resetAnnot () = valueOfAnnot := AnnotMap.empty

let (!!) pat fmt =
  (* FIXME: get pos from expr *)
  OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
  OManager.printf "In the pattern %a@]@\n" pp#pat pat;
  OManager.error fmt

(*
The function [match_pattern] returns an option of a new env, by adding the
bindings introduced by the pattern

If the match is unsuccessfull, the function returns [None]
*)
let rec match_pattern env pat value =
  match pat, value with
  | Q.PatCoerce (_, pat, _), _ -> match_pattern env pat value

  | Q.PatConst (_, pc), V.V_const (_, vc) ->
      if pc = vc (* Q.const_expr, Pervasives.compare *)
      then Some env
      else None

  | Q.PatVar (_, ident), _ -> Some (IdentMap.add ident value env)

  | Q.PatAny _, _ -> Some env

  | Q.PatAs (_, alias_pat, ident), _ -> (
      let new_env_opt = match_pattern env alias_pat value in
      match new_env_opt with
      | None ->
          (* The aliased pattern didn't match the value, so the ident alias
is not bound. *)
          None
      | Some new_env ->
          (* The aliased pattern matched the value. May be this induced some
bindings we must keep and we also must add a binding for the ident
alias. *)
          Some (IdentMap.add ident value new_env)
      )
  | Q.PatRecord (_, [], rowvar), V.V_record (_, fields,_) ->
      if rowvar = `open_ || StringMap.is_empty fields
      then Some env
      else None

  | Q.PatRecord (_, pfields, rowvar), V.V_record (_, vfields, _) ->
      let rec check_fields env present = function
        | [] -> (
            match rowvar with
            | `open_ -> Some env

            (* The pattern matching is closed. We must check if we have matched all the fields *)
            | `closed -> (
                let surjective =
                  StringMap.fold (fun key _ bool -> bool && StringSet.mem key present) vfields true
                in
                if surjective then Some env else None
              )
          )

        | (field, p1) :: tl -> (
            match StringMap.find_opt field vfields with
            | None -> None
            | Some value -> (
                match match_pattern env p1 (Lazy.force value) with
                | None -> None
                | Some env -> check_fields env (StringSet.add field present) tl
              )
          )

      in check_fields env StringSet.empty pfields

  | _ -> None

let nopos = FilePos.nopos "OpaTopEval.eval"

let (!!) expr fmt =
  (* FIXME: get pos from expr *)
  OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
  OManager.printf "In the expression %a@]@\n" pp#expr expr;
  OManager.error fmt

let rec eval env expr =

  let _ =
    #<If:OPATOP_EXPR>
      OManager.printf "eval(expr): %a@." pp#expr expr
    #<End>
  in

  let main_expr = expr in
  let value =
    if P.noeval_get() then V.t_null ~pos:nopos ()
    else match expr with
    | Q.Const (label, e) -> V.V_const (Annot.pos label, e)

    | Q.Ident (_, id) -> (
        try
          (* must be mem by type checking, but typer may be off *)
          IdentMap.find id env
        with
        | Not_found -> !! expr "unbound value %S@\n" (Ident.to_string id)
      )

    | Q.LetIn (_, lets, in_) ->
        let seen = ref IdentSet.empty in
        let fold env (id, expr) =
          if IdentSet.mem id !seen
          then !! main_expr "Variable %S is bound several times in this let and@\n" (Ident.to_string id)
          else (
            seen := IdentSet.add id !seen ;
            let value = eval env expr in
            let env = IdentMap.add id value env in
            env
          )
        in
        let env = List.fold_left fold env lets in
        eval env in_

    | Q.LetRecIn (_, lets, in_) ->
        let env =
          let tmp = ref IdentMap.empty in
          let fold env (id, expr) =
            let value =
              let lambda =
                match traverse_ignore expr with
                | Q.Lambda _ as expr -> expr
                | _ -> !! main_expr "This kind of expression is not allowed as right-hand side of `let rec'@\n"
              in
              V.V_closure (Q.Pos.expr lambda, tmp, lambda)
            in
            setValueOfAnnot (Q.QAnnot.expr expr) value;
            IdentMap.add id value env
          in
          let env = List.fold_left fold env lets in
          tmp := env;
          env
        in
        eval env in_

    | Q.Lambda (label, _, _) -> V.V_closure (Annot.pos label, ref env, expr)

    (* Apply : Be carrefully with this lines, the main idea of this version of interpreter is here *)
    (* The magie is just here in case of specialisation of high functional mixity between qml & ocaml *)
    (* In a simplier version (for example : no functionnal qml value of type 'a -> 'b can be passed
as an argument of type 'a of a bypass-function) the hack would be not necessary *)
    | Q.Apply (_, f, args) -> (
        let vf = eval env f in
        let fail_arity i j =
          fail "arity mismatch (expected %d, get %d), cannot apply %a in %a." i j
            OpaTopValue.pp vf pp#expr main_expr in
        match vf with
        | V.V_closure (_, clot_env, Q.Lambda (_, ids, body)) ->
            (* classic_apply : apply beta-redex with closure *)
            let update_env1 clot_env id arg = IdentMap.add id (eval env arg) clot_env in
            let update_env clot_env ids args =
              try List.fold_left2 update_env1 clot_env ids args
              with Invalid_argument "List.fold_left2" -> fail_arity (List.length ids) (List.length args);
            in
            eval (update_env (!clot_env) ids args) body

        (* The followings line are interresting, that allow partial application of bypass,
and a shorter code for the initial binding builtins *)
        | V.V_bypass (_, targs , ret, oof) -> (
            let lenargsapp = List.length targs in
            let lenargsty = List.length args in
            if lenargsapp <> lenargsty then fail_arity lenargsapp lenargsty;
            let mls = List.map2 (fun ty qml -> V.Proj.ocaml_of_t ~eval ty (eval env qml)) targs args in
            let ml =
              match mls with
              | [] ->
                  let _ =
                    #<If:OPATOP_HOOK>
                      prerr_endline "eval: HOOK-03";
                    #<End>
                  in
                  (Obj.obj oof) ()
              | _ ->
                  let _ =
                    #<If:OPATOP_HOOK>
                      prerr_endline "eval: HOOK-04";
                    #<End>
                  in
                  List.fold_left (fun func arg -> (Obj.magic func) arg) (Obj.obj oof) mls
            in
            let _ =
              #<If:OPATOP_HOOK>
                prerr_endline "eval: HOOK-05";
              #<End>
            in
            V.Proj.t_of_ocaml ret (Obj.repr ml)
          )

        | _ ->
            !! expr "cannot apply %a on %a. This value is not a function@\n"
              V.pp vf (Format.pp_list "@ " pp#expr) args
      )

    | Q.Match (_, expr, pat_expr_list) ->
        let v_expr = eval env expr in
        let rec aux = function
          | [] ->
              !! main_expr "pattern match failure. the value is %a@\n" V.pp v_expr
          | (pat, expr) :: tl -> (
              match match_pattern env pat v_expr with
              | Some env ->
                  eval env expr
              | None -> aux tl
            )
        in aux pat_expr_list

    | Q.Record (label, fields) ->
        let fold fields (field, expr) =
          let value = eval env expr in
          let fields = StringMap.add field (Lazy.lazy_from_val value) fields in
          fields
        in
        let fields = List.fold_left fold StringMap.empty fields in
        V.V_record (Annot.pos label, fields, ref None)

    | Q.Dot (_, expr, field) -> (
        let v_expr = eval env expr in
        match v_expr with
        | V.V_record (_, fields, _) -> (
            let lazy_value =
              try
                StringMap.find field fields
              with
              | Not_found ->
                  !! expr "this record has no field %S\n(maybe the typer is off)@\n" field
            in
            Lazy.force lazy_value
          )
        | v ->
            !! main_expr "in dot field %S : expected a record@ but got %a@\n" field V.pp v
      )

    (* { field = expr } :: expr *)
    | Q.ExtendRecord (_, field, expr, record) -> (
        let v_expr = eval env expr in
        let v_record = eval env record in
        match v_record with
        | V.V_record (pos, fields, _) ->
            let value = Lazy.lazy_from_val v_expr in
            let fields = StringMap.add field value fields in
            (* FIXME: merge with the pos from the main_expr *)
            V.V_record (pos, fields, ref None)
        | _ ->
            !! main_expr "extend record { %s = %a } :: %a@ expected a record@\n"
              field V.pp v_expr V.pp v_record
      )

    (* FIXME: remove this directive, change the type of the Bypass node *)
    (* TODO: and get back the check of restriction in this case *)
    | Q.Directive (_, `restricted_bypass _, [Q.Bypass (_, key)], _)
    | Q.Bypass (_, key) -> (
        (* get the cached bypass map *)
        let bypass_map = OpaTopBsl.bypass_map () in
        match OpaTopBsl.find_opt key bypass_map with
        | Some bypass -> (
            match OpaTopBsl.eval bypass with
            | Some value -> value
            | None -> (
                !! expr "This external primitive is not available in opatop@\n"
              )
          )

        | None ->
            !! expr "Unknow external primitive. Maybe do you want to use a plugin ?@\n"
      )

    | Q.Path _ ->
        !! expr "Presence of a raw database reading node not resolved by DbGen@\n"

    | Q.Directive (_, `fail, message, _) -> (
        match message with
        | [] ->
            !! expr "@@fail@\n"

        | message :: _ ->
            let message =
              match eval env message with
              | V.V_const (_, Q.String message) -> message
              | v -> !! expr "@@fail expects one argument of type string but got: %a@\n" V.pp v
            in
            !! expr "@@fail: %s@\n" message
      )

    | Q.Directive (_, `assert_, [cond], _) -> (
        let void = V.Proj.t_void () in
        if not (P.assert_get ()) then void else
          let v_cond = eval env cond in
          match v_cond with
          | V.V_record (_, fields, _) ->
              (* Keep in sync with qml semantic *)
              if (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) then void
              else !! expr "assert failure"
          | _ ->
              !! expr "assert condition not a bool value: %a@\n"
                V.pp v_cond
      )

    | Q.Directive (_, `create_lazy_record, exprs, _) -> (
        let expr, o = QmlDirectives.create_lazy_record_arguments exprs in
        match expr with
        | Q.Record (_, fields) ->
            let embed_data = Option.map (eval env) o in
            let fold fields (field, expr) =
              let lazy_value = lazy (eval env expr) in
              StringMap.add field lazy_value fields in
            let fields = List.fold_left fold StringMap.empty fields in
            V.V_record (nopos, fields, ref embed_data)
        | _ -> assert false
      )

    | Q.Directive (_, `callcc, [expr], _) ->
        let fake_bypass = make_bypass "bslcps.notcps_compatibility.callcc_directive" in
        let expr = QC.apply fake_bypass [expr] in
        eval env expr

    | Q.Directive (label, `llarray, exprs, _) ->
        let len = ref 0 in
        let rev_exprs = List.rev_map (fun e -> incr(len); eval env e) exprs in
        let array = Array.unsafe_create !len in
        let pred_len = pred !len in
        let iteri v i = let i = pred_len - i in array.(i) <- v in
        List.iteri iteri rev_exprs ;
        let string = "llarray" in
        let args = [ B.TypeVar (Annot.pos label, B.TypeVar.next()) ] in
        OpaTopValue.Proj.t_extern string args array

    (* ignored nodes *)
    | Q.Directive (_, #ignored_directive, [expr], _)
    | Q.Coerce (_, expr, _) -> eval env expr

    | Q.Directive (_, d, e, t) ->
        !! expr "Directive %a is not available in qmltop"
          (fun fmt () -> pp#directive fmt d e t) ()
  in

  let annot = Q.QAnnot.expr main_expr in

  let _ =
    #<If:OPATOP_EXPR>
      OManager.printf "value: (%a : § %d)@." OpaTopValue.pp value (Annot.to_int annot)
    #<End>
  in

  (* Store the value in the map *)
  setValueOfAnnot annot value;
  value
Something went wrong with that request. Please try again.