summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ChangeLog.MELT20
-rw-r--r--gcc/melt-runtime.c7
-rw-r--r--gcc/melt/warmelt-genobj.melt24
-rw-r--r--gcc/melt/warmelt-modes.melt5
-rw-r--r--gcc/melt/warmelt-normal.melt164
-rw-r--r--gcc/melt/warmelt-outobj.melt19
6 files changed, 170 insertions, 69 deletions
diff --git a/gcc/ChangeLog.MELT b/gcc/ChangeLog.MELT
index 95ed919d41d..66f21db6430 100644
--- a/gcc/ChangeLog.MELT
+++ b/gcc/ChangeLog.MELT
@@ -1,6 +1,26 @@
2012-09-15 Basile Starynkevitch <basile@starynkevitch.net>
+ * melt-runtime.c (meltgc_read_from_val): Change the location name
+ to <parsed-string#%ld> format.
+
+ * melt/warmelt-normal.melt
+ (class_nrep_check_running_module_environment_container): New.
+ (normexp_update_current_module_environment_container): Instanciate
+ it for runtime extension.
+
+ * melt/warmelt-genobj.melt
+ (compilobj_nrep_check_running_module_environment_container): New
+ method for compile_obj of
+ class_nrep_check_running_module_environment_container.
+
+ * melt/warmelt-outobj.melt (translate_run_melt_expressions): More
+ debug.
+
+ * melt/warmelt-modes.melt (eval_docmd): Eval in a fresh environment.
+
+2012-09-15 Basile Starynkevitch <basile@starynkevitch.net>
+
{{Regenerate}}
* melt-build-script.sh: Regenerate.
* melt/generated/meltrunsup-inc.c: Regenerate.
diff --git a/gcc/melt-runtime.c b/gcc/melt-runtime.c
index e239a07c4d6..9c85c07fbf1 100644
--- a/gcc/melt-runtime.c
+++ b/gcc/melt-runtime.c
@@ -7780,6 +7780,7 @@ end:
melt_ptr_t
meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_t locnam_p)
{
+ static long parsecount;
#if MELT_HAVE_DEBUG
char curlocbuf[140];
#endif
@@ -7819,6 +7820,7 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_t locnam_p)
}
if (!rbuf)
goto end;
+ parsecount++;
rds.rfil = 0;
rds.rpath = 0;
rds.rlineno = 0;
@@ -7827,9 +7829,12 @@ meltgc_read_from_val (melt_ptr_t strv_p, melt_ptr_t locnam_p)
rd = &rds;
MELT_LOCATION_HERE_PRINTF(curlocbuf, "meltgc_read_from_val rbuf=%.70s", rbuf);
if (locnamv == NULL) {
+ char buf[40];
+ memset(buf, 0, sizeof(buf));
+ snprintf (buf, sizeof(buf), "<parsed-string#%ld>", parsecount);
rds.rhas_file_location = false;
locnamv = meltgc_new_string ((meltobject_ptr_t) MELT_PREDEF(DISCR_STRING),
- "<string>");
+ buf);
rd->rpfilnam = (melt_ptr_t *) &locnamv;
}
rds.rpfilnam = (melt_ptr_t *) & locnamv;
diff --git a/gcc/melt/warmelt-genobj.melt b/gcc/melt/warmelt-genobj.melt
index d3f9a487a37..cc6027c17b9 100644
--- a/gcc/melt/warmelt-genobj.melt
+++ b/gcc/melt/warmelt-genobj.melt
@@ -5452,6 +5452,30 @@ $SBUF.}#
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun compilobj_nrep_check_running_module_environment_container (nchmeb gcx)
+ (debug "compilobj_nrep_check_running_module_environment_container nchmeb=" nchmeb "\n gcx=" gcx)
+ (assert_msg "check nucmeb" (is_a nchmeb class_nrep_check_running_module_environment_container))
+ (assert_msg "check gcx" (is_a gcx class_extension_generation_context))
+ (let (
+ (nchcomm (get_field :nchrumod_comment nchmeb))
+ (nloc (get_field :nrep_loc nchmeb))
+ (ocontenvloc (get_field :igncx_contenvloc gcx))
+ (obodl (make_list discr_list))
+ (csbuf (make_strbuf discr_strbuf))
+ (ocblo (instance class_objcommentedblock
+ :obi_loc nloc
+ :oblo_bodyl obodl
+ :ocomblo_comment
+ (progn
+ (add2out csbuf "check.run.mod.env:" nchcomm)
+ (strbuf2string discr_string csbuf))))
+ )
+ (debug "compilobj_nrep_check_running_module_environment_container ocblo=" ocblo "\n ocontenvloc=" ocontenvloc)
+ (assert_msg "@$@unimplemented compilobj_nrep_check_running_module_environment_container")
+ ))
+(install_method class_nrep_check_running_module_environment_container compile_obj compilobj_nrep_check_running_module_environment_container)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/gcc/melt/warmelt-modes.melt b/gcc/melt/warmelt-modes.melt
index 252952f2f3e..59e34018f34 100644
--- a/gcc/melt/warmelt-modes.melt
+++ b/gcc/melt/warmelt-modes.melt
@@ -189,9 +189,10 @@ has basic debug support thru DEBUG, ASSERT_MSG..."
"\n inexprs=" inexprs)
(assert_msg "check curenv" (is_a curenv class_environment))
(let (
- (res (translate_run_melt_expressions inexprs curenv))
+ (newenv (fresh_env curenv))
+ (res (translate_run_melt_expressions inexprs newenv))
)
- (debug "eval_docmd run res=" res)
+ (debug "eval_docmd run res=" res "\n newenv=" newenv)
(return :true)
)))
diff --git a/gcc/melt/warmelt-normal.melt b/gcc/melt/warmelt-normal.melt
index be49a222699..accde0b6ad1 100644
--- a/gcc/melt/warmelt-normal.melt
+++ b/gcc/melt/warmelt-normal.melt
@@ -720,6 +720,11 @@ routine procedures.}#
ncumeb_comment ;optional comment
))
+;; normalized check of current running module environment box
+(defclass class_nrep_check_running_module_environment_container
+ :super class_nrep_expression
+ :fields (nchrumod_comment ;optional comment
+ ))
;;; export all the normalized representations classes
(export_class ;; normal representations classes in alphabetical order
@@ -737,6 +742,7 @@ routine procedures.}#
class_nrep_chunk
class_nrep_citeration
class_nrep_checksignal
+ class_nrep_check_running_module_environment_container
class_nrep_closedocc
class_nrep_comment
class_nrep_constant
@@ -7005,80 +7011,114 @@ source location.}#
(assert_msg "check update_current_module_environment_container recv" (is_a recv class_source_update_current_module_environment_container))
(assert_msg "check env" (is_a env class_environment))
(assert_msg "check nctxt" (is_a ncx class_normalization_context))
- (debug "normexp_update_current_module_environment_container recv" recv)
+ (debug "normexp_update_current_module_environment_container recv=" recv
+ "\n env=" env
+ "\n ncx=" ncx)
+ (shortbacktrace_dbg "normexp_update_current_module_environment_container" 15)
(let (
(sloc (unsafe_get_field :loca_location recv))
(scomm (unsafe_get_field :sucme_comment recv))
(curproc (unsafe_get_field :nctx_curproc ncx))
(iniproc (unsafe_get_field :nctx_initproc ncx))
(modctx (unsafe_get_field :nctx_modulcontext ncx))
- (modnam (if (is_a modctx class_module_context) (unsafe_get_field :mocx_modulename modctx)))
+ (modnam (get_field :mocx_modulename modctx))
)
(if (!= curproc iniproc)
(progn
(error_plain sloc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER) not at toplevel")
(return)))
- (let ( (nup (instance class_nrep_update_current_module_environment_container
- ;; :ncumeb_expr filled later
+ (debug "normexp_update_current_module_environment_container modctx=" modctx)
+ (cond ((is_a modctx class_running_extension_module_context)
+ (let ( (nchk (instance class_nrep_check_running_module_environment_container
+ :nrep_loc sloc
+ :nchrumod_comment scomm
+ ))
+ (csym (clone_symbol 'checkrunmodenvbox_))
+ (cbind (instance
+ class_normal_let_binding
+ :letbind_loc sloc
+ :binder csym
+ :letbind_type ctype_void
+ ;; ctype_void because the sideffect is in nchk
+ :letbind_expr nchk))
+ (clocc (instance
+ class_nrep_locsymocc
:nrep_loc sloc
- :ncumeb_comment scomm
- ))
- (csym (clone_symbol 'updatcurmodenvbox_))
- (cbind (instance
- class_normal_let_binding
- :letbind_loc sloc
- :binder csym
- :letbind_type ctype_void
- ;; ctype_void because the sideffect is in nup
- :letbind_expr nup))
- (clocc (instance
- class_nrep_locsymocc
- :nrep_loc sloc
- :nocc_ctyp ctype_void
- :nocc_symb csym
- :nocc_bind cbind))
- (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
- (add2sbuf_strconst sb "cur.mod.env.cont : ")
- (add2sbuf_string sb scomm)
- sb))
- (scurenvbox (instance class_source_current_module_environment_container
- :loca_location sloc
- :cmec_comment (strbuf2string discr_string csbuf)))
- (sgetcurenvbox
- (instance
- class_source_or
- :loca_location psloc
- :sor_disj
- (tuple
- scurenvbox
- (instance
- class_source_apply
- :loca_location psloc
- :sapp_fun (instance
- class_source_unsafe_get_field
- :loca_location psloc
- :suget_obj (instance
- class_source_fetch_predefined
- :loca_location psloc
- :sfepd_predef 'initial_system_data
- )
- :suget_field sysdata_cont_fresh_env
- )
- :sargop_args (tuple
- (instance class_source_parent_module_environment
- :loca_location psloc)
- modnam
- )))))
- )
- (multicall
- (ncurenvbox bindlist)
- (normal_exp sgetcurenvbox env ncx sloc)
- (list_append bindlist cbind)
- (unsafe_put_fields nup :nucmeb_expr ncurenvbox)
- (debug "normexp_update_current_module_environment_container result bindlist=" bindlist" clocc=" clocc)
- (return clocc bindlist)
- )
- )))
+ :nocc_ctyp ctype_void
+ :nocc_symb csym
+ :nocc_bind cbind))
+ (bindlist (list cbind))
+ )
+ (debug "normexp_update_current_module_environment_container gives nchk=" nchk
+ " clocc=" clocc " bindlist=" bindlist)
+ (return clocc bindlist)
+ ))
+ ((is_a modctx class_module_context)
+ (assert_msg "check modctx not running" (is_not_a modctx class_running_extension_module_context))
+ (let ( (nup (instance class_nrep_update_current_module_environment_container
+ ;; :ncumeb_expr filled later
+ :nrep_loc sloc
+ :ncumeb_comment scomm
+ ))
+ (csym (clone_symbol 'updatcurmodenvbox_))
+ (cbind (instance
+ class_normal_let_binding
+ :letbind_loc sloc
+ :binder csym
+ :letbind_type ctype_void
+ ;; ctype_void because the sideffect is in nup
+ :letbind_expr nup))
+ (clocc (instance
+ class_nrep_locsymocc
+ :nrep_loc sloc
+ :nocc_ctyp ctype_void
+ :nocc_symb csym
+ :nocc_bind cbind))
+ (csbuf (let ( (sb (make_strbuf discr_strbuf)) )
+ (add2sbuf_strconst sb "cur.mod.env.cont : ")
+ (add2sbuf_string sb scomm)
+ sb))
+ (scurenvbox (instance class_source_current_module_environment_container
+ :loca_location sloc
+ :cmec_comment (strbuf2string discr_string csbuf)))
+ (sgetcurenvbox
+ (instance
+ class_source_or
+ :loca_location psloc
+ :sor_disj
+ (tuple
+ scurenvbox
+ (instance
+ class_source_apply
+ :loca_location psloc
+ :sapp_fun (instance
+ class_source_unsafe_get_field
+ :loca_location psloc
+ :suget_obj (instance
+ class_source_fetch_predefined
+ :loca_location psloc
+ :sfepd_predef 'initial_system_data
+ )
+ :suget_field sysdata_cont_fresh_env
+ )
+ :sargop_args (tuple
+ (instance class_source_parent_module_environment
+ :loca_location psloc)
+ modnam
+ )))))
+ )
+ (multicall
+ (ncurenvbox bindlist)
+ (normal_exp sgetcurenvbox env ncx sloc)
+ (list_append bindlist cbind)
+ (unsafe_put_fields nup :nucmeb_expr ncurenvbox)
+ (debug "normexp_update_current_module_environment_container result bindlist=" bindlist" clocc=" clocc)
+ (return clocc bindlist)
+ )
+ ))
+ (:else
+ (assert_msg "normexp_update_current_module_environment_container unexpected module context" ()))
+ )))
(install_method class_source_update_current_module_environment_container normal_exp normexp_update_current_module_environment_container)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/gcc/melt/warmelt-outobj.melt b/gcc/melt/warmelt-outobj.melt
index 153afe569c3..9fa7be30a63 100644
--- a/gcc/melt/warmelt-outobj.melt
+++ b/gcc/melt/warmelt-outobj.melt
@@ -5588,6 +5588,7 @@ if (1) return;
"\n normlist=" normlist)
(assert_msg "null iniprobody" (null (get_field :nproc_body inipro)))
(put_fields inipro :nproc_body normlist)
+ (debug "translate_macroexpanded_list unpdated inipro=" inipro)
(assert_msg "check inipro" (is_a inipro class_nrep_initproc))
(assert_msg "check iniproctransl" (is_closure iniproctransl))
(debug "translate_macroexpanded_list before calling iniproctransl inipro= " inipro)
@@ -5699,7 +5700,6 @@ if (1) return;
(add2out baksbuf delfilnam "~")
(let ( (bakfilnam (strbuf2string discr_string baksbuf))
)
- (debug "translate_macroexpanded_list delfilix=" delfilix)
(code_chunk
backupchk
#{ /*translate_macroexpanded_list $BACKUPCHK*/ {
@@ -5847,6 +5847,8 @@ if (1) return;
;;;;;**********************************************************
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; an internal primitive to run an extension file with a basename, an
+;; environment, and a tuple of literals
(defprimitive melt_run_extension (basename env litval) :value
#{ /* melt_run_extension */ meltgc_run_c_extension
((melt_ptr_t) $BASENAME,
@@ -5868,6 +5870,8 @@ if (1) return;
(:long starterrcount (melt_error_counter))
(nakedbasnam ())
(referr (instance class_reference))
+ ;; we need to store the normlist for debugging purposes
+ (refnormlist (instance class_reference))
)
(code_chunk numchk #{/* translate_run_melt_expressions $NUMCHK */
char basbuf_$NUMCHK[64] ;
@@ -5990,8 +5994,11 @@ if (1) return;
;; normalextend should ensure that the last normal gives a value
(normalextend
(lambda (normlist modctx ncx inienv)
- (debug "translate_run_melt_expressions/normalextend normlist=" normlist "\n ncx=" ncx)
+ (debug "translate_run_melt_expressions/normalextend normlist=" normlist
+ "\n old !refnormlist=" !refnormlist
+ "\n ncx=" ncx)
(shortbacktrace_dbg "translate_run_melt_expressions/normalextend" 13)
+ (assert_msg "check null !refnormlist" (null !refnormlist))
(let ( (lastnorm (list_last_element normlist))
(lastctyp (get_ctype lastnorm inienv))
)
@@ -6023,6 +6030,7 @@ if (1) return;
(list_append normlist (instance class_nrep_nil))
(debug "translate_run_melt_expressions/normalextend updated normlist=" normlist)
))
+ (set_ref refnormlist normlist)
(debug "translate_run_melt_expressions/normalextend updated normlist=" normlist)
)))
)
@@ -6032,11 +6040,14 @@ if (1) return;
(return () ()))
(let ( (basename (make_string_tempname_suffixed discr_string nakedbasnam "_eXt"))
)
- (debug "translate_run_melt_expressions basename=" basename)
+ (debug "translate_run_melt_expressions basename=" basename
+ " refnormlist=" refnormlist)
;; translate to C code
(translate_macroexpanded_list xlist basename modctx ncx env
normalextend compile2obj_initextendproc)
- (debug "translate_run_melt_expressions after translation to nakedbasnam=" nakedbasnam)
+ (debug "translate_run_melt_expressions after translation"
+ " refnormlist=" refnormlist
+ " to nakedbasnam=" nakedbasnam)
(when (or (notnull !referr) (>i (melt_error_counter) starterrcount))
(runerrorhdlr '"runtime translation to code failed")
(return () ()))
View Lorry Controller Status