summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/backtrace.c14
-rw-r--r--libguile/programs.c48
-rw-r--r--libguile/programs.h1
-rw-r--r--module/language/ghil/compile-glil.scm2
-rw-r--r--module/language/glil.scm8
-rw-r--r--module/language/glil/compile-assembly.scm32
-rw-r--r--module/language/scheme/compile-ghil.scm12
-rw-r--r--module/system/vm/program.scm18
8 files changed, 99 insertions, 36 deletions
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 418b6d777..a8afcdf34 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -473,14 +473,14 @@ display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
*file = scm_source_property (source, scm_sym_filename);
*line = scm_source_property (source, scm_sym_line);
}
- else if (scm_is_vector (source))
+ else if (scm_is_pair (source)
+ && scm_is_pair (scm_cdr (source))
+ && scm_is_pair (scm_cddr (source))
+ && !scm_is_pair (scm_cdddr (source)))
{
- /* #(line column file), from VM compilation */
- size_t len = scm_c_vector_length (source);
- if (len >= 3)
- *file = scm_c_vector_ref (source, 2);
- if (len >= 1)
- *line = scm_c_vector_ref (source, 0);
+ /* (addr . (filename . (line . column))), from vm compilation */
+ *file = scm_cadr (source);
+ *line = scm_caddr (source);
}
}
diff --git a/libguile/programs.c b/libguile/programs.c
index b4d43bf6e..1c42e15d6 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -49,6 +49,7 @@
#include "modules.h"
#include "programs.h"
#include "procprop.h" // scm_sym_name
+#include "srcprop.h" // scm_sym_filename
#include "vm.h"
@@ -219,7 +220,7 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
"")
#define FUNC_NAME s_scm_program_sources
{
- SCM meta;
+ SCM meta, sources, ret, filename;
SCM_VALIDATE_PROGRAM (1, program);
@@ -227,7 +228,25 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
if (scm_is_false (meta))
return SCM_EOL;
- return scm_cadr (scm_call_0 (meta));
+ filename = SCM_BOOL_F;
+ ret = SCM_EOL;
+ for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
+ sources = scm_cdr (sources))
+ {
+ SCM x = scm_car (sources);
+ if (scm_is_pair (x))
+ {
+ if (scm_is_number (scm_car (x)))
+ {
+ SCM addr = scm_car (x);
+ ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
+ ret);
+ }
+ else if (scm_is_eq (scm_car (x), scm_sym_filename))
+ filename = scm_cdr (x);
+ }
+ }
+ return scm_reverse_x (ret, SCM_UNDEFINED);
}
#undef FUNC_NAME
@@ -258,17 +277,28 @@ SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
+ (SCM program, SCM ip),
+ "")
+#define FUNC_NAME s_scm_program_source
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_c_program_source (program, scm_to_size_t (ip));
+}
+#undef FUNC_NAME
+
extern SCM
scm_c_program_source (SCM program, size_t ip)
{
- SCM sources, source;
-
- sources = scm_program_sources (program);
- source = scm_assv (scm_from_size_t (ip), sources);
- if (scm_is_false (source))
- return SCM_BOOL_F;
+ SCM sources, source = SCM_BOOL_F;
- return scm_cdr (source); /* a #(line column file) vector */
+ for (sources = scm_program_sources (program);
+ !scm_is_null (sources)
+ && scm_to_size_t (scm_caar (sources)) <= ip;
+ sources = scm_cdr (sources))
+ source = scm_car (sources);
+
+ return source; /* (addr . (filename . (line . column))) */
}
SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
diff --git a/libguile/programs.h b/libguile/programs.h
index 263228bec..68a6936a2 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -71,6 +71,7 @@ extern SCM scm_program_arity (SCM program);
extern SCM scm_program_meta (SCM program);
extern SCM scm_program_bindings (SCM program);
extern SCM scm_program_sources (SCM program);
+extern SCM scm_program_source (SCM program, SCM ip);
extern SCM scm_program_properties (SCM program);
extern SCM scm_program_name (SCM program);
extern SCM scm_program_objects (SCM program);
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index 0723e71da..4230549ba 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -431,6 +431,8 @@
((external)
(push-code! #f (make-glil-argument 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
+ ;; push on definition source location
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
;; compile body
(comp body #t #f)
;; create GLIL
diff --git a/module/language/glil.scm b/module/language/glil.scm
index b1e42e476..b222779a1 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -37,7 +37,7 @@
<glil-unbind> make-glil-unbind glil-unbind?
<glil-source> make-glil-source glil-source?
- glil-source-loc
+ glil-source-props
<glil-void> make-glil-void glil-void?
@@ -82,7 +82,7 @@
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
- (<glil-source> loc)
+ (<glil-source> props)
;; Objects
(<glil-void>)
(<glil-const> obj)
@@ -122,7 +122,7 @@
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
((unbind) (make-glil-unbind))
- ((source ,loc) (make-glil-source loc))
+ ((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
((argument ,op ,index) (make-glil-argument op index))
@@ -145,7 +145,7 @@
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
((<glil-unbind>) `(unbind))
- ((<glil-source> loc) `(source ,loc))
+ ((<glil-source> props) `(source ,props))
;; constants
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index d33210159..1f0b88a32 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -44,6 +44,29 @@
(define-record <subprogram> code)
+(define (limn-sources sources)
+ (let lp ((in sources) (out '()) (filename #f))
+ (if (null? in)
+ (reverse! out)
+ (let ((addr (caar in))
+ (new-filename (assq-ref (cdar in ) 'filename))
+ (line (assq-ref (cdar in) 'line))
+ (column (assq-ref (cdar in) 'column)))
+ (cond
+ ((not (equal? new-filename filename))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ (filename ,new-filename)
+ . ,out)
+ new-filename))
+ ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
+ (lp (cdr in)
+ `((,addr . (,line . ,column))
+ . ,out)
+ filename))
+ (else
+ (lp (cdr in) out filename)))))))
+
(define (make-meta bindings sources tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
@@ -129,7 +152,7 @@
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
- (reverse source-alist)
+ (limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
addr))
@@ -139,7 +162,8 @@
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
- (apply + addr (map byte-length subcode)))))))))
+ (fold (lambda (x len) (+ (byte-length x) len))
+ addr subcode))))))))
(receive (code bindings sources labels objects len)
(process-body)
@@ -190,10 +214,10 @@
label-alist
object-alist))
- ((<glil-source> loc)
+ ((<glil-source> props)
(values '()
bindings
- (acons addr loc source-alist)
+ (acons addr props source-alist)
label-alist
object-alist))
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 160f94a99..3693b3867 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -127,10 +127,11 @@
(define (translate-1 e l x)
(let ((l (or l (location x))))
(define (retrans x) (translate-1 e #f x))
+ (define (retrans/loc x) (translate-1 e (or (location x) l) x))
(cond ((pair? x)
(let ((head (car x)) (tail (cdr x)))
(cond
- ((lookup-transformer head retrans)
+ ((lookup-transformer head retrans/loc)
=> (lambda (t) (t e l x)))
;; FIXME: lexical/module overrides of forbidden primitives
@@ -166,7 +167,10 @@
,sym
(lambda (e l exp)
(define (retrans x)
- ((@ (language scheme compile-ghil) translate-1) e #f x))
+ ((@ (language scheme compile-ghil) translate-1)
+ e
+ (or ((@@ (language scheme compile-ghil) location) x) l)
+ x))
(define syntax-error (@ (system base compile) syntax-error))
(pmatch (cdr exp)
,@clauses
@@ -518,6 +522,4 @@
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
- (vector (assq-ref props 'line)
- (assq-ref props 'column)
- (assq-ref props 'filename))))))
+ props))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index cfb7362b4..739451e85 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -28,7 +28,7 @@
binding:start binding:end
source:addr source:line source:column source:file
- program-bindings program-sources
+ program-bindings program-sources program-source
program-properties program-property program-documentation
program-name
@@ -53,12 +53,12 @@
(define (source:addr source)
(car source))
+(define (source:file source)
+ (cadr source))
(define (source:line source)
- (vector-ref (cdr source) 0))
+ (caddr source))
(define (source:column source)
- (vector-ref (cdr source) 1))
-(define (source:file source)
- (vector-ref (cdr source) 2))
+ (cdddr source))
(define (program-property prog prop)
(assq-ref (program-properties proc) prop))
@@ -80,7 +80,11 @@
(define (write-program prog port)
(format port "#<program ~a ~a>"
(or (program-name prog)
- (let ((s (program-sources prog)))
- (and (not (null? s)) (cdar s)))
+ (and=> (program-source prog 0)
+ (lambda (s)
+ (format #f "~a at ~a:~a:~a"
+ (number->string (object-address prog) 16)
+ (or (source:file s) "<unknown port>")
+ (source:line s) (source:column s))))
(number->string (object-address prog) 16))
(program-bindings-as-lambda-list prog)))