diff options
author | Andy Wingo <wingo@pobox.com> | 2009-03-17 23:11:56 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-03-17 23:11:56 +0100 |
commit | e04894e1ac6c631d8fd1b92de4189f7b260f9509 (patch) | |
tree | 0171ea11d31f711c2c9dd886dd4dcbad12c266fc /module/system/xref.scm | |
parent | c9d5bfad9ef1c601db8ca1e9ceff66de34411bb1 (diff) | |
download | guile-e04894e1ac6c631d8fd1b92de4189f7b260f9509.tar.gz |
add xref.scm
* module/system/xref.scm: New module, will provide callers/callees info.
* module/Makefile.am (SOURCES): Add xref.scm.
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r-- | module/system/xref.scm | 73 |
1 files changed, 73 insertions, 0 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm new file mode 100644 index 000000000..8d1cb54cf --- /dev/null +++ b/module/system/xref.scm @@ -0,0 +1,73 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (system xref) + #:use-module (system base pmatch) + #:use-module (system base compile) + #:use-module (system vm program) + #:export (procedure-callees)) + +(define (program-callees prog) + (cond + ((program-objects prog) + => (lambda (objects) + (let ((n (vector-length objects)) + (progv (make-vector (vector-length objects) #f)) + (asm (decompile (program-objcode prog) #:to 'assembly))) + (pmatch asm + ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body) + (for-each + (lambda (x) + (pmatch x + ((toplevel-ref ,n) (vector-set! progv n #t)) + ((toplevel-set ,n) (vector-set! progv n #t)))) + body))) + (let lp ((i 0) (out '())) + (cond + ((= i n) (reverse out)) + ((program? (vector-ref objects i)) + (lp (1+ i) (append (reverse (program-callees + (vector-ref objects i))) + out))) + ((vector-ref progv i) + (let ((obj (vector-ref objects i))) + (if (variable? obj) + (lp (1+ i) (cons (variable-ref obj) out)) + ;; otherwise it's an unmemoized binding + (pmatch obj + (,sym (guard (symbol? sym)) + (let ((v (module-variable (program-module prog) sym))) + (lp (1+ i) + (if v (cons (variable-ref v) out) out)))) + ((,mod ,sym ,public?) + ;; hm, hacky. + (let ((m (nested-ref the-root-module + (append '(%app modules) mod)))) + (let ((v (and m (module-variable + (if public? (module-interface m) m) + sym)))) + (lp (1+ i) + (if v (cons (variable-ref v) out) out))))))))) + (else (lp (1+ i) out))))))) + (else '()))) + +(define (procedure-callees proc) + (cond + ((program? proc) (program-callees proc)) + ((procedure-source proc) (hacky-procedure-callees proc)) + (else '())))
\ No newline at end of file |