diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-16 20:58:54 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-09 23:43:25 +0200 |
commit | eb2bc00fb3863986927f0bade97487209b6d6a5b (patch) | |
tree | 8671c68378b99fc3066de39d6e0e9dc1e11a8b3e /module | |
parent | f88e574d58aa3e64b6f1ed0bc6ea918d20a67d88 (diff) | |
download | guile-eb2bc00fb3863986927f0bade97487209b6d6a5b.tar.gz |
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.
Diffstat (limited to 'module')
-rw-r--r-- | module/system/vm/debug.scm | 3 | ||||
-rw-r--r-- | module/system/vm/program.scm | 59 |
2 files changed, 41 insertions, 21 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 6f241087d..5196ecae1 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -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. diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index fdfc9a8aa..a4bd64e28 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -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 (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) - (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-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))) |