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

Wire up ability to print RTL program arities

Browse source 
* 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
Download patch file Download diff file Expand all files Collapse all files

3
module/system/vm/debug.scm
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.

61
module/system/vm/program.scm
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)))