diff options
-rw-r--r-- | libguile/backtrace.c | 14 | ||||
-rw-r--r-- | libguile/programs.c | 48 | ||||
-rw-r--r-- | libguile/programs.h | 1 | ||||
-rw-r--r-- | module/language/ghil/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/language/glil.scm | 8 | ||||
-rw-r--r-- | module/language/glil/compile-assembly.scm | 32 | ||||
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 12 | ||||
-rw-r--r-- | module/system/vm/program.scm | 18 |
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))) |