summaryrefslogtreecommitdiff
path: root/module/system/xref.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-03-17 23:11:56 +0100
committerAndy Wingo <wingo@pobox.com>2009-03-17 23:11:56 +0100
commite04894e1ac6c631d8fd1b92de4189f7b260f9509 (patch)
tree0171ea11d31f711c2c9dd886dd4dcbad12c266fc /module/system/xref.scm
parentc9d5bfad9ef1c601db8ca1e9ceff66de34411bb1 (diff)
downloadguile-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.scm73
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