(***********************************************************************) (* *) (* Applied Type System *) (* *) (***********************************************************************) (* ** ATS/Postiats - Unleashing the Potential of Types! ** Copyright (C) 2011-2013 Hongwei Xi, ATS Trustful Software, Inc. ** All rights reserved ** ** ATS is free software; you can redistribute it and/or modify it under ** the terms of the GNU GENERAL PUBLIC LICENSE (GPL) as published by the ** Free Software Foundation; either version 3, or (at your option) any ** later version. ** ** ATS is distributed in the hope that it will be useful, but WITHOUT ANY ** WARRANTY; without even the implied warranty of MERCHANTABILITY or ** FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License ** for more details. ** ** You should have received a copy of the GNU General Public License ** along with ATS; see the file COPYING. If not, please write to the ** Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ** 02110-1301, USA. *) (* ****** ****** *) // // Author: Hongwei Xi // Authoremail: gmhwxi AT gmail DOT com // Start Time: April, 2011 // (* ****** ****** *) #include "./pats_params.hats" (* ****** ****** *) // staload ATSPRE = "./pats_atspre.dats" // (* ****** ****** *) staload UN = "prelude/SATS/unsafe.sats" (* ****** ****** *) staload ERR = "./pats_error.sats" staload LOC = "./pats_location.sats" overload + with $LOC.location_combine staload SYM = "./pats_symbol.sats" macdef BACKSLASH = $SYM.symbol_BACKSLASH macdef UNDERSCORE = $SYM.symbol_UNDERSCORE overload = with $SYM.eq_symbol_symbol (* ****** ****** *) staload "./pats_basics.sats" (* ****** ****** *) staload "./pats_errmsg.sats" staload _(*anon*) = "./pats_errmsg.dats" implement prerr_FILENAME<> () = prerr "pats_trans1_dynexp" (* ****** ****** *) staload "./pats_fixity.sats" staload "./pats_lexing.sats" staload "./pats_syntax.sats" staload "./pats_staexp1.sats" staload "./pats_dynexp1.sats" (* ****** ****** *) staload "./pats_trans1.sats" staload "./pats_trans1_env.sats" (* ****** ****** *) #define l2l list_of_list_vt (* ****** ****** *) // macdef list_sing (x) = list_cons (,(x), list_nil(*void*)) // (* ****** ****** *) // // HX: translation of dynamic expr // typedef d1expitm = fxitm (d1exp) typedef d1expitmlst = List (d1expitm) // (* ****** ****** *) // extern fun d1exp_app_proc ( loc0: location , d1e_fun: d1exp, d1e_arg: d1exp ) : d1exp // end-of-function // implement d1exp_app_proc ( loc0, d1e_fun, d1e_arg ) = let in // case+ d1e_fun.d1exp_node of // case+ // | D1Eidextapp (id, d1es_arg) => let val d1es_arg = list_cons (d1e_arg, d1es_arg) // end of [val] in d1exp_idextapp (loc0, id, d1es_arg) end // end of [D1Eidexpapp] | _ (*non-D1Eidextapp*) => let in case+ d1e_arg.d1exp_node of // case+ | D1Elist ( npf, d1es ) => let val locarg = d1e_arg.d1exp_loc in d1exp_app_dyn (loc0, d1e_fun, locarg, npf, d1es) end // end of [D1Elist] | D1Esexparg (s1a) => let in case+ d1e_fun.d1exp_node of // case+ | D1Eapp_sta (d1e_fun, s1as) => let val s1as = list_extend(s1as, s1a) in d1exp_app_sta(loc0, d1e_fun, l2l(s1as)) end // end of [d1exp_app_sta] | _ (*non-D1Eapp_sta*) => ( d1exp_app_sta (loc0, d1e_fun, list_sing(s1a)) ) (* end of [non-D1Eapp_sta] *) end // end of [D1Esexparg] | _ (*non-list-sexparg*) => let val npf = ~1 // HX: default val locarg = d1e_arg.d1exp_loc val d1es_arg = list_sing (d1e_arg) in d1exp_app_dyn (loc0, d1e_fun, locarg, npf, d1es_arg) end // end of [non-list-sexparg] end // end of [non-D1Eidextapp] // end // end of [d1exp_app_proc] (* ****** ****** *) local fn appf ( d1e1: d1exp , d1e2: d1exp ) :<cloref1> d1expitm = let val loc = d1e1.d1exp_loc + d1e2.d1exp_loc val d1e_app = d1exp_app_proc (loc, d1e1, d1e2) (* val () = begin println! ("d1expitm_app: f: d1e_app = ", d1e_app) end // end of [val] *) in FXITMatm (d1e_app) end // end of [appf] in (* in of [local] *) fn d1expitm_app (loc: location): d1expitm = fxitm_app (loc, appf) // end of [d1expitm_app] end // end of [local] fn d1exp_get_loc (x: d1exp): location = x.d1exp_loc fn d1exp_make_opr ( opr: d1exp, f: fxty ) : d1expitm = begin fxopr_make {d1exp} ( d1exp_get_loc , lam (loc, x, loc_arg, xs) => d1exp_app_dyn (loc, x, loc_arg, ~1(*npf*), xs) , opr, f ) // end of [fxopr_make] end // end of [d1exp_make_opr] fn d1expitm_backslash ( loc_opr: location ) : d1expitm = begin fxopr_make_backslash {d1exp} ( lam x => x.d1exp_loc , lam (loc, x, loc_arg, xs) => d1exp_app_dyn (loc, x, loc_arg, ~1(*npf*), xs) , loc_opr ) // end of [fxopr_make_backslash] end // end of [d1expitm_backslash] fn d1expitm_underscore (loc: location): d1expitm = FXITMatm (d1exp_top (loc)) // end of [d1expitm_underscore] (* ****** ****** *) fun s0expdarg_tr ( d0e: d0exp ) : s1exparg = let val d1e = d0exp_tr (d0e) in // case+ d1e.d1exp_node of | D1Esexparg (s1a) => s1a | _ => let val loc = d0e.d0exp_loc val () = prerr_interror_loc (loc) val () = prerrln! (": s0expdarg_tr: d1e = ", d1e) in $ERR.abort_interr{s1exparg}((*reachable*)) end // end of [_] // end // end of [s0expdarg_tr] fn s0expdarglst_tr (xs: d0explst): s1exparglst = l2l(list_map_fun (xs, s0expdarg_tr)) // end of [s0expdarglst_tr] (* ****** ****** *) // #if (FUNCLO_DEFAULT = 1) macdef FUNCLOdefault = FUNCLOcloptr #endif // #if (FUNCLO_DEFAULT = ~1) macdef FUNCLOdefault = FUNCLOcloref #endif // (* ****** ****** *) implement d0exp_tr_lams_dyn ( lamknd, locopt, fcopt, lin, args, res, efcopt, d0e_body ) = let // fun aux ( lamknd: int , args: f0arglst , d1e_body: d1exp , flag: int ) :<cloref1> d1exp = begin // case+ args of | list_cons (arg, args) => let val loc_arg = arg.f0arg_loc val d1e_body = aux ( lamknd, args, d1e_body, flag1 ) where { val f0a = arg.f0arg_node val flag1 = ( case+ f0a of F0ARGdyn _ => flag+1 | _ => flag ) : int // end of [val] } (* end of [where] *) val loc_body = d1e_body.d1exp_loc val loc = ( case+ locopt of | Some loc => loc | None () => loc_arg + loc_body ) : location // end of [val] in case+ arg.f0arg_node of // case+ // | F0ARGdyn p0t when flag = 0 => let val p1t = p0at_tr p0t val isbox = lamkind_isbox (lamknd) in if isbox > 0 then d1exp_lam_dyn (loc, lin, p1t, d1e_body) else d1exp_laminit_dyn (loc, lin, p1t, d1e_body) // end of [if] end // end of [F0ARGdyn when ...] // | F0ARGdyn p0t (* flag > 0 *) => let val p1t = p0at_tr (p0t) val fc0 = FUNCLOdefault(*mac*) val d1e_body = d1exp_ann_funclo_opt (loc_body, d1e_body, fc0) // end of [val] in d1exp_lam_dyn (loc, lin, p1t, d1e_body) end // end of [F0ARGdyn] // | F0ARGsta1 qua => d1exp_lam_sta_syn (loc, loc_arg, s0qualst_tr qua, d1e_body) // end of [F0ARGsta1] // | F0ARGsta2 s0v => d1exp_lam_sta_ana (loc, loc_arg, s0vararg_tr s0v, d1e_body) // end of [F0ARGsta2] // | F0ARGmet3 s0es => d1exp_lam_met (loc, loc_arg, s0explst_tr s0es, d1e_body) // end of [F0ARGmet3] end // end of [list_cons] // | list_nil ((*void*)) => d1e_body // end (* end of [aux] *) // val d1e_body = d0exp_tr (d0e_body) // val d1e_body = (case+ res of | Some s0e => let val loc = s0e.s0exp_loc + d1e_body.d1exp_loc val s1e = s0exp_tr (s0e) in d1exp_ann_type (loc, d1e_body, s1e) end // end of [Some] | None () => d1e_body // end of [None] ) : d1exp // val d1e_body = ( case+ efcopt of | Some efc => begin d1exp_ann_effc (d1e_body.d1exp_loc, d1e_body, efc) end // end of [Some] | None () => d1e_body ) : d1exp // end of [val] // val d1e_body = ( case+ fcopt of | Some fc => begin d1exp_ann_funclo (d1e_body.d1exp_loc, d1e_body, fc) end // end of [Some] | None () => d1e_body ) : d1exp // end of [val] // in aux (lamknd, args, d1e_body, 0(*flag*)) end // end of [d0exp_tr_lams_dyn] (* ****** ****** *) implement termet_check ( loc, ismet, efcopt ) = ( // case+ efcopt of | Some efc => let val okay = ( if ismet then true else effcst_contain_ntm (efc) ) : bool // end of [val] in if ~okay then { val () = prerr_error1_loc (loc) val () = prerrln! (": a termination metric is missing") val () = the_trans1errlst_add (T1E_termet_check(loc)) } (* end of [if] *) end // end of [Some] | None ((*void*)) => () // end of [None] // ) (* end of [termet_check] *) (* ****** ****** *) fn i0nvarg_tr (arg: i0nvarg): i1nvarg = let val opt = s0expopt_tr (arg.i0nvarg_typ) in i1nvarg_make (arg.i0nvarg_loc, arg.i0nvarg_sym, opt) end // end of [i0nvarg_tr] fun i0nvarglst_tr (xs: i0nvarglst): i1nvarglst = l2l(list_map_fun (xs, i0nvarg_tr)) fn i0nvresstate_tr (res: i0nvresstate): i1nvresstate = let val s1qs = ( case+ res.i0nvresstate_qua of | Some s0qs => s0qualst_tr (s0qs) | None () => list_nil () ) : s1qualst // end of [val] val arg = i0nvarglst_tr res.i0nvresstate_arg in i1nvresstate_make (s1qs, arg) end // end of [i0nvresstate_tr] (* ****** ****** *) fn loopi0nv_tr (loc: location, inv: loopi0nv): loopi1nv = let val qua = ( case+ inv.loopi0nv_qua of | Some s0qs => s0qualst_tr s0qs | None () => list_nil () ) : s1qualst val met = ( case+ inv.loopi0nv_met of | Some s0es => Some (s0explst_tr s0es) | None () => None () ) : s1explstopt val arg = i0nvarglst_tr inv.loopi0nv_arg val res = i0nvresstate_tr inv.loopi0nv_res in loopi1nv_make (loc, qua, met, arg, res) end // end of [loopi0nv_tr] (* ****** ****** *) fn i0fcl_tr (ifcl: i0fcl): i1fcl = let // val test = d0exp_tr(ifcl.i0fcl_test) val body = d0exp_tr(ifcl.i0fcl_body) // in i1fcl_make(ifcl.i0fcl_loc, test, body) end // of [i0fcl_tr] fn i0fclist_tr (ifcls: i0fclist): i1fclist = list_of_list_vt(list_map_fun<i0fcl>(ifcls, i0fcl_tr)) // end of [i0fclist_tr] (* ****** ****** *) fn gm0at_tr (gm0t: gm0at): gm1at = let val d1e = d0exp_tr(gm0t.gm0at_exp) val opt = ( case+ gm0t.gm0at_pat of | Some p0t => Some(p0at_tr p0t) | None() => None() ) : p1atopt // end of [val] in gm1at_make (gm0t.gm0at_loc, d1e, opt) end // end of [gm0at_tr] fn gm0atlst_tr (gm0ts: gm0atlst): gm1atlst = list_of_list_vt(list_map_fun<gm0at>(gm0ts, gm0at_tr)) // end of [gm0atlst_tr] (* ****** ****** *) fn c0lau_tr (c0l: c0lau): c1lau = let // val loc = c0l.c0lau_loc val gp0t = c0l.c0lau_pat // val p1t = p0at_tr (gp0t.guap0at_pat) val gua = gm0atlst_tr (gp0t.guap0at_gua) // val body = d0exp_tr (c0l.c0lau_body) // in // c1lau_make ( loc, p1t, gua, c0l.c0lau_seq, c0l.c0lau_neg, body ) (* c1lau_make *) // end // end of [c0lau_tr] fn c0laulst_tr (c0ls: c0laulst): c1laulst = list_of_list_vt(list_map_fun<c0lau>(c0ls, c0lau_tr)) // end of [c0laulst_tr] fn sc0lau_tr (sc0l: sc0lau): sc1lau = let val sp1t = sp0at_tr (sc0l.sc0lau_pat) val body = d0exp_tr (sc0l.sc0lau_body) in sc1lau_make (sc0l.sc0lau_loc, sp1t, body) end // end of [sc0lau_tr] fn sc0laulst_tr (sc0ls: sc0laulst): sc1laulst = list_of_list_vt(list_map_fun<sc0lau>(sc0ls, sc0lau_tr)) // end of [sc0laulst_tr] (* ****** ****** *) local fn d0exp_tr_errmsg_opr (d0e0: d0exp): d1exp = let val loc0 = d0e0.d0exp_loc val () = prerr_error1_loc (loc0) val () = prerrln! (": the operator needs to be applied.") val () = the_trans1errlst_add (T1E_d0exp_tr(d0e0)) in d1exp_errexp (loc0) end // end of [d0exp_tr_errmsg_opr] in (* in of [local] *) implement d0exp_tr (d0e0) = let // #define :: list_cons // fun aux_item ( d0e0: d0exp ) : d1expitm = let // val loc0 = d0e0.d0exp_loc // in // case+ d0e0.d0exp_node of // | D0Eide id when id = BACKSLASH => d1expitm_backslash (loc0) | D0Eide id when id = UNDERSCORE => d1expitm_underscore (loc0) // | D0Eide id => let val d1e = d1exp_ide (loc0, id) val opt = the_fxtyenv_find (id) in case+ opt of | ~None_vt() => FXITMatm (d1e) // HX: not operator // end of [None_vt] | ~Some_vt(f) => d1exp_make_opr(d1e, f) // HX: operator // end of [Some_vt] end // end of [D0Eide] // | D0Eopid (id) => FXITMatm (d1exp_ide (loc0, id)) | D0Edqid (dq, id) => FXITMatm (d1exp_dqid (loc0, dq, id)) // | D0Eidext id => FXITMatm (d1exp_idext (loc0, id)) // | D0Eint x => FXITMatm (d1exp_i0nt (loc0, x)) | D0Echar x => FXITMatm (d1exp_c0har (loc0, x)) | D0Efloat x => FXITMatm (d1exp_f0loat (loc0, x)) | D0Estring x => FXITMatm (d1exp_s0tring (loc0, x)) // | D0Eempty() => FXITMatm (d1exp_empty (loc0)) // | D0Ecstsp(x) => FXITMatm (d1exp_cstsp (loc0, x)) // | D0Etyrep(s0e) => FXITMatm (d1exp_tyrep (loc0, s0exp_tr (s0e))) // end of [D0Etyrep] // | D0Eliteral (d0e) => FXITMatm (d1exp_literal (loc0, d0exp_tr (d0e))) // end of [D0Eliteral] // | D0Eextval (s0e, name) => FXITMatm( d1exp_extval(loc0, s0exp_tr(s0e), name) ) (* [FXITMatm] *) // end of [D0Eextval] // | D0Eextfcall (s0e, _fun, _arg) => let val s1e = s0exp_tr (s0e) val _arg = d0explst_tr (_arg) in FXITMatm ( d1exp_extfcall (loc0, s1e, _fun, _arg) ) (* end of [FXITMatm] *) end // end of [D0Eextfcall] | D0Eextmcall (s0e, _obj, _mtd, _arg) => let val s1e = s0exp_tr (s0e) val _obj = d0exp_tr (_obj) val _arg = d0explst_tr (_arg) in FXITMatm ( d1exp_extmcall (loc0, s1e, _obj, _mtd, _arg) ) (* end of [FXITMatm] *) end // end of [D0Eextmcall] // (* | D0Elabel lab => d1exp_label (loc0, lab) *) | D0Eloopexn (knd) => FXITMatm (d1exp_loopexn (loc0, knd)) // | D0Efoldat (d0es) => let val s1as = s0expdarglst_tr (d0es) fn f ( d1e: d1exp ) :<cloref1> d1expitm = let val loc = loc0 + d1e.d1exp_loc in FXITMatm (d1exp_foldat (loc, s1as, d1e)) end // end of [f] in FXITMopr (loc0, FXOPRpre (foldat_prec_dyn, f)) end // end of [D0Efoldat] // | D0Efreeat (d0es) => let val s1as = s0expdarglst_tr (d0es) fn f ( d1e: d1exp ) :<cloref1> d1expitm = let val loc = loc0 + d1e.d1exp_loc in FXITMatm (d1exp_freeat (loc, s1as, d1e)) end // end of [f] in FXITMopr (loc0, FXOPRpre (freeat_prec_dyn, f)) end // end of [D0Efreeat] // | D0Etmpid (qid, tmparg) => let val tmparg = list_map_fun (tmparg, t0mpmarg_tr) // end of [val] in FXITMatm (d1exp_tmpid (loc0, qid, (l2l)tmparg)) end // end of [D0Etmpid] // | D0Elet (d0cs, d0e_body) => let // val (pfenv|()) = the_trans1_env_push() // val d1cs = d0eclist_tr (d0cs) val d1e_body = d0exp_tr (d0e_body) // val ((*popped*)) = the_trans1_env_pop (pfenv | (*none*)) // in FXITMatm (d1exp_let (loc0, d1cs, d1e_body)) end // end of [D0Elet] // | D0Edeclseq d0cs => let // val (pfenv|()) = the_trans1_env_push() // val d1cs = d0eclist_tr (d0cs) val body = d1exp_empty (loc0) // val ((*popped*)) = the_trans1_env_pop (pfenv | (*none*)) // in FXITMatm (d1exp_let (loc0, d1cs, body)) end // end of [D0Edeclseq] // | D0Ewhere (d0e_body, d0cs) => let // val (pfenv|()) = the_trans1_env_push() // val d1cs = d0eclist_tr (d0cs) val d1e_body = d0exp_tr (d0e_body) // val ((*popped*)) = the_trans1_env_pop (pfenv | (*none*)) // in FXITMatm (d1exp_where (loc0, d1e_body, d1cs)) end // end of [D0Ewhere] // | D0Eapp _ => let // val deis = aux_itemlst (d0e0) // val d1e0 = fixity_resolve ( loc0 , d1exp_get_loc, d1expitm_app(loc0), deis ) (* end of [val] *) // (* val () = println! ("d0exp_tr: aux_item: d1e0 = ", d1e0) // end of [val] *) // val d1e0 = d1exp_syndef_resolve (loc0, d1e0) // in FXITMatm (d1e0) end // end of [D0Eapp] // | D0Elist (npf, d0es) => let val d1es = d0explst_tr (d0es) in FXITMatm (d1exp_list (loc0, npf, d1es)) end // end of [D0Elist] // | D0Eifhead ( hd, _cond, _then, _else ) => let val inv = i0nvresstate_tr hd.ifhead_inv val _cond = d0exp_tr (_cond) val _then = d0exp_tr (_then) val _else = d0expopt_tr (_else) val d1e_if = d1exp_ifhead (loc0, inv, _cond, _then, _else) in FXITMatm (d1e_if) end // end of [D0Eifhead] | D0Esifhead ( hd, _cond, _then, _else ) => let val i0nv = hd.sifhead_inv val i1nv = i0nvresstate_tr (i0nv) val _cond = s0exp_tr (_cond) val _then = d0exp_tr (_then) val _else = d0exp_tr (_else) val d1e_sif = d1exp_sifhead (loc0, i1nv, _cond, _then, _else) in FXITMatm (d1e_sif) end // end of [D0Esifhead] // | D0Eifcasehd (ifhd, ifcls) => let val i0nv = ifhd.ifhead_inv val i1nv = i0nvresstate_tr(i0nv) val ifcls = i0fclist_tr (ifcls) val d1e_ifcase = d1exp_ifcasehd(loc0, i1nv, ifcls) in FXITMatm (d1e_ifcase) end // end of [D0Eifcasehd] // | D0Ecasehead (hd, d0e, c0ls) => let val tok = hd.casehead_tok val-T_CASE(knd) = tok.token_node val i0nv = hd.casehead_inv val i1nv = i0nvresstate_tr (i0nv) val d1e = d0exp_tr (d0e) val d1es = ( case+ d1e.d1exp_node of | D1Elist(_(*npf*), d1es) => d1es | _ => list_sing(d1e) ) : d1explst // end of [val] val c1ls = c0laulst_tr (c0ls) in FXITMatm(d1exp_casehead(loc0, knd, i1nv, d1es, c1ls)) end // end of [D0Ecasehead] | D0Escasehead (hd, s0e, sc0ls) => let // // HX: hd.casehead_knd is always 0 // val i0nv = hd.scasehead_inv val i1nv = i0nvresstate_tr(i0nv) // val s1e = s0exp_tr(s0e) val sc1ls = sc0laulst_tr(sc0ls) // in FXITMatm(d1exp_scasehead(loc0, i1nv, s1e, sc1ls)) end // end of [D0Escasehead] // | D0Elst (lin, elt, d0e_elts) => let val elt = s0expopt_tr(elt) val d1e_elts = d0exp_tr(d0e_elts) val d1es_elts = ( case+ d1e_elts.d1exp_node of (* case+ *) | D1Elist(_(*npf*), d1es) => d1es | _ => list_sing(d1e_elts) ) : d1explst // end of [val] val d1e_lst = d1exp_lst (loc0, lin, elt, d1es_elts) in FXITMatm (d1e_lst) end // end of [D0Elst] | D0Etup(knd, npf, d0es) => let val d1es = d0explst_tr d0es in FXITMatm(d1exp_tup (loc0, knd, npf, d1es)) end // end of [D0Etup] | D0Erec(knd, npf, ld0es) => let val ld1es = list_map_fun (ld0es, labd0exp_tr) // end of [val] in FXITMatm(d1exp_rec(loc0, knd, npf, (l2l)ld1es)) end // end of [D0Erec] | D0Eseq(d0es) => FXITMatm(d1exp_seq(loc0, d0explst_tr d0es)) // | D0Earrsub (qid, loc_ind, d0ess) => let val d1e_arr = d1exp_dqid(qid.dqi0de_loc, qid.dqi0de_qua, qid.dqi0de_sym) // end of [val] val d0es_ind = list_concat(d0ess) val d1es_ind = d0explst_tr($UN.castvwtp1{d0explst}(d0es_ind)) val ((*freed*)) = list_vt_free (d0es_ind) in FXITMatm(d1exp_arrsub(loc0, d1e_arr, loc_ind, d1es_ind)) end // end of [D0Earrsub] | D0Earrpsz(elt, d0e_elts) => let val elt = s0expopt_tr(elt) val d1e_elts = d0exp_tr(d0e_elts) val d1es_elts = ( case+ d1e_elts.d1exp_node of | D1Elist(_(*npf*), d1es) => d1es | _ => list_sing (d1e_elts) ) : d1explst // end of [val] in FXITMatm (d1exp_arrpsz (loc0, elt, d1es_elts)) end // end of [D0Earrpsz] | D0Earrinit (elt, asz, init) => let val elt = s0exp_tr (elt) val asz = d0expopt_tr (asz) val init = d0explst_tr (init) in FXITMatm(d1exp_arrinit(loc0, elt, asz, init)) end // end of [D0Earrinit] // | D0Eraise(d0e) => FXITMatm(d1exp_raise (loc0, d0exp_tr (d0e))) // | D0Eeffmask (eff, d0e) => let val ( fcopt, lin, prf, efc // HX: fcopt, lin, prf are all ignored! ) = e0fftaglst_tr (eff) val d1e = d0exp_tr (d0e) in FXITMatm(d1exp_effmask (loc0, efc, d1e)) end // end of [D0Eeffmask] | D0Eeffmask_arg (knd, d0e) => let val d1e = d0exp_tr (d0e) in FXITMatm(d1exp_effmask_arg (loc0, knd, d1e)) end // end of [D0Eeffmask_arg] // | D0Evararg (d0es) => FXITMatm(d1exp_vararg(loc0, d0explst_tr(d0es))) // end of [D0Evararg] // | D0Evcopyenv (knd, d0e) => FXITMatm(d1exp_vcopyenv(loc0, knd, d0exp_tr(d0e))) // end of [D0Evcopyenv] // | D0Eshowtype(d0e) => FXITMatm (d1exp_showtype(loc0, d0exp_tr(d0e))) // | D0Etempenver(d0e) => FXITMatm (d1exp_tempenver(loc0, d0exp_tr(d0e))) // | D0Eptrof () => let fn f (d1e: d1exp):<cloref1> d1expitm = let val loc = loc0 + d1e.d1exp_loc in FXITMatm (d1exp_ptrof (loc, d1e)) end (* end of [f] *) in FXITMopr (loc0, FXOPRpre (ptrof_prec_dyn, f)) end // end of [D0Eptrof] | D0Eviewat () => let fn f (d1e: d1exp) :<cloref1> d1expitm = let val loc = loc0 + d1e.d1exp_loc in FXITMatm (d1exp_viewat (loc, d1e)) end (* end of [f] *) in FXITMopr (loc0, FXOPRpre (viewat_prec_dyn, f)) end // end of [D0Eviewat] // | D0Esexparg (s0a) => FXITMatm (d1exp_sexparg (loc0, s0exparg_tr (loc0, s0a))) // end of [D0Esexparg] | D0Eexist (loc_qua, s0a, d0e) => let val s1a = s0exparg_tr (loc_qua, s0a) val d1e = d0exp_tr (d0e) in FXITMatm (d1exp_exist (loc0, s1a, d1e)) end // end of [D0Eexist] // | D0Elam ( knd, args, res, effopt, body ) => let val lin0 = lamkind_islin (knd) val ( fcopt, lin, efcopt ) = ( case+ effopt of | Some eff => let val ( fcopt, lin, prf, efc ) = e0fftaglst_tr (eff) val lin = (if lin0 > 0 then 1 else lin): int in (fcopt, lin, Some efc) end // end of [Some] | None () => (None (), lin0, None ()) ) : (fcopt, int, effcstopt) val d1e_lam = d0exp_tr_lams_dyn (knd, Some loc0, fcopt, lin, args, res, efcopt, body) // end of [val] in FXITMatm (d1e_lam) end // end of [D0Elam] | D0Efix ( knd, id, args, res, effopt, d0e_def ) => let val ( fcopt, lin, efcopt ) = ( case+ effopt of | Some(eff) => let val ( fcopt , lin, prf, efc ) = e0fftaglst_tr(eff) in (fcopt, lin, Some(efc)) end // end of [Some] | None((*void*)) => ( None(*fcopt*), 0(*lin*), None(*efcopt*) ) // end of [None] ) : (fcopt, int, effcstopt) // end of [val] val d1e_def = d0exp_tr_lams_dyn ( knd, Some loc0, fcopt, lin, args, res, efcopt, d0e_def ) (* end of [val] *) // val ismet = d1exp_is_metric (d1e_def) val () = termet_check (loc0, ismet, efcopt) // val isbox = lamkind_isbox (knd) // HX: fixind = lamkind val knd = (if isbox > 0 then 1 else 0): int // in FXITMatm (d1exp_fix (loc0, knd, id, d1e_def)) end // end of [D0Efix] // | D0Edelay (knd, d0e) => let val d1e = d0exp_tr (d0e) in FXITMatm (d1exp_delay (loc0, knd, d1e)) end // end of [D0Edelay] // | D0Esel_lab (knd, lab) => let val d1l = d1lab_lab (loc0, lab) fn f ( d1e: d1exp ) :<cloref1> d1expitm = let val loc = d1e.d1exp_loc + loc0 in FXITMatm (d1exp_selab (loc, knd, d1e, d1l)) end // end of [let] // end of [f] in FXITMopr (loc0, FXOPRpos (select_prec, f)) end // end of [D0Esel_lab] | D0Esel_ind (knd, d0ess) => let // val d0es_ind = list_concat (d0ess) val d1es_ind = d0explst_tr ($UN.castvwtp1{d0explst}(d0es_ind)) // end of [val] val () = list_vt_free (d0es_ind) // val d1l = d1lab_ind (loc0, d1es_ind) fn f ( d1e: d1exp ) :<cloref1> d1expitm = let val loc = d1e.d1exp_loc + loc0 in FXITMatm (d1exp_selab (loc, knd, d1e, d1l)) end // end of [let] // end of [f] in FXITMopr (loc0, FXOPRpos (select_prec, f)) end // end of [D0Esel_ind] // | D0Etrywith (hd, d0e, c0ls) => let val inv = i0nvresstate_tr (hd.tryhead_inv) val d1e = d0exp_tr (d0e) val c1ls = c0laulst_tr (c0ls) in FXITMatm (d1exp_trywith (loc0, inv, d1e, c1ls)) end // end of [D0Etrywith] // | D0Efor ( invopt, loc_inv, itp, body ) => let val inv = ( case+ invopt of | Some x => loopi0nv_tr (loc_inv, x) | None _ => loopi1nv_nil (loc_inv) ) : loopi1nv // end of [val] val init = d0exp_tr itp.itp_init val test = d0exp_tr itp.itp_test val post = d0exp_tr itp.itp_post val body = d0exp_tr body in FXITMatm (d1exp_for (loc0, inv, init, test, post, body)) end // end of [D0Efor] | D0Ewhile ( invopt, loc_inv, test, body ) => let val inv = ( case+ invopt of | Some x => loopi0nv_tr (loc_inv, x) | None _ => loopi1nv_nil (loc_inv) ) : loopi1nv // end of [val] val test = d0exp_tr (test) val body = d0exp_tr (body) in FXITMatm (d1exp_while (loc0, inv, test, body)) end // end of [D0Ewhile] // | D0Eann (d0e, s0e) => let val d1e = d0exp_tr d0e val s1e = s0exp_tr s0e in FXITMatm(d1exp_ann_type (loc0, d1e, s1e)) end // end of [D0Eann] // | D0Emacsyn(knd, d0e) => FXITMatm(d1exp_macsyn (loc0, knd, d0exp_tr(d0e))) // end of [D0Emacsyn] // | D0Esolassert(d0e) => FXITMatm(d1exp_solassert(loc0, d0exp_tr(d0e))) | D0Esolverify(s0e) => FXITMatm(d1exp_solverify(loc0, s0exp_tr(s0e))) // (* | _ => let val () = prerr_interror_loc (loc0) val () = fprintln! ( stderr_ref, "d0exp_tr: aux_item: d0e0 = ", d0e0 ) (* end of [fprintln!] *) val () = assertloc (false) in $ERR.abort_interr((*deadcode*)) end // end of [_] *) // end (* end of [aux_item] *) // and aux_itemlst (d0e0: d0exp): d1expitmlst = let fun loop (d0e0: d0exp, res: d1expitmlst): d1expitmlst = case+ d0e0.d0exp_node of | D0Eapp (d0e1, d0e2) => let val res = aux_item d0e2 :: res in loop (d0e1, res) end // end of [D0Eapp] | _ => aux_item d0e0 :: res // end of [loop] in loop (d0e0, list_nil ()) end // end of [aux_itemlist] // (* val () = { val loc0 = d0e0.d0exp_loc val () = $LOC. print_location (loc0) val () = print ": d0exp_tr: d0e0 = " val () = fprint_d0exp (stdout_ref, d0e0) val () = print_newline () } // end of [val] *) // in // case+ aux_item(d0e0) of (* case+ *) | FXITMatm(p1t) => p1t | FXITMopr(_, _) => d0exp_tr_errmsg_opr (d0e0) // end // end of [d0exp_tr] end // end of [local] (* ****** ****** *) implement d0explst_tr (xs) = l2l(list_map_fun(xs, d0exp_tr)) (* ****** ****** *) implement d0expopt_tr (opt) = ( // case+ opt of | Some(d0e) => Some(d0exp_tr(d0e)) | None() => None() // ) (* end of [d0expopt_tr] *) (* ****** ****** *) implement labd0exp_tr (ld0e) = let val+DL0ABELED (l, d0e) = ld0e in labd1exp_make(l, d0exp_tr(d0e)) end // end of [labd0exp_tr] (* ****** ****** *) // implement S0Ed2ctype_tr (d2ctp) = ( $UN.cast{S1Ed2ctype}(d0exp_tr($UN.cast{d0exp}(d2ctp))) ) (* end of [S0Ed2ctype_tr] *) // (* ****** ****** *) (* end of [pats_trans1_dynexp.dats] *)