API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Nov 12th, 2018
87
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
OCaml 18.15 KB | None | 0 0
raw download clone embed print report
  1.  
  2. (* reader.ml
  3.  * A compiler from Scheme to x86/64
  4.  *
  5.  * Programmer: Mayer Goldberg, 2018
  6. *)
  7.  
  8. #use "pc.ml";;
  9. open PC;;
  10.  
  11.  
  12. exception X_not_yet_implemented;;
  13. exception X_this_should_not_happen;;
  14. type number =
  15.     | Int of int
  16.     | Float of float;;
  17.  
  18. type sexpr =
  19.     | Bool of bool
  20.     | None
  21.     | Nil
  22.     | Number of number
  23.     | Char of char
  24.     | String of string
  25.     | Symbol of string
  26.     | Some of char
  27.     | Pair of sexpr * sexpr
  28.     | Vector of sexpr list;;
  29.  
  30. let rec sexpr_eq s1 s2 =
  31.   match s1, s2 with
  32.     | Bool(b1), Bool(b2) -> b1 = b2
  33.     | Nil, Nil -> true
  34.     | Number(Float f1), Number(Float f2) -> abs_float(f1 -. f2) < 0.001
  35.     | Number(Int n1), Number(Int n2) -> n1 = n2
  36.     | Char(c1), Char(c2) -> c1 = c2
  37.     | String(s1), String(s2) -> s1 = s2
  38.     | Symbol(s1), Symbol(s2) -> s1 = s2
  39.     | Pair(car1, cdr1), Pair(car2, cdr2) -> (sexpr_eq car1 car2) && (sexpr_eq cdr1 cdr2)
  40.     | Vector(l1), Vector(l2) -> List.for_all2 sexpr_eq l1 l2
  41.     | _ -> false;;
  42.  
  43.  
  44. (*
  45. let istrue s= PC.caten (PC.char '#') (PC.char_ci 't') s;;
  46. let isfalse s= PC.caten (PC.char '#') (PC.char_ci 'f') s;;
  47. let boolpars str =
  48. let s = string_to_list str in
  49. PC.disj istrue isfalse s;;
  50. let trueorfalse m =
  51. (fun ((e,b))-> if (lowercase_ascii b=='t') then Bool true else Bool false) m;;
  52.  
  53. let yala s= PC.pack boolpars trueorfalse s;;
  54. *)
  55. let nt_digit_0_to_9 =
  56.   pack (const (fun ch -> '0' <= ch && ch <= '9'))
  57.     (fun ch -> (int_of_char ch) - 48);;
  58.  
  59. let nt_natural =
  60.   let rec make_nt_natural () =
  61.     pack (caten nt_digit_0_to_9
  62.             (disj (delayed make_nt_natural)
  63.                nt_epsilon))
  64.       (function (a, s) -> a :: s) in
  65.     pack (make_nt_natural())
  66.       (fun s ->
  67.          (List.fold_left
  68.             (fun a b -> 10 * a + b)
  69.             0
  70.             s));;
  71.  
  72. let nt_digit_a_to_f =
  73.   pack (const (fun ch -> 'a' <= ch && ch <= 'f'))
  74.     (fun ch -> (int_of_char ch) - 87);;
  75.  
  76. let nt_digit_A_to_F =
  77.   pack (const (fun ch -> 'A' <= ch && ch <= 'F'))
  78.     (fun ch -> (int_of_char ch) - 55);;
  79.  
  80. let nt_hex =
  81.   let rec make_nt_hex () =
  82.     pack (caten (disj (disj nt_digit_0_to_9 nt_digit_a_to_f) nt_digit_A_to_F)
  83.             (disj (delayed make_nt_hex)
  84.                nt_epsilon))
  85.       (function (a, s) -> a :: s) in
  86.     pack (pack (caten  (caten (caten (char '#') (char_ci 'x')) (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  87.                                                                                                             | None -> 1
  88.                                                                                                             | (Some('+')) -> 1
  89.                                                                                                             | (Some('-')) -> -1
  90.                                                                                                             | l -> 8))) (make_nt_hex())) (function (((a,b),c),d) -> List.map (fun (x) -> c*x) d))
  91.       (fun s ->
  92.          (List.fold_left
  93.             (fun a b -> 16 * a + b)
  94.             0
  95.             s));;
  96. let nt_little_float =
  97.   let rec make_nt_natural () =
  98.     pack (caten nt_digit_0_to_9
  99.             (disj (delayed make_nt_natural)
  100.                nt_epsilon))
  101.       (function (a, s) -> a :: s) in
  102.     pack (pack (make_nt_natural()) (fun (x) -> List.map float_of_int x))
  103.       (fun (s) ->
  104.          (List.fold_right
  105.             (fun a b -> b /. 10.  +. a /. 10.)
  106.             s
  107.             0.));;
  108. let nt_hexdigit = disj (disj nt_digit_0_to_9 nt_digit_a_to_f) nt_digit_A_to_F;;
  109. let nt_hex_natural = pack (pack (plus nt_hexdigit) (fun (a) -> List.map float_of_int a)) (fun (s) ->
  110.                                                                                            (List.fold_right
  111.                                                                                               (fun a b -> b /. 16.  +. a /. 16.)
  112.                                                                                               s
  113.                                                                                               0.));;
  114. let nt_hexfloat =
  115.   pack (caten (caten (pack nt_hex  (fun (a) ->  float_of_int a)) (char '.')) nt_hex_natural) (fun ((a,b),c) -> if a<0. then a +. -1.*.c else a +. c);;
  116.  
  117. let nt_float =
  118.   let rec make_nt_natural () =
  119.     pack (caten nt_digit_0_to_9
  120.             (disj (delayed make_nt_natural)
  121.                nt_epsilon))
  122.       (function (a, s) -> a :: s) in
  123.     pack (pack (caten (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  124.                                                                           | None -> 1.
  125.                                                                           | (Some('+')) -> 1.
  126.                                                                           | (Some('-')) -> -1.
  127.                                                                           | l -> 8.)) (caten (pack (make_nt_natural()) (fun (x) -> List.map float_of_int x)) (char '.'))) (nt_little_float)) (fun ((a,(b,c)),d) -> ((List.map (fun (x) -> a*.x) b),a*.d)))
  128.       (fun (s,d) ->
  129.          (List.fold_left
  130.             (fun a b -> 10. *. a +. b)
  131.             0.
  132.             s)+.d);;
  133.  
  134.  
  135.  
  136. let nt_plusminusinteger num =
  137.   let m= disj (caten (char '-')   (pack nt_natural (fun s -> -1*s))) (caten  (pack (maybe (char '+')) (fun l -> match l with
  138.                                                                                                         | None -> '+'
  139.                                                                                                         | (Some('+')) -> '+'
  140.                                                                                                         | l -> 'f' )) nt_natural) num in
  141.     (fun ((e,s),c) -> (s,c)) m;;
  142.  
  143. let nt_integer num =
  144.   nt_plusminusinteger num;;
  145.  
  146. let nt_scientific_int =  pack (caten (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  147.                                                                                                | None -> '0'
  148.                                                                                                | (Some('+')) -> '0'
  149.                                                                                                | (Some('-')) -> '-'
  150.                                                                                                | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b)) (pack (caten (char_ci 'e') (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  151.                                                                                                                                                                                                                                                                   | None -> '0'
  152.                                                                                                                                                                                                                                                                   | (Some('+')) -> '0'
  153.                                                                                                                                                                                                                                                                   | (Some('-')) -> '-'
  154.                                                                                                                                                                                                                                                                   | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b))) (fun (a,b) -> List.append (a::[]) b)))
  155.                            (fun (a,b) -> float_of_string (list_to_string (List.append a b)));;
  156.  
  157. let nt_scientific_float =  pack (caten (pack (caten (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  158.                                                                                                               | None -> '0'
  159.                                                                                                               | (Some('+')) -> '0'
  160.                                                                                                               | (Some('-')) -> '-'
  161.                                                                                                               | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b)) (pack (caten (char '.') (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b))) (fun (a,b) -> List.append a b)) (pack (caten (char_ci 'e') (pack (caten (pack (maybe (disj (char '+') (char '-'))) (fun l -> match l with
  162.                                                                                                                                                                                                                                                                                                                                                                                                            | None -> '0'
  163.                                                                                                                                                                                                                                                                                                                                                                                                            | (Some('+')) -> '0'
  164.                                                                                                                                                                                                                                                                                                                                                                                                            | (Some('-')) -> '-'
  165.                                                                                                                                                                                                                                                                                                                                                                                                            | l -> '8')) (plus (range_ci '0' '9'))) (fun (a,b) -> List.append (a::[]) b) )) (fun (a,b) -> List.append (a::[]) b)))
  166.                              (fun (a,b) -> float_of_string (list_to_string (List.append a b)));;
  167.  
  168. let nt_charprefix = (word "#\\");;
  169. let nt_visiblechar = const (fun ch -> (int_of_char ch)>32 && (int_of_char ch)<=127);;
  170. let nt_namedchar = disj_list [(pack (word_ci "newline") (fun (a) -> '\010'));(pack (word_ci "page") (fun (a) -> '\012'));(pack (word_ci "space") (fun (a) -> ' '));(pack (word_ci "nul") (fun (a) -> '\000'));(pack (word_ci "return") (fun (a) -> '\013'));(pack (word_ci "tab") (fun (a) -> '\009'))];;
  171. let nt_hexchar = pack (caten (char_ci 'x') (plus nt_hexdigit)) (fun (d,c) -> char_of_int
  172.                                                                                (List.fold_left
  173.                                                                                   (fun a b -> 16 * a + b)
  174.                                                                                   0
  175.                                                                                   c));;
  176.  
  177.  
  178.  
  179. let nt_stringlitteralchar = pack (diff nt_any (one_of "\\\"")) (fun (a) -> a::[]);;  
  180.  
  181. let nt_string_meta_f = pack (word "\\f") (fun _ -> '\012'::[]);;
  182. let nt_string_meta_bkslsh = pack (word "\\\\") (fun _ -> '\\'::[]);;
  183. let nt_string_meta_quote = pack (word "\\\"") (fun _ -> '\"'::[]);;
  184. let nt_string_meta_t = pack (word "\\t") (fun _ -> '\t'::[]);;
  185. let nt_string_meta_n = pack (word "\\n") (fun _ -> '\n'::[]);;
  186. let nt_string_meta_r = pack (word "\\r") (fun _ -> '\r'::[]);;
  187.  
  188. let nt_stringmetachar = disj_list [nt_string_meta_f ; nt_string_meta_bkslsh ; nt_string_meta_quote ; nt_string_meta_t ; nt_string_meta_n ; nt_string_meta_r];;
  189. let nt_stringhexchar = pack (caten (caten (word_ci "\\x") (pack (plus nt_hexdigit)
  190.                                                             (fun (c) -> (char_of_int
  191.                                                                            (List.fold_left
  192.                                                                               (fun a b -> 16 * a + b)
  193.                                                                               0
  194.                                                                               c))))) (char ';')) (fun ((a,b),c) -> b::[]);;
  195.  
  196. let nt_string_char = disj_list [nt_stringmetachar;nt_stringlitteralchar;nt_stringhexchar];;
  197.  
  198. test_string nt_string_char "\\t";;
  199.  
  200. let nt_symbolchar = disj_list [(range '0' '9');(range_ci 'a' 'z'); (const (fun ch -> ch=='!' ||ch=='$' ||ch=='^' ||ch=='*' ||ch=='-' ||ch=='_' ||ch=='=' ||ch=='+' ||ch=='<' ||ch=='>' ||ch=='?' ||ch=='/' ||ch==':' ))];;
  201. let which_quote x = match x with
  202.  | "\'" -> "quote"
  203.  | "`" -> "quasiquote"
  204.  | "," -> "unquote"
  205.  | ",@" -> "unquote-splicing"
  206.  | x -> "no"
  207.  
  208. (* let nt_white = pack nt_whitespace (fun a -> None);; *)
  209. let nt_symbol = pack (plus nt_symbolchar) (fun (a) -> list_to_string a);;
  210. let nt_string = pack (caten (caten (char '\"') (star nt_string_char)) (char '\"')) (fun ((a,b),c) -> list_to_string (List.flatten b));;
  211. let nt_number = disj (pack (disj_list [nt_scientific_int;nt_scientific_float;nt_float;nt_hexfloat]) (fun (a) -> Float(a))) (pack (disj nt_plusminusinteger nt_hex) (fun (a) -> Int(a)));;
  212. let nt_char = pack (caten nt_charprefix (disj_list [nt_hexchar;nt_namedchar;nt_visiblechar])) (fun (a,b) -> b);;
  213. (*let nt_char = not_followed_by (nt_char) (disj_list [nt_symbol]);;*)
  214.  
  215. (* line comment impl *)
  216. let nt_smcol = char ';';;
  217. let nt_nwln = char '\n';;
  218. let nt_end_inp = pack nt_end_of_input (fun _ -> ' ');;
  219.  
  220. let nt_notend = const (fun ch -> ch != '\n');;
  221. let nt_skip = pack (star nt_notend) (fun l -> ' ');;
  222. let nt_line_comm = pack (caten_list [nt_smcol;nt_skip;(disj nt_nwln nt_end_inp)]) (fun a -> ' ');;
  223. test_string nt_line_comm "; this is comment
  224. this is second line";;
  225. let nt_comment = nt_line_comm;; (* disj sexpr_comment *)
  226.  
  227. (* Parsers without spaces from right & left   AND   sexp conversion *)
  228. let _whitespaces_ = star (disj nt_whitespace nt_comment);;
  229. let nts_symbol = pack (caten (caten _whitespaces_ nt_symbol) _whitespaces_) (fun ((l,p),r) -> Symbol p);;
  230. let nts_string = pack (caten (caten _whitespaces_ nt_string) _whitespaces_) (fun ((l,p),r) -> String p);;
  231. let nts_char = pack (caten (caten _whitespaces_ nt_char) _whitespaces_) (fun ((l,p),r) -> Char p);;
  232. let nts_number = pack (caten (caten _whitespaces_ nt_number) _whitespaces_)  (fun ((l,p),r) -> Number p);;
  233.  
  234. test_string nts_string "\"This is a string with \\r \"";;
  235. test_string nts_string "\"This is a string with \"";;
  236.  
  237. let nt_bool =
  238.  let istrue = pack (word_ci "#t") (fun _ -> Bool true) in
  239.  let isfalse = pack (word_ci "#f") (fun _ -> Bool false) in
  240.    not_followed_by (disj istrue isfalse) (disj_list [nts_symbol;nts_string]);;
  241. let nts_bool = pack (caten (caten _whitespaces_ nt_bool) _whitespaces_)  (fun ((l,p),r) -> p);;
  242.  
  243. test_string nts_symbol "string";;
  244. test_string nts_char "#\\tab";;
  245.  
  246. let lp = char '(';;
  247. let rp = char ')';;
  248. let lbp = char '[';;
  249. let rbp = char ']';;
  250. (* sexprs disjoint impl *)
  251. let rec nts_sexpr = fun a -> (disj_list [nts_list;nts_bool;nts_quote;nts_number;nts_symbol;nts_string;nts_char]) a
  252. and nts_sexprs = fun a -> (star nts_sexpr) a
  253. and nts_dot_list s =
  254.  let nts_dotted_list = (caten (plus nts_sexpr) (caten (char '.') nts_sexpr)) in
  255.  let nts_dotted_list = pack nts_dotted_list (fun (l,(c,r)) -> (l@[r])) in
  256.    nts_dotted_list s
  257. and nt_list s =
  258.  let x = pack (caten (caten lp (disj_list [nts_dot_list;(star nts_sexpr)])) rp) (fun ((l,p),r) -> p) in  (*   star nts_sexpr*)
  259.  let x = pack x (fun l -> List.fold_right (fun a b -> Pair(a,b)) l Nil) in
  260.    x s
  261. and nts_list = fun b -> (pack (caten (caten _whitespaces_ nt_list) _whitespaces_) (fun ((l,p),r) -> p)) b
  262. and nts_quote = fun a -> (pack (caten (disj_list [(word "\'");(word "`");(word ",@");(word ",")]) (nts_sexpr))
  263.                            (fun (a,b) -> Pair(Symbol((which_quote (list_to_string a))), Pair(b,Nil)))) a;;
  264.  
  265. test_string nts_quote ",@test";;
  266. test_string (nts_sexprs) "1 #f \"Test\" #x44 #\\a";;
  267.  
  268.  
  269. (*
  270. let rec  nt_sexprs = fun a -> (disj_list [(pack nt_number (fun (a) -> Number(a)));nt_bool;nt_char;nt_symbol;nt_string;nt_quote]) a
  271.  
  272. let nts_sexprs = star nts_sexpr;;
  273.  
  274. and nts_quote s =
  275. let quote_parser = (caten (disj_list [(word "\'");(word "`");(word ",@");(word ",")]) (nts_sexprs)) in
  276. let nts_quote = (pack quote_parser (fun (a,b) -> Pair(Symbol((which_quote (list_to_string a))), Pair(b,Nil)))) in
  277. let nts_quote =  pack (caten (caten _whitespaces_ nts_quote) _whitespaces_)  (fun ((l,p),r) -> p) in
  278. nts_quote s;;
  279. *)
  280.  
  281. (* Genna section
  282.   What is left to do:
  283.  
  284. *)
  285.  
  286.  
  287. (* list impl *)
  288.  
  289. test_string nts_dot_list "1 2 . 3";;
  290.  
  291.  
  292.  
  293.  
  294. test_string (nts_list) "(1 #\\a 3)";;
  295. test_string (nts_list) "(1 #\\a (1 2) 3)";;
  296.  
  297. let nts_nil = pack (word "()") (fun _ -> Nil);;
  298. let nts_vector = pack (caten (char '#') nt_list) (fun (a, l) -> l);;
  299.  
  300. test_string (nts_vector) "#(1 #\\a)";;
  301.  
  302. let nts_brack_pair s =  (* TODO: is it okay to nil to be third element?*)
  303.  let x = pack (caten (caten lbp (nts_sexprs)) rbp) (fun ((l,p),r) -> p) in
  304.  let x = pack x (fun l -> List.fold_right (fun a b -> Pair(a,b)) l Nil) in
  305.    x s;;
  306.  
  307. test_string nts_brack_pair "[x 3]";;
  308.  
  309. (*let nts_comb_list = disj_list [nts_dotted_list;nts_list;nts_nil];;*)
  310.  
  311.  
  312.  
  313. let pack_final nt s =
  314.  let (e, s) = (nt s) in
  315.    e;;
  316. (*     Genna section end
  317.       raise X_not_yet_implemented;;
  318. *)
  319.  
  320.  
  321. module Reader: sig
  322.  val read_sexpr : string -> sexpr
  323.  val read_sexprs : string -> sexpr list
  324. end
  325.  
  326. = struct
  327.  let normalize_scheme_symbol str =
  328.    let s = string_to_list str in
  329.      if (andmap
  330.            (fun ch -> (ch = (lowercase_ascii ch)))
  331.            s) then str
  332.      else Printf.sprintf "|%s|" str;;
  333.  
  334.  
  335.  
  336.  let read_sexpr string =
  337.    pack_final nts_sexpr (string_to_list string);;
  338.  
  339.  let read_sexprs string = pack_final nts_sexprs (string_to_list string);;
  340. end;; (* struct Reader *)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
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!