summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/Makefile.am2
-rw-r--r--module/system/xref.scm73
2 files changed, 75 insertions, 0 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index ea6b8ccb4..64a74482b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -34,6 +34,8 @@ SOURCES = \
system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
system/vm/trace.scm system/vm/vm.scm \
\
+ system/xref.scm \
+ \
system/repl/repl.scm system/repl/common.scm \
system/repl/command.scm \
\
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