Added support for source location tracking.

* src/guile/skribilo/ast.scm (<ast>): Added the `:loc' init-keyword.

* src/guile/skribilo/lib.scm: Re-export `invocation-location'.
  (define-markup): Locally define `&invocation-location' for use by
  markups.
  (define-simple-markup): Initialize `loc'.
  (define-simple-container): Likewise.
  (%skribe-warn): New `col'. parameter.
  (skribe-warning): Updated.
  (skribe-warning/ast): Likewise.

* src/guile/skribilo/location.scm (<location>): Removed slot `pos'.
  Added slot `column'.  Export `location-column'.
  (location-pos): Kept for compatibility.
  (write): New method.
  (invocation-location): New function.

git-archimport-id: lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-38

3 files changed, 63 insertions, 27 deletions

diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm
index 55f37bf..5146f75 100644
--- a/src/guile/skribilo/ast.scm
+++ b/src/guile/skribilo/ast.scm
@@ -2,7 +2,7 @@
 ;;;
 ;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;; Copyright 2003, 2004  Manuel Serrano
-;;; Copyright 2005, 2006  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2005, 2006, 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -167,13 +167,12 @@
 ;;; Abstract syntax tree (AST).
 ;;;
 
-;;FIXME: set! location in <ast>
 (define-class <ast> ()
   ;; Parent of this guy.
   (parent  :accessor ast-parent :init-keyword :parent :init-value 'unspecified)
 
   ;; Its source location.
-  (loc     :init-value #f)
+  (loc     :init-value #f :init-keyword :loc)
 
   ;; This slot is used as an optimization when resolving an AST: sub-parts of
   ;; the tree are marked as resolved as soon as they are and don't need to be
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index 21b2a4d..1bac503 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,8 +1,7 @@
+;;; lib.scm -- Utilities.
 ;;;
-;;; lib.scm	-- Utilities
-;;;
-;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -32,6 +31,9 @@
   :export-syntax (new define-markup define-simple-markup
                   define-simple-container define-processor-markup)
 
+  ;; Re-exported because used in `define-markup'.
+  :re-export  (invocation-location)
+
   :use-module (skribilo config)
   :use-module (skribilo ast)
 
@@ -100,7 +102,12 @@
 
   (let ((name (car bindings))
 	(opts (cdr bindings)))
-    `(define*-public ,(cons name (fix-rest-arg opts)) ,@body)))
+    `(define*-public ,(cons name (fix-rest-arg opts))
+       ;; Memorize the invocation location.  Note: the invocation depth
+       ;; passed to `invocation-location' was determined experimentally and
+       ;; may change as Guile changes (XXX).
+       (let ((&invocation-location (invocation-location 6)))
+         ,@body))))
 
 
 ;;;
@@ -112,7 +119,7 @@
 	  (markup ',markup)
 	  (ident (or ident (symbol->string
 			    (gensym ',(symbol->string markup)))))
-	  (loc loc)
+	  (loc (or loc &invocation-location))
 	  (class class)
 	  (required-options '())
 	  (options (the-options opts :ident :class :loc))
@@ -128,7 +135,7 @@
 	  (markup ',markup)
 	  (ident (or ident (symbol->string
 			    (gensym ',(symbol->string markup)))))
-	  (loc loc)
+	  (loc (or loc &invocation-location))
 	  (class class)
 	  (required-options '())
 	  (options (the-options opts :ident :class :loc))
@@ -196,15 +203,10 @@
 ;;;
 ;;; SKRIBE-WARNING  &  SKRIBE-WARNING/AST
 ;;;
-(define (%skribe-warn level file line lst)
+(define (%skribe-warn level file line col lst)
   (let ((port (current-error-port)))
-    (if (or (not file) (not line))
-	(begin
-	  ;; XXX:  This is a bit hackish, but it proves to be quite useful.
-	  (set! file (port-filename (current-input-port)))
-	  (set! line (port-line (current-input-port)))))
-    (when (and file line)
-      (format port "~a:~a: " file line))
+    (when (and file line col)
+      (format port "~a:~a:~a: " file line col))
     (format port "warning: ")
     (for-each (lambda (x) (format port "~a " x)) lst)
     (newline port)))
@@ -212,15 +214,16 @@
 
 (define (skribe-warning level . obj)
   (if (>= (*warning*) level)
-      (%skribe-warn level #f #f obj)))
+      (%skribe-warn level #f #f #f obj)))
 
 
 (define (skribe-warning/ast level ast . obj)
   (if (>= (*warning*) level)
       (let ((l (ast-loc ast)))
 	(if (location? l)
-	    (%skribe-warn level (location-file l) (location-line l) obj)
-	    (%skribe-warn level #f #f obj)))))
+	    (%skribe-warn level (location-file l) (location-line l)
+                          (location-column l) obj)
+	    (%skribe-warn level #f #f #f obj)))))
 
 ;;;
 ;;; SKRIBE-MESSAGE
diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm
index 7c870fa..1ca278f 100644
--- a/src/guile/skribilo/location.scm
+++ b/src/guile/skribilo/location.scm
@@ -1,7 +1,7 @@
 ;;; location.scm -- Skribilo source location.
 ;;;
-;;; Copyright 2003-2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;; Copyright 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -23,7 +23,9 @@
   :use-module (oop goops)
   :use-module ((skribilo utils syntax) :select (%skribilo-module-reader))
   :export (<location> location? ast-location
-	   location-file location-line location-pos))
+	   location-file location-line location-column
+           location-pos
+           invocation-location))
 
 ;;; Author:  Ludovic Courtès
 ;;;
@@ -41,13 +43,17 @@
 ;;;
 
 (define-class <location> ()
-  (file :init-keyword :file :getter location-file)
-  (pos  :init-keyword :pos  :getter location-pos)
-  (line :init-keyword :line :getter location-line))
+  (file   :init-keyword :file   :getter location-file)
+  (column :init-keyword :column :getter location-column)
+  (line   :init-keyword :line   :getter location-line))
 
 (define (location? obj)
   (is-a? obj <location>))
 
+(define (location-pos loc)
+  ;; Kept for compatibility with Skribe.  XXX: Move to `compat.scm'.
+  0)
+
 (define (ast-location obj)
   (let ((loc (slot-ref obj 'loc)))
     (if (location? loc)
@@ -63,6 +69,34 @@
 	  (format #f "~a, line ~a" file line))
 	"no source location")))
 
+(define-method (write (loc <location>) port)
+  (format port "#<<location> ~a \"~a\":~a:~a>"
+          (object-address loc)
+          (location-file loc)
+          (location-line loc)
+          (location-column loc)))
+
+
+
+;;;
+;;; Getting an invocation's location.
+;;;
+
+(define (invocation-location . depth)
+  ;; Return a location object denoting the place of invocation of this
+  ;; function's caller.
+  (let ((depth (if (null? depth) 4 (car depth))))
+    (let* ((stack  (make-stack #t))
+           (frame  (stack-ref stack depth))
+           (source (frame-source frame)))
+      (and source
+           (let ((file (source-property source 'filename))
+                 (line (source-property source 'line))
+                 (col  (source-property source 'column)))
+             (and file
+                  (make <location> :file file
+                        :line (and line (+ line 1))
+                        :column col)))))))
 
 ;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83