Mercurial > urweb
diff src/cjr_print.sml @ 185:19ee24bffbc0
FFI datatypes
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 03 Aug 2008 17:57:47 -0400 |
parents | d11754ffe252 |
children | 88d46972de53 |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Aug 03 16:53:13 2008 -0400 +++ b/src/cjr_print.sml Sun Aug 03 17:57:47 2008 -0400 @@ -266,46 +266,54 @@ end end +fun patConInfo env pc = + case pc of + PConVar n => + let + val (x, _, dn) = E.lookupConstructor env n + val (dx, _) = E.lookupDatatype env dn + in + ("__lwd_" ^ dx ^ "_" ^ Int.toString dn, + "__lwc_" ^ x ^ "_" ^ Int.toString n) + end + | PConFfi {mod = m, datatyp, con} => + ("lw_" ^ m ^ "_" ^ datatyp, + "lw_" ^ m ^ "_" ^ con) + fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t p | ERel n => p_rel env n | ENamed n => p_enamed env n - | ECon (n, eo) => + | ECon (pc, eo) => let - val (x, _, dn) = E.lookupConstructor env n - val (dx, _) = E.lookupDatatype env dn + val (xd, xc) = patConInfo env pc in box [string "({", newline, string "struct", space, - string "__lwd_", - string dx, - string "_", - string (Int.toString dn), + string xd, space, string "*tmp", space, string "=", space, - string "lw_malloc(ctx, sizeof(struct __lwd_", - string dx, - string "_", - string (Int.toString dn), + string "lw_malloc(ctx, sizeof(struct ", + string xd, string "));", newline, string "tmp->tag", space, string "=", space, - string ("__lwc_" ^ x ^ "_" ^ Int.toString n), + string xc, string ";", newline, case eo of NONE => box [] - | SOME e => box [string "tmp->data.__lwc_", - string x, + | SOME e => box [string "tmp->data.", + string xd, space, string "=", space,