aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/guile/skribilo/ast.scm124
-rw-r--r--src/guile/skribilo/engine.scm7
-rw-r--r--src/guile/skribilo/module.scm7
-rw-r--r--src/guile/skribilo/package/eq.scm2
-rw-r--r--src/guile/skribilo/package/eq/lout.scm2
-rw-r--r--src/guile/skribilo/skribe/Makefile.am2
-rw-r--r--src/guile/skribilo/skribe/utils.scm259
-rw-r--r--src/guile/skribilo/utils/Makefile.am3
-rw-r--r--src/guile/skribilo/utils/keywords.scm99
9 files changed, 236 insertions, 269 deletions
diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm
index ee53f30..fdfecd4 100644
--- a/src/guile/skribilo/ast.scm
+++ b/src/guile/skribilo/ast.scm
@@ -1,6 +1,7 @@
;;; ast.scm -- Skribilo abstract syntax trees.
;;;
;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2003, 2004 Manuel Serrano
;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;;
@@ -47,9 +48,15 @@
container-env-get
<document> document? document-ident document-body
- document-options document-end))
+ document-options document-end
-;;; Author: Ludovic Courtès
+ ;; traversal
+ find-markup-ident
+ container-search-down search-down find-down find1-down
+ find-up find1-up
+ ast-document ast-chapter ast-section))
+
+;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès
;;;
;;; Commentary:
;;;
@@ -365,6 +372,119 @@
(define document-env container-env)
+
+;;;
+;;; AST traversal utilities.
+;;;
+
+
+;; 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
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((container? obj)
+ (let ((rest (loop (markup-body obj))))
+ (if (pred obj)
+ (cons obj rest)
+ rest)))
+ ((pred obj)
+ (list obj))
+ (else
+ '()))))
+
+(define (search-down pred obj)
+ (let loop ((obj (markup-body obj)))
+ (cond
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((markup? obj)
+ (let ((rest (loop (markup-body obj))))
+ (if (pred obj)
+ (cons obj rest)
+ rest)))
+ ((pred obj)
+ (list obj))
+ (else
+ '()))))
+
+(define (find-down pred obj)
+ (let loop ((obj obj))
+ (cond
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((markup? obj)
+ (if (pred obj)
+ (list (cons obj (loop (markup-body obj))))
+ '()))
+ (else
+ (if (pred obj)
+ (list obj)
+ '())))))
+
+(define (find1-down pred obj)
+ (let loop ((obj obj)
+ (stack '()))
+ (cond
+ ((memq obj stack)
+ (skribe-error 'find1-down "Illegal cyclic object" obj))
+ ((pair? obj)
+ (let liip ((obj obj))
+ (cond
+ ((null? obj)
+ #f)
+ (else
+ (or (loop (car obj) (cons obj stack))
+ (liip (cdr obj)))))))
+ ((pred obj)
+ obj)
+ ((markup? obj)
+ (loop (markup-body obj) (cons obj stack)))
+ (else
+ #f))))
+
+(define (find-up pred obj)
+ (let loop ((obj obj)
+ (res '()))
+ (cond
+ ((not (ast? obj))
+ res)
+ ((pred obj)
+ (loop (ast-parent obj) (cons obj res)))
+ (else
+ (loop (ast-parent obj) (cons obj res))))))
+
+(define (find1-up pred obj)
+ (let loop ((obj obj))
+ (cond
+ ((not (ast? obj))
+ #f)
+ ((pred obj)
+ obj)
+ (else
+ (loop (ast-parent obj))))))
+
+(define (ast-document m)
+ (find1-up document? m))
+
+(define (ast-chapter m)
+ (find1-up (lambda (n) (is-markup? n 'chapter)) m))
+
+(define (ast-section m)
+ (find1-up (lambda (n) (is-markup? n 'section)) m))
+
+
;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7
;;; ast.scm ends here
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index 341288c..c422476 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -38,7 +38,7 @@
*current-engine*
default-engine default-engine-set!
make-engine copy-engine find-engine lookup-engine
- engine-custom engine-custom-set!
+ engine-custom engine-custom-set! engine-custom-add!
engine-format? engine-add-writer!
processor-get-engine
push-default-engine pop-default-engine
@@ -302,6 +302,11 @@ otherwise the requested engine is returned."
(set-car! (cdr c) val)
(slot-set! e 'customs (cons (list id val) customs)))))
+(define (engine-custom-add! e id val)
+ (let ((old (engine-custom e id)))
+ (if (unspecified? old)
+ (engine-custom-set! e id (list val))
+ (engine-custom-set! e id (cons val old)))))
(define (engine-add-writer! e ident pred upred opt before action
after class valid)
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 1d716be..6a6301b 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -1,6 +1,6 @@
;;; module.scm -- Integration of Skribe code as Guile modules.
;;;
-;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;;
;;; This program is free software; you can redistribute it and/or modify
@@ -47,10 +47,11 @@
(skribilo utils syntax) ;; `unless', `when', etc.
(skribilo utils compat) ;; `skribe-load-path', etc.
+ (skribilo utils keywords) ;; `the-body', `the-options'
(skribilo module)
(skribilo ast) ;; `<document>', `document?', etc.
(skribilo config)
- (skribilo runtime) ;; `the-options', `the-body', `make-string-replace'
+ (skribilo runtime) ;; `make-string-replace', etc.
(skribilo biblio)
(skribilo lib) ;; `define-markup', `unwind-protect', etc.
(skribilo resolve)
@@ -86,7 +87,7 @@
((ice-9 receive) . (receive))))
(define %skribe-core-modules
- '("utils" "api" "index" "param" "sui"))
+ '("api" "index" "param" "sui"))
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
index 1b0b4aa..1bcdaaa 100644
--- a/src/guile/skribilo/package/eq.scm
+++ b/src/guile/skribilo/package/eq.scm
@@ -26,7 +26,7 @@
:use-module (skribilo lib)
:use-module (skribilo utils syntax)
:use-module (skribilo module)
- :use-module (skribilo skribe utils) ;; `the-options', etc.
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
:autoload (skribilo skribe api) (it symbol sub sup)
:autoload (skribilo engine lout) (lout-illustration)
:use-module (ice-9 optargs))
diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm
index 4de515e..f350f48 100644
--- a/src/guile/skribilo/package/eq/lout.scm
+++ b/src/guile/skribilo/package/eq/lout.scm
@@ -26,7 +26,7 @@
:use-module (skribilo engine)
:use-module (skribilo lib)
:use-module (skribilo utils syntax)
- :use-module (skribilo skribe utils) ;; `the-options', etc.
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
:use-module (ice-9 optargs))
(fluid-set! current-reader %skribilo-module-reader)
diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am
index 5b329b4..ff40489 100644
--- a/src/guile/skribilo/skribe/Makefile.am
+++ b/src/guile/skribilo/skribe/Makefile.am
@@ -1,2 +1,2 @@
guilemoduledir = $(GUILE_SITE)/skribilo/skribe
-dist_guilemodule_DATA = api.scm index.scm param.scm sui.scm utils.scm
+dist_guilemodule_DATA = api.scm index.scm param.scm sui.scm
diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm
deleted file mode 100644
index 9aaa81f..0000000
--- a/src/guile/skribilo/skribe/utils.scm
+++ /dev/null
@@ -1,259 +0,0 @@
-;;; utils.scm
-;;;
-;;; Copyright 2003, 2004 Manuel Serrano
-;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
-;;;
-;;;
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;; USA.
-
-(define-skribe-module (skribilo skribe utils))
-
-;;; Author: Manuel Serrano
-;;; Commentary:
-;;;
-;;; A library of various utilities, including AST traversal helper functions.
-;;;
-;;; Code:
-
-
-;;; The contents of the file below are unchanged compared to Skribe 1.2d's
-;;; `lib.scm' file found in the `common' directory.
-
-;*---------------------------------------------------------------------*/
-;* engine-custom-add! ... */
-;*---------------------------------------------------------------------*/
-(define-public (engine-custom-add! e id val)
- (let ((old (engine-custom e id)))
- (if (unspecified? old)
- (engine-custom-set! e id (list val))
- (engine-custom-set! e id (cons val old)))))
-
-;*---------------------------------------------------------------------*/
-;* find-markup-ident ... */
-;*---------------------------------------------------------------------*/
-(define-public (find-markup-ident ident)
- (let ((r (find-markups ident)))
- (if (or (pair? r) (null? r))
- r
- '())))
-
-;*---------------------------------------------------------------------*/
-;* container-search-down ... */
-;*---------------------------------------------------------------------*/
-(define-public (container-search-down pred obj)
- (with-debug 4 'container-search-down
- (debug-item "obj=" (find-runtime-type obj))
- (let loop ((obj (markup-body obj)))
- (cond
- ((pair? obj)
- (apply append (map (lambda (o) (loop o)) obj)))
- ((container? obj)
- (let ((rest (loop (markup-body obj))))
- (if (pred obj)
- (cons obj rest)
- rest)))
- ((pred obj)
- (list obj))
- (else
- '())))))
-
-;*---------------------------------------------------------------------*/
-;* search-down ... */
-;*---------------------------------------------------------------------*/
-(define-public (search-down pred obj)
- (with-debug 4 'search-down
- (debug-item "obj=" (find-runtime-type obj))
- (let loop ((obj (markup-body obj)))
- (cond
- ((pair? obj)
- (apply append (map (lambda (o) (loop o)) obj)))
- ((markup? obj)
- (let ((rest (loop (markup-body obj))))
- (if (pred obj)
- (cons obj rest)
- rest)))
- ((pred obj)
- (list obj))
- (else
- '())))))
-
-;*---------------------------------------------------------------------*/
-;* find-down ... */
-;*---------------------------------------------------------------------*/
-(define-public (find-down pred obj)
- (with-debug 4 'find-down
- (debug-item "obj=" (find-runtime-type obj))
- (let loop ((obj obj))
- (cond
- ((pair? obj)
- (apply append (map (lambda (o) (loop o)) obj)))
- ((markup? obj)
- (debug-item "loop=" (find-runtime-type obj)
- " " (markup-ident obj))
- (if (pred obj)
- (list (cons obj (loop (markup-body obj))))
- '()))
- (else
- (if (pred obj)
- (list obj)
- '()))))))
-
-;*---------------------------------------------------------------------*/
-;* find1-down ... */
-;*---------------------------------------------------------------------*/
-(define-public (find1-down pred obj)
- (with-debug 4 'find1-down
- (let loop ((obj obj)
- (stack '()))
- (debug-item "obj=" (find-runtime-type obj)
- " " (if (markup? obj) (markup-markup obj) "???")
- " " (if (markup? obj) (markup-ident obj) ""))
- (cond
- ((memq obj stack)
- (skribe-error 'find1-down "Illegal cyclic object" obj))
- ((pair? obj)
- (let liip ((obj obj))
- (cond
- ((null? obj)
- #f)
- (else
- (or (loop (car obj) (cons obj stack))
- (liip (cdr obj)))))))
- ((pred obj)
- obj)
- ((markup? obj)
- (loop (markup-body obj) (cons obj stack)))
- (else
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* find-up ... */
-;*---------------------------------------------------------------------*/
-(define-public (find-up pred obj)
- (let loop ((obj obj)
- (res '()))
- (cond
- ((not (ast? obj))
- res)
- ((pred obj)
- (loop (ast-parent obj) (cons obj res)))
- (else
- (loop (ast-parent obj) (cons obj res))))))
-
-;*---------------------------------------------------------------------*/
-;* find1-up ... */
-;*---------------------------------------------------------------------*/
-(define-public (find1-up pred obj)
- (let loop ((obj obj))
- (cond
- ((not (ast? obj))
- #f)
- ((pred obj)
- obj)
- (else
- (loop (ast-parent obj))))))
-
-;*---------------------------------------------------------------------*/
-;* ast-document ... */
-;*---------------------------------------------------------------------*/
-(define-public (ast-document m)
- (find1-up document? m))
-
-;*---------------------------------------------------------------------*/
-;* ast-chapter ... */
-;*---------------------------------------------------------------------*/
-(define-public (ast-chapter m)
- (find1-up (lambda (n) (is-markup? n 'chapter)) m))
-
-;*---------------------------------------------------------------------*/
-;* ast-section ... */
-;*---------------------------------------------------------------------*/
-(define-public (ast-section m)
- (find1-up (lambda (n) (is-markup? n 'section)) m))
-
-;*---------------------------------------------------------------------*/
-;* the-body ... */
-;* ------------------------------------------------------------- */
-;* Filter out the options */
-;*---------------------------------------------------------------------*/
-(define-public (the-body opt+)
- (let loop ((opt* opt+)
- (res '()))
- (cond
- ((null? opt*)
- (reverse! res))
- ((not (pair? opt*))
- (skribe-error 'the-body "Illegal body" opt*))
- ((keyword? (car opt*))
- (if (null? (cdr opt*))
- (skribe-error 'the-body "Illegal option" (car opt*))
- (loop (cddr opt*) res)))
- (else
- (loop (cdr opt*) (cons (car opt*) res))))))
-
-;*---------------------------------------------------------------------*/
-;* the-options ... */
-;* ------------------------------------------------------------- */
-;* Returns an list made of options. The OUT argument contains */
-;* keywords that are filtered out. */
-;*---------------------------------------------------------------------*/
-(define-public (the-options opt+ . out)
- (let loop ((opt* opt+)
- (res '()))
- (cond
- ((null? opt*)
- (reverse! res))
- ((not (pair? opt*))
- (skribe-error 'the-options "Illegal options" opt*))
- ((keyword? (car opt*))
- (cond
- ((null? (cdr opt*))
- (skribe-error 'the-options "Illegal option" (car opt*)))
- ((memq (car opt*) out)
- (loop (cdr opt*) res))
- (else
- (loop (cdr opt*)
- (cons (list (car opt*) (cadr opt*)) res)))))
- (else
- (loop (cdr opt*) res)))))
-
-;*---------------------------------------------------------------------*/
-;* list-split ... */
-;*---------------------------------------------------------------------*/
-(define-public (list-split l num . fill)
- (let loop ((l l)
- (i 0)
- (acc '())
- (res '()))
- (cond
- ((null? l)
- (reverse! (cons (if (or (null? fill) (= i num))
- (reverse! acc)
- (append! (reverse! acc)
- (make-list (- num i) (car fill))))
- res)))
- ((= i num)
- (loop l
- 0
- '()
- (cons (reverse! acc) res)))
- (else
- (loop (cdr l)
- (+ i 1)
- (cons (car l) acc)
- res)))))
-
-;;; utils.scm ends here
diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am
index fa693a1..8f1d481 100644
--- a/src/guile/skribilo/utils/Makefile.am
+++ b/src/guile/skribilo/utils/Makefile.am
@@ -1,4 +1,5 @@
guilemoduledir = $(GUILE_SITE)/skribilo/utils
-dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm
+dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm \
+ keywords.scm
## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f
diff --git a/src/guile/skribilo/utils/keywords.scm b/src/guile/skribilo/utils/keywords.scm
new file mode 100644
index 0000000..52390a9
--- /dev/null
+++ b/src/guile/skribilo/utils/keywords.scm
@@ -0,0 +1,99 @@
+;;; keywords.scm -- Convenience procedures for keyword-argument handling.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+(define-module (skribilo utils keywords)
+ :export (the-body the-options list-split))
+
+;;; Author: Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides convenience functions to handle keyword arguments.
+;;; These are typically used by markup functions.
+;;;
+;;; Code:
+
+(define (the-body opt+)
+ ;; Filter out the keyword arguments from OPT+.
+ (let loop ((opt* opt+)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-body "Illegal body" opt*))
+ ((keyword? (car opt*))
+ (if (null? (cdr opt*))
+ (skribe-error 'the-body "Illegal option" (car opt*))
+ (loop (cddr opt*) res)))
+ (else
+ (loop (cdr opt*) (cons (car opt*) res))))))
+
+(define (the-options opt+ . out)
+ ;; Return a list made of keyword arguments (i.e., each time, a keyword
+ ;; followed by its associated value). The OUT argument should be a list
+ ;; containing keyword argument names to be filtered out (e.g.,
+ ;; `(#:ident)').
+ (let loop ((opt* opt+)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-options "Illegal options" opt*))
+ ((keyword? (car opt*))
+ (cond
+ ((null? (cdr opt*))
+ (skribe-error 'the-options "Illegal option" (car opt*)))
+ ((memq (car opt*) out)
+ (loop (cdr opt*) res))
+ (else
+ (loop (cdr opt*)
+ (cons (list (car opt*) (cadr opt*)) res)))))
+ (else
+ (loop (cdr opt*) res)))))
+
+(define (list-split l num . fill)
+ (let loop ((l l)
+ (i 0)
+ (acc '())
+ (res '()))
+ (cond
+ ((null? l)
+ (reverse! (cons (if (or (null? fill) (= i num))
+ (reverse! acc)
+ (append! (reverse! acc)
+ (make-list (- num i) (car fill))))
+ res)))
+ ((= i num)
+ (loop l
+ 0
+ '()
+ (cons (reverse! acc) res)))
+ (else
+ (loop (cdr l)
+ (+ i 1)
+ (cons (car l) acc)
+ res)))))
+
+;;; arch-tag: 3e9066d5-6d7d-4da5-922b-cc3d4ba8476e
+
+;;; keywords.scm ends here
generated by cgit v1.2.3 (git 2.47.1) at 2024-12-26 06:04:15 +0000