aboutsummaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/ast.scm5
-rw-r--r--src/guile/skribilo/lib.scm39
-rw-r--r--src/guile/skribilo/location.scm46
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
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-08 10:46:36 +0000