2 (** These are the functions provided by the runtime system. *)
5 let error_prefix = "Primitives"
6 let error s = Error.global_error error_prefix s
7 let warning s = Error.warning error_prefix s
10 ("print_schar", "extern void print_schar(signed char);")
12 ("print_uchar", "extern void print_uchar(unsigned char);")
14 ("print_sshort", "extern void print_sshort(signed short);")
16 ("print_ushort", "extern void print_ushort(unsigned short);")
18 ("print_sint", "extern void print_sint(signed int);")
20 ("print_uint", "extern void print_uint(unsigned int);")
22 ("scan_int", "extern int scan_int(void);")
24 ("alloc", "extern int* alloc(int);")
26 ("newline", "extern void newline(void);")
28 ("space", "extern void space(void);")
30 ("rand_bool", "extern int rand_bool(void);")
32 ("rand_int", "extern int rand_int(int);")
39 [print_schar ; print_uchar ; print_sshort ; print_ushort ;
40 print_sint ; print_uint ; scan_int ; alloc ; newline ; space ;
44 let args_byte_size = function
45 | s when s = ident print_schar || s = ident print_uchar -> AST.QInt 1
46 | s when s = ident print_sshort || s = ident print_ushort -> AST.QInt 2
47 | s when s = ident print_sint || s = ident print_uint || s = ident rand_int ->
49 | s when s = ident scan_int || s = ident newline || s = ident space ||
50 s = ident rand_bool ->
52 | s when s = ident alloc -> AST.QPtr
53 | s -> error ("unknown primitive " ^ s ^ ".")
57 List.fold_left (fun res f -> StringTools.Set.add f res) StringTools.Set.empty
58 (List.map ident primitives_list)
60 let is_primitive f = StringTools.Set.mem f primitives
63 module Interpret (M : Memory.S) = struct
65 type res = V of M.Value.t list | A of M.Value.address
67 let print_integer_primitives =
69 [print_schar ; print_uchar ; print_sshort ; print_ushort ;
70 print_sint ; print_uint]
72 let is_print_integer_primitive f = List.mem f print_integer_primitives
74 let print_integer_primitive_funs = function
75 | f when f = ident print_schar ->
76 (IntValue.Int8.cast, IntValue.Int8.to_signed_repr)
77 | f when f = ident print_uchar ->
78 (IntValue.Int8.cast, IntValue.Int8.to_unsigned_repr)
79 | f when f = ident print_sshort ->
80 (IntValue.Int16.cast, IntValue.Int16.to_signed_repr)
81 | f when f = ident print_ushort ->
82 (IntValue.Int16.cast, IntValue.Int16.to_unsigned_repr)
83 | f when f = ident print_sint ->
84 (IntValue.Int32.cast, IntValue.Int32.to_signed_repr)
85 | f when f = ident print_uint ->
86 (IntValue.Int32.cast, IntValue.Int32.to_unsigned_repr)
87 | f -> error ("unknown integer printing primitive " ^ f ^ ".")
89 let make_int_value vs = IntValue.Int32.merge (List.map M.Value.to_int_repr vs)
91 let print_integer f mem vs =
92 let (cast, to_int_repr) = print_integer_primitive_funs f in
93 let i = make_int_value vs in
95 let i = to_int_repr i in
96 Printf.printf "%s%!" (IntValue.print_int_repr i) ;
100 let f res v = res && M.Value.is_int v in
101 List.fold_left f true args
104 let i = IntValue.Int32.of_int i in
105 let is = IntValue.Int32.break i (4 / M.Value.int_size) in
106 List.map M.Value.of_int_repr is
108 let t mem f = function
109 | args when is_print_integer_primitive f && are_ints args ->
110 print_integer f mem args
111 | _ when f = ident scan_int ->
112 Printf.printf ": %!" ;
113 (mem, V (res_of_int (int_of_string (read_line ()))))
114 | args when f = ident alloc && are_ints args ->
115 let size = IntValue.Int32.to_int (make_int_value args) in
116 let (mem, addr) = M.alloc mem size in
118 | _ when f = ident newline ->
119 Printf.printf "\n%!" ;
121 | _ when f = ident space ->
122 Printf.printf " %!" ;
124 | _ when f = ident rand_bool ->
125 (mem, V (res_of_int (Random.int 2)))
126 | args when f = ident rand_int && are_ints args ->
127 let i = IntValue.Int32.to_int (make_int_value args) in
128 (mem, V (res_of_int (Random.int i)))
129 | _ -> error ("unknown primitive " ^ f ^ " or bad arguments.")
133 let print_signedness = function
135 | AST.Unsigned -> "u"
137 let print_size = string_of_int
139 let print_type = function
140 | AST.Sig_int (size, sign) ->
141 "int" ^ (print_size size) ^ (print_signedness sign)
142 | AST.Sig_float (size, sign) ->
143 "float" ^ (print_size size) ^ (print_signedness sign)
144 | AST.Sig_offset -> "offset"
145 | AST.Sig_ptr -> "ptr"
147 let print_type_return = function
148 | AST.Type_ret t -> print_type t
149 | AST.Type_void -> "void"
151 let rec print_arg_types = function
153 | t :: ts -> (print_type t) ^ " -> " ^ (print_arg_types ts)
156 Printf.sprintf "%s%s"
157 (print_arg_types sg.AST.args)
158 (print_type_return sg.AST.res)
161 let f res s = res ^ "\n" ^ s in
162 (List.fold_left f "" (List.map proto primitives_list)) ^ "\n\n"