mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

RTL programs print with their name

Browse source 
* libguile/print.c (iprin1): Use scm_i_program_print for RTL programs
  too.

* libguile/procprop.c (scm_procedure_name): For RTL programs, call
  scm_i_rtl_program_name if there is no override.

* libguile/programs.h:
* libguile/programs.c (scm_i_rtl_program_name): New helper, dispatches
  to (system vm program).
  (scm_i_program_print): For RTL programs, the fallback prints the code
  pointer too.

* module/system/vm/program.scm (rtl-program-name): Use the debug info to
  get an RTL program name.
  (write-program): Work with RTL programs too.

* test-suite/tests/rtl.test ("procedure name"): Add test.
This commit is contained in:
Andy Wingo 2013-05-05 18:26:53 +02:00
parent e2cbf527c4
commit e65f80af42
6 changed files with 60 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/print.c
View file

@ -657,8 +657,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_i_variable_print (exp, port, pstate);
break;
case scm_tc7_rtl_program:
scm_i_rtl_program_print (exp, port, pstate);
break;
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;

17
libguile/procprop.c
View file

@ -223,10 +223,25 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
SCM props, ret;
SCM_VALIDATE_PROC (1, proc);
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
proc = SCM_STRUCT_PROCEDURE (proc);
return scm_procedure_property (proc, scm_sym_name);
props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_pair (props))
ret = scm_assq_ref (props, scm_sym_name);
else if (SCM_RTL_PROGRAM_P (proc))
ret = scm_i_rtl_program_name (proc);
else if (SCM_PROGRAM_P (proc))
ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
else
ret = SCM_BOOL_F;
return ret;
}
#undef FUNC_NAME

33
libguile/programs.c
View file

@ -111,14 +111,16 @@ SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
}
#undef FUNC_NAME
void
scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
SCM
scm_i_rtl_program_name (SCM program)
{
scm_puts_unlocked ("#<rtl-program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc_unlocked (' ', port);
scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
scm_putc_unlocked ('>', port);
static SCM rtl_program_name = SCM_BOOL_F;
if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
rtl_program_name =
scm_c_private_variable ("system vm program", "rtl-program-name");
return scm_call_1 (scm_variable_ref (rtl_program_name), program);
}
void
@ -147,9 +149,20 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
}
else if (scm_is_false (write_program) || print_error)
{
scm_puts_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc_unlocked ('>', port);
if (SCM_RTL_PROGRAM_P (program))
{
scm_puts_unlocked ("#<rtl-program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc_unlocked (' ', port);
scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
scm_putc_unlocked ('>', port);
}
else
{
scm_puts_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc_unlocked ('>', port);
}
}
else
{

3
libguile/programs.h
View file

@ -44,8 +44,7 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM free
SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
/*
* Programs