Implemented per-document node identifiers.

* src/guile/skribilo/ast.scm: Autoload `srfi-1' on `fold'.
  (*node-table*): Removed.
  (bind-markup!): Removed.
  (initialize<markup>): Removed.
  (find-markups): Removed.
  (write<markup>): Commented out debugging `format'.
  (<document>)[node-table]: New slot.
  [nodes-bound?]: New slot.
  (document-lookup-node): New.
  (document-bind-node!): New.
  (document-bind-nodes!): New.
  (ast-fold): New.
  (find-markup-ident): Removed.

* src/guile/skribilo/output.scm (*document-being-output*): New.
  (out<document>): New.

* src/guile/skribilo/resolve.scm (*document-being-resolved*): New.
  (resolve!): Invoke `document-bind-nodes!' before resolving the
  document.
  (do-resolve!<document>): Parameterize `*document-being-resolved*'.
  (resolve-ident): Use `document-lookup-node' instead of `find-markups'.

* src/guile/skribilo/utils/compat.scm (bind-markup!): New.
  (find-markups): New.
  (find-markup-ident): New.

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

4 files changed, 151 insertions, 74 deletions

diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm
index f8ee519..e17b2dd 100644
--- a/src/guile/skribilo/ast.scm
+++ b/src/guile/skribilo/ast.scm
@@ -24,6 +24,7 @@
   :use-module (oop goops)
   :autoload (skribilo location) (location?)
   :autoload (skribilo lib) (skribe-type-error skribe-error)
+  :autoload (srfi srfi-1)  (fold)
   :use-module (skribilo utils syntax)
   :export (<ast> ast? ast-loc ast-loc-set!
 		 ast-parent ast->string ast->file-location
@@ -35,10 +36,9 @@
 	   <node> node? node-options node-loc node-body
 	   <processor> processor? processor-combinator processor-engine
 
-	   <markup> markup? bind-markup! markup-options is-markup?
+	   <markup> markup? markup-options is-markup?
 		    markup-markup markup-body markup-body-set!
                     markup-ident markup-class
-		    find-markups
 		    markup-option markup-option-set!
 		    markup-option-add! markup-output
 		    markup-parent markup-document markup-chapter
@@ -49,9 +49,11 @@
 
 	   <document> document? document-ident document-body
 		      document-options document-end
+		      document-lookup-node document-bind-node!
+		      document-bind-nodes!
 
            ;; traversal
-           find-markup-ident
+	   ast-fold
            container-search-down search-down find-down find1-down
            find-up find1-up
            ast-document ast-chapter ast-section))
@@ -68,18 +70,13 @@
 
 (fluid-set! current-reader %skribilo-module-reader)
 
-(define *node-table* (make-hash-table))
-					; Used to stores the nodes of  an AST.
-					; It permits to retrieve a node from its
-					; identifier.
 
 
 
-;;; ======================================================================
 ;;;
-;;;				<AST>
+;;; Abstract syntax tree (AST).
 ;;;
-;;; ======================================================================
+
 ;;FIXME: set! location in <ast>
 (define-class <ast> ()
   ;; Parent of this guy.
@@ -198,29 +195,16 @@
 
 
 
-;;; ======================================================================
 ;;;
-;;;				<MARKUP>
+;;; Markup.
 ;;;
-;;; ======================================================================
+
 (define-class <markup> (<node>)
   (ident  :init-keyword :ident  :getter markup-ident :init-value #f)
   (class  :init-keyword :class  :getter markup-class :init-value #f)
   (markup :init-keyword :markup :getter markup-markup))
 
 
-(define (bind-markup! node)
-  (hash-set! *node-table*
-	     (markup-ident node)
-	     ;(lambda (cur) (cons node cur))
-	     (list node)))
-
-
-(define-method (initialize (self <markup>) initargs)
-  (next-method)
-  (bind-markup! self))
-
-
 (define (markup? obj)		(is-a? obj <markup>))
 (define (markup-options obj)	(slot-ref obj 'options))
 (define markup-body    node-body)
@@ -280,9 +264,6 @@
 
 
 
-(define (find-markups ident)
-  (hash-ref *node-table* ident #f))
-
 
 (define-method (write (obj <markup>) port)
   (format port "#<~A (~A/~A) ~A>"
@@ -299,7 +280,7 @@
 		   (source (procedure-source proc))
 		   (file (and source (source-property source 'filename)))
 		   (line (and source (source-property source 'line))))
-	      (format (current-error-port) "src=~a~%" source)
+	      ;;(format (current-error-port) "src=~a~%" source)
 	      (string-append name
 			     (if file
 				 (string-append " " file
@@ -358,12 +339,15 @@
     (and (pair? c) (cadr c))))
 
 
-;;; ======================================================================
+
 ;;;
-;;;				<DOCUMENT>
+;;; Document.
 ;;;
-;;; ======================================================================
-(define-class <document> (<container>))
+
+(define-class <document> (<container>)
+  (node-table   :init-thunk make-hash-table :getter document-node-table)
+  (nodes-bound? :init-value #f :getter document-nodes-bound?))
+
 
 (define (document? obj)      (is-a? obj <document>))
 (define (document-ident obj) (slot-ref obj 'ident))
@@ -371,24 +355,60 @@
 (define document-options     markup-options)
 (define document-env         container-env)
 
+(define (document-lookup-node doc ident)
+  ;; Lookup the node with identifier IDENT (a string) in document DOC.
+  (hash-ref (document-node-table doc) ident))
+
+(define (document-bind-node! doc node . ident)
+  ;; Bind NODE (a markup object) to DOC (a document object).
+  (let ((ident (if (null? ident) (markup-ident node) (car ident))))
+    (if ident
+	(let ((handle (hash-get-handle (document-node-table doc) ident)))
+	  ;;(format (current-error-port) "binding `~a' in `~a'~%" ident node)
+	  (if (and (pair? handle) (not (eq? (cdr handle) node)))
+	      (error "node identifier already bound"
+		     (cdr handle)) ;; FIXME: use `raise'
+	      (hash-set! (document-node-table doc) ident node))))))
+
+(define (document-bind-nodes! doc)
+  ;; Bind all the nodes contained in DOC if they are not already bound.
+  ;; Once, this is done, `document-lookup-node' can be used to search a node
+  ;; by its identifier.
+
+  ;; We assume that unresolved nodes do not introduce any new identifier,
+  ;; hence this optimization.
+  (if (document-nodes-bound? doc)
+      #t
+      (begin
+	(ast-fold (lambda (node result)
+		    (if (markup? node) (document-bind-node! doc node))
+		    #t)
+		  #t ;; unused
+		  doc)
+	(slot-set! doc 'nodes-bound? #t))))
 
 
 ;;;
 ;;; AST traversal utilities.
 ;;;
 
+(define (ast-fold proc init ast)
+  ;; Apply PROC to each node in AST (per `node?'), in a way similar to `fold'
+  ;; (in SRFI-1).
+  (let loop ((ast ast)
+	     (result init))
+    (cond ((pair? ast)
+	   (fold loop result ast))
+	  ((node? ast)
+	   (loop (node-body ast) (proc ast result)))
+	  (else result))))
+
 
 ;; The procedures below are almost unchanged compared to Skribe 1.2d's
 ;; `lib.scm' file found in the `common' directory, written by Manuel Serrano
 ;; (I removed uses of `with-debug' et al., though).
 
 
-(define (find-markup-ident ident)
-  (let ((r (find-markups ident)))
-    (if (or (pair? r) (null? r))
-        r
-        '())))
-
 (define (container-search-down pred obj)
   (let loop ((obj (markup-body obj)))
     (cond
diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm
index 7a49fd1..a33c040 100644
--- a/src/guile/skribilo/output.scm
+++ b/src/guile/skribilo/output.scm
@@ -1,6 +1,6 @@
 ;;; output.scm  --  Skribilo output stage.
 ;;;
-;;; Copyright 2003-2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2003, 2004  Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;; Copyright 2005, 2006  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
@@ -32,8 +32,10 @@
   :use-module (skribilo condition)
   :use-module (srfi srfi-35)
   :use-module (srfi srfi-34)
+  :use-module (srfi srfi-39)
 
   :export     (output
+	       *document-being-output*
 	       &output-error &output-unresolved-error &output-writer-error
 	       output-error? output-unresolved-error? output-writer-error?))
 
@@ -85,6 +87,10 @@
 ;;; Output method.
 ;;;
 
+;; The document being output.  Note: This is only meant to be used by the
+;; compatibility layer in order to implement things like `find-markups'!
+(define *document-being-output* (make-parameter #f))
+
 (define-generic out)
 
 (define (%out/writer n e w)
@@ -122,6 +128,10 @@
 (define-method (out node e)
   #f)
 
+(define-method (out (node <document>) e)
+  ;; Only needed by the compatibility layer.
+  (parameterize ((*document-being-output* node))
+    (next-method)))
 
 (define-method (out (node <pair>) e)
   (let loop ((n* node))
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 224bc06..c2e2c35 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -1,7 +1,7 @@
 ;;; resolve.scm  --  Skribilo reference resolution.
 ;;;
-;;; 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, 2006  Ludovic Courtès <ludovic.courtes@laas.fr>
 ;;;
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -33,6 +33,7 @@
 
   :export (resolve! resolve-search-parent resolve-children resolve-children*
 	   find1 resolve-counter resolve-parent resolve-ident
+	   *document-being-resolved*
 
            &resolution-error resolution-error?
            &resolution-orphan-error resolution-orphan-error?
@@ -80,6 +81,10 @@
 ;;; Resolving nodes.
 ;;;
 
+;; The document being resolved.  Note: This is only meant to be used by the
+;; compatibility layer in order to implement things like `find-markups'!
+(define *document-being-resolved* (make-parameter #f))
+
 (define *unresolved* (make-parameter #f))
 (define-generic do-resolve!)
 
@@ -95,6 +100,13 @@
 (define (resolve! ast engine env)
   (with-debug 3 'resolve
      (debug-item "ast=" ast)
+
+     (if (document? ast)
+	 ;; Bind nodes prior to resolution so that unresolved nodes can
+	 ;; lookup nodes by identifier using `document-lookup-node' or
+	 ;; `resolve-ident'.
+	 (document-bind-nodes! ast))
+
      (parameterize ((*unresolved* #f))
        (let Loop ((ast ast))
 	 (*unresolved* #f)
@@ -187,16 +199,17 @@
 
 
 (define-method (do-resolve! (node <document>) engine env0)
-  (next-method)
-  ;; resolve the engine custom
-  (let ((env (append `((parent ,node)) env0)))
-    (for-each (lambda (c)
-		(let ((i (car c))
-		      (a (cadr c)))
-		  (debug-item "custom=" i " " a)
-		  (set-car! (cdr c) (do-resolve! a engine env))))
-	      (slot-ref engine 'customs)))
-  node)
+  (parameterize ((*document-being-resolved* node))
+    (next-method)
+    ;; resolve the engine custom
+    (let ((env (append `((parent ,node)) env0)))
+      (for-each (lambda (c)
+		  (let ((i (car c))
+			(a (cadr c)))
+		    (debug-item "custom=" i " " a)
+		    (set-car! (cdr c) (do-resolve! a engine env))))
+		(slot-ref engine 'customs)))
+    node))
 
 
 (define-method (do-resolve! (node <unresolved>) engine env)
@@ -209,7 +222,8 @@
 	    (res  (proc node engine env))
 	    (loc  (ast-loc node)))
        (when (ast? res)
-	 (ast-loc-set! res loc))
+	 (ast-loc-set! res loc)
+	 (slot-set! res 'parent (assq 'parent env)))
        (debug-item "res=" res)
        (*unresolved* #t)
        res)))
@@ -289,12 +303,19 @@
 	     (set-car! (cdr c) (+ 1 num))
 	     (+ 1 num)))))))
 
-;;;; ======================================================================
-;;;;
-;;;; RESOLVE-IDENT
-;;;;
-;;;; ======================================================================
+
+;;;
+;;; `resolve-ident'.
+;;;
+;;; This function kind of sucks because the document where IDENT is to be
+;;; searched is not explictly passed.  Thus, using `document-lookup-node' is
+;;; recommended instead of using this function.
+;;;
+
 (define (resolve-ident ident markup n e)
+  ;; Search for a node with identifier IDENT and markup type MARKUP.  N is
+  ;; typically an `<unresolved>' node and the node lookup should be performed
+  ;; in its parent document.  E is the "environment" (an alist).
   (with-debug 4 'resolve-ident
      (debug-item "ident=" ident)
      (debug-item "markup=" markup)
@@ -303,15 +324,10 @@
          (raise (condition (&invalid-argument-error ;; type error
                             (proc-name "resolve-ident")
                             (argument  ident))))
-	 (let ((mks (find-markups ident)))
-	   (and mks
-		(if (not markup)
-		    (car mks)
-		    (let loop ((mks mks))
-		      (cond
-			((null? mks)
-			 #f)
-			((is-markup? (car mks) markup)
-			 (car mks))
-			(else
-			 (loop (cdr mks)))))))))))
+	 (let* ((doc (ast-document n))
+		(result (and doc (document-lookup-node doc ident))))
+	   (if (or (not markup)
+		   (and (markup? result) (eq? (markup-markup result) markup)))
+	       result
+	       #f)))))
+
diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm
index c8c3bd0..118f294 100644
--- a/src/guile/skribilo/utils/compat.scm
+++ b/src/guile/skribilo/utils/compat.scm
@@ -25,15 +25,18 @@
   :use-module (skribilo parameters)
   :use-module (skribilo evaluator)
   :use-module (srfi srfi-1)
-  :autoload   (srfi srfi-13) (string-rindex)
+  :autoload   (srfi srfi-13)       (string-rindex)
   :use-module (srfi srfi-34)
   :use-module (srfi srfi-35)
   :use-module (ice-9 optargs)
-  :autoload   (skribilo ast) (ast?)
+  :autoload   (skribilo ast)       (ast? document? document-lookup-node)
   :autoload   (skribilo condition) (file-search-error? &file-search-error)
-  :autoload   (skribilo reader) (make-reader)
-  :autoload   (skribilo lib) (type-name)
+  :autoload   (skribilo reader)    (make-reader)
+  :autoload   (skribilo lib)       (type-name)
+  :autoload   (skribilo resolve)   (*document-being-resolved*)
+  :autoload   (skribilo output)    (*document-being-output*)
   :use-module (skribilo debug)
+
   :re-export (file-size)  ;; re-exported from `(skribilo utils files)'
   :replace (gensym))
 
@@ -178,6 +181,34 @@
 
 
 ;;;
+;;; Node lookup (formerly provided by `ast.scm').
+;;;
+
+(define-public (bind-markup! node)
+  (let ((doc (or (*document-being-resolved*)
+		 (*document-being-output*))))
+    (if (document? doc)
+	(document-bind-node! doc node)
+	(error "Sorry, unable to achieve `bind-markup!'.  Use `document-bind-node!' instead."
+	       node))))
+
+(define-public (find-markups ident)
+  (let ((doc (or (*document-being-resolved*)
+		 (*document-being-output*))))
+    (if (document? doc)
+	(let ((result (document-lookup-node doc ident)))
+	  (if result
+	      (list result)
+	      #f))
+	(error "Sorry, unable to achieve `find-markups'.  Use `document-lookup-node' instead."
+	       ident))))
+
+(define-public (find-markup-ident ident)
+  (or (find-markups ident) '()))
+
+
+
+;;;
 ;;; Debugging facilities.
 ;;;