API tools faq
paste
Guest User

Untitled

a guest
Feb 16th, 2019
103
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 9.23 KB | None | 0 0
raw download clone embed print report
  1. diff -Naur ocaml-4.00.1/typing/typecore.ml ocaml-4.00.1-format-check/typing/typecore.ml
  2. --- ocaml-4.00.1/typing/typecore.ml 2013-03-13 00:54:14.000000000 +0100
  3. +++ ocaml-4.00.1-format-check/typing/typecore.ml 2013-03-13 01:25:46.000000000 +0100
  4. @@ -37,6 +37,11 @@
  5. | Label_not_mutable of Longident.t
  6. | Incomplete_format of string
  7. | Bad_conversion of string * int * char
  8. + | Incompatible_flags of string * int * char * char
  9. + | Bad_conversion_flag of string * int * char * char
  10. + | Unexpected_width of string * int
  11. + | Unexpected_precision of string * int
  12. + | Size_overflow of string * int
  13. | Undefined_method of type_expr * string
  14. | Undefined_inherited_method of string
  15. | Virtual_class of Longident.t
  16. @@ -1088,6 +1093,16 @@
  17. raise (Error (loc, Bad_conversion (fmt, i, c))) in
  18. let incomplete_format fmt =
  19. raise (Error (loc, Incomplete_format fmt)) in
  20. + let size_overflow fmt i =
  21. + raise (Error (loc, Size_overflow (fmt, i))) in
  22. + let incompatible_flags fmt i f1 f2 =
  23. + raise (Error (loc, Incompatible_flags (fmt, i, f1, f2))) in
  24. + let bad_conversion_flag f c fmt i =
  25. + raise (Error (loc, Bad_conversion_flag (fmt, i, c, f))) in
  26. + let unexpected_width fmt i =
  27. + raise (Error (loc, Unexpected_width (fmt, i))) in
  28. + let unexpected_precision fmt i =
  29. + raise (Error (loc, Unexpected_precision (fmt, i))) in
  30.  
  31. let rec type_in_format fmt =
  32.  
  33. @@ -1098,6 +1113,29 @@
  34. and ty_aresult = newvar ()
  35. and ty_uresult = newvar () in
  36.  
  37. + let zero_flag = ref false
  38. + and plus_flag = ref false
  39. + and minus_flag = ref false
  40. + and width_flag = ref false
  41. + and prec_flag = ref false in
  42. +
  43. + let rec check_flags valid_flags fmt i j =
  44. + let check (flag_ref, flag_char, error) =
  45. + if !flag_ref && not (List.mem flag_char valid_flags) then
  46. + error fmt i;
  47. + flag_ref := false;
  48. + in
  49. + if !zero_flag && !minus_flag then incompatible_flags fmt i '-' '0';
  50. + if !minus_flag && not !width_flag then incompatible_flags fmt i '-' 'W';
  51. + if !zero_flag && not !width_flag then incompatible_flags fmt i '0' 'W';
  52. + List.iter check [
  53. + (zero_flag, '0', bad_conversion_flag '0' fmt.[j]);
  54. + (plus_flag, '+', bad_conversion_flag '+' fmt.[j]);
  55. + (minus_flag, '-', bad_conversion_flag '-' fmt.[j]);
  56. + (width_flag, 'w', unexpected_width);
  57. + (prec_flag, '.', unexpected_precision);
  58. + ] in
  59. +
  60. let meta = ref 0 in
  61.  
  62. let rec scan_format i =
  63. @@ -1117,13 +1155,24 @@
  64. let rec scan_flags i j =
  65. if j >= len then incomplete_format fmt else
  66. match fmt.[j] with
  67. - | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
  68. + | '#' | ' ' -> scan_flags i (j + 1)
  69. + | '0' -> zero_flag := true; scan_flags i (j + 1)
  70. + | '+' -> plus_flag := true; scan_flags i (j + 1)
  71. + | '-' -> minus_flag := true; scan_flags i (j + 1)
  72. | _ -> scan_width i j
  73. - and scan_width i j = scan_width_or_prec_value scan_precision i j
  74. - and scan_decimal_string scan i j =
  75. + and scan_width i j =
  76. + if j >= len then incomplete_format fmt else
  77. + match fmt.[j] with
  78. + | '*' | '0' .. '9' ->
  79. + width_flag := true;
  80. + scan_width_or_prec_value scan_precision i j
  81. + | _ ->
  82. + scan_precision i j
  83. + and scan_decimal_string scan i j digit_nb =
  84. if j >= len then incomplete_format fmt else
  85. + if digit_nb > 9 then size_overflow fmt i else
  86. match fmt.[j] with
  87. - | '0' .. '9' -> scan_decimal_string scan i (j + 1)
  88. + | '0' .. '9' -> scan_decimal_string scan i (j + 1) (digit_nb + 1)
  89. | _ -> scan i j
  90. and scan_width_or_prec_value scan i j =
  91. if j >= len then incomplete_format fmt else
  92. @@ -1131,12 +1180,13 @@
  93. | '*' ->
  94. let ty_uresult, ty_result = scan i (j + 1) in
  95. ty_uresult, ty_arrow Predef.type_int ty_result
  96. - | '-' | '+' -> scan_decimal_string scan i (j + 1)
  97. - | _ -> scan_decimal_string scan i j
  98. + | _ -> scan_decimal_string scan i j 0
  99. and scan_precision i j =
  100. if j >= len then incomplete_format fmt else
  101. match fmt.[j] with
  102. - | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
  103. + | '.' ->
  104. + prec_flag := true;
  105. + scan_width_or_prec_value scan_conversion i (j + 1)
  106. | _ -> scan_conversion i j
  107. and scan_indication j =
  108. if j >= len then j - 1 else
  109. @@ -1199,20 +1249,36 @@
  110. and scan_conversion i j =
  111. if j >= len then incomplete_format fmt else
  112. match fmt.[j] with
  113. - | '%' | '@' | '!' | ',' -> scan_format (j + 1)
  114. + | '%' | '@' | '!' | ',' ->
  115. + check_flags [] fmt i j;
  116. + scan_format (j + 1)
  117. | 's' | 'S' ->
  118. + check_flags [ '-' ; 'w' ; '.' ] fmt i j;
  119. let j = scan_indication (j + 1) in
  120. conversion j Predef.type_string
  121. | '[' ->
  122. + check_flags [] fmt i j;
  123. let j = scan_range (j + 1) in
  124. let j = scan_indication (j + 1) in
  125. conversion j Predef.type_string
  126. - | 'c' | 'C' -> conversion j Predef.type_char
  127. + | 'c' | 'C' ->
  128. + check_flags [] fmt i j;
  129. + conversion j Predef.type_char
  130. | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' ->
  131. + if !zero_flag && !prec_flag then incompatible_flags fmt i '0' '.';
  132. + check_flags [ '0' ; '+' ; '-' ; 'w' ; '.' ] fmt i j;
  133. conversion j Predef.type_int
  134. - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
  135. - | 'B' | 'b' -> conversion j Predef.type_bool
  136. + | 'f' | 'e' | 'E' | 'g' | 'G' ->
  137. + check_flags [ '0' ; '+' ; '-' ; 'w' ; '.' ] fmt i j;
  138. + conversion j Predef.type_float
  139. + | 'F' ->
  140. + check_flags [] fmt i j;
  141. + conversion j Predef.type_float
  142. + | 'B' | 'b' ->
  143. + check_flags [] fmt i j;
  144. + conversion j Predef.type_bool
  145. | 'a' | 'r' as conv ->
  146. + check_flags [] fmt i j;
  147. let conversion =
  148. if conv = 'a' then conversion_a else conversion_r in
  149. let ty_e = newvar () in
  150. @@ -1232,8 +1298,12 @@
  151. | 'l' | 'L' -> conversion_r j ty_e (Pref.type_list ty_e)
  152. | 'o' | 'O' -> conversion_r j ty_e (Pref.type_option ty_e)
  153. | _ -> conversion_r (j - 1) ty_e ty_e end *)
  154. - | 't' -> conversion j (ty_arrow ty_input ty_aresult)
  155. + | 't' ->
  156. + check_flags [] fmt i j;
  157. + conversion j (ty_arrow ty_input ty_aresult)
  158. | 'l' | 'n' | 'L' as c ->
  159. + if !zero_flag && !prec_flag then incompatible_flags fmt i '0' '.';
  160. + check_flags [ '0' ; '+' ; '-' ; 'w' ; '.' ] fmt i j;
  161. let j = j + 1 in
  162. if j >= len then conversion (j - 1) Predef.type_int else begin
  163. match fmt.[j] with
  164. @@ -1247,6 +1317,7 @@
  165. | c -> conversion (j - 1) Predef.type_int
  166. end
  167. | '{' | '(' as c ->
  168. + check_flags [] fmt i j;
  169. let j = j + 1 in
  170. if j >= len then incomplete_format fmt else
  171. let sj =
  172. @@ -3105,11 +3176,35 @@
  173. | Label_not_mutable lid ->
  174. fprintf ppf "The record field label %a is not mutable" longident lid
  175. | Incomplete_format s ->
  176. - fprintf ppf "Premature end of format string ``%S''" s
  177. + fprintf ppf "Premature end of format string %S" s
  178. | Bad_conversion (fmt, i, c) ->
  179. fprintf ppf
  180. "Bad conversion %%%c, at char number %d \
  181. - in format string ``%s''" c i fmt
  182. + in format string %S" c i fmt
  183. + | Bad_conversion_flag (fmt, i, c, flag) ->
  184. + fprintf ppf
  185. + "Bad conversion %%%c%c, at char number %d \
  186. + in format string %S" flag c i fmt
  187. + | Incompatible_flags (fmt, i, flag, 'W') ->
  188. + fprintf ppf
  189. + "Flag %C invalid without width, at char number %d in format string %S"
  190. + flag i fmt
  191. + | Incompatible_flags (fmt, i, flag, '.') ->
  192. + fprintf ppf
  193. + "Incompatible flag %C with precision, at char number %d in format \
  194. + string %S" flag i fmt
  195. + | Incompatible_flags (fmt, i, flag1, flag2) ->
  196. + fprintf ppf
  197. + "Incompatible flags %C and %C, at char number %d in format string %S"
  198. + flag1 flag2 i fmt
  199. + | Unexpected_width (fmt, i) ->
  200. + fprintf ppf "Unexpected width, at char number %d in format string %S"
  201. + i fmt
  202. + | Unexpected_precision (fmt, i) ->
  203. + fprintf ppf "Unexpected precision, at char number %d in format string %S"
  204. + i fmt
  205. + | Size_overflow (fmt, i) ->
  206. + fprintf ppf "Size overflow, at char number %d in format string %S" i fmt
  207. | Undefined_method (ty, me) ->
  208. reset_and_mark_loops ty;
  209. fprintf ppf
  210. diff -Naur ocaml-4.00.1/typing/typecore.mli ocaml-4.00.1-format-check/typing/typecore.mli
  211. --- ocaml-4.00.1/typing/typecore.mli 2013-03-13 00:54:14.000000000 +0100
  212. +++ ocaml-4.00.1-format-check/typing/typecore.mli 2013-03-13 00:53:51.000000000 +0100
  213. @@ -79,6 +79,11 @@
  214. | Label_not_mutable of Longident.t
  215. | Incomplete_format of string
  216. | Bad_conversion of string * int * char
  217. + | Incompatible_flags of string * int * char * char
  218. + | Bad_conversion_flag of string * int * char * char
  219. + | Unexpected_width of string * int
  220. + | Unexpected_precision of string * int
  221. + | Size_overflow of string * int
  222. | Undefined_method of type_expr * string
  223. | Undefined_inherited_method of string
  224. | Virtual_class of Longident.t
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!