From 8008a4d20f277910d5524e7704db32068010a0a5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Sep 2006 11:43:55 +0000 Subject: Implemented per-document node identifiers. * src/guile/skribilo/ast.scm: Autoload `srfi-1' on `fold'. (*node-table*): Removed. (bind-markup!): Removed. (initialize): Removed. (find-markups): Removed. (write): Commented out debugging `format'. ()[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): New. * src/guile/skribilo/resolve.scm (*document-being-resolved*): New. (resolve!): Invoke `document-bind-nodes!' before resolving the document. (do-resolve!): 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 --- src/guile/skribilo/ast.scm | 98 ++++++++++++++++++++++--------------- src/guile/skribilo/output.scm | 12 ++++- src/guile/skribilo/resolve.scm | 76 ++++++++++++++++------------ src/guile/skribilo/utils/compat.scm | 39 +++++++++++++-- 4 files changed, 151 insertions(+), 74 deletions(-) (limited to 'src') 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-loc ast-loc-set! ast-parent ast->string ast->file-location @@ -35,10 +36,9 @@ node? node-options node-loc node-body processor? processor-combinator processor-engine - markup? bind-markup! markup-options is-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-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. -;;; ====================================================================== ;;; -;;; +;;; Abstract syntax tree (AST). ;;; -;;; ====================================================================== + ;;FIXME: set! location in (define-class () ;; Parent of this guy. @@ -198,29 +195,16 @@ -;;; ====================================================================== ;;; -;;; +;;; Markup. ;;; -;;; ====================================================================== + (define-class () (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 ) initargs) - (next-method) - (bind-markup! self)) - - (define (markup? obj) (is-a? obj )) (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 ) 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. ;;; -;;; ====================================================================== -(define-class ()) + +(define-class () + (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 )) (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 +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI ;;; Copyright 2005, 2006 Ludovic Courtès ;;; ;;; @@ -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 ) e) + ;; Only needed by the compatibility layer. + (parameterize ((*document-being-output* node)) + (next-method))) (define-method (out (node ) 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 -;;; Copyright 2005 Ludovic Courtès +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 Ludovic Courtès ;;; ;;; ;;; 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 ) 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 ) 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 `' 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)) @@ -176,6 +179,34 @@ (%skribe-reader port)) + +;;; +;;; 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. -- cgit v1.2.3