diff options
| -rw-r--r-- | ChangeLog | 40 | ||||
| -rw-r--r-- | src/guile/skribilo/ast.scm | 98 | ||||
| -rw-r--r-- | src/guile/skribilo/output.scm | 12 | ||||
| -rw-r--r-- | src/guile/skribilo/resolve.scm | 76 | ||||
| -rw-r--r-- | src/guile/skribilo/utils/compat.scm | 39 |
5 files changed, 191 insertions, 74 deletions
@@ -2,6 +2,46 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-09-03 11:25:37 GMT Ludovic Courtes <ludovic.courtes@laas.fr> patch-72 + + Summary: + Implemented per-document node identifiers. + Revision: + skribilo--devel--1.2--patch-72 + + * 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. + + modified files: + ChangeLog src/guile/skribilo/ast.scm + src/guile/skribilo/output.scm src/guile/skribilo/resolve.scm + src/guile/skribilo/utils/compat.scm + + 2006-09-03 10:49:42 GMT Ludovic Courtes <ludovic.courtes@laas.fr> patch-71 Summary: 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. ;;; |