| 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 | |