Initial import of Skribe 1.2d.

Initial import of Skribe 1.2d.


git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0

1 files changed, 281 insertions, 0 deletions

diff --git a/src/bigloo/resolve.scm b/src/bigloo/resolve.scm
new file mode 100644
index 0000000..7507560
--- /dev/null
+++ b/src/bigloo/resolve.scm
@@ -0,0 +1,281 @@
+;*=====================================================================*/
+;*    serrano/prgm/project/skribe/src/bigloo/resolve.scm               */
+;*    -------------------------------------------------------------    */
+;*    Author      :  Manuel Serrano                                    */
+;*    Creation    :  Fri Jul 25 09:31:18 2003                          */
+;*    Last change :  Sun Jul 11 09:17:52 2004 (serrano)                */
+;*    Copyright   :  2003-04 Manuel Serrano                            */
+;*    -------------------------------------------------------------    */
+;*    The Skribe resolve stage                                         */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;*    The module                                                       */
+;*---------------------------------------------------------------------*/
+(module skribe_resolve
+   
+   (include "debug.sch")
+   
+   (import  skribe_types
+	    skribe_lib
+	    skribe_bib
+	    skribe_eval)
+   
+   (import  skribe_index)
+   
+   (export  (resolve! ::obj ::%engine ::pair-nil)
+	    (resolve-children ::obj)
+	    (resolve-children* ::obj)
+	    (resolve-parent ::%ast ::pair-nil)
+	    (resolve-search-parent ::%ast ::pair-nil ::procedure)
+	    (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o)
+	    (resolve-ident ::bstring ::obj ::%ast ::obj)))
+
+;*---------------------------------------------------------------------*/
+;*    *unresolved* ...                                                 */
+;*---------------------------------------------------------------------*/
+(define *unresolved* #f)
+
+;*---------------------------------------------------------------------*/
+;*    resolve! ...                                                     */
+;*    -------------------------------------------------------------    */
+;*    This function iterates over an ast until all unresolved          */
+;*    references are resolved.                                         */
+;*---------------------------------------------------------------------*/
+(define (resolve! ast engine env)
+   (with-debug 3 'resolve
+      (debug-item "ast=" ast)
+      (let ((old *unresolved*))
+	 (let loop ((ast ast))
+	    (set! *unresolved* #f)
+	    (let ((ast (do-resolve! ast engine env)))
+	       (if *unresolved*
+		   (loop ast)
+		   (begin
+		      (set! *unresolved* old)
+		      ast)))))))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve!  ...                                                 */
+;*---------------------------------------------------------------------*/
+(define-generic (do-resolve! ast engine env)
+   (if (pair? ast)
+       (do-resolve*! ast engine env)
+       ast))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve! ::%node ...                                          */
+;*---------------------------------------------------------------------*/
+(define-method (do-resolve! node::%node engine env)
+   (with-access::%node node (body options parent)
+      (with-debug 5 'do-resolve::body 
+	 (debug-item "node=" (if (markup? node)
+				 (markup-markup node)
+				 (find-runtime-type node)))
+	 (debug-item "body=" (find-runtime-type body))
+	 (if (not (eq? parent #unspecified))
+	     node
+	     (let ((p (assq 'parent env)))
+		(set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
+		(if (pair? options)
+		    (begin
+		       (debug-item "unresolved options=" options)
+		       (for-each (lambda (o)
+				    (set-car! (cdr o)
+					      (do-resolve! (cadr o) engine env)))
+				 options)
+		       (debug-item "resolved options=" options)))))
+	 (set! body (do-resolve! body engine env))
+	 node)))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve! ::%container ...                                     */
+;*---------------------------------------------------------------------*/
+(define-method (do-resolve! node::%container engine env0)
+   (with-access::%container node (body options env parent)
+      (with-debug 5 'do-resolve::%container
+	 (debug-item "markup=" (markup-markup node))
+	 (debug-item "body=" (find-runtime-type body))
+	 (debug-item "env0=" env0)
+	 (debug-item "env=" env)
+	 (if (not (eq? parent #unspecified))
+	     node
+	     (let ((p (assq 'parent env0)))
+		(set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
+		(if (pair? options)
+		    (let ((e (append `((parent ,node)) env0)))
+		       (debug-item "unresolved options=" options)
+		       (for-each (lambda (o)
+				    (set-car! (cdr o)
+					      (do-resolve! (cadr o) engine e)))
+				 options)
+		       (debug-item "resolved options=" options)))
+		(let ((e `((parent ,node) ,@env ,@env0)))
+		   (set! body (do-resolve! body engine e))
+		   node))))
+      ;; return the container
+      node))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve! ::%document ...                                      */
+;*---------------------------------------------------------------------*/
+(define-method (do-resolve! node::%document engine env0)
+   (with-access::%document node (env)
+      (call-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))))
+		   (%engine-customs engine)))
+      ;; return the container
+      node))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve! ::%unresolved ...                                    */
+;*---------------------------------------------------------------------*/
+(define-method (do-resolve! node::%unresolved engine env)
+   (with-debug 5 'do-resolve::%unresolved
+      (debug-item "node=" node)
+      (with-access::%unresolved node (proc parent loc)
+	 (let ((p (assq 'parent env)))
+	    (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))))
+	 (let ((res (resolve! (proc node engine env) engine env)))
+	    (if (ast? res) (%ast-loc-set! res loc))
+	    (debug-item "res=" res)
+	    (set! *unresolved* #t)
+	    res))))
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve! ::handle ...                                         */
+;*---------------------------------------------------------------------*/
+(define-method (do-resolve! node::%handle engine env)
+   node)
+
+;*---------------------------------------------------------------------*/
+;*    do-resolve*! ...                                                 */
+;*---------------------------------------------------------------------*/
+(define (do-resolve*! n+ engine env)
+   (let loop ((n* n+))
+      (cond
+	 ((pair? n*)
+	  (set-car! n* (do-resolve! (car n*) engine env))
+	  (loop (cdr n*)))
+	 ((not (null? n*))
+	  (skribe-error 'do-resolve "Illegal argument" n*))
+	 (else
+	  n+))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-children ...                                             */
+;*---------------------------------------------------------------------*/
+(define (resolve-children n)
+   (if (pair? n)
+       n
+       (list n)))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-children* ...                                            */
+;*---------------------------------------------------------------------*/
+(define (resolve-children* n)
+   (cond
+      ((pair? n)
+       (map resolve-children* n))
+      ((%container? n)
+       (cons n (resolve-children* (%container-body n))))
+      (else
+       (list n))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-parent ...                                               */
+;*---------------------------------------------------------------------*/
+(define (resolve-parent n e)
+   (with-debug 5 'resolve-parent
+      (debug-item "n=" n)
+      (cond
+	 ((not (%ast? n))
+	  (let ((c (assq 'parent e)))
+	     (if (pair? c)
+		 (cadr c)
+		 n)))
+	 ((eq? (%ast-parent n) #unspecified)
+	  (skribe-error 'resolve-parent "Orphan node" n))
+	 (else
+	  (%ast-parent n)))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-search-parent ...                                        */
+;*---------------------------------------------------------------------*/
+(define (resolve-search-parent n e pred)
+   (with-debug 5 'resolve-search-parent
+      (debug-item "node=" (find-runtime-type n))
+      (debug-item "searching=" pred)
+      (let ((p (resolve-parent n e)))
+	 (debug-item "parent=" (find-runtime-type p) " "
+		     (if (markup? p) (markup-markup p) "???"))
+	 (cond
+	    ((pred p)
+	     p)
+	    ((%unresolved? p)
+	     p)
+	    ((not p)
+	     #f)
+	    (else
+	     (resolve-search-parent p e pred))))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-counter ...                                              */
+;*---------------------------------------------------------------------*/
+(define (resolve-counter n e cnt val . opt)
+   (let ((c (assq (symbol-append cnt '-counter) e)))
+      (if (not (pair? c))
+	  (if (or (null? opt) (not (car opt)) (null? e))
+	      (skribe-error cnt "Orphan node" n)
+	      (begin
+		 (set-cdr! (last-pair e)
+			   (list (list (symbol-append cnt '-counter) 0)
+				 (list (symbol-append cnt '-env) '())))
+		 (resolve-counter n e cnt val)))
+	  (let* ((num (cadr c))
+		 (nval (if (integer? val)
+			   val
+			   (+ 1 num))))
+	     (let ((c2 (assq (symbol-append cnt '-env) e)))
+		(set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2))))
+	     (cond
+		((integer? val)
+		 (set-car! (cdr c) val)
+		 (car val))
+		((not val)
+		 val)
+		(else
+		 (set-car! (cdr c) (+ 1 num))
+		 (+ 1 num)))))))
+
+;*---------------------------------------------------------------------*/
+;*    resolve-ident ...                                                */
+;*---------------------------------------------------------------------*/
+(define (resolve-ident ident markup n e)
+   (with-debug 4 'resolve-ident
+      (debug-item "ident=" ident)
+      (debug-item "markup=" markup)
+      (debug-item "n=" (if (markup? n) (markup-markup n) n))
+      (if (not (string? ident))
+	  (skribe-type-error 'resolve-ident
+			     "Illegal ident"
+			     ident
+			     "string")
+	  (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)))))))))))