(***********************************************************************) (* *) (* 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: June, 2012 // (* ****** ****** *) // // HX: for handling macro expansion during typechecking // (* ****** ****** *) staload UN = "prelude/SATS/unsafe.sats" (* ****** ****** *) staload ERR = "./pats_error.sats" (* ****** ****** *) staload "./pats_errmsg.sats" staload _(*anon*) = "./pats_errmsg.dats" implement prerr_FILENAME<> () = prerr "pats_dmacro2" (* ****** ****** *) staload STMP = "./pats_stamp.sats" typedef stamp = $STMP.stamp (* ****** ****** *) staload "./pats_staexp2.sats" staload "./pats_staexp2_util.sats" staload "./pats_dynexp2.sats" (* ****** ****** *) staload "./pats_dmacro2.sats" (* ****** ****** *) implement m2val_true = M2Vbool (true) implement m2val_false = M2Vbool (false) (* ****** ****** *) implement liftval2dexp (loc0, m2v) = let in case+ m2v of | M2Vint (i) => d2exp_int (loc0, i) | M2Vchar (c) => d2exp_char (loc0, c) | M2Vfloat (rep) => d2exp_float (loc0, rep) | M2Vstring (s) => d2exp_string (loc0, s) | M2Vunit () => d2exp_empty (loc0) | _ => let val () = prerr_errmac_loc (loc0) val () = prerr ": a value representing code (AST) cannot be lifted." val () = prerr_newline () in d2exp_errexp (loc0) end // end of [_] end // end of [liftval2dexp] (* ****** ****** *) local // // HX: ptr for s2var or d2var // dataviewtype alphenv = | ALPHENVsadd of (s2var, s2var(*new*), alphenv) | ALPHENVdadd of (d2var, d2var(*new*), alphenv) | ALPHENVmark of (alphenv) // marking for unwinding | ALPHENVnil of () // end of [alphenv] assume alphenv_viewtype = alphenv in (* in of [local] *) implement alphenv_nil () = ALPHENVnil () implement alphenv_free (env) = let in // case+ env of | ~ALPHENVsadd (_, _, env) => alphenv_free (env) | ~ALPHENVdadd (_, _, env) => alphenv_free (env) | ~ALPHENVmark env => alphenv_free (env) | ~ALPHENVnil () => () // end // end of [alphenv_free] implement alphenv_sadd (env, s2v, s2v_new) = let in env := ALPHENVsadd (s2v, s2v_new, env) end // end of [alphenv_sadd] implement alphenv_dadd (env, d2v, d2v_new) = let in env := ALPHENVdadd (d2v, d2v_new, env) end // end of [alphenv_dadd] (* ****** ****** *) implement alphenv_sfind (env, key) = let // fun loop ( env: !alphenv, key: s2var ) : s2varopt_vt = let in // case+ env of | ALPHENVsadd (_key, _val, !p_env1) => let val ans = ( if key = _key then Some_vt (_val) else loop (!p_env1, key) // end of [if] ) : s2varopt_vt // end of [val] in fold@ (env); ans end | ALPHENVdadd (_key, _val, !p_env1) => let val ans = loop (!p_env1, key) in fold@ (env); ans end // end of [ALPHENVdadd] | ALPHENVmark (!p_env1) => let val ans = loop (!p_env1, key) in fold@ (env); ans end // end of [ALPHENVmark] | ALPHENVnil () => let prval () = fold@ env in None_vt () end // end of [ALPHENVnil] end // end of [loop] // in loop (env, key) end // end of [alphenv_sfind] (* ****** ****** *) implement alphenv_dfind (env, key) = let // fun loop ( env: !alphenv, key: d2var ) : d2varopt_vt = let in // case+ env of | ALPHENVsadd (_key, _val, !p_env1) => let val ans = loop (!p_env1, key) in fold@ (env); ans end // end of [ALPHENVsadd] | ALPHENVdadd (_key, _val, !p_env1) => let val ans = ( if key = _key then Some_vt (_val) else loop (!p_env1, key) // end of [if] ) : d2varopt_vt // end of [val] in fold@ (env); ans end | ALPHENVmark (!p_env1) => let val ans = loop (!p_env1, key) in fold@ (env); ans end // end of [ALPHENVmark] | ALPHENVnil () => let prval () = fold@ env in None_vt () end // end of [ALPHENVnil] end // end of [loop] // in loop (env, key) end // end of [alphenv_dfind] (* ****** ****** *) implement alphenv_pop (env) = let // fun loop (env: alphenv): alphenv = let in case+ env of | ~ALPHENVsadd (_, _, env) => loop (env) | ~ALPHENVdadd (_, _, env) => loop (env) | ~ALPHENVmark (env) => (env) | ~ALPHENVnil () => ALPHENVnil () end // end of [loop] // in env := loop (env) end // end of [alphenv_pop] implement alphenv_push (env) = (env := ALPHENVmark env) end // end of [local] (* ****** ****** *) local // datavtype evalctx = | EVALCTXnil of () | EVALCTXsadd of (s2var, m2val, evalctx) | EVALCTXdadd of (d2var, m2val, evalctx) // end of [eval0ctx] // assume evalctx_viewtype = evalctx // in (* in of [local] *) implement evalctx_nil () = EVALCTXnil () implement fprint_evalctx (out, ctx) = let in // case+ ctx of | EVALCTXsadd ( s2v, m2v, !p_ctx1 ) => let val () = fprint_s2var (out, s2v) val () = fprint_string (out, " - ") val () = fprint_m2val (out, m2v) val () = fprint_newline (out) val () = fprint_evalctx (out, !p_ctx1) prval () = fold@ (ctx) in // nothing end // end of [EVALCTXsadd] | EVALCTXdadd ( d2v, m2v, !p_ctx1 ) => let val () = fprint_d2var (out, d2v) val () = fprint_string (out, " - ") val () = fprint_m2val (out, m2v) val () = fprint_newline (out) val () = fprint_evalctx (out, !p_ctx1) prval () = fold@ (ctx) in // nothing end // end of [EVALCTXsadd] | EVALCTXnil () => let prval () = fold@ ctx in (*nothing*) end // end of [EVALCTXnil] // end // end of [fprint_evalctx] implement print_evalctx (ctx) = fprint_evalctx (stdout_ref, ctx) // end of [print_evalctx] implement prerr_evalctx (ctx) = fprint_evalctx (stderr_ref, ctx) // end of [prerr_evalctx] (* ****** ****** *) implement evalctx_sadd (ctx, s2v, m2v) = EVALCTXsadd (s2v, m2v, ctx) // end of [evalctx_sadd] implement evalctx_dadd (ctx, d2v, m2v) = EVALCTXdadd (d2v, m2v, ctx) // end of [evalctx_dadd] implement evalctx_dfind (ctx, d2v) = let in // case+ ctx of | EVALCTXsadd ( _key, _val, !p_ctx1 ) => let val ans = evalctx_dfind (!p_ctx1, d2v) prval () = fold@ (ctx) in ans end // end of [EVALCTXsadd] | EVALCTXdadd ( _key, _val, !p_ctx1 ) => let in if d2v = _key then let prval () = fold@ (ctx) in Some_vt (_val) end else let val ans = evalctx_dfind (!p_ctx1, d2v) prval () = fold@ (ctx) in ans end // end of [if] end // end of [EVALCTXdadd] | EVALCTXnil () => let prval () = fold@ (ctx) in None_vt () end // end of [EVALCTXnil] // end // end of [evalctx_dfind] implement evalctx_free (ctx) = ( case+ ctx of | ~EVALCTXsadd (_, _, ctx) => evalctx_free (ctx) | ~EVALCTXdadd (_, _, ctx) => evalctx_free (ctx) | ~EVALCTXnil () => () ) // end of [evalctx_free] (* ****** ****** *) // fun s2exp_make_m2val (m2v: m2val): s2exp = ( case m2v of | M2Vscode(s2e) => s2e | _ (*non-M2Vscode*) => s2exp_errexp(s2rt_t0ype) ) (* end of [s2exp_make_m2val] *) // implement stasub_make_evalctx (ctx) = let // fun aux ( ctx: !evalctx, sub: &stasub ) : void = let in case+ ctx of | EVALCTXsadd (_key, _val, !p_ctx1) => let val () = aux (!p_ctx1, sub) val s2v = _key val s2e = s2exp_make_m2val (_val) val () = stasub_add (sub, s2v, s2e) in fold@ (ctx) end | EVALCTXdadd (_key, _val, !p_ctx1) => let val () = aux (!p_ctx1, sub) in fold@ (ctx) end | EVALCTXnil () => fold@ (ctx) end // end of [aux] // var sub = stasub_make_nil () val () = aux (ctx, sub) // in sub end // end of [stasub_make_evalctx] // (* ****** ****** *) end // end of [local] (* ****** ****** *) implement dmacro_eval_xstage (d2e) = let val loc0 = d2e.d2exp_loc var ctx = evalctx_nil () var env = alphenv_nil () val m2v = eval0_d2exp (loc0, ctx, env, d2e) val () = alphenv_free (env) val () = evalctx_free (ctx) in liftval2dexp (loc0, m2v) end // end of [dmacro_eval_xstage] implement dmacro_eval_decode (d2e) = let val loc0 = d2e.d2exp_loc var ctx = evalctx_nil () var env = alphenv_nil () val m2v = eval0_d2exp (loc0, ctx, env, d2e) val () = alphenv_free (env) val () = evalctx_free (ctx) in // case+ m2v of | M2Vdcode (d2e_new) => d2e_new | _ => let val () = prerr_errmac_loc (loc0) val () = prerr ": the macro expansion should yield code (AST)" val () = prerr ", but the following value is obtained instead: " val () = prerr_m2val (m2v) val () = prerr_newline () in d2exp_errexp (loc0) end // end of [_] // end // end of [dmacro_eval_decode] (* ****** ****** *) implement dmacro_eval_app_short (loc0, d2m, d2as) = let var ctx = evalctx_nil () var env = alphenv_nil () val d2e = eval0_app_mac_short (loc0, d2m, ctx, env, d2as) val () = alphenv_free (env) val () = evalctx_free (ctx) in d2e end // end of [dmacro_eval_app_short] (* ****** ****** *) (* end of [pats_dmacro2.dats] *)