Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | open Pcaml ;; |
2 | ||
3 | let lap x y = x :: y | |
4 | let c_ify e loc = | |
5 | match e with | |
6 | <:expr< $int:_$ >> -> <:expr< (C_int $e$) >> | |
7 | | <:expr< $str:_$ >> -> <:expr< (C_string $e$) >> | |
8 | | <:expr< $chr:_$ >> -> <:expr< (C_char $e$) >> | |
9 | | <:expr< $flo:_$ >> -> <:expr< (C_double $e$) >> | |
10 | | <:expr< True >> -> <:expr< (C_bool $e$) >> | |
11 | | <:expr< False >> -> <:expr< (C_bool $e$) >> | |
12 | | _ -> <:expr< $e$ >> | |
13 | let mk_list args loc f = | |
14 | let rec mk_list_inner args loc f = | |
15 | match args with | |
16 | [] -> <:expr< [] >> | |
17 | | x :: xs -> | |
18 | (let loc = MLast.loc_of_expr x in | |
19 | <:expr< [ ($f x loc$) ] @ ($mk_list_inner xs loc f$) >>) in | |
20 | match args with | |
21 | [] -> <:expr< (Obj.magic C_void) >> | |
22 | | [ a ] -> <:expr< (Obj.magic $f a loc$) >> | |
23 | | _ -> <:expr< (Obj.magic (C_list ($mk_list_inner args loc f$))) >> | |
24 | ||
25 | EXTEND | |
26 | expr: | |
27 | [ [ e1 = expr ; "'" ; "[" ; e2 = expr ; "]" -> | |
28 | <:expr< (invoke $e1$) "[]" (C_list [ $c_ify e2 loc$ ]) >> | |
29 | | e1 = expr ; "->" ; l = LIDENT ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
30 | <:expr< (invoke $e1$) $str:l$ ($mk_list args loc c_ify$) >> | |
31 | | e1 = expr ; "->" ; u = UIDENT ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
32 | <:expr< (invoke $e1$) $str:u$ ($mk_list args loc c_ify$) >> | |
33 | | e1 = expr ; "->" ; s = expr LEVEL "simple" ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
34 | <:expr< (invoke $e1$) $s$ ($mk_list args loc c_ify$) >> | |
35 | | e1 = expr ; "'" ; "." ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
36 | <:expr< (invoke $e1$) "()" ($mk_list args loc c_ify$) >> | |
37 | | e1 = expr ; "'" ; "->" ; l = LIDENT ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
38 | <:expr< (invoke ((invoke $e1$) "->" C_void)) $str:l$ ($mk_list args loc c_ify$) >> | |
39 | | e1 = expr ; "'" ; "->" ; u = UIDENT ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
40 | <:expr< (invoke ((invoke $e1$) "->" C_void)) $str:u$ ($mk_list args loc c_ify$) >> | |
41 | | e1 = expr ; "'" ; "->" ; s = expr LEVEL "simple" ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
42 | <:expr< (invoke ((invoke $e1$) "->" C_void)) $s$ ($mk_list args loc c_ify$) >> | |
43 | | e1 = expr ; "'" ; "++" -> | |
44 | <:expr< (invoke $e1$) "++" C_void >> | |
45 | | e1 = expr ; "'" ; "--" -> | |
46 | <:expr< (invoke $e1$) "--" C_void >> | |
47 | | e1 = expr ; "'" ; "-" ; e2 = expr -> | |
48 | <:expr< (invoke $e1$) "-" (C_list [ $c_ify e2 loc$ ]) >> | |
49 | | e1 = expr ; "'" ; "+" ; e2 = expr -> <:expr< (invoke $e1$) "+" (C_list [ $c_ify e2 loc$ ]) >> | |
50 | | e1 = expr ; "'" ; "*" ; e2 = expr -> <:expr< (invoke $e1$) "*" (C_list [ $c_ify e2 loc$ ]) >> | |
51 | | "'" ; "&" ; e1 = expr -> | |
52 | <:expr< (invoke $e1$) "&" C_void >> | |
53 | | "'" ; "!" ; e1 = expr -> | |
54 | <:expr< (invoke $e1$) "!" C_void >> | |
55 | | "'" ; "~" ; e1 = expr -> | |
56 | <:expr< (invoke $e1$) "~" C_void >> | |
57 | | e1 = expr ; "'" ; "/" ; e2 = expr -> | |
58 | <:expr< (invoke $e1$) "/" (C_list [ $c_ify e2 loc$ ]) >> | |
59 | | e1 = expr ; "'" ; "%" ; e2 = expr -> | |
60 | <:expr< (invoke $e1$) "%" (C_list [ $c_ify e2 loc$ ]) >> | |
61 | | e1 = expr ; "'" ; "lsl" ; e2 = expr -> | |
62 | <:expr< (invoke $e1$) ("<" ^ "<") (C_list [ $c_ify e2 loc$ ]) >> | |
63 | | e1 = expr ; "'" ; "lsr" ; e2 = expr -> | |
64 | <:expr< (invoke $e1$) (">" ^ ">") (C_list [ $c_ify e2 loc$ ]) >> | |
65 | | e1 = expr ; "'" ; "<" ; e2 = expr -> | |
66 | <:expr< (invoke $e1$) "<" (C_list [ $c_ify e2 loc$ ]) >> | |
67 | | e1 = expr ; "'" ; "<=" ; e2 = expr -> | |
68 | <:expr< (invoke $e1$) "<=" (C_list [ $c_ify e2 loc$ ]) >> | |
69 | | e1 = expr ; "'" ; ">" ; e2 = expr -> | |
70 | <:expr< (invoke $e1$) ">" (C_list [ $c_ify e2 loc$ ]) >> | |
71 | | e1 = expr ; "'" ; ">=" ; e2 = expr -> | |
72 | <:expr< (invoke $e1$) ">=" (C_list [ $c_ify e2 loc$ ]) >> | |
73 | | e1 = expr ; "'" ; "==" ; e2 = expr -> | |
74 | <:expr< (invoke $e1$) "==" (C_list [ $c_ify e2 loc$ ]) >> | |
75 | | e1 = expr ; "'" ; "!=" ; e2 = expr -> | |
76 | <:expr< (invoke $e1$) "!=" (C_list [ $c_ify e2 loc$ ]) >> | |
77 | | e1 = expr ; "'" ; "&" ; e2 = expr -> | |
78 | <:expr< (invoke $e1$) "&" (C_list [ $c_ify e2 loc$ ]) >> | |
79 | | e1 = expr ; "'" ; "^" ; e2 = expr -> | |
80 | <:expr< (invoke $e1$) "^" (C_list [ $c_ify e2 loc$ ]) >> | |
81 | | e1 = expr ; "'" ; "|" ; e2 = expr -> | |
82 | <:expr< (invoke $e1$) "|" (C_list [ $c_ify e2 loc$ ]) >> | |
83 | | e1 = expr ; "'" ; "&&" ; e2 = expr -> | |
84 | <:expr< (invoke $e1$) "&&" (C_list [ $c_ify e2 loc$ ]) >> | |
85 | | e1 = expr ; "'" ; "||" ; e2 = expr -> | |
86 | <:expr< (invoke $e1$) "||" (C_list [ $c_ify e2 loc$ ]) >> | |
87 | | e1 = expr ; "'" ; "=" ; e2 = expr -> | |
88 | <:expr< (invoke $e1$) "=" (C_list [ $c_ify e2 loc$ ]) >> | |
89 | | e1 = expr ; "'" ; "+=" ; e2 = expr -> | |
90 | <:expr< (invoke $e1$) "+=" (C_list [ $c_ify e2 loc$ ]) >> | |
91 | | e1 = expr ; "'" ; "-=" ; e2 = expr -> | |
92 | <:expr< (invoke $e1$) "-=" (C_list [ $c_ify e2 loc$ ]) >> | |
93 | | e1 = expr ; "'" ; "*=" ; e2 = expr -> | |
94 | <:expr< (invoke $e1$) "*=" (C_list [ $c_ify e2 loc$ ]) >> | |
95 | | e1 = expr ; "'" ; "/=" ; e2 = expr -> | |
96 | <:expr< (invoke $e1$) "/=" (C_list [ $c_ify e2 loc$ ]) >> | |
97 | | e1 = expr ; "'" ; "%=" ; e2 = expr -> | |
98 | <:expr< (invoke $e1$) "%=" (C_list [ $c_ify e2 loc$ ]) >> | |
99 | | e1 = expr ; "'" ; "lsl" ; "=" ; e2 = expr -> | |
100 | <:expr< (invoke $e1$) ("<" ^ "<=") (C_list [ $c_ify e2 loc$ ]) >> | |
101 | | e1 = expr ; "'" ; "lsr" ; "=" ; e2 = expr -> | |
102 | <:expr< (invoke $e1$) (">" ^ ">=") (C_list [ $c_ify e2 loc$ ]) >> | |
103 | | e1 = expr ; "'" ; "&=" ; e2 = expr -> | |
104 | <:expr< (invoke $e1$) "&=" (C_list [ $c_ify e2 loc$ ]) >> | |
105 | | e1 = expr ; "'" ; "^=" ; e2 = expr -> | |
106 | <:expr< (invoke $e1$) "^=" (C_list [ $c_ify e2 loc$ ]) >> | |
107 | | e1 = expr ; "'" ; "|=" ; e2 = expr -> | |
108 | <:expr< (invoke $e1$) "|=" (C_list [ $c_ify e2 loc$ ]) >> | |
109 | | "'" ; e = expr -> c_ify e loc | |
110 | | c = expr ; "as" ; id = LIDENT -> <:expr< $lid:"get_" ^ id$ $c$ >> | |
111 | | c = expr ; "to" ; id = LIDENT -> <:expr< $uid:"C_" ^ id$ $c$ >> | |
112 | | "`" ; "`" ; l = LIDENT -> <:expr< C_enum `$lid:l$ >> | |
113 | | "`" ; "`" ; u = UIDENT -> <:expr< C_enum `$uid:u$ >> | |
114 | | f = expr ; "'" ; "(" ; args = LIST0 (expr LEVEL "simple") SEP "," ; ")" -> | |
115 | <:expr< $f$ ($mk_list args loc c_ify$) >> | |
116 | ] ] ; | |
117 | END ;; | |
118 |