From fbbaa49d9e953218a08c0cd0c789d9f334cd7bc4 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es
Date: Tue, 3 Apr 2007 09:35:33 +0000
Subject: Added source location tracking to various packages.

* src/guile/skribilo/package/base.scm: Autoload `parameters'.
  (ref)[skribe-ref]: Use `search-path' and `*document-path*' instead of
  `find-file/path' and `skribe-path'.

  Initialize the `loc' field of markups.

* src/guile/skribilo/package/eq.scm: Likewise.

* src/guile/skribilo/package/pie.scm: Likewise.

* src/guile/skribilo/package/slide.scm: Likewise.

git-archimport-id: lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-39
---
 src/guile/skribilo/package/base.scm  | 64 +++++++++++++++++++++++++++++++++---
 src/guile/skribilo/package/eq.scm    |  2 ++
 src/guile/skribilo/package/pie.scm   |  5 ++-
 src/guile/skribilo/package/slide.scm | 12 +++++--
 4 files changed, 76 insertions(+), 7 deletions(-)

(limited to 'src/guile')

diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm
index 1971ca5..73cf93d 100644
--- a/src/guile/skribilo/package/base.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -1,7 +1,7 @@
 ;;; base.scm -- The base markup package of Skribe/Skribilo.
 ;;;
 ;;; 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
@@ -31,6 +31,7 @@
   :autoload   (srfi srfi-1)        (every any filter)
   :autoload   (skribilo evaluator) (include-document)
   :autoload   (skribilo engine)    (engine?)
+  :autoload   (skribilo parameters)(*document-path*)
 
   ;; optional ``sub-packages''
   :autoload   (skribilo biblio)    (*bib-table* resolve-bib
@@ -80,6 +81,7 @@
 		 (ast->string title)
 		 (symbol->string (gensym "document"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:title :author :ending))
       (options (the-options opts :ident :class :env))
       (body (the-body opts))
@@ -125,6 +127,7 @@
 	  (markup 'author)
 	  (ident (or ident (symbol->string (gensym "author"))))
 	  (class class)
+          (loc   &invocation-location)
 	  (required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
 	  (options `((:name ,name)
 		     (:align ,align)
@@ -145,6 +148,7 @@
 	 (markup 'toc)
 	 (ident (or ident (symbol->string (gensym "toc"))))
 	 (class class)
+         (loc   &invocation-location)
 	 (required-options '())
 	 (options `((:chapter ,chapter)
 		    (:section ,section)
@@ -154,6 +158,7 @@
 	 (body (cond
 		  ((null? body)
 		   (new unresolved
+                      (loc   &invocation-location)
 		      (proc (lambda (n e env)
 			       (handle
 				(resolve-search-parent n env document?))))))
@@ -185,6 +190,7 @@
       (markup 'chapter)
       (ident (or ident (symbol->string (gensym "chapter"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:title :file :toc :number))
       (options `((:toc ,toc)
 		 (:number ,(and number
@@ -225,6 +231,7 @@
       (markup 'section)
       (ident (or ident (symbol->string (gensym "section"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:title :toc :file :toc :number))
       (options `((:number ,(section-number number 'section))
 		 (:toc ,toc)
@@ -252,6 +259,7 @@
       (markup 'subsection)
       (ident (or ident (symbol->string (gensym "subsection"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:title :toc :file :number))
       (options `((:number ,(section-number number 'subsection))
 		 (:toc ,toc)
@@ -276,6 +284,7 @@
       (markup 'subsubsection)
       (ident (or ident (symbol->string (gensym "subsubsection"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:title :toc :number :file))
       (options `((:number ,(section-number number 'subsubsection))
 		 (:toc ,toc)
@@ -296,6 +305,7 @@
      (markup '~)
      (ident (symbol->string (gensym "~")))
      (class class)
+     (loc   &invocation-location)
      (required-options '())
      (options (the-options opts :class))
      (body (the-body opts))))
@@ -315,6 +325,7 @@
       (markup 'footnote)
       (ident (symbol->string (gensym "footnote")))
       (class class)
+      (loc   &invocation-location)
       (required-options '())
       (options `((:label
 		  ,(cond ((string? label) label)
@@ -335,6 +346,7 @@
    (let ((ln (new markup
 		(ident (or ident (symbol->string (gensym "linebreak"))))
 		(class class)
+                (loc   &invocation-location)
 		(markup 'linebreak)))
 	 (num (the-body opts)))
       (cond
@@ -359,6 +371,7 @@
       (markup 'hrule)
       (ident (or ident (symbol->string (gensym "hrule"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '())
       (options `((:width ,width)
 		 (:height ,height)
@@ -377,6 +390,7 @@
       (markup 'color)
       (ident (or ident (symbol->string (gensym "color"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:bg :fg :width))
       (options `((:bg ,(if bg (skribe-use-color! bg) bg))
 		 (:fg ,(if fg (skribe-use-color! fg) fg))
@@ -395,6 +409,7 @@
       (markup 'frame)
       (ident (or ident (symbol->string (gensym "frame"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:width :border :margin))
       (options `((:margin ,margin)
 		 (:border ,(cond
@@ -416,6 +431,7 @@
       (markup 'font)
       (ident (or ident (symbol->string (gensym "font"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:size))
       (options (the-options opts :ident :class))
       (body (the-body opts))))
@@ -434,6 +450,7 @@
 	  (markup 'flush)
 	  (ident (or ident (symbol->string (gensym "flush"))))
 	  (class class)
+          (loc   &invocation-location)
 	  (required-options '(:side))
 	  (options (the-options opts :ident :class))
 	  (body (the-body opts))))
@@ -469,6 +486,7 @@
 	  (markup 'prog)
 	  (ident (or ident (symbol->string (gensym "prog"))))
 	  (class class)
+          (loc   &invocation-location)
 	  (required-options '(:line :mark))
 	  (options (the-options opts :ident :class :linedigit))
 	  (body (make-prog-body (the-body opts) line linedigit mark)))))
@@ -566,6 +584,7 @@
 			s
 			(symbol->string (gensym "figure"))))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:legend :number :multicolumns))
       (options `((:number
 		  ,(new unresolved
@@ -619,6 +638,7 @@
       (markup 'itemize)
       (ident (or ident (symbol->string (gensym "itemize"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:symbol))
       (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
       (body (parse-list-of 'itemize 'item (the-body opts)))))
@@ -631,6 +651,7 @@
       (markup 'enumerate)
       (ident (or ident (symbol->string (gensym "enumerate"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:symbol))
       (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
       (body (parse-list-of 'enumerate 'item (the-body opts)))))
@@ -643,6 +664,7 @@
       (markup 'description)
       (ident (or ident (symbol->string (gensym "description"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:symbol))
       (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
       (body (parse-list-of 'description 'item (the-body opts)))))
@@ -660,6 +682,7 @@
 	  (markup 'item)
 	  (ident (or ident (symbol->string (gensym "item"))))
 	  (class class)
+          (loc   &invocation-location)
 	  (required-options '(:key))
 	  (options `((:key ,key) ,@(the-options opts :ident :class :key)))
 	  (body (the-body opts)))))
@@ -711,6 +734,7 @@
 	     (markup 'table)
 	     (ident (or ident (symbol->string (gensym "table"))))
 	     (class class)
+             (loc   &invocation-location)
 	     (required-options '(:width :frame :rules))
 	     (options `((:frame ,frame)
 			(:rules ,rules)
@@ -726,6 +750,7 @@
       (markup 'tr)
       (ident (or ident (symbol->string (gensym "tr"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '())
       (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
 		 ,@(the-options opts :ident :class :bg)))
@@ -767,6 +792,7 @@
 	     (markup 'tc)
 	     (ident (or ident (symbol->string (gensym "tc"))))
 	     (class class)
+             (loc   &invocation-location)
 	     (required-options '(:width :align :valign :colspan))
 	     (options `((markup ,m)
 			(:align ,align)
@@ -824,6 +850,7 @@
 	  (markup 'image)
 	  (ident (or ident (symbol->string (gensym "image"))))
 	  (class class)
+          (loc   &invocation-location)
 	  (required-options '(:file :url :width :height))
 	  (options (the-options opts :ident :class))
 	  (body (the-body opts))))))
@@ -881,6 +908,7 @@
 			   symbol)))))
     (new markup
 	 (markup 'symbol)
+         (loc    &invocation-location)
 	 (body v))))
 
 ;*---------------------------------------------------------------------*/
@@ -890,6 +918,7 @@
    (if (not (string? format))
        (skribe-type-error '! "Illegal format:" format "string")
        (new command
+          (loc &invocation-location)
 	  (fmt format)
 	  (body node))))
 
@@ -915,6 +944,7 @@
        (skribe-error 'processor "Illegal procedure" procedure))
       (else
        (new processor
+          (loc &invocation-location)
 	  (combinator combinator)
 	  (engine engine)
 	  (procedure (or procedure (lambda (n e) n)))
@@ -936,14 +966,17 @@
 	 (section
 	  (error 'handle "Illegal handle `section' option" section)
 	  (new unresolved
+             (loc  &invocation-location)
 	     (proc (lambda (n e env)
 		      (let ((s (resolve-ident section 'section n env)))
 			 (new handle
+                            (loc   &invocation-location)
 			    (ast s)))))))
 	 ((and (pair? body)
 	       (null? (cdr body))
 	       (markup? (car body)))
 	  (new handle
+             (loc &invocation-location)
 	     (ast (car body))))
 	 (else
 	  (skribe-error 'handle "Illegal handle" opts)))))
@@ -961,6 +994,7 @@
       (markup 'mailto)
       (ident (or ident (symbol->string (gensym "ident"))))
       (class class)
+      (loc   &invocation-location)
       (required-options '(:text))
       (options (the-options opts :ident :class))
       (body (the-body opts))))
@@ -995,6 +1029,7 @@
 		       (markup 'mark)
 		       (ident (symbol->string (gensym bs)))
 		       (class class)
+                       (loc   &invocation-location)
 		       (options (the-options opts :ident :class :text))
 		       (body text))))
 	     (hash-set! *mark-table* bs n)
@@ -1037,6 +1072,7 @@
 		   (markup 'unref)
 		   (ident (symbol->string (gensym "unref")))
 		   (class class)
+                   (loc   &invocation-location)
 		   (required-options '(:text))
 		   (options `((kind ,kind) ,@(the-options opts :ident :class)))
 		   (body (list text ": " (ast->file-location ast)))))
@@ -1046,11 +1082,12 @@
 		   (markup 'unref)
 		   (ident (symbol->string (gensym "unref")))
 		   (class class)
+                   (loc   &invocation-location)
 		   (required-options '(:text))
 		   (options `((kind ,kind) ,@(the-options opts :ident :class)))
 		   (body text))))))
    (define (skribe-ref skribe)
-      (let ((path (find-file/path skribe (skribe-path))))
+      (let ((path (search-path (*document-path*) skribe)))
 	 (if (not path)
 	     (unref #f skribe 'sui-file)
 	     (let* ((sui (load-sui path))
@@ -1064,6 +1101,7 @@
 	 (markup 'ref)
 	 (ident (symbol->string (gensym "handle-ref")))
 	 (class class)
+         (loc   &invocation-location)
 	 (required-options '(:text))
 	 (options `((kind handle) ,@(the-options opts :ident :class)))
 	 (body text)))
@@ -1071,6 +1109,7 @@
       (if (not (string? title))
 	  (skribe-type-error 'ref "illegal reference" title "string")
 	  (new unresolved
+             (loc  &invocation-location)
 	     (proc (lambda (n e env)
 		      (let* ((doc (ast-document n))
                              (s (find1-down
@@ -1084,6 +1123,7 @@
 				(markup 'ref)
 				(ident (symbol->string (gensym "title-ref")))
 				(class class)
+                                (loc   &invocation-location)
 				(required-options '(:text))
 				(options `((kind ,kind)
 					   (mark ,title)
@@ -1095,6 +1135,7 @@
       (if (not (string? text))
 	  (skribe-type-error 'ref "Illegal reference" text "string")
 	  (new unresolved
+             (loc  &invocation-location)
 	     (proc (lambda (n e env)
 		      (let ((s (resolve-ident text kind n env)))
 			 (if s
@@ -1102,6 +1143,7 @@
 				(markup 'ref)
 				(ident (symbol->string (gensym "ident-ref")))
 				(class class)
+                                (loc   &invocation-location)
 				(required-options '(:text))
 				(options `((kind ,kind)
 					   (mark ,text)
@@ -1113,6 +1155,7 @@
       (if (not (string? mark))
 	  (skribe-type-error 'mark "Illegal mark, " mark "string")
 	  (new unresolved
+             (loc  &invocation-location)
 	     (proc (lambda (n e env)
 		      (let ((s (hash-ref *mark-table* mark)))
 			 (if s
@@ -1120,6 +1163,7 @@
 				(markup 'ref)
 				(ident (symbol->string (gensym "mark-ref")))
 				(class class)
+                                (loc   &invocation-location)
 				(required-options '(:text))
 				(options `((kind mark)
 					   (mark ,mark)
@@ -1134,6 +1178,7 @@
 			  (markup 'bib-ref)
 			  (ident (symbol->string (gensym "bib-ref")))
 			  (class class)
+                          (loc   &invocation-location)
 			  (required-options '(:text))
 			  (options (the-options opts :ident :class))
 			  (body (new handle
@@ -1150,6 +1195,7 @@
 	     (markup 'bib-ref+)
 	     (ident (symbol->string (gensym "bib-ref+")))
 	     (class class)
+             (loc   &invocation-location)
 	     (options (the-options opts :ident :class))
 	     (body (map make-bib-ref text)))
 	  (make-bib-ref text)))
@@ -1158,10 +1204,12 @@
 	 (markup 'url-ref)
 	 (ident (symbol->string (gensym "url-ref")))
 	 (class class)
+         (loc   &invocation-location)
 	 (required-options '(:url :text))
 	 (options (the-options opts :ident :class))))
    (define (line-ref line)
       (new unresolved
+         (loc   &invocation-location)
 	 (proc  (lambda (n e env)
 		   (let ((l (resolve-line line)))
 		      (if (pair? l)
@@ -1169,6 +1217,7 @@
 			     (markup 'line-ref)
 			     (ident (symbol->string (gensym "line-ref")))
 			     (class class)
+                             (loc   &invocation-location)
 			     (options `((:text ,(markup-ident (car l)))
 					,@(the-options opts :ident :class)))
 			     (body (new handle
@@ -1201,6 +1250,7 @@
                              (separator ".") (class #f))
   ;; Produce a numbered reference to `ident'.
   (new unresolved
+       (loc  &invocation-location)
        (proc (lambda (n e env)
 	       (let* ((parent (ast-parent n))
                       (doc (ast-document n))
@@ -1216,6 +1266,7 @@
                         (markup 'unref)
                         (ident (symbol->string (gensym "unref")))
                         (class class)
+                        (loc   &invocation-location)
                         (required-options '(:text))
                         (options `((kind numref)
                                    ,@(the-options opts :ident :class)))
@@ -1240,6 +1291,7 @@
 ;*---------------------------------------------------------------------*/
 (define-markup (resolve fun)
    (new unresolved
+      (loc  &invocation-location)
       (proc fun)))
 
 ;*---------------------------------------------------------------------*/
@@ -1280,6 +1332,7 @@
 		     "Cound must be either `partial' or `full'"
 		     count)
        (new unresolved
+          (loc  &invocation-location)
 	  (proc (lambda (n e env)
 		   (resolve-the-bib bib-table
 				    (new handle (ast n))
@@ -1333,6 +1386,7 @@
 		  (markup '&index-entry)
 		  (ident (or ident (symbol->string (gensym "index"))))
 		  (class class)
+                  (loc   &invocation-location)
 		  (options `((name ,ename) ,@(the-options opts :ident :class)))
 		  (body (if url
 			    (ref :url url :text (or shape ename))
@@ -1378,6 +1432,7 @@
 			(filter (lambda (o) (not (index? o))) bd)))
 	 (else
 	  (new unresolved
+             (loc  &invocation-location)
 	     (proc (lambda (n e env)
 		      (resolve-the-index (ast-loc n)
 					 ident class
@@ -1394,8 +1449,8 @@
 ;*---------------------------------------------------------------------*/
 ;*    p ...                                                            */
 ;*---------------------------------------------------------------------*/
-(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location)
-   (paragraph :ident ident :class class :loc &skribe-eval-location
+(define-markup (p #!rest opt #!key ident (class #f))
+   (paragraph :ident ident :class class :loc &invocation-location
       (the-body opt)))
 
 ;*---------------------------------------------------------------------*/
@@ -1453,6 +1508,7 @@
 (define-markup (q #!rest opt)
    (new markup
       (markup 'q)
+      (loc &invocation-location)
       (options (the-options opt))
       (body (the-body opt))))
 
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
index af2c906..7ad39d8 100644
--- a/src/guile/skribilo/package/eq.scm
+++ b/src/guile/skribilo/package/eq.scm
@@ -203,6 +203,7 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g.,
        (markup 'eq-display)
        (ident (or ident (symbol->string (gensym "eq-display"))))
        (class class)
+       (loc   &invocation-location)
        (options (the-options opts :ident :class))
        (body (the-body opts))))
 
@@ -214,6 +215,7 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g.,
        (markup 'eq)
        (ident (or ident (symbol->string (gensym "eq"))))
        (class class)
+       (loc   &invocation-location)
        (options `((:div-style ,div-style) (:align-with ,align-with)
                   (:mul-style ,mul-style)
                   ,@(the-options opts
diff --git a/src/guile/skribilo/package/pie.scm b/src/guile/skribilo/package/pie.scm
index 8ccf858..232ef9c 100644
--- a/src/guile/skribilo/package/pie.scm
+++ b/src/guile/skribilo/package/pie.scm
@@ -1,6 +1,6 @@
 ;;; pie.scm  --  An pie-chart formatting package.
 ;;;
-;;; 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
@@ -52,6 +52,7 @@
    (new container
 	(markup 'pie)
 	(ident (or ident (symbol->string (gensym "pie"))))
+        (loc &invocation-location)
 	(options (the-options opts))
 	(body (the-body opts))))
 
@@ -60,6 +61,7 @@
    (new container
 	(markup 'slice)
 	(ident (or ident (symbol->string (gensym "slice"))))
+        (loc &invocation-location)
 	(weight weight)
 	(color color)
 	(detach? detach?)
@@ -71,6 +73,7 @@
    (new markup
 	(markup 'sliceweight)
 	(ident (or ident (symbol->string (gensym "sliceweight"))))
+        (loc &invocation-location)
 	(percentage? percentage?)
 	(options (the-options opts))
 	(body '())))
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index cbcae0b..cb5edda 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -1,7 +1,7 @@
 ;;; slide.scm  --  Overhead transparencies.
 ;;;
 ;;; Copyright 2003, 2004  Manuel Serrano
-;;; Copyright 2006  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2006, 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -68,6 +68,7 @@
 			  (symbol->string (gensym "slide"))
 			  ident))
 	       (class class)
+               (loc   &invocation-location)
 	       (required-options '(:title :number :toc))
 	       (options `((:number
 			   ,(cond
@@ -145,6 +146,7 @@
 ;*---------------------------------------------------------------------*/
 (define-markup (slide-pause)
    (new markup
+      (loc    &invocation-location)
       (markup 'slide-pause)))
 
 ;*---------------------------------------------------------------------*/
@@ -153,6 +155,7 @@
 (define-markup (slide-vspace #!rest opt #!key (unit 'cm))
    (new markup
       (markup 'slide-vspace)
+      (loc &invocation-location)
       (options `((:unit ,unit) ,@(the-options opt :unit)))
       (body (the-body opt))))
 
@@ -174,7 +177,7 @@
 		     command)
        (new markup
 	  (markup 'slide-embed)
-	  (loc &skribe-eval-location)
+          (loc &invocation-location)
 	  (required-options '(:alt))
 	  (options `((:geometry-opt ,geometry-opt)
 		     (:alt ,alt)
@@ -191,6 +194,7 @@
 	  (markup 'slide-record)
 	  (ident ident)
 	  (class class)
+          (loc   &invocation-location)
 	  (options `((:play ,play) ,@(the-options opt)))
 	  (body (the-body opt)))))
 
@@ -204,6 +208,7 @@
 	  (markup 'slide-play)
 	  (ident ident)
 	  (class class)
+          (loc   &invocation-location)
 	  (options `((:color ,(if color (skribe-use-color! color) #f))
 		     ,@(the-options opt :color)))
 	  (body (the-body opt)))))
@@ -223,6 +228,7 @@
 	 (markup 'slide-play*)
 	 (ident ident)
 	 (class class)
+         (loc   &invocation-location)
 	 (options `((:color ,(if color (skribe-use-color! color) #f))
 		    (:scolor ,(if color (skribe-use-color! scolor) #f))
 		    ,@(the-options opt :color :scolor)))
@@ -250,6 +256,7 @@
       (required-options '(:title :outline?))
       (ident (or ident (symbol->string (gensym "slide-topic"))))
       (class class)
+      (loc   &invocation-location)
       (options `((:outline? ,outline?)
                  ,@(the-options opt :outline? :class)))
       (body (the-body opt))))
@@ -265,6 +272,7 @@
       (required-options '(:title :outline?))
       (ident (or ident (symbol->string (gensym "slide-subtopic"))))
       (class class)
+      (loc   &invocation-location)
       (options `((:outline? ,outline?)
                  ,@(the-options opt :outline? :class)))
       (body (the-body opt))))
-- 
cgit v1.2.3