From ffd41b153e703042c117e9a491066f799608a425 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 3 Apr 2007 09:27:59 +0000 Subject: Added support for source location tracking. * src/guile/skribilo/ast.scm (): 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 (): 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 --- src/guile/skribilo/ast.scm | 5 ++--- src/guile/skribilo/lib.scm | 39 ++++++++++++++++++---------------- src/guile/skribilo/location.scm | 46 +++++++++++++++++++++++++++++++++++------ 3 files changed, 63 insertions(+), 27 deletions(-) (limited to 'src') 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 ;;; Copyright 2003, 2004 Manuel Serrano -;;; Copyright 2005, 2006 Ludovic Courtès +;;; Copyright 2005, 2006, 2007 Ludovic Courtès ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -167,13 +167,12 @@ ;;; Abstract syntax tree (AST). ;;; -;;FIXME: set! location in (define-class () ;; 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 -;;; Copyright © 2005 Ludovic Courtès +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2007 Ludovic Courtès ;;; ;;; ;;; 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 -;;; Copyright 2005 Ludovic Courtès +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2007 Ludovic Courtès ;;; ;;; ;;; 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? 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 () - (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 )) +(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 ) port) + (format port "#< ~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 :file file + :line (and line (+ line 1)) + :column col))))))) ;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83 -- cgit v1.2.3