From ce811ece0affa2b20531f4191538dc5b5bafc510 Mon Sep 17 00:00:00 2001
From: Ludovic Courtes
Date: Sat, 2 Jul 2005 12:40:07 +0000
Subject: Minor fixes for file/line error reporting.

* src/guile/skribilo/lib.scm (skribe-line-error):  Removed.
  (skribe-ast-error):  Fixed.  Use `location-line' instead of
  `location-pos'.
  (skribe-error):  Fixed.
  (%skribe-warn):  Use the file and line number of CURRENT-INPUT-PORT by
  default.

* src/guile/skribilo/types.scm:  Export `location-file', `location-line'
  and `location-pos'.
  (initialize):  New method for `<ast>' objects, initialize slot `loc'
  with information from CURRENT-INPUT-PORT.
  (ast-location):  Fixed.

git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-5
---
 src/guile/skribilo/lib.scm   | 22 +++++++++++-----------
 src/guile/skribilo/types.scm | 12 +++++++++++-
 2 files changed, 22 insertions(+), 12 deletions(-)

(limited to 'src/guile')

diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index aaf1a8f..8667f7e 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -28,7 +28,7 @@
 
 (define-module (skribilo lib)
   :export (skribe-eval-location skribe-ast-error skribe-error
-           skribe-type-error skribe-line-error
+           skribe-type-error
            skribe-warning skribe-warning/ast
            skribe-message
 
@@ -167,13 +167,14 @@
   (let ((l     (ast-loc obj))
 	(shape (if (markup? obj) (markup-markup obj) obj)))
     (if (location? l)
-	(error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape)
-	(error "~a: ~a ~s " proc msg shape))))
+	(error (format #f "~a:~a: ~a: ~a ~s" (location-file l)
+		       (location-line l) proc msg shape))
+	(error (format #f "~a: ~a ~s " proc msg shape)))))
 
 (define (skribe-error proc msg obj)
   (if (ast? obj)
       (skribe-ast-error proc msg obj)
-      (error proc msg obj)))
+      (error (format #f "~a: ~a ~s" proc msg obj))))
 
 
 ;;;
@@ -183,17 +184,16 @@
   (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f))
 
 
-
-;;; FIXME: Peut-être virée maintenant
-(define (skribe-line-error file line proc msg obj)
-  (error (format "%a:%a:  ~a:~a ~S" file line proc msg obj)))
-
-
 ;;;
 ;;; SKRIBE-WARNING  &  SKRIBE-WARNING/AST
 ;;;
 (define (%skribe-warn level file line 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))
     (format port "warning: ")
@@ -210,7 +210,7 @@
   (if (>= *skribe-warning* level)
       (let ((l (ast-loc ast)))
 	(if (location? l)
-	    (%skribe-warn level (location-file l) (location-pos l) obj)
+	    (%skribe-warn level (location-file l) (location-line l) obj)
 	    (%skribe-warn level #f #f obj)))))
 
 ;;;
diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm
index 8d51c8c..4b3729c 100644
--- a/src/guile/skribilo/types.scm
+++ b/src/guile/skribilo/types.scm
@@ -45,6 +45,7 @@
 		       document-options document-end
 	    <language> language?
 	    <location> location? ast-location
+	    location-file location-line location-pos
 
 	    *node-table*)
    :use-module (oop goops))
@@ -65,6 +66,15 @@
   (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified)
   (loc    :init-value #f))
 
+(define-method (initialize (ast <ast>) . args)
+  (next-method)
+  (let ((file (port-filename (current-input-port)))
+	(line (port-line (current-input-port)))
+	(column (port-column (current-input-port))))
+    (slot-set! ast 'loc
+	       (make <location>
+		 :file file :line line :pos (* line column)))))
+
 (define (ast? obj)		(is-a? obj <ast>))
 (define (ast-loc obj)		(slot-ref obj 'loc))
 (define (ast-loc-set! obj v)	(slot-set! obj 'loc v))
@@ -313,5 +323,5 @@
 			       (> lenf len))
 			  (substring fname len (+ 1 (string-length fname)))
 			  fname)))
-	  (format "~a, line ~a" file line))
+	  (format #f "~a, line ~a" file line))
 	"no source location")))
-- 
cgit v1.2.3