summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-08-03 14:03:47 +0200
committerAndy Wingo <wingo@pobox.com>2008-08-03 14:03:47 +0200
commit96969dc1d645db882768da14f47ce8a4fc699f08 (patch)
tree7a2c2d4a621820583163d5f3d024665d165b9377
parent427d4a0c51e4e186fa20b7d85dccf77b5dae8c88 (diff)
downloadguile-96969dc1d645db882768da14f47ce8a4fc699f08.tar.gz
fix recording of source locations
* module/language/scheme/translate.scm (translate, trans) (make-pmatch-transformers): When recursing into subexpressions, get the appropriate source location information. (location): Include the source filename in the location information. * module/system/il/compile.scm (codegen): Record source locations in more cases. (This information ends up being part of the procedure metadata, not the actual codepath.) * module/system/il/glil.scm (unparse): Don't destructure the source locations (it's a vector now).
-rw-r--r--module/language/scheme/translate.scm10
-rw-r--r--module/system/il/compile.scm71
-rw-r--r--module/system/il/glil.scm2
3 files changed, 43 insertions, 40 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index e46ef36b1..07fc2070f 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -33,7 +33,7 @@
(define (translate x e)
(call-with-ghil-environment (make-ghil-mod e) '()
(lambda (env vars)
- (make-ghil-lambda env #f vars #f (trans env #f x)))))
+ (make-ghil-lambda env #f vars #f (trans env (location x) x)))))
;;;
@@ -80,7 +80,7 @@
(else #f))))
(define (trans e l x)
- (define (retrans x) (trans e l x))
+ (define (retrans x) (trans e (location x) x))
(cond ((pair? x)
(let ((head (car x)) (tail (cdr x)))
(cond
@@ -120,7 +120,7 @@
(clauses (cdr clause)))
`(cons ',sym
(lambda (,env ,loc ,exp)
- (define (,retranslate x) (trans ,env ,loc x))
+ (define (,retranslate x) (trans ,env (location x) x))
(pmatch (cdr ,exp)
,@clauses
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
@@ -340,4 +340,6 @@
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
- (cons (assq-ref props 'line) (assq-ref props 'column))))))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index b45b12836..c74fe8a87 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -106,11 +106,13 @@
(define (codegen ghil)
(let ((stack '()))
- (define (push-code! code)
+ (define (push-code! loc code)
+ (if loc (set! stack (cons (make-glil-source loc) stack)))
(set! stack (cons code stack)))
- (define (push-bindings! vars)
+ (define (push-bindings! loc vars)
(if (not (null? vars))
(push-code!
+ loc
(make-glil-bind
(map list
(map ghil-var-name vars)
@@ -118,13 +120,12 @@
(map ghil-var-index vars))))))
(define (comp tree tail drop)
(define (push-label! label)
- (push-code! (make-glil-label label)))
- (define (push-branch! inst label)
- (push-code! (make-glil-branch inst label)))
+ (push-code! #f (make-glil-label label)))
+ (define (push-branch! loc inst label)
+ (push-code! loc (make-glil-branch inst label)))
(define (push-call! loc inst args)
(for-each comp-push args)
- (push-code! (make-glil-call inst (length args)))
- (push-code! (make-glil-source loc)))
+ (push-code! loc (make-glil-call inst (length args))))
;; possible tail position
(define (comp-tail tree) (comp tree tail drop))
;; push the result
@@ -133,20 +134,20 @@
(define (comp-drop tree) (comp tree #f #t))
;; drop the result if unnecessary
(define (maybe-drop)
- (if drop (push-code! *ia-drop*)))
+ (if drop (push-code! #f *ia-drop*)))
;; return here if necessary
(define (maybe-return)
- (if tail (push-code! *ia-return*)))
+ (if tail (push-code! #f *ia-return*)))
;; return this code if necessary
- (define (return-code! code)
- (if (not drop) (push-code! code))
+ (define (return-code! loc code)
+ (if (not drop) (push-code! loc code))
(maybe-return))
;; return void if necessary
(define (return-void!)
- (return-code! *ia-void*))
+ (return-code! #f *ia-void*))
;; return object if necessary
- (define (return-object! obj)
- (return-code! (make-glil-const #:obj obj)))
+ (define (return-object! loc obj)
+ (return-code! loc (make-glil-const #:obj obj)))
;;
;; dispatch
(record-case tree
@@ -154,7 +155,7 @@
(return-void!))
((<ghil-quote> env loc obj)
- (return-object! obj))
+ (return-object! loc obj))
((<ghil-quasiquote> env loc exp)
(let loop ((x exp))
@@ -166,7 +167,7 @@
((pair? x)
(loop (car x))
(loop (cdr x))
- (push-code! (make-glil-call 'cons 2)))
+ (push-code! #f (make-glil-call 'cons 2)))
((record? x)
(record-case x
((<ghil-unquote> env loc exp)
@@ -175,21 +176,21 @@
(comp-push exp)
(push-call! #f 'list-break '()))))
(else
- (push-code! (make-glil-const #:obj x)))))
+ (push-code! #f (make-glil-const #:obj x)))))
(maybe-drop)
(maybe-return))
((<ghil-ref> env loc var)
- (return-code! (make-glil-var 'ref env var)))
+ (return-code! loc (make-glil-var 'ref env var)))
((<ghil-set> env loc var val)
(comp-push val)
- (push-code! (make-glil-var 'set env var))
+ (push-code! loc (make-glil-var 'set env var))
(return-void!))
((<ghil-define> env loc var val)
(comp-push val)
- (push-code! (make-glil-var 'define env var))
+ (push-code! loc (make-glil-var 'define env var))
(return-void!))
((<ghil-if> env loc test then else)
@@ -201,9 +202,9 @@
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(comp-push test)
- (push-branch! 'br-if-not L1)
+ (push-branch! loc 'br-if-not L1)
(comp-tail then)
- (if (not tail) (push-branch! 'br L2))
+ (if (not tail) (push-branch! #f 'br L2))
(push-label! L1)
(comp-tail else)
(if (not tail) (push-label! L2))))
@@ -218,18 +219,18 @@
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(if (null? exps)
- (return-object! #t)
+ (return-object! loc #t)
(do ((exps exps (cdr exps)))
((null? (cdr exps))
(comp-tail (car exps))
- (if (not tail) (push-branch! 'br L2))
+ (if (not tail) (push-branch! #f 'br L2))
(push-label! L1)
- (return-object! #f)
+ (return-object! #f #f)
(if (not tail) (push-label! L2))
(maybe-drop)
(maybe-return))
(comp-push (car exps))
- (push-branch! 'br-if-not L1)))))
+ (push-branch! #f 'br-if-not L1)))))
((<ghil-or> env loc exps)
;; EXP
@@ -241,7 +242,7 @@
;; L1:
(let ((L1 (make-label)))
(if (null? exps)
- (return-object! #f)
+ (return-object! loc #f)
(do ((exps exps (cdr exps)))
((null? (cdr exps))
(comp-tail (car exps))
@@ -250,7 +251,7 @@
(maybe-return))
(comp-push (car exps))
(push-call! #f 'dup '())
- (push-branch! 'br-if L1)
+ (push-branch! #f 'br-if L1)
(push-call! #f 'drop '())))))
((<ghil-begin> env loc exps)
@@ -268,14 +269,14 @@
;; (set VARS)...
;; BODY
(for-each comp-push vals)
- (push-bindings! vars)
- (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
+ (push-bindings! loc vars)
+ (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
(reverse vars))
(comp-tail body)
- (push-code! (make-glil-unbind)))
+ (push-code! #f (make-glil-unbind)))
((<ghil-lambda> env loc vars rest body)
- (return-code! (codegen tree)))
+ (return-code! loc (codegen tree)))
((<ghil-inline> env loc inline args)
;; ARGS...
@@ -303,7 +304,7 @@
(finalize-index! locs)
(finalize-index! exts)
;; meta bindings
- (push-bindings! vars)
+ (push-bindings! #f vars)
;; export arguments
(do ((n 0 (1+ n))
(l vars (cdr l)))
@@ -311,8 +312,8 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
- (push-code! (make-glil-argument 'ref n))
- (push-code! (make-glil-external 'set 0 (ghil-var-index v)))))))
+ (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
;; compile body
(comp body #t #f)
;; create GLIL
diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 6a3ec4c17..5afa6fe3e 100644
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -172,7 +172,7 @@
,@(map unparse body)))
((<glil-bind> vars) `(@bind ,@vars))
((<glil-unbind>) `(@unbind))
- ((<glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
+ ((<glil-source> loc) `(@source ,loc))
;; constants
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))