Source file interpreter.ml

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
let state env : int =
  match TableParser.MenhirInterpreter.top env with
  | Some (TableParser.MenhirInterpreter.Element (s, _, _, _)) -> TableParser.MenhirInterpreter.number s
  | None -> 0

type result =
  | Continue of Environment.env
  | Continue_Error
  | Stop

type readline_result =
  | Eof
  | Empty
  | Buffer of Sedlexing.lexbuf

let readline_base command_str env =
  match Readline.readline ~prompt:UtilsLib.Error.base_prompt ~completion_fun:(Completion.complete env "") () with
  | None -> Eof
  | Some "" -> Empty
  | Some input ->
    let () = command_str := input in
    let () = Readline.add_history input in
    let lexbuf = Sedlexing.Utf8.from_string input in
    let () = Sedlexing.set_position lexbuf
      { Lexing.pos_cnum = 0 ; Lexing.pos_bol = 0 ; Lexing.pos_lnum = 1 ; Lexing.pos_fname = "" } in
      Buffer lexbuf

let readline_cont command_str cont_line pstart env =
  match Readline.readline ~prompt:UtilsLib.Error.cont_prompt ~completion_fun:(Completion.complete env (!command_str ^ "\n")) () with
  | None -> Eof
  | Some input ->
    let () = command_str := !command_str ^ "\n" ^ input in
    let () = Readline.append_to_last_entry ("\n" ^ input) in
    let lexbuf = Sedlexing.Utf8.from_string (cont_line ^ "\n" ^ input) in
    let () = Sedlexing.set_position lexbuf pstart in
      Buffer lexbuf

(* This loop parses the user input in lexbuf, and ask for more input if it may
 * be correct but incomplete. This happends in two cases : an unfinished token
 * from the lexer (represented by a special token), or an incomplete word of
 * the grammar (a parsing error when the next token is EOI). *)
let rec interactive_loop env checkpoint last_checkpoint last_token lexbuf line_num command_str =
  match checkpoint with
  | TableParser.MenhirInterpreter.InputNeeded _ -> (
      match Lexer.lex lexbuf with
      | Lexer.PartialToken (str, err) -> (
          let pstart, pend = Sedlexing.lexing_positions lexbuf in
          match readline_cont command_str str pstart env with
          | Eof | Empty -> Errors.LexingErrors.emit err ~loc:(pstart, pend)
          | Buffer lexbuf ->
              interactive_loop env checkpoint last_checkpoint last_token lexbuf (line_num + 1) command_str)
      | Lexer.Token (tok, _) ->
          let pstart, pend = Sedlexing.lexing_positions lexbuf in
          let new_checkpoint =
            TableParser.MenhirInterpreter.offer checkpoint (tok, pstart, pend)
          in
            interactive_loop env new_checkpoint checkpoint (Some tok) lexbuf line_num command_str)
  | TableParser.MenhirInterpreter.Shifting _
  | TableParser.MenhirInterpreter.AboutToReduce _ ->
      let checkpoint = TableParser.MenhirInterpreter.resume checkpoint in
      interactive_loop env checkpoint last_checkpoint last_token lexbuf line_num command_str
  | TableParser.MenhirInterpreter.HandlingError s_env ->
      if last_token = Some Parser.EOI then
        let (pstart, pend) = Sedlexing.lexing_positions lexbuf in
        match readline_cont command_str "" pstart env with
        | Eof | Empty -> Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError (state s_env)) ~loc:(pstart, pend))
        | Buffer lexbuf ->
            interactive_loop env last_checkpoint last_checkpoint None lexbuf (line_num + 1) command_str
      else
        let loc = Sedlexing.lexing_positions lexbuf in
        Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError (state s_env)) ~loc)
  | TableParser.MenhirInterpreter.Accepted f ->
      (match Lexer.lex lexbuf with
      | Lexer.Token (Parser.EOI, _) -> f
      | _ -> let loc = Sedlexing.lexing_positions lexbuf in
          Errors.(SyntaxErrors.emit Syntax_l.TrailingChars ~loc))
  | TableParser.MenhirInterpreter.Rejected -> assert false

let rec interactive env =
  let command_str = ref "" in
  try
    match readline_base command_str env with
    | Eof -> Stop
    | Empty -> interactive env
    | Buffer lexbuf ->
        let start =
          TableParser.Incremental.interactive_command
            (fst (Sedlexing.lexing_positions lexbuf))
        in
        let command = interactive_loop env start start None lexbuf 1 command_str in
        let () = UtilsLib.Utils.sterm_set_size (); UtilsLib.Utils.term_set_size () in
        let res_val_list, res_env = command env in
        let () = Option.iter (Value.print true) res_val_list in
        Continue { res_env with Environment.last_value =
          if res_val_list = None then res_env.Environment.last_value else res_val_list }
  with
  | Sys.Break ->
      interactive env
  | e -> UtilsLib.Error.print_error e (Some !command_str); Continue_Error

let script lexbuf env =
  let parser =
    MenhirLib.Convert.Simplified.traditional2revised CodeParser.script_command in

  let rec parse () =
    try
      let command_str = ref "" in
      let command_o = parser
        (fun () -> match Lexer.lex lexbuf with
        | Lexer.Token (tok, str) -> command_str := !command_str ^ str;
            let pstart, pend = Sedlexing.lexing_positions lexbuf in
            tok, pstart, pend
        | Lexer.PartialToken (_, err) ->
            let loc = Sedlexing.lexing_positions lexbuf in
            Errors.LexingErrors.emit err ~loc) in
      match command_o with
      | Some command -> (command, !command_str) :: parse ()
      | None -> []
    with
      | CodeParser.Error s ->
        let loc = Sedlexing.lexing_positions lexbuf in
          Errors.(SyntaxErrors.emit (Syntax_l.SyntaxError s) ~loc) in

  let command_list =
    try
      parse ()
    with
    | e -> UtilsLib.Error.print_error_fatal e None in

  let env = List.fold_left
    (fun env (command, command_str) ->
      try
        if env.Environment.config.Config.step_by_step then
          (Printf.printf "%s\n" command_str; ignore (read_line ()));
        let (value_o, env) = command env in
        let () = Option.iter (Value.print env.Environment.config.Config.step_by_step) value_o in
        (if env.Environment.config.Config.step_by_step && value_o <> None then
          ignore (read_line ()));
        env
      with
      | e -> UtilsLib.Error.print_error e None; env)
    env
    command_list in
  env