1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00

Wire up ability to print RTL program arities

* libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
  dispatch to scm_i_program_arity.

* libguile/programs.c (scm_i_program_print): Refactor reference to
  write-program.
  (scm_i_rtl_program_minimum_arity): New procedure, dispatches to
  Scheme.
  (scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
  appropriate.

* module/system/vm/debug.scm (program-minimum-arity): New export.

* module/system/vm/program.scm (rtl-program-minimum-arity): New internal
  function.
  (program-arguments-alists): New helper, implemented also for RTL
  procedures.
  (write-program): Refactor a bit, and call program-arguments-alists.

* test-suite/tests/rtl.test ("simply procedure arity"): Add tests that
  arities make it all the way to cold ELF and back to warm Guile.
This commit is contained in:
Andy Wingo 2013-05-16 20:58:54 +02:00
parent f88e574d58
commit eb2bc00fb3
5 changed files with 100 additions and 34 deletions

View file

@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return 1;
}
while (!SCM_PROGRAM_P (proc))
while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
{
@ -80,14 +80,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
see. */
*req -= 1;
return 1;
}
else if (SCM_RTL_PROGRAM_P (proc))
{
*req = 0;
*opt = 0;
*rest = 1;
return 1;
}
else

View file

@ -129,9 +129,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
static int print_error = 0;
if (scm_is_false (write_program) && scm_module_system_booted_p)
write_program = scm_module_local_variable
(scm_c_resolve_module ("system vm program"),
scm_from_latin1_symbol ("write-program"));
write_program = scm_c_private_variable ("system vm program",
"write-program");
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
@ -450,11 +449,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
*req = *opt = *rest = 0;
}
static int
scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
{
static SCM rtl_program_minimum_arity = SCM_BOOL_F;
SCM l;
if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
rtl_program_minimum_arity =
scm_c_private_variable ("system vm debug",
"rtl-program-minimum-arity");
l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
if (scm_is_false (l))
return 0;
*req = scm_to_int (scm_car (l));
*opt = scm_to_int (scm_cadr (l));
*rest = scm_is_true (scm_caddr (l));
return 1;
}
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
SCM arities;
if (SCM_RTL_PROGRAM_P (program))
return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
arities = scm_program_arities (program);
if (!scm_is_pair (arities))
return 0;

View file

@ -55,7 +55,8 @@
find-debug-context
find-program-debug-info
arity-arguments-alist
find-program-arities))
find-program-arities
program-minimum-arity))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.

View file

@ -61,6 +61,12 @@
(and=> (find-program-debug-info (rtl-program-code program))
program-debug-info-name))
;; This procedure is called by programs.c.
(define (rtl-program-minimum-arity program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(program-minimum-arity (rtl-program-code program)))
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@ -276,25 +282,38 @@
1+
0)))
(define (write-program prog port)
(format port "#<procedure ~a~a>"
(or (procedure-name prog)
(and=> (and (program? prog) (program-source prog 0))
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
(or (source:file s)
(if s "<current input>" "<unknown port>"))
(source:line-for-user s) (source:column s))))
(number->string (object-address prog) 16))
(let ((arities (and (program? prog) (program-arities prog))))
(if (or (not arities) (null? arities))
""
(string-append
" " (string-join (map (lambda (a)
(object->string
(arguments-alist->lambda-list
(arity->arguments-alist prog a))))
arities)
" | "))))))
(define (program-arguments-alists prog)
(cond
((rtl-program? prog)
(map arity-arguments-alist
(find-program-arities (rtl-program-code prog))))
((program? prog)
(map (lambda (arity) (arity->arguments-alist prog arity))
(or (program-arities prog) '())))
(else (error "expected a program" prog))))
(define (write-program prog port)
(define (program-identity-string)
(or (procedure-name prog)
(and=> (and (program? prog) (program-source prog 0))
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
(or (source:file s)
(if s "<current input>" "<unknown port>"))
(source:line-for-user s) (source:column s))))
(number->string (object-address prog) 16)))
(define (program-formals-string)
(let ((arguments (program-arguments-alists prog)))
(if (null? arguments)
""
(string-append
" " (string-join (map (lambda (a)
(object->string
(arguments-alist->lambda-list a)))
arguments)
" | ")))))
(format port "#<procedure ~a~a>"
(program-identity-string) (program-formals-string)))

View file

@ -316,3 +316,33 @@
(return 0)
(end-arity)
(end-program))))))
(with-test-prefix "simply procedure arity"
(pass-if-equal "#<procedure foo ()>"
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return 0)
(end-arity)
(end-program)))))
(pass-if-equal "#<procedure foo (x y)>"
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
(begin-standard-arity (x y) 2 #f)
(load-constant 0 42)
(return 0)
(end-arity)
(end-program)))))
(pass-if-equal "#<procedure foo (x #:optional y . z)>"
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
(begin-opt-arity (x) (y) z 3 #f)
(load-constant 0 42)
(return 0)
(end-arity)
(end-program))))))