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:
parent
f88e574d58
commit
eb2bc00fb3
5 changed files with 100 additions and 34 deletions
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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))))))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue