summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribilo.scm4
-rw-r--r--src/guile/skribilo/Makefile.am4
-rw-r--r--src/guile/skribilo/ast.scm173
-rw-r--r--src/guile/skribilo/biblio.scm246
-rw-r--r--src/guile/skribilo/biblio/Makefile.am4
-rw-r--r--src/guile/skribilo/biblio/abbrev.scm170
-rw-r--r--src/guile/skribilo/biblio/author.scm136
-rw-r--r--src/guile/skribilo/biblio/bibtex.scm83
-rw-r--r--src/guile/skribilo/color.scm2
-rw-r--r--src/guile/skribilo/coloring/c-lex.l2
-rw-r--r--src/guile/skribilo/coloring/c-lex.l.scm2
-rw-r--r--src/guile/skribilo/coloring/c.scm2
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l2
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l.scm2
-rw-r--r--src/guile/skribilo/coloring/lisp.scm4
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l2
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l.scm2
-rw-r--r--src/guile/skribilo/condition.scm52
-rw-r--r--src/guile/skribilo/debug.scm69
-rw-r--r--src/guile/skribilo/engine.scm11
-rw-r--r--src/guile/skribilo/engine/context.scm2
-rw-r--r--src/guile/skribilo/engine/html.scm61
-rw-r--r--src/guile/skribilo/engine/html4.scm2
-rw-r--r--src/guile/skribilo/engine/lout.scm61
-rw-r--r--src/guile/skribilo/evaluator.scm9
-rw-r--r--src/guile/skribilo/index.scm (renamed from src/guile/skribilo/skribe/index.scm)55
-rw-r--r--src/guile/skribilo/lib.scm52
-rw-r--r--src/guile/skribilo/location.scm2
-rw-r--r--src/guile/skribilo/module.scm12
-rw-r--r--src/guile/skribilo/output.scm83
-rw-r--r--src/guile/skribilo/package/Makefile.am4
-rw-r--r--src/guile/skribilo/package/base.scm (renamed from src/guile/skribilo/skribe/api.scm)184
-rw-r--r--src/guile/skribilo/package/eq.scm122
-rw-r--r--src/guile/skribilo/package/eq/lout.scm122
-rw-r--r--src/guile/skribilo/package/pie.scm314
-rw-r--r--src/guile/skribilo/package/pie/Makefile.am4
-rw-r--r--src/guile/skribilo/package/pie/lout.scm132
-rw-r--r--src/guile/skribilo/package/slide.scm2
-rw-r--r--src/guile/skribilo/package/slide/html.scm2
-rw-r--r--src/guile/skribilo/package/slide/latex.scm2
-rw-r--r--src/guile/skribilo/package/slide/lout.scm2
-rw-r--r--src/guile/skribilo/package/web-book.scm29
-rw-r--r--src/guile/skribilo/parameters.scm2
-rw-r--r--src/guile/skribilo/prog.scm2
-rw-r--r--src/guile/skribilo/reader.scm2
-rw-r--r--src/guile/skribilo/reader/outline.scm6
-rw-r--r--src/guile/skribilo/reader/skribe.scm25
-rw-r--r--src/guile/skribilo/resolve.scm67
-rw-r--r--src/guile/skribilo/skribe/Makefile.am2
-rw-r--r--src/guile/skribilo/skribe/bib.scm215
-rw-r--r--src/guile/skribilo/skribe/param.scm2
-rw-r--r--src/guile/skribilo/skribe/sui.scm2
-rw-r--r--src/guile/skribilo/skribe/utils.scm259
-rw-r--r--src/guile/skribilo/source.scm2
-rw-r--r--src/guile/skribilo/utils/Makefile.am3
-rw-r--r--src/guile/skribilo/utils/compat.scm32
-rw-r--r--src/guile/skribilo/utils/files.scm2
-rw-r--r--src/guile/skribilo/utils/images.scm2
-rw-r--r--src/guile/skribilo/utils/keywords.scm99
-rw-r--r--src/guile/skribilo/utils/strings.scm (renamed from src/guile/skribilo/runtime.scm)45
-rw-r--r--src/guile/skribilo/utils/syntax.scm36
-rw-r--r--src/guile/skribilo/verify.scm5
-rw-r--r--src/guile/skribilo/writer.scm2
-rwxr-xr-xsrc/skribilo.in9
64 files changed, 2114 insertions, 937 deletions
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index dbaa368..53afa89 100644
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -22,7 +22,7 @@ exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;; Commentary:
@@ -464,6 +464,8 @@ Processes a Skribilo/Skribe source file and produces its output.
(open-output-file output-file)
(current-output-port))))
+ (setvbuf (*skribilo-output-port*) _IOFBF 16384)
+
;; (start-stack 7
(if source-file
(with-input-from-file source-file doskribe)
diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am
index 6689d15..8de8774 100644
--- a/src/guile/skribilo/Makefile.am
+++ b/src/guile/skribilo/Makefile.am
@@ -2,9 +2,9 @@ guilemoduledir = $(GUILE_SITE)/skribilo
dist_guilemodule_DATA = biblio.scm color.scm config.scm \
debug.scm engine.scm evaluator.scm \
lib.scm module.scm output.scm prog.scm \
- reader.scm resolve.scm runtime.scm \
+ reader.scm resolve.scm \
source.scm parameters.scm verify.scm \
writer.scm ast.scm location.scm \
condition.scm
-SUBDIRS = utils reader engine package skribe coloring
+SUBDIRS = utils reader engine package skribe coloring biblio
diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm
index 3968b18..f8ee519 100644
--- a/src/guile/skribilo/ast.scm
+++ b/src/guile/skribilo/ast.scm
@@ -1,7 +1,8 @@
;;; ast.scm -- Skribilo abstract syntax trees.
;;;
-;;; 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 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;;
;;; This program is free software; you can redistribute it and/or modify
@@ -16,12 +17,13 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo ast)
:use-module (oop goops)
:autoload (skribilo location) (location?)
+ :autoload (skribilo lib) (skribe-type-error skribe-error)
:use-module (skribilo utils syntax)
:export (<ast> ast? ast-loc ast-loc-set!
ast-parent ast->string ast->file-location
@@ -34,9 +36,11 @@
<processor> processor? processor-combinator processor-engine
<markup> markup? bind-markup! markup-options is-markup?
- markup-markup markup-body markup-ident markup-class
+ markup-markup markup-body markup-body-set!
+ markup-ident markup-class
find-markups
- markup-option markup-option-add! markup-output
+ markup-option markup-option-set!
+ markup-option-add! markup-output
markup-parent markup-document markup-chapter
<container> container? container-options
@@ -44,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:
;;;
@@ -214,6 +224,9 @@
(define (markup? obj) (is-a? obj <markup>))
(define (markup-options obj) (slot-ref obj 'options))
(define markup-body node-body)
+(define (markup-body-set! m body)
+ (slot-set! m 'resolved? #f)
+ (slot-set! m 'body body))
(define (markup-option m opt)
(if (markup? m)
@@ -222,6 +235,14 @@
(cadr c)))
(skribe-type-error 'markup-option "Illegal markup: " m "markup")))
+(define (markup-option-set! m opt val)
+ (if (markup? m)
+ (let ((c (assq opt (slot-ref m 'options))))
+ (if (and (pair? c) (pair? (cdr c)))
+ (set-cdr! c (list val))
+ (skribe-error 'markup-option-set! "unknown option: "
+ m)))
+ (skribe-type-error 'markup-option-set! "Illegal markup: " m "markup")))
(define (markup-option-add! m opt val)
(if (markup? m)
@@ -263,12 +284,31 @@
(hash-ref *node-table* ident #f))
-(define-method (write-object (obj <markup>) port)
- (format port "#[~A (~A/~A) ~A]"
+(define-method (write (obj <markup>) port)
+ (format port "#<~A (~A/~A) ~A>"
(class-name (class-of obj))
(slot-ref obj 'markup)
(slot-ref obj 'ident)
- (address-of obj)))
+ (object-address obj)))
+
+(define-method (write (node <unresolved>) port)
+ (let ((proc (slot-ref node 'proc)))
+ (format port "#<<unresolved> (~A~A) ~A>"
+ proc
+ (let* ((name (or (procedure-name proc) ""))
+ (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)
+ (string-append name
+ (if file
+ (string-append " " file
+ (if line
+ (number->string line)
+ ""))
+ "")))
+ (object-address node))))
+
;;; XXX: This was already commented out in the original Skribe source.
@@ -332,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/biblio.scm b/src/guile/skribilo/biblio.scm
index 082fb99..e5ab6e3 100644
--- a/src/guile/skribilo/biblio.scm
+++ b/src/guile/skribilo/biblio.scm
@@ -1,7 +1,7 @@
;;; biblio.scm -- Bibliography functions.
;;;
-;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2005, 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
@@ -15,27 +15,46 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.main.st
(define-module (skribilo biblio)
- :use-module (skribilo runtime)
+ :use-module (skribilo utils strings)
:use-module (skribilo utils syntax) ;; `when', `unless'
- :use-module (skribilo module)
- :use-module (skribilo skribe bib) ;; `make-bib-entry'
- :autoload (srfi srfi-34) (raise)
+ :autoload (srfi srfi-34) (raise)
:use-module (srfi srfi-35)
- :autoload (skribilo condition) (&file-search-error)
+ :use-module (srfi srfi-1)
+ :autoload (skribilo condition) (&file-search-error)
:autoload (skribilo reader) (%default-reader)
:autoload (skribilo parameters) (*bib-path*)
- :autoload (ice-9 format) (format)
+ :autoload (skribilo ast) (<markup> <handle>)
+
+ :use-module (ice-9 optargs)
+ :use-module (oop goops)
+
:export (bib-table? make-bib-table default-bib-table
- bib-add! bib-duplicate
- skribe-open-bib-file parse-bib))
+ bib-add! bib-duplicate bib-for-each bib-map
+ skribe-open-bib-file parse-bib
+
+ bib-load! resolve-bib resolve-the-bib make-bib-entry
+
+ ;; sorting entries
+ bib-sort/authors bib-sort/idents bib-sort/dates))
+
+;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Provides the bibliography data type and basic bibliography handling,
+;;; including simple procedures to sort bibliography entries.
+;;;
+;;; FIXME: This module need cleanup!
+;;;
+;;; Code:
(fluid-set! current-reader %skribilo-module-reader)
@@ -66,15 +85,23 @@
(set! *bib-table* (make-bib-table "default-bib-table")))
*bib-table*)
-;;
-;; Utilities
-;;
(define (%bib-error who entry)
(let ((msg "bibliography syntax error on entry"))
(if (%epair? entry)
(skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry)
(skribe-error who msg entry))))
+(define* (bib-for-each proc :optional (table (default-bib-table)))
+ (hash-for-each (lambda (ident entry)
+ (proc ident entry))
+ table))
+
+(define* (bib-map proc :optional (table (default-bib-table)))
+ (hash-map->list (lambda (ident entry)
+ (proc ident entry))
+ table))
+
+
;;; ======================================================================
;;;
;;; BIB-DUPLICATE
@@ -162,3 +189,194 @@
path)))
(raise (condition (&file-search-error (file-name file)
(path (*bib-path*))))))))
+
+
+;;;
+;;; High-level API.
+;;;
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `bib.scm' file found in the `common' directory. The copyright notice for
+;;; this file was:
+;;;
+;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano
+;;;
+
+
+;*---------------------------------------------------------------------*/
+;* bib-load! ... */
+;*---------------------------------------------------------------------*/
+(define (bib-load! table filename command)
+ (if (not (bib-table? table))
+ (skribe-error 'bib-load "Illegal bibliography table" table)
+ ;; read the file
+ (let ((p (skribe-open-bib-file filename command)))
+ (if (not (input-port? p))
+ (skribe-error 'bib-load "Can't open data base" filename)
+ (unwind-protect
+ (parse-bib table p)
+ (close-input-port p))))))
+
+;*---------------------------------------------------------------------*/
+;* resolve-bib ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-bib table ident)
+ (if (not (bib-table? table))
+ (skribe-error 'resolve-bib "Illegal bibliography table" table)
+ (let* ((i (cond
+ ((string? ident) ident)
+ ((symbol? ident) (symbol->string ident))
+ (else (skribe-error 'resolve-bib "Illegal ident" ident))))
+ (en (hash-ref table i)))
+ (if (is-markup? en '&bib-entry)
+ en
+ #f))))
+
+;*---------------------------------------------------------------------*/
+;* make-bib-entry ... */
+;*---------------------------------------------------------------------*/
+(define (make-bib-entry kind ident fields from)
+ (let* ((m (make <markup>
+ :markup '&bib-entry
+ :ident ident
+ :options `((kind ,kind) (from ,from))))
+ (h (make <handle> :ast m)))
+ (for-each (lambda (f)
+ (if (and (pair? f)
+ (pair? (cdr f))
+ (null? (cddr f))
+ (symbol? (car f)))
+ (markup-option-add! m
+ (car f)
+ (make <markup>
+ :markup (symbol-append
+ '&bib-entry-
+ (car f))
+ :parent h
+ :body (cadr f)))
+ (bib-parse-error f)))
+ fields)
+ m))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/authors ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/authors l)
+ (define (cmp i1 i2 def)
+ (cond
+ ((and (markup? i1) (markup? i2))
+ (cmp (markup-body i1) (markup-body i2) def))
+ ((markup? i1)
+ (cmp (markup-body i1) i2 def))
+ ((markup? i2)
+ (cmp i1 (markup-body i2) def))
+ ((and (string? i1) (string? i2))
+ (if (string=? i1 i2)
+ (def)
+ (string<? i1 i2)))
+ ((string? i1)
+ #f)
+ ((string? i2)
+ #t)
+ (else
+ (def))))
+ (sort l (lambda (e1 e2)
+ (cmp (markup-option e1 'author)
+ (markup-option e2 'author)
+ (lambda ()
+ (cmp (markup-option e1 'year)
+ (markup-option e2 'year)
+ (lambda ()
+ (cmp (markup-option e1 'title)
+ (markup-option e2 'title)
+ (lambda ()
+ (cmp (markup-ident e1)
+ (markup-ident e2)
+ (lambda ()
+ #t)))))))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/idents ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/idents l)
+ (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f)))))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/dates ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/dates l)
+ (sort l (lambda (p1 p2)
+ (define (month-num m)
+ (let ((body (markup-body m)))
+ (if (not (string? body))
+ 13
+ (let* ((s (if (> (string-length body) 3)
+ (substring body 0 3)
+ body))
+ (sy (string->symbol (string-downcase body)))
+ (c (assq sy '((jan . 1)
+ (feb . 2)
+ (mar . 3)
+ (apr . 4)
+ (may . 5)
+ (jun . 6)
+ (jul . 7)
+ (aug . 8)
+ (sep . 9)
+ (oct . 10)
+ (nov . 11)
+ (dec . 12)))))
+ (if (pair? c) (cdr c) 13)))))
+ (let ((d1 (markup-option p1 'year))
+ (d2 (markup-option p2 'year)))
+ (cond
+ ((not (markup? d1)) #f)
+ ((not (markup? d2)) #t)
+ (else
+ (let ((y1 (markup-body d1))
+ (y2 (markup-body d2)))
+ (cond
+ ((string>? y1 y2) #t)
+ ((string<? y1 y2) #f)
+ (else
+ (let ((d1 (markup-option p1 'month))
+ (d2 (markup-option p2 'month)))
+ (cond
+ ((not (markup? d1)) #f)
+ ((not (markup? d2)) #t)
+ (else
+ (let ((m1 (month-num d1))
+ (m2 (month-num d2)))
+ (> m1 m2))))))))))))))
+
+;*---------------------------------------------------------------------*/
+;* resolve-the-bib ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-the-bib table n sort pred count opts)
+ (define (count! entries)
+ (let loop ((es entries)
+ (i 1))
+ (if (pair? es)
+ (begin
+ (markup-option-add! (car es)
+ :title
+ (make <markup>
+ :markup '&bib-entry-ident
+ :parent (car es)
+ :options `((number ,i))
+ :body (make <handle> :ast (car es))))
+ (loop (cdr es) (+ i 1))))))
+ (if (not (bib-table? table))
+ (skribe-error 'resolve-the-bib "Illegal bibliography table" table)
+ (let* ((es (sort (hash-map->list (lambda (key val) val) table)))
+ (fes (filter (if (procedure? pred)
+ (lambda (m) (pred m n))
+ (lambda (m) (pair? (markup-option m 'used))))
+ es)))
+ (count! (if (eq? count 'full) es fes))
+ (make <markup>
+ :markup '&the-bibliography
+ :options opts
+ :body fes))))
+
+
+;;; biblio.scm ends here
diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am
new file mode 100644
index 0000000..9442562
--- /dev/null
+++ b/src/guile/skribilo/biblio/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/biblio
+dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm
+
+## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657
diff --git a/src/guile/skribilo/biblio/abbrev.scm b/src/guile/skribilo/biblio/abbrev.scm
new file mode 100644
index 0000000..9c88b6a
--- /dev/null
+++ b/src/guile/skribilo/biblio/abbrev.scm
@@ -0,0 +1,170 @@
+;;; abbrev.scm -- Determining abbreviations.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo biblio abbrev)
+ :use-module (srfi srfi-13)
+ :autoload (skribilo ast) (markup? markup-body-set!)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :autoload (ice-9 regex) (regexp-substitute/global)
+ :export (is-abbreviation? is-acronym? abbreviate-word
+ abbreviate-string abbreviate-markup
+
+ %cs-conference-abbreviations
+ %ordinal-number-abbreviations
+ %common-booktitle-abbreviations))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to identify or generate abbreviations. This module
+;;; particularly targets booktitle abbreviations (in bibliography entries).
+;;;
+;;; Code:
+
+(define (is-abbreviation? str)
+ ;; Return #t if STR denotes an abbreviation or name initial.
+ (and (>= (string-length str) 2)
+ (char=? (string-ref str 1) #\.)))
+
+(define (is-acronym? str)
+ (string=? str (string-upcase str)))
+
+(define (abbreviate-word word)
+ (if (or (string=? "" word)
+ (and (>= (string-length word) 3)
+ (string=? "and" (substring word 0 3)))
+ (is-acronym? word))
+ word
+ (let ((dash (string-index word #\-))
+ (abbr (string (string-ref word 0) #\.)))
+ (if (not dash)
+ abbr
+ (string-append (string (string-ref word 0)) "-"
+ (abbreviate-word
+ (substring word (+ 1 dash)
+ (string-length word))))))))
+
+(define (abbreviate-string subst title)
+ ;; Abbreviate common conference names within TITLE based on the SUBST list
+ ;; of regexp-substitution pairs (see examples below). This function also
+ ;; removes the abbreviation if it appears in parentheses right after the
+ ;; substitution regexp. Example:
+ ;;
+ ;; "Symposium on Operating Systems Principles (SOSP 2004)"
+ ;;
+ ;; yields
+ ;;
+ ;; "SOSP"
+ ;;
+ (let loop ((title title)
+ (subst subst))
+ (if (null? subst)
+ title
+ (let* ((abbr (cdar subst))
+ (abbr-rexp (string-append "( \\(" abbr "[^\\)]*\\))?"))
+ (to-replace (string-append (caar subst) abbr-rexp)))
+ (loop (regexp-substitute/global #f to-replace title
+ 'pre abbr 'post)
+ (cdr subst))))))
+
+(define (abbreviate-markup subst markup)
+ ;; A version of `abbreviate-string' generalized to arbitrary markup
+ ;; objects.
+ (let loop ((markup markup))
+ (cond ((string? markup)
+ (let ((purify (make-string-replace '((#\newline " ")
+ (#\tab " ")))))
+ (abbreviate-string subst (purify markup))))
+ ((list? markup)
+ (map loop markup))
+ ((markup? markup)
+ (markup-body-set! markup (loop (markup-body title)))
+ markup)
+ (else markup))))
+
+
+;;;
+;;; Common English abbreviations.
+;;;
+
+;; The following abbreviation alists may be passed to `abbreviate-string'
+;; and `abbreviate-markup'.
+
+(define %cs-conference-abbreviations
+ ;; Common computer science conferences and their acronym.
+ '(("(Symposium [oO]n )?Operating Systems? Design and [iI]mplementation"
+ . "OSDI")
+ ("(Symposium [oO]n )?Operating Systems? Principles"
+ . "SOSP")
+ ("([wW]orkshop [oO]n )?Hot Topics [iI]n Operating Systems"
+ . "HotOS")
+ ("([cC]onference [oO]n )?[fF]ile [aA]nd [sS]torage [tT]echnologies"
+ . "FAST")
+ ("([tT]he )?([iI]nternational )?[cC]onference [oO]n [aA]rchitectural Support [fF]or Programming Languages [aA]nd Operating Systems"
+ . "ASPLOS")
+ ("([tT]he )?([iI]nternational )?[cC]onference [oO]n Peer-[tT]o-[pP]eer Computing"
+ . "P2P")
+ ("([iI]nternational )?[cC]onference [oO]n [dD]ata [eE]ngineering"
+ . "ICDE")
+ ("([cC]onference [oO]n )?[mM]ass [sS]torage [sS]ystems( [aA]nd [tT]echnologies)?"
+ . "MSS")
+ ("([sS]ymposium [oO]n )?[nN]etworked [sS]ystems [dD]esign [aA]nd [Ii]mplementation"
+ . "NSDI")))
+
+
+(define %ordinal-number-abbreviations
+ ;; The poor man's abbreviation system.
+
+ ;; FIXME: Given the current `abbreviate-string', there is no clean way to
+ ;; make it ignore things like "twenty-first" (instead of yielding an awful
+ ;; "twenty-1st").
+ '(("[Ff]irst" . "1st")
+ ("[sS]econd" . "2nd")
+ ("[Tt]hird" . "3rd")
+ ("[Ff]ourth" . "4th")
+ ("[Ff]ifth" . "5th")
+ ("[Ss]ixth" . "6th")
+ ("[Ss]eventh" . "7th")
+ ("[eE]ighth" . "8th")
+ ("[Nn]inth" . "9th")
+ ("[Tt]enth" . "10th")
+ ("[Ee]leventh" . "11th")
+ ("[Tt]welfth" . "12th")
+ ("[Tt]hirteenth" . "13th")
+ ("[Ff]ourteenth" . "14th")
+ ("[Ff]ifteenth" . "15th")
+ ("[Ss]ixteenth" . "16th")
+ ("[Ss]eventeenth" . "17th")
+ ("[Ee]ighteenth" . "18th")
+ ("[Nn]ineteenth" . "19th")))
+
+(define %common-booktitle-abbreviations
+ ;; Common book title abbreviations. This is used by
+ ;; `abbreviate-booktitle'.
+ '(("[pP]roceedings?" . "Proc.")
+ ("[iI]nternational" . "Int.")
+ ("[sS]ymposium" . "Symp.")
+ ("[cC]onference" . "Conf.")))
+
+
+;;; arch-tag: 34e0c5bb-592f-467b-b59a-d6f7d130ae4e
+
+;;; abbrev.scm ends here
diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm
new file mode 100644
index 0000000..ea15f4c
--- /dev/null
+++ b/src/guile/skribilo/biblio/author.scm
@@ -0,0 +1,136 @@
+;;; author.scm -- Handling author names.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo biblio author)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (skribilo biblio abbrev)
+ :autoload (skribilo ast) (markup-option markup-body markup-ident)
+ :autoload (skribilo lib) (skribe-error)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :export (comma-separated->author-list
+ comma-separated->and-separated-authors
+
+ extract-first-author-name
+ abbreviate-author-first-names
+ abbreviate-first-names
+ first-author-last-name
+
+ bib-sort/first-author-last-name))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to manipulate author names as strings.
+;;;
+;;; Code:
+
+(define (comma-separated->author-list authors)
+ ;; Return a list of strings where each individual string is an author
+ ;; name. AUTHORS is a string representing a list of author names separated
+ ;; by a comma.
+
+ ;; XXX: I should use SRFI-13 instead.
+ (string-split authors #\,))
+
+(define (comma-separated->and-separated-authors authors)
+ ;; Take AUTHORS, a string containing comma-separated author names, and
+ ;; return a string where author names are separated by " and " (suitable
+ ;; for BibTeX).
+ (string-join (comma-separated->author-list authors)
+ " and " 'infix))
+
+
+(define (extract-first-author-name names)
+ ;; Extract the name of the first author from string
+ ;; NAMES that is a comma-separated list of authors.
+ (let ((author-name-end (or (string-index names #\,)
+ (string-length names))))
+ (substring names 0 author-name-end)))
+
+(define (abbreviate-author-first-names name)
+ ;; Abbreviate author first names
+ (let* ((components (string-split name #\space))
+ (component-number (length components)))
+ (apply string-append
+ (append
+ (map (lambda (c)
+ (string-append (abbreviate-word c) " "))
+ (list-head components
+ (- component-number 1)))
+ (list-tail components (- component-number 1))))))
+
+(define (abbreviate-first-names names)
+ ;; Abbreviate first names in NAMES. NAMES is supposed to be
+ ;; something like "Ludovic Courtès, Marc-Olivier Killijian".
+ (let loop ((names ((make-string-replace '((#\newline " ")
+ (#\tab " ")))
+ names))
+ (result ""))
+ (if (string=? names "")
+ result
+ (let* ((len (string-length names))
+ (first-author-names-end (or (string-index names #\,)
+ len))
+ (first-author-names (substring names 0
+ first-author-names-end))
+ (next (substring names
+ (min (+ 1 first-author-names-end) len)
+ len)))
+ (loop next
+ (string-append result
+ (if (string=? "" result) "" ", ")
+ (abbreviate-author-first-names
+ first-author-names)))))))
+
+
+(define (first-author-last-name authors)
+ ;; Return a string containing exactly the last name of the first author.
+ ;; Author names in AUTHORS are assumed to be comma separated.
+ (let loop ((first-author (extract-first-author-name authors)))
+ (let ((space (string-index first-author #\space)))
+ (if (not space)
+ first-author
+ (loop (substring first-author (+ space 1)
+ (string-length first-author)))))))
+
+(define (bib-sort/first-author-last-name entries)
+ ;; May be passed as the `:sort' argument of `the-bibliography'.
+ (let ((check-author (lambda (e)
+ (if (not (markup-option e 'author))
+ (skribe-error 'web
+ "No author for this bib entry"
+ (markup-ident e))
+ #t))))
+ (sort entries
+ (lambda (e1 e2)
+ (let* ((x1 (check-author e1))
+ (x2 (check-author e2))
+ (a1 (first-author-last-name
+ (markup-body (markup-option e1 'author))))
+ (a2 (first-author-last-name
+ (markup-body (markup-option e2 'author)))))
+ (string-ci<=? a1 a2))))))
+
+
+;;; arch-tag: c9a1ef10-a2cd-4a06-bd35-fbdee1abf09a
+
+;;; author.scm ends here
diff --git a/src/guile/skribilo/biblio/bibtex.scm b/src/guile/skribilo/biblio/bibtex.scm
new file mode 100644
index 0000000..319df1d
--- /dev/null
+++ b/src/guile/skribilo/biblio/bibtex.scm
@@ -0,0 +1,83 @@
+;;; bibtex.scm -- Handling BibTeX references.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo biblio bibtex)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :autoload (skribilo ast) (markup-option ast->string)
+ :autoload (skribilo engine) (engine-filter find-engine)
+ :use-module (skribilo biblio author)
+ :use-module (srfi srfi-39)
+ :export (print-as-bibtex-entry))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; A set of BibTeX tools, e.g., issuing a BibTeX entry from a `&bib-entry'
+;;; markup object.
+;;;
+;;; Code:
+
+(define *bibtex-author-filter*
+ ;; Defines how the `author' field is to be filtered.
+ (make-parameter comma-separated->and-separated-authors))
+
+(define (print-as-bibtex-entry entry)
+ "Display @code{&bib-entry} object @var{entry} as a BibTeX entry."
+ (let ((show-option (lambda (opt)
+ (let* ((o (markup-option entry opt))
+ (f (make-string-replace '((#\newline " "))))
+ (g (if (eq? opt 'author)
+ (lambda (a)
+ ((*bibtex-author-filter*) (f a)))
+ f)))
+ (if (not o)
+ #f
+ `(,(symbol->string opt)
+ " = \""
+ ,(g (ast->string (markup-body o)))
+ "\","))))))
+ (format #t "@~a{~a,~%"
+ (markup-option entry 'kind)
+ (markup-ident entry))
+ (for-each (lambda (opt)
+ (let* ((o (show-option opt))
+ (tex-filter (engine-filter
+ (find-engine 'latex)))
+ (filter (lambda (n)
+ (tex-filter (ast->string n))))
+ (id (lambda (a) a)))
+ (if o
+ (display
+ (apply string-append
+ `(,@(map (if (eq? 'url opt)
+ id filter)
+ (cons " " o))
+ "\n"))))))
+ '(author institution title
+ booktitle journal number
+ year month url pages address publisher))
+ (display "}\n")))
+
+
+;;; arch-tag: 8b5913cc-9077-4e92-839e-c4c633b7bd46
+
+;;; bibtex.scm ends here
diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm
index d2ba1d4..8b6205f 100644
--- a/src/guile/skribilo/color.scm
+++ b/src/guile/skribilo/color.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l
index a5b337e..7d7b1ce 100644
--- a/src/guile/skribilo/coloring/c-lex.l
+++ b/src/guile/skribilo/coloring/c-lex.l
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm
index c9129cf..d78e09e 100644
--- a/src/guile/skribilo/coloring/c-lex.l.scm
+++ b/src/guile/skribilo/coloring/c-lex.l.scm
@@ -14,7 +14,7 @@
;
; 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.
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;
; Gestion des Input Systems
diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm
index baa3e53..d2a2b9f 100644
--- a/src/guile/skribilo/coloring/c.scm
+++ b/src/guile/skribilo/coloring/c.scm
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l
index c4db526..30b6a44 100644
--- a/src/guile/skribilo/coloring/lisp-lex.l
+++ b/src/guile/skribilo/coloring/lisp-lex.l
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm
index b5db4e8..6ae7fe6 100644
--- a/src/guile/skribilo/coloring/lisp-lex.l.scm
+++ b/src/guile/skribilo/coloring/lisp-lex.l.scm
@@ -14,7 +14,7 @@
;
; 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.
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;
; Gestion des Input Systems
diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm
index e3458b1..13bb6db 100644
--- a/src/guile/skribilo/coloring/lisp.scm
+++ b/src/guile/skribilo/coloring/lisp.scm
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
@@ -24,7 +24,7 @@
:use-module (skribilo utils syntax)
:use-module (skribilo source)
:use-module (skribilo lib)
- :use-module (skribilo runtime)
+ :use-module (skribilo utils strings)
:use-module (srfi srfi-39)
:use-module (ice-9 match)
:autoload (ice-9 regex) (make-regexp)
diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l
index 5d9a8d9..aa7d312 100644
--- a/src/guile/skribilo/coloring/xml-lex.l
+++ b/src/guile/skribilo/coloring/xml-lex.l
@@ -17,7 +17,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm
index 0e3fe05..d58e42b 100644
--- a/src/guile/skribilo/coloring/xml-lex.l.scm
+++ b/src/guile/skribilo/coloring/xml-lex.l.scm
@@ -14,7 +14,7 @@
;
; 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.
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;
; Gestion des Input Systems
diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm
index 820dcc5..4d61efb 100644
--- a/src/guile/skribilo/condition.scm
+++ b/src/guile/skribilo/condition.scm
@@ -15,20 +15,26 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo condition)
+ :autoload (srfi srfi-1) (find)
:autoload (srfi srfi-34) (guard)
:use-module (srfi srfi-35)
:use-module (srfi srfi-39)
:export (&skribilo-error skribilo-error?
&invalid-argument-error invalid-argument-error?
+ &too-few-arguments-error too-few-arguments-error?
+
&file-error file-error?
&file-search-error file-search-error?
&file-open-error file-open-error?
&file-write-error file-write-error?
+ register-error-condition-handler!
+ lookup-error-condition-handler
+
%call-with-skribilo-error-catch
call-with-skribilo-error-catch))
@@ -58,6 +64,11 @@
(proc-name invalid-argument-error:proc-name)
(argument invalid-argument-error:argument))
+(define-condition-type &too-few-arguments-error &skribilo-error
+ too-few-arguments-error?
+ (proc-name too-few-arguments-error:proc-name)
+ (arguments too-few-arguments-error:arguments))
+
;;;
;;; File errors.
@@ -80,6 +91,28 @@
;;;
+;;; Adding new error conditions from other modules.
+;;;
+
+(define %external-error-condition-alist '())
+
+(define (register-error-condition-handler! pred handler)
+ (set! %external-error-condition-alist
+ (cons (cons pred handler)
+ %external-error-condition-alist)))
+
+(define (lookup-error-condition-handler c)
+ (let ((pair (find (lambda (pair)
+ (let ((pred (car pair)))
+ (pred c)))
+ %external-error-condition-alist)))
+ (if (pair? pair)
+ (cdr pair)
+ #f)))
+
+
+
+;;;
;;; Convenience functions.
;;;
@@ -90,6 +123,11 @@
(invalid-argument-error:argument c))
(exit exit-val))
+ ((too-few-arguments-error? c)
+ (format (current-error-port) "in `~a': too few arguments: ~S~%"
+ (too-few-arguments-error:proc-name c)
+ (too-few-arguments-error:arguments c)))
+
((file-search-error? c)
(format (current-error-port) "~a: not found in path `~S'~%"
(file-error:file-name c)
@@ -111,9 +149,15 @@
(file-error:file-name c))
(exit exit-val))
- ((skribilo-error? c)
- (format (current-error-port) "undefined skribilo error: ~S~%"
- c)
+ (;;(skribilo-error? c)
+ #t ;; XXX: The SRFI-35 currently in `guile-lib' doesn't work
+ ;; properly with non-direct super-types.
+ (let ((handler (lookup-error-condition-handler c)))
+ (if (procedure? handler)
+ (handler c)
+ (format (current-error-port)
+ "undefined skribilo error: ~S~%"
+ c)))
(exit exit-val)))
(thunk)))
diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm
index 1481a56..f7709a0 100644
--- a/src/guile/skribilo/debug.scm
+++ b/src/guile/skribilo/debug.scm
@@ -15,14 +15,15 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo debug)
:use-module (skribilo utils syntax)
:use-module (srfi srfi-17)
- :use-module (srfi srfi-39))
+ :use-module (srfi srfi-39)
+ :export-syntax (debug-item with-debug))
(fluid-set! current-reader %skribilo-module-reader)
@@ -102,14 +103,15 @@
;;;
;;; debug-item
;;;
-(define-public (debug-item . args)
- (if (or (>= (*debug*) (*margin-level*))
- (*debug-item?*))
- (begin
- (display (*debug-margin*) (*debug-port*))
- (display (debug-color (- (*debug-depth*) 1) "- ") (*debug-port*))
- (for-each (lambda (a) (display a (*debug-port*))) args)
- (newline (*debug-port*)))))
+(define-macro (debug-item . args)
+ `(if (*debug-item?*) (%do-debug-item ,@args)))
+
+(define-public (%do-debug-item . args)
+ (begin
+ (display (*debug-margin*) (*debug-port*))
+ (display (debug-color (- (*debug-depth*) 1) "- ") (*debug-port*))
+ (for-each (lambda (a) (display a (*debug-port*))) args)
+ (newline (*debug-port*))))
;;(define-macro (debug-item . args)
;; `())
@@ -125,30 +127,29 @@
;;;
;;; %with-debug
-;;
-(define-public (%with-debug lvl lbl thunk)
- (parameterize ((*margin-level* lvl))
- (if (or (and (number? lvl) (>= (*debug*) lvl))
- (and (symbol? lbl)
- (memq lbl (*watched-symbols*))))
- (parameterize ((*debug-item?* #t))
- (display (*debug-margin*) (*debug-port*))
- (display (if (= (*debug-depth*) 0)
- (debug-color (*debug-depth*) "+ " lbl)
- (debug-color (*debug-depth*) "--+ " lbl))
- (*debug-port*))
- (newline (*debug-port*))
- (%with-debug-margin (debug-color (*debug-depth*) " |")
- thunk))
- (thunk))))
-
-(define-macro (with-debug level label . body)
- `(%with-debug ,level ,label (lambda () ,@body)))
-
-;;(define-macro (with-debug level label . body)
-;; `(begin ,@body))
-
-(export with-debug)
+;;;
+(define-public (%do-with-debug lvl lbl thunk)
+ (parameterize ((*margin-level* lvl)
+ (*debug-item?* #t))
+ (display (*debug-margin*) (*debug-port*))
+ (display (if (= (*debug-depth*) 0)
+ (debug-color (*debug-depth*) "+ " lbl)
+ (debug-color (*debug-depth*) "--+ " lbl))
+ (*debug-port*))
+ (newline (*debug-port*))
+ (%with-debug-margin (debug-color (*debug-depth*) " |")
+ thunk)))
+
+(define-macro (with-debug level label . body)
+ ;; We have this as a macro in order to avoid procedure calls in the
+ ;; non-debugging case. Unfortunately, the macro below duplicates BODY,
+ ;; which has a negative impact on memory usage and startup time (XXX).
+ (if (number? level)
+ `(if (or (>= (*debug*) ,level)
+ (memq ,label (*watched-symbols*)))
+ (%do-with-debug ,level ,label (lambda () ,@body))
+ (begin ,@body))
+ (error "with-debug: syntax error")))
; Example:
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
index 3e05571..06667ad 100644
--- a/src/guile/skribilo/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo engine)
@@ -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)
@@ -369,7 +374,7 @@ otherwise the requested engine is returned."
(use-modules (skribilo module))
;; At this point, we're almost done with the bootstrap process.
-(format #t "base engine: ~a~%" (lookup-engine 'base))
+;(format #t "base engine: ~a~%" (lookup-engine 'base))
(define *current-engine*
;; By default, use the HTML engine.
diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm
index a79e88a..c9e0986 100644
--- a/src/guile/skribilo/engine/context.scm
+++ b/src/guile/skribilo/engine/context.scm
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
index 4ba058a..c290189 100644
--- a/src/guile/skribilo/engine/html.scm
+++ b/src/guile/skribilo/engine/html.scm
@@ -115,7 +115,7 @@
;; emit-sui
(emit-sui #f)
;; the body
- (background "#ffffff")
+ (background #f)
(foreground #f)
;; the margins
(margin-padding 3)
@@ -124,42 +124,42 @@
(section-left-margin #f)
(left-margin-font #f)
(left-margin-size 17.)
- (left-margin-background "#dedeff")
+ (left-margin-background #f)
(left-margin-foreground #f)
(right-margin #f)
(chapter-right-margin #f)
(section-right-margin #f)
(right-margin-font #f)
(right-margin-size 17.)
- (right-margin-background "#dedeff")
+ (right-margin-background #f)
(right-margin-foreground #f)
;; author configuration
(author-font #f)
;; title configuration
(title-font #f)
- (title-background "#8381de")
+ (title-background #f)
(title-foreground #f)
(file-title-separator " -- ")
;; html file naming
(file-name-proc ,html-file-default)
;; index configuration
- (index-header-font-size +2.)
+ (index-header-font-size #f) ;; +2.
;; chapter configuration
(chapter-number->string number->string)
(chapter-file #f)
;; section configuration
(section-title-start "<h3>")
(section-title-stop "</h3>")
- (section-title-background "#dedeff")
- (section-title-foreground "black")
+ (section-title-background #f)
+ (section-title-foreground #f)
(section-title-number-separator " ")
(section-number->string number->string)
(section-file #f)
;; subsection configuration
(subsection-title-start "<h3>")
(subsection-title-stop "</h3>")
- (subsection-title-background "#ffffff")
- (subsection-title-foreground "#8381de")
+ (subsection-title-background #f)
+ (subsection-title-foreground #f)
(subsection-title-number-separator " ")
(subsection-number->string number->string)
(subsection-file #f)
@@ -167,7 +167,7 @@
(subsubsection-title-start "<h4>")
(subsubsection-title-stop "</h4>")
(subsubsection-title-background #f)
- (subsubsection-title-foreground "#8381de")
+ (subsubsection-title-foreground #f)
(subsubsection-title-number-separator " ")
(subsubsection-number->string number->string)
(subsubsection-file #f)
@@ -572,7 +572,7 @@
;* document ... */
;*---------------------------------------------------------------------*/
(markup-writer 'document
- :options '(:title :author :ending :html-title :env)
+ :options '(:title :author :ending :html-title :env :keywords)
:action (lambda (n e)
(let* ((id (markup-ident n))
(title (new markup
@@ -601,13 +601,23 @@
;*---------------------------------------------------------------------*/
(markup-writer '&html-head
:before (lambda (n e)
- (printf "<head>\n")
- (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;")
- (printf "charset=~A\">\n" (engine-custom (find-engine 'html)
- 'charset)))
+ (printf "<head>\n")
+ (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;")
+ (printf "charset=~A\">\n" (engine-custom (find-engine 'html)
+ 'charset)))
:after "</head>\n\n")
;*---------------------------------------------------------------------*/
+;* &html-meta ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-meta
+ :before "<meta name=\"keywords\" content=\""
+ :action (lambda (n e)
+ (let ((kw* (map ast->string (or (markup-body n) '()))))
+ (output (keyword-list->comma-separated kw*) e)))
+ :after "\">\n")
+
+;*---------------------------------------------------------------------*/
;* &html-body ... */
;*---------------------------------------------------------------------*/
(markup-writer '&html-body
@@ -867,7 +877,10 @@
(when title
(display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>")
(if (html-color-spec? tbg)
- (printf "<td align=\"center\" bgcolor=\"~a\">" tbg)
+ (printf "<td align=\"center\"~A>"
+ (if (html-color-spec? tbg)
+ (string-append "bgcolor=\"" tbg "\"")
+ ""))
(display "<td align=\"center\">"))
(if (string? tfg)
(printf "<font color=\"~a\">" tfg))
@@ -1058,13 +1071,9 @@
(display "</td></tr>"))
;; name
(printf "<tr><td align=\"~a\">" align)
- (if nfn
- (printf "<font ~a>\n" nfn)
- (display "<font size=\"+2\"><i>\n"))
+ (if nfn (printf "<font ~a>\n" nfn))
(output name e)
- (if nfn
- (printf "</font>\n")
- (display "</i></font>\n"))
+ (if nfn (printf "</font>\n"))
(display "</td></tr>")
;; title
(if title (row title))
@@ -1190,12 +1199,18 @@
(class (markup-class n))
(parent n)
(body (html-browser-title n))))
+ (meta (new markup
+ (markup '&html-meta)
+ (ident (string-append id "-meta"))
+ (class (markup-class n))
+ (parent n)
+ (body (markup-option n :keywords))))
(head (new markup
(markup '&html-head)
(ident (string-append id "-head"))
(class (markup-class n))
(parent n)
- (body header)))
+ (body (list header meta))))
(ftnote (new markup
(markup '&html-footnotes)
(ident (string-append id "-footnote"))
diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm
index ddc7c73..48550ef 100644
--- a/src/guile/skribilo/engine/html4.scm
+++ b/src/guile/skribilo/engine/html4.scm
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
index 8727df8..893ab2e 100644
--- a/src/guile/skribilo/engine/lout.scm
+++ b/src/guile/skribilo/engine/lout.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
;;; Taken from `lcourtes@laas.fr--2004-libre',
@@ -642,7 +642,8 @@
(pdf-author #t)
;; Keywords (a list of string) in the PDF
- ;; document information.
+ ;; document information. This custom is deprecated,
+ ;; use the `:keywords' option of `document' instead.
(pdf-keywords #f)
;; Extra PDF information, an alist of key-value
@@ -812,15 +813,11 @@
(if (or (string? t) (ast? t))
t
(markup-option doc :title))))
- (keywords (engine-custom engine 'pdf-keywords))
- (extra-fields (engine-custom engine 'pdf-extra-info))
- (stringify-kw (lambda (kws)
- (let loop ((kws kws) (s ""))
- (if (null? kws) s
- (loop (cdr kws)
- (string-append s (car kws)
- (if (pair? (cdr kws))
- ", " ""))))))))
+ (keywords (or (engine-custom engine 'pdf-keywords)
+ (map ast->string
+ (or (markup-option doc :keywords) '()))))
+ (extra-fields (engine-custom engine 'pdf-extra-info)))
+
(string-append "[ "
(if title
(docinfo-field "Title" (ast->string title))
@@ -837,13 +834,11 @@
(else (ast->string author)))
""))
"")
- (if keywords
+ (if (pair? keywords)
(docinfo-field "Keywords"
- (cond ((string? keywords)
- keywords)
- ((pair? keywords)
- (stringify-kw keywords))
- (else "")))
+ (apply string-append
+ (keyword-list->comma-separated
+ keywords)))
"")
;; arbitrary key-value pairs, see sect. 4.7, "Info
;; dictionary" of the `pdfmark' reference.
@@ -926,7 +921,7 @@
(if (< size 0) "0.3f" "1.5f")
"1.0f"))))
-(define (lout-color-specification skribe-color)
+(define-public (lout-color-specification skribe-color)
;; Return a Lout color name, ie. a string which is either an English color
;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string
;; representing a Skribe color such as "black" or "#ffffff".
@@ -975,7 +970,7 @@
;* document ... */
;*---------------------------------------------------------------------*/
(markup-writer 'document
- :options '(:title :author :ending :env)
+ :options '(:title :author :ending :keywords :env)
:before (lambda (n e) ;; `e' is the engine
(let* ((doc-type (let ((d (engine-custom e 'document-type)))
(if (string? d)
@@ -1136,7 +1131,7 @@
(lout-make-doc-cover-sheet n e))))
(if doc-style?
- ;; Putting it here will only works with `doc' documents.
+ ;; Putting it here will only work with `doc' documents.
(lout-output-pdf-meta-info n e))))
:after (lambda (n e)
@@ -1363,21 +1358,6 @@
(printf "\n\n@End @~a\n\n" lout-markup))))
-(define (markup-option-set! m opt val)
- ;; Sets the value of markup option `opt' of markup `m' to `val'.
- (let ((o (assoc opt (markup-options m))))
- (if o
- (begin
-; (set-cdr! o val)
- (markup-option-add! m opt val) ;; FIXME: the above method fails
- (if (not (eq? (markup-option m opt) val))
- (skribe-error 'markup-option-set!
- "Doesn't work!" (markup-option m opt))))
- (begin
- (lout-debug "markup-option-set!: markup ~a doesn't have option ~a"
- m opt)
- #f))))
-
(define (lout-markup-child-type skribe-markup)
;; Return the child markup type of `skribe-markup' (e.g. for `chapter',
;; return `section').
@@ -1413,8 +1393,15 @@
;; first section while other styles don't.
(printf "\n@Begin~as\n" lout-markup-name))
- ;; update the `&substructs-started?' option of the parent
- (markup-option-set! parent '&substructs-started? #t)
+ ;; FIXME: We need to make sure that PARENT is a large-scale
+ ;; structure, otherwise it won't have the `&substructs-started?'
+ ;; option (e.g., if PARENT is a `color' markup). I need to clarify
+ ;; this.
+ (if (memq (markup-markup parent)
+ '(document chapter section subsection subsubsection))
+ ;; update the `&substructs-started?' option of the parent
+ (markup-option-set! parent '&substructs-started? #t))
+
(lout-debug "start-struct: updated parent: ~a"
(markup-option parent '&substructs-started?))))
diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm
index b47f821..abee2fd 100644
--- a/src/guile/skribilo/evaluator.scm
+++ b/src/guile/skribilo/evaluator.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
@@ -26,7 +26,8 @@
:autoload (skribilo parameters) (*verbose* *document-path*)
:autoload (skribilo location) (<location>)
:autoload (skribilo ast) (ast? markup?)
- :autoload (skribilo engine) (engine? find-engine engine-ident)
+ :autoload (skribilo engine) (*current-engine*
+ engine? find-engine engine-ident)
:autoload (skribilo reader) (*document-reader*)
:autoload (skribilo verify) (verify)
@@ -56,8 +57,8 @@
;;;
(define (%evaluate expr)
;; Evaluate EXPR, an arbitrary S-expression that may contain calls to the
- ;; markup functions defined in `(skribilo skribe api)', e.g., `(bold
- ;; "hello")'.
+ ;; markup functions defined in a markup package such as
+ ;; `(skribilo package base)', e.g., `(bold "hello")'.
(let ((result (eval expr (current-module))))
(if (ast? result)
diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/index.scm
index 415cadf..33f8d15 100644
--- a/src/guile/skribilo/skribe/index.scm
+++ b/src/guile/skribilo/index.scm
@@ -1,7 +1,7 @@
;;; index.scm
;;;
;;; Copyright 2003, 2004 Manuel Serrano
-;;; 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
@@ -16,52 +16,70 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
-(define-skribe-module (skribilo skribe index))
+(define-module (skribilo index)
+ :use-syntax (skribilo utils syntax)
+ :use-syntax (skribilo lib)
+
+ :use-module (skribilo lib)
+ :use-module (skribilo ast)
+ :use-module (srfi srfi-39)
+
+ ;; XXX: The use of `mark' here introduces a cross-dependency between
+ ;; `index' and `package base'. Thus, we require that each of these two
+ ;; modules autoloads the other one.
+ :autoload (skribilo package base) (mark)
+
+ :export (index? make-index-table *index-table*
+ default-index resolve-the-index))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
;;; Author: Manuel Serrano
;;; Commentary:
;;;
-;;; A library of index-related functions.
+;;; A library of functions dealing with the creation of indices in
+;;; documents.
;;;
;;; Code:
-;;; The contents of the file below are unchanged compared to Skribe 1.2d's
-;;; `index.scm' file found in the `common' directory.
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `index.scm' file found in the `common' directory.
;*---------------------------------------------------------------------*/
;* index? ... */
;*---------------------------------------------------------------------*/
-(define-public (index? obj)
- (hashtable? obj))
+(define (index? obj)
+ (hash-table? obj))
;*---------------------------------------------------------------------*/
;* *index-table* ... */
;*---------------------------------------------------------------------*/
-(define-public *index-table* #f)
+(define *index-table* (make-parameter #f))
;*---------------------------------------------------------------------*/
;* make-index-table ... */
;*---------------------------------------------------------------------*/
-(define-public (make-index-table ident)
- (make-hashtable))
+(define (make-index-table ident)
+ (make-hash-table))
;*---------------------------------------------------------------------*/
;* default-index ... */
;*---------------------------------------------------------------------*/
-(define-public (default-index)
- (if (not *index-table*)
- (set! *index-table* (make-index-table "default-index")))
- *index-table*)
+(define (default-index)
+ (if (not (*index-table*))
+ (*index-table* (make-index-table "default-index")))
+ (*index-table*))
;*---------------------------------------------------------------------*/
;* resolve-the-index ... */
;*---------------------------------------------------------------------*/
-(define-public (resolve-the-index loc i c indexes split char-offset header-limit col)
+(define (resolve-the-index loc i c indexes split char-offset header-limit col)
;; fetch the descriminating index name letter
(define (index-ref n)
(let ((name (markup-option n 'name)))
@@ -101,7 +119,10 @@
(else
(loop (cdr buckets)
(cons (car buckets) res)))))))
- (let* ((entries (apply append (map hashtable->list indexes)))
+ (let* ((entries (apply append (map (lambda (t)
+ (hash-map->list
+ (lambda (key val) val) t))
+ indexes)))
(sorted (map sort-entries-bucket
(merge-buckets
(sort entries
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index f08a36e..21b2a4d 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -17,7 +17,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo lib)
@@ -27,7 +27,7 @@
skribe-warning skribe-warning/ast
skribe-message
- %procedure-arity)
+ type-name %procedure-arity)
:export-syntax (new define-markup define-simple-markup
define-simple-container define-processor-markup)
@@ -146,6 +146,21 @@
(options (the-options opts)))))
+
+;;;
+;;; TYPE-NAME
+;;;
+(define (type-name obj)
+ (cond ((string? obj) "string")
+ ((ast? obj) "ast")
+ ((list? obj) "list")
+ ((pair? obj) "pair")
+ ((number? obj) "number")
+ ((char? obj) "character")
+ ((keyword? obj) "keyword")
+ (else (with-output-to-string
+ (lambda () (write obj))))))
+
;;;
;;; SKRIBE-EVAL-LOCATION ...
;;;
@@ -215,38 +230,9 @@
(apply format (current-error-port) fmt obj)))
-
;;;
-;;; KEY-GET
-;;;
-;;; We need to redefine the standard key-get to be more permissive. In
-;;; STklos key-get accepts a list which is formed only of keywords. In
-;;; Skribe, parameter lists are of the form
-;;; (:title "..." :option "...." body1 body2 body3)
-;;; So is we find an element which is not a keyword, we skip it (unless it
-;;; follows a keyword of course). Since the compiler of extended lambda
-;;; uses the function key-get, it will now accept Skribe markups
-(define* (key-get lst key #:optional (default #f) default?)
- (define (not-found)
- (if default?
- default
- (error 'key-get "value ~S not found in list ~S" key lst)))
- (let Loop ((l lst))
- (cond
- ((null? l)
- (not-found))
- ((not (pair? l))
- (error 'key-get "bad list ~S" lst))
- ((keyword? (car l))
- (if (null? (cdr l))
- (error 'key-get "bad keyword list ~S" lst)
- (if (eq? (car l) key)
- (cadr l)
- (Loop (cddr l)))))
- (else
- (Loop (cdr l))))))
-
-
+;;; %PROCEDURE-ARITY
+;;;
(define (%procedure-arity proc)
(car (procedure-property proc 'arity)))
diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm
index c663605..7c870fa 100644
--- a/src/guile/skribilo/location.scm
+++ b/src/guile/skribilo/location.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo location)
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 753aca8..54989fb 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
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo module)
@@ -45,12 +45,14 @@
(srfi srfi-13) ;; strings
(ice-9 optargs) ;; `define*'
+ (skribilo package base) ;; the core markups
(skribilo utils syntax) ;; `unless', `when', etc.
(skribilo utils compat) ;; `skribe-load-path', etc.
+ (skribilo utils keywords) ;; `the-body', `the-options'
+ (skribilo utils strings) ;; `make-string-replace', etc.
(skribilo module)
(skribilo ast) ;; `<document>', `document?', etc.
(skribilo config)
- (skribilo runtime) ;; `the-options', `the-body', `make-string-replace'
(skribilo biblio)
(skribilo lib) ;; `define-markup', `unwind-protect', etc.
(skribilo resolve)
@@ -73,6 +75,8 @@
((skribilo engine html) . (html-markup-class html-class
html-width))
((skribilo utils images) . (convert-image))
+ ((skribilo index) . (index? make-index-table default-index
+ resolve-the-index))
((skribilo source) . (source-read-lines source-fontify
language? language-extractor
language-fontifier source-fontify))
@@ -86,7 +90,7 @@
((ice-9 receive) . (receive))))
(define %skribe-core-modules
- '("utils" "api" "bib" "index" "param" "sui"))
+ '("param" "sui"))
diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm
index 02633f1..7a49fd1 100644
--- a/src/guile/skribilo/output.scm
+++ b/src/guile/skribilo/output.scm
@@ -1,7 +1,7 @@
;;; output.scm -- Skribilo output stage.
;;;
;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;; 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
@@ -16,23 +16,75 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo output)
- :export (output)
:autoload (skribilo engine) (engine-ident processor-get-engine)
:autoload (skribilo writer) (writer? writer-ident lookup-markup-writer)
- :use-module (skribilo lib)
+ :autoload (skribilo location) (location?)
:use-module (skribilo ast)
:use-module (skribilo debug)
:use-module (skribilo utils syntax)
- :use-module (oop goops))
+ :use-module (oop goops)
+
+ :use-module (skribilo condition)
+ :use-module (srfi srfi-35)
+ :use-module (srfi srfi-34)
+
+ :export (output
+ &output-error &output-unresolved-error &output-writer-error
+ output-error? output-unresolved-error? output-writer-error?))
+
(fluid-set! current-reader %skribilo-module-reader)
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &output-error &skribilo-error
+ output-error?)
+
+(define-condition-type &output-unresolved-error &output-error
+ output-unresolved-error?
+ (ast output-unresolved-error:ast))
+
+(define-condition-type &output-writer-error &output-error
+ output-writer-error?
+ (writer output-writer-error:writer))
+
+
+(define (handle-output-error c)
+ ;; Issue a user-friendly error message for error condition C.
+ (cond ((output-unresolved-error? c)
+ (let* ((node (output-unresolved-error:ast c))
+ (location (and (ast? node) (ast-loc node))))
+ (format (current-error-port) "unresolved node: ~a~a~%"
+ node
+ (if (location? location)
+ (string-append " "
+ (location-file location) ":"
+ (location-line location))
+ ""))))
+ ((output-writer-error? c)
+ (format (current-error-port) "invalid writer: ~a~%"
+ (output-writer-error:writer c)))
+ (else
+ (format (current-error-port) "undefined output error: ~a~%"
+ c))))
+
+(register-error-condition-handler! output-error?
+ handle-output-error)
+
+
+
+;;;
+;;; Output method.
+;;;
+
(define-generic out)
(define (%out/writer n e w)
@@ -58,11 +110,10 @@
((is-a? (car writer) <writer>)
(%out/writer node e (car writer)))
((not (car writer))
- (skribe-error 'output
- (format #f "illegal ~A user writer" (engine-ident e))
- (if (markup? node) (markup-markup node) node)))
+ (raise (condition (&output-writer-error (writer writer)))))
(else
- (skribe-error 'output "illegal user writer" (car writer)))))))
+ (raise (condition (&output-writer-error (writer writer)))))))))
+
;;;
@@ -79,7 +130,9 @@
(out (car n*) e)
(loop (cdr n*)))
((not (null? n*))
- (skribe-error 'out "Illegal argument" n*)))))
+ (raise (condition (&invalid-argument-error
+ (proc-name output)
+ (argument n*))))))))
(define-method (out (node <string>) e)
@@ -113,7 +166,9 @@
(if (> n 0)
(if (<= n lb)
(output (list-ref body (- n 1)) e)
- (skribe-error '! "Too few arguments provided" n)))
+ (raise (condition (&too-few-arguments-error
+ (proc-name "output<command>")
+ (arguments n))))))
lf)
(let ((c (string-ref fmt i)))
(cond
@@ -128,7 +183,9 @@
(output (list-ref body (- n 1)) e)
i)
(else
- (skribe-error '! "Too few arguments provided" n))))
+ (raise (condition (&too-few-arguments-error
+ (proc-name "output<command>")
+ (arguments n)))))))
(else
(loops (+ i 1)
(+ (- (char->integer c)
@@ -151,7 +208,7 @@
(define-method (out (n <unresolved>) e)
- (skribe-error 'output "orphan unresolved" n))
+ (raise (condition (&output-unresolved-error (ast n)))))
(define-method (out (node <markup>) e)
diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am
index 6cb30b9..693f088 100644
--- a/src/guile/skribilo/package/Makefile.am
+++ b/src/guile/skribilo/package/Makefile.am
@@ -2,6 +2,6 @@ guilemoduledir = $(GUILE_SITE)/skribilo/package
dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \
lncs.scm scribe.scm sigplan.scm skribe.scm \
slide.scm web-article.scm web-book.scm \
- eq.scm
+ eq.scm pie.scm base.scm
-SUBDIRS = slide eq
+SUBDIRS = slide eq pie
diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/package/base.scm
index 2cd8b2e..8f484a0 100644
--- a/src/guile/skribilo/skribe/api.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -1,4 +1,4 @@
-;;; api.scm -- The markup API of Skribe/Skribilo.
+;;; base.scm -- The base markup package of Skribe/Skribilo.
;;;
;;; Copyright 2003, 2004 Manuel Serrano
;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
@@ -16,13 +16,34 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
-(define-skribe-module (skribilo skribe api)
+(define-module (skribilo package base)
+ :use-syntax (skribilo lib)
+ :use-syntax (skribilo reader)
+ :use-syntax (skribilo utils syntax)
+ :use-syntax (ice-9 optargs)
+
+ :use-module (skribilo ast)
+ :use-module (skribilo resolve)
+ :use-module (skribilo utils keywords)
+ :autoload (srfi srfi-1) (every any filter)
+ :autoload (skribilo evaluator) (include-document)
+ :autoload (skribilo engine) (engine?)
+
+ ;; optional ``sub-packages''
+ :autoload (skribilo biblio) (default-bib-table resolve-bib)
+ :autoload (skribilo color) (skribe-use-color!)
+ :autoload (skribilo source) (language? source-read-lines source-fontify)
+ :autoload (skribilo prog) (make-prog-body resolve-line)
+ :autoload (skribilo index) (make-index-table)
+
:replace (symbol))
-;;; Author: Manuel Serrano
+(fluid-set! current-reader (make-reader 'skribe))
+
+;;; Author: Manuel Serrano
;;; Commentary:
;;;
;;; This module contains all the core markups of Skribe/Skribilo.
@@ -30,8 +51,8 @@
;;; Code:
-;;; The contents of the file below are unchanged compared to Skribe 1.2d's
-;;; `api.scm' file found in the `common' directory.
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `api.scm' file found in the `common' directory.
@@ -41,7 +62,7 @@
(define-markup (include file)
(if (not (string? file))
(skribe-error 'include "Illegal file (string expected)" file)
- (skribe-include file)))
+ (include-document file)))
;*---------------------------------------------------------------------*/
;* document ... */
@@ -51,12 +72,12 @@
#!key
(ident #f) (class "document")
(title #f) (html-title #f) (author #f)
- (ending #f) (env '()))
+ (ending #f) (keywords '()) (env '()))
(new document
(markup 'document)
(ident (or ident
(ast->string title)
- (symbol->string (gensym 'document))))
+ (symbol->string (gensym "document"))))
(class class)
(required-options '(:title :author :ending))
(options (the-options opts :ident :class :env))
@@ -68,6 +89,20 @@
(list 'figure-counter 0) (list 'figure-env '()))))))
;*---------------------------------------------------------------------*/
+;* keyword-list->comma-separated ... */
+;*---------------------------------------------------------------------*/
+(define-public (keyword-list->comma-separated kw*)
+ ;; Turn the the list of keywords (which may be strings or other markups)
+ ;; KW* into a markup where the elements of KW* are comma-separated. This
+ ;; may commonly be used in handling the `:keywords' option of `document'.
+ (let loop ((kw* kw*) (result '()))
+ (if (null? kw*)
+ (reverse! result)
+ (loop (cdr kw*)
+ (cons* (if (pair? (cdr kw*)) ", " "")
+ (car kw*) result)))))
+
+;*---------------------------------------------------------------------*/
;* author ... */
;*---------------------------------------------------------------------*/
(define-markup (author #!rest
@@ -87,7 +122,7 @@
(skribe-error 'author "Illegal align value" align)
(new container
(markup 'author)
- (ident (or ident (symbol->string (gensym 'author))))
+ (ident (or ident (symbol->string (gensym "author"))))
(class class)
(required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
(options `((:name ,name)
@@ -107,7 +142,7 @@
(let ((body (the-body opts)))
(new container
(markup 'toc)
- (ident (or ident (symbol->string (gensym 'toc))))
+ (ident (or ident (symbol->string (gensym "toc"))))
(class class)
(required-options '())
(options `((:chapter ,chapter)
@@ -147,7 +182,7 @@
title (html-title #f) (file #f) (toc #t) (number #t))
(new container
(markup 'chapter)
- (ident (or ident (symbol->string (gensym 'chapter))))
+ (ident (or ident (symbol->string (gensym "chapter"))))
(class class)
(required-options '(:title :file :toc :number))
(options `((:toc ,toc)
@@ -187,7 +222,7 @@
title (file #f) (toc #t) (number #t))
(new container
(markup 'section)
- (ident (or ident (symbol->string (gensym 'section))))
+ (ident (or ident (symbol->string (gensym "section"))))
(class class)
(required-options '(:title :toc :file :toc :number))
(options `((:number ,(section-number number 'section))
@@ -214,7 +249,7 @@
title (file #f) (toc #t) (number #t))
(new container
(markup 'subsection)
- (ident (or ident (symbol->string (gensym 'subsection))))
+ (ident (or ident (symbol->string (gensym "subsection"))))
(class class)
(required-options '(:title :toc :file :number))
(options `((:number ,(section-number number 'subsection))
@@ -238,7 +273,7 @@
title (file #f) (toc #f) (number #t))
(new container
(markup 'subsubsection)
- (ident (or ident (symbol->string (gensym 'subsubsection))))
+ (ident (or ident (symbol->string (gensym "subsubsection"))))
(class class)
(required-options '(:title :toc :number :file))
(options `((:number ,(section-number number 'subsubsection))
@@ -258,7 +293,7 @@
(define-markup (~ #!rest opts #!key (class #f))
(new markup
(markup '~)
- (ident (gensym '~))
+ (ident (gensym "~"))
(class class)
(required-options '())
(options (the-options opts :class))
@@ -272,7 +307,7 @@
;; The `:label' option used to be called `:number'.
(new container
(markup 'footnote)
- (ident (symbol->string (gensym 'footnote)))
+ (ident (symbol->string (gensym "footnote")))
(class class)
(required-options '())
(options `((:label
@@ -292,7 +327,7 @@
;*---------------------------------------------------------------------*/
(define-markup (linebreak #!rest opts #!key (ident #f) (class #f))
(let ((ln (new markup
- (ident (or ident (symbol->string (gensym 'linebreak))))
+ (ident (or ident (symbol->string (gensym "linebreak"))))
(class class)
(markup 'linebreak)))
(num (the-body opts)))
@@ -316,7 +351,7 @@
(width 100.) (height 1))
(new markup
(markup 'hrule)
- (ident (or ident (symbol->string (gensym 'hrule))))
+ (ident (or ident (symbol->string (gensym "hrule"))))
(class class)
(required-options '())
(options `((:width ,width)
@@ -334,7 +369,7 @@
(bg #f) (fg #f) (width #f) (margin #f))
(new container
(markup 'color)
- (ident (or ident (symbol->string (gensym 'color))))
+ (ident (or ident (symbol->string (gensym "color"))))
(class class)
(required-options '(:bg :fg :width))
(options `((:bg ,(if bg (skribe-use-color! bg) bg))
@@ -352,7 +387,7 @@
(width #f) (margin 2) (border 1))
(new container
(markup 'frame)
- (ident (or ident (symbol->string (gensym 'frame))))
+ (ident (or ident (symbol->string (gensym "frame"))))
(class class)
(required-options '(:width :border :margin))
(options `((:margin ,margin)
@@ -373,7 +408,7 @@
(size #f) (face #f))
(new container
(markup 'font)
- (ident (or ident (symbol->string (gensym 'font))))
+ (ident (or ident (symbol->string (gensym "font"))))
(class class)
(required-options '(:size))
(options (the-options opts :ident :class))
@@ -391,7 +426,7 @@
((center left right)
(new container
(markup 'flush)
- (ident (or ident (symbol->string (gensym 'flush))))
+ (ident (or ident (symbol->string (gensym "flush"))))
(class class)
(required-options '(:side))
(options (the-options opts :ident :class))
@@ -426,7 +461,7 @@
(skribe-error 'prog "Illegal mark" mark)
(new container
(markup 'prog)
- (ident (or ident (symbol->string (gensym 'prog))))
+ (ident (or ident (symbol->string (gensym "prog"))))
(class class)
(required-options '(:line :mark))
(options (the-options opts :ident :class :linedigit))
@@ -523,7 +558,7 @@
(let ((s (ast->string legend)))
(if (not (string=? s ""))
s
- (symbol->string (gensym 'figure))))))
+ (symbol->string (gensym "figure"))))))
(class class)
(required-options '(:legend :number :multicolumns))
(options `((:number
@@ -551,12 +586,13 @@
(null? (cdr lst)))
(parse-list-of for markup (car lst)))
(else
- (let loop ((lst lst))
+ (let loop ((lst lst)
+ (result '()))
(cond
((null? lst)
- '())
+ (reverse! result))
((pair? (car lst))
- (loop (car lst)))
+ (loop (car lst) result))
(else
(let ((r (car lst)))
(if (not (is-markup? r markup))
@@ -567,7 +603,7 @@
(markup-markup r)
(find-runtime-type r))
markup)))
- (cons r (loop (cdr lst))))))))))
+ (loop (cdr lst) (cons r result)))))))))
;*---------------------------------------------------------------------*/
;* itemize ... */
@@ -575,7 +611,7 @@
(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol)
(new container
(markup 'itemize)
- (ident (or ident (symbol->string (gensym 'itemize))))
+ (ident (or ident (symbol->string (gensym "itemize"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -587,7 +623,7 @@
(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol)
(new container
(markup 'enumerate)
- (ident (or ident (symbol->string (gensym 'enumerate))))
+ (ident (or ident (symbol->string (gensym "enumerate"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -599,7 +635,7 @@
(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol)
(new container
(markup 'description)
- (ident (or ident (symbol->string (gensym 'description))))
+ (ident (or ident (symbol->string (gensym "description"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -616,7 +652,7 @@
(skribe-type-error 'item "Illegal key:" key "node")
(new container
(markup 'item)
- (ident (or ident (symbol->string (gensym 'item))))
+ (ident (or ident (symbol->string (gensym "item"))))
(class class)
(required-options '(:key))
(options `((:key ,key) ,@(the-options opts :ident :class :key)))
@@ -667,7 +703,7 @@
(else
(new container
(markup 'table)
- (ident (or ident (symbol->string (gensym 'table))))
+ (ident (or ident (symbol->string (gensym "table"))))
(class class)
(required-options '(:width :frame :rules))
(options `((:frame ,frame)
@@ -682,7 +718,7 @@
(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f))
(new container
(markup 'tr)
- (ident (or ident (symbol->string (gensym 'tr))))
+ (ident (or ident (symbol->string (gensym "tr"))))
(class class)
(required-options '())
(options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
@@ -723,7 +759,7 @@
(else
(new container
(markup 'tc)
- (ident (or ident (symbol->string (gensym 'tc))))
+ (ident (or ident (symbol->string (gensym "tc"))))
(class class)
(required-options '(:width :align :valign :colspan))
(options `((markup ,m)
@@ -780,7 +816,7 @@
(else
(new markup
(markup 'image)
- (ident (or ident (symbol->string (gensym 'image))))
+ (ident (or ident (symbol->string (gensym "image"))))
(class class)
(required-options '(:file :url :width :height))
(options (the-options opts :ident :class))
@@ -863,7 +899,13 @@
(skribe-error 'processor "Illegal engine" engine))
((and procedure
(or (not (procedure? procedure))
- (not (correct-arity? procedure 2))))
+ (not (let ((a (procedure-property procedure 'arity)))
+ (and (pair? a)
+ (let ((compulsory (car a))
+ (optional (cadr a))
+ (rest? (caddr a)))
+ (or rest?
+ (>= (+ compulsory optional) 2))))))))
(skribe-error 'processor "Illegal procedure" procedure))
(else
(new processor
@@ -911,7 +953,7 @@
(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text)
(new markup
(markup 'mailto)
- (ident (or ident (symbol->string (gensym 'ident))))
+ (ident (or ident (symbol->string (gensym "ident"))))
(class class)
(required-options '(:text))
(options (the-options opts :ident :class))
@@ -920,7 +962,7 @@
;*---------------------------------------------------------------------*/
;* *mark-table* ... */
;*---------------------------------------------------------------------*/
-(define *mark-table* (make-hashtable))
+(define *mark-table* (make-hash-table))
;*---------------------------------------------------------------------*/
;* mark ... */
@@ -949,7 +991,7 @@
(class class)
(options (the-options opts :ident :class :text))
(body text))))
- (hashtable-put! *mark-table* bs n)
+ (hash-set! *mark-table* bs n)
n)))))
;*---------------------------------------------------------------------*/
@@ -1019,7 +1061,31 @@
(required-options '(:text))
(options `((kind handle) ,@(the-options opts :ident :class)))
(body text)))
- (define (doref text kind)
+ (define (do-title-ref title kind)
+ (if (not (string? title))
+ (skribe-type-error 'ref "illegal reference" title "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let* ((doc (ast-document n))
+ (s (find1-down
+ (lambda (n)
+ (and (is-markup? n kind)
+ (equal? (markup-option n :title)
+ title)))
+ doc)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'title-ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind)
+ (mark ,title)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n title (or kind 'title)))))))))
+ (define (do-ident-ref text kind)
(if (not (string? text))
(skribe-type-error 'ref "Illegal reference" text "string")
(new unresolved
@@ -1028,7 +1094,7 @@
(if s
(new markup
(markup 'ref)
- (ident (symbol->string 'ref))
+ (ident (symbol->string 'indent-ref))
(class class)
(required-options '(:text))
(options `((kind ,kind)
@@ -1042,7 +1108,7 @@
(skribe-type-error 'mark "Illegal mark, " mark "string")
(new unresolved
(proc (lambda (n e env)
- (let ((s (hashtable-get *mark-table* mark)))
+ (let ((s (hash-ref *mark-table* mark)))
(if s
(new markup
(markup 'ref)
@@ -1108,17 +1174,17 @@
(cond
(skribe (skribe-ref skribe))
(handle (handle-ref handle))
- (ident (doref ident #f))
- (chapter (doref chapter 'chapter))
- (section (doref section 'section))
- (subsection (doref subsection 'subsection))
- (subsubsection (doref subsubsection 'subsubsection))
- (figure (doref figure 'figure))
+ (ident (do-ident-ref ident #f))
+ (chapter (do-title-ref chapter 'chapter))
+ (section (do-title-ref section 'section))
+ (subsection (do-title-ref subsection 'subsection))
+ (subsubsection (do-title-ref subsubsection 'subsubsection))
+ (figure (do-ident-ref figure 'figure))
(mark (mark-ref mark))
(bib (bib-ref bib))
(url (url-ref))
(line (line-ref line))
- (else (skribe-error 'ref "Illegal reference" opts)))))
+ (else (skribe-error 'ref "illegal reference" opts)))))
;*---------------------------------------------------------------------*/
;* resolve ... */
@@ -1212,11 +1278,11 @@
"Illegal index table, "
index
"index"))))
- (m (mark (symbol->string (gensym))))
+ (m (mark (symbol->string (gensym "mark"))))
(h (new handle (ast m)))
(new (new markup
(markup '&index-entry)
- (ident (or ident (symbol->string (gensym 'index))))
+ (ident (or ident (symbol->string (gensym "index"))))
(class class)
(options `((name ,ename) ,@(the-options opts :ident :class)))
(body (if url
@@ -1225,10 +1291,12 @@
;; New is bound to a dummy option of the mark in order
;; to make new options verified.
(markup-option-add! m 'to-verify new)
- (hashtable-update! table
- ename
- (lambda (cur) (cons new cur))
- (list new))
+
+ (let ((handle (hash-get-handle table ename)))
+ (if (not handle)
+ (hash-set! table ename (list new))
+ (set-cdr! handle (cons new (cdr handle)))))
+
m))
;*---------------------------------------------------------------------*/
@@ -1255,7 +1323,7 @@
(skribe-error 'the-index "Illegal char offset" char-offset))
((not (integer? column))
(skribe-error 'the-index "Illegal column number" column))
- ((not (every? index? bd))
+ ((not (every index? bd))
(skribe-error 'the-index
"Illegal indexes"
(filter (lambda (o) (not (index? o))) bd)))
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
index 45a863f..4f5020e 100644
--- a/src/guile/skribilo/package/eq.scm
+++ b/src/guile/skribilo/package/eq.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo package eq)
@@ -26,8 +26,8 @@
:use-module (skribilo lib)
:use-module (skribilo utils syntax)
:use-module (skribilo module)
- :use-module (skribilo skribe utils) ;; `the-options', etc.
- :autoload (skribilo skribe api) (it symbol sub sup)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :autoload (skribilo package base) (it symbol sub sup)
:autoload (skribilo engine lout) (lout-illustration)
:use-module (ice-9 optargs))
@@ -76,10 +76,6 @@
sim cong approx neq equiv le ge subset supset subseteq supseteq
oplus otimes perp mid lceil rceil lfloor rfloor langle rangle))
-(define %rebindings
- (map (lambda (sym)
- (list sym (symbol-append 'eq: sym)))
- %operators))
(define (make-fast-member-predicate lst)
(let ((h (make-hash-table)))
@@ -93,15 +89,60 @@
(define-public known-operator? (make-fast-member-predicate %operators))
(define-public known-symbol? (make-fast-member-predicate %symbols))
+(define-public equation-markup-name?
+ (make-fast-member-predicate (map (lambda (s)
+ (symbol-append 'eq: s))
+ %operators)))
+
(define-public (equation-markup? m)
"Return true if @var{m} is an instance of one of the equation sub-markups."
- (define eq-sym?
- (make-fast-member-predicate (map (lambda (s)
- (symbol-append 'eq: s))
- %operators)))
(and (markup? m)
- (eq-sym? (markup-markup m))))
+ (equation-markup-name? (markup-markup m))))
+
+(define-public (equation-markup-name->operator m)
+ "Given symbol @var{m} (an equation markup name, e.g., @code{eq:+}), return
+a symbol representing the mathematical operator denoted by @var{m} (e.g.,
+@code{+})."
+ (if (equation-markup-name? m)
+ (string->symbol (let ((str (symbol->string m)))
+ (substring str
+ (+ 1 (string-index str #\:))
+ (string-length str))))
+ #f))
+
+
+;;;
+;;; Operator precedence.
+;;;
+
+(define %operator-precedence
+ ;; FIXME: This needs to be augmented.
+ '((+ . 1)
+ (- . 1)
+ (* . 2)
+ (/ . 2)
+ (sum . 3)
+ (product . 3)
+ (= . 0)
+ (< . 0)
+ (> . 0)
+ (<= . 0)
+ (>= . 0)))
+
+(define-public (operator-precedence op)
+ (let ((p (assq op %operator-precedence)))
+ (if (pair? p) (cdr p) 0)))
+
+
+
+;;;
+;;; Turning an S-exp into an `eq' markup.
+;;;
+(define %rebindings
+ (map (lambda (sym)
+ (list sym (symbol-append 'eq: sym)))
+ %operators))
(define (eq:symbols->strings equation)
"Turn symbols located in non-@code{car} positions into strings."
@@ -122,12 +163,14 @@
(eval `(let ,%rebindings ,(eq:symbols->strings equation))
(current-module)))
+
;;;
;;; Markup.
;;;
-(define-markup (eq :rest opts :key (ident #f) (renderer #f) (class "eq"))
+(define-markup (eq :rest opts :key (ident #f) (inline? #f)
+ (renderer #f) (class "eq"))
(new markup
(markup 'eq)
(ident (or ident (symbol->string (gensym "eq"))))
@@ -208,13 +251,13 @@
body))
(loop (cdr body) (cons first result)))))))))
+
;;;
-;;; Base and text-only implementation.
+;;; Text-based rendering.
;;;
-
(markup-writer 'eq (find-engine 'base)
:action (lambda (node engine)
;; The `:renderer' option should be a symbol (naming an engine
@@ -246,24 +289,37 @@
renderer))))))
(define-macro (simple-markup-writer op . obj)
- `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base)
- :action (lambda (node engine)
- (let loop ((operands (markup-body node)))
- (if (null? operands)
- #t
- (let ((o (car operands)))
- (display (if (equation-markup? o) "(" ""))
- (output o engine)
- (display (if (equation-markup? o) ")" ""))
- (if (pair? (cdr operands))
- (begin
- (display " ")
- (output ,(if (null? obj)
- (symbol->string op)
- (car obj))
- engine)
- (display " ")))
- (loop (cdr operands))))))))
+ ;; Note: The text-only rendering is less ambiguous if we parenthesize
+ ;; without taking operator precedence into account.
+ (let ((precedence (operator-precedence op)))
+ `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base)
+ :action (lambda (node engine)
+ (let loop ((operands (markup-body node)))
+ (if (null? operands)
+ #t
+ (let* ((o (car operands))
+ (nested-eq? (equation-markup? o))
+ (need-paren?
+ (and nested-eq?
+; (< (operator-precedence
+; (equation-markup-name->operator
+; (markup-markup o)))
+; ,precedence)
+ )
+ ))
+
+ (display (if need-paren? "(" ""))
+ (output o engine)
+ (display (if need-paren? ")" ""))
+ (if (pair? (cdr operands))
+ (begin
+ (display " ")
+ (output ,(if (null? obj)
+ (symbol->string op)
+ (car obj))
+ engine)
+ (display " ")))
+ (loop (cdr operands)))))))))
(simple-markup-writer +)
(simple-markup-writer -)
diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm
index 561e4cb..c487b85 100644
--- a/src/guile/skribilo/package/eq/lout.scm
+++ b/src/guile/skribilo/package/eq/lout.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo package eq lout)
@@ -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)
@@ -53,64 +53,78 @@
(markup-writer 'eq (find-engine 'lout)
- :before "{ @Eq { "
+ :options '(:inline?)
+ :before "{ "
:action (lambda (node engine)
- (let ((eq (markup-body node)))
- ;(fprint (current-error-port) "eq=" eq)
- (output eq engine)))
+ (display (if (markup-option node :inline?)
+ "@E { "
+ "@Eq { "))
+ (let ((eq (markup-body node)))
+ ;;(fprint (current-error-port) "eq=" eq)
+ (output eq engine)))
:after " } }")
-;;
-;; `+' and `-' have lower precedence than `*', `/', `=', etc., so their
-;; operands do not need to be enclosed in braces.
-;;
-
-(markup-writer 'eq:+ (find-engine 'lout)
- :action (lambda (node engine)
- (let loop ((operands (markup-body node)))
- (if (null? operands)
- #t
- (begin
- ;; no braces
- (output (car operands) engine)
- (if (pair? (cdr operands))
- (display " + "))
- (loop (cdr operands)))))))
-
-(markup-writer 'eq:- (find-engine 'lout)
- :action (lambda (node engine)
- (let loop ((operands (markup-body node)))
- (if (null? operands)
- #t
- (begin
- ;; no braces
- (output (car operands) engine)
- (if (pair? (cdr operands))
- (display " - "))
- (loop (cdr operands)))))))
-
-(define-macro (simple-lout-markup-writer sym . lout-name)
- `(markup-writer ',(symbol-append 'eq: sym)
- (find-engine 'lout)
- :action (lambda (node engine)
- (let loop ((operands (markup-body node)))
- (if (null? operands)
- #t
- (begin
- (display " { ")
- (output (car operands) engine)
- (display " }")
- (if (pair? (cdr operands))
- (display ,(string-append " "
- (if (null? lout-name)
- (symbol->string sym)
- (car lout-name))
- " ")))
- (loop (cdr operands))))))))
+(define-macro (simple-lout-markup-writer sym . args)
+ (let* ((lout-name (if (null? args)
+ (symbol->string sym)
+ (car args)))
+ (parentheses? (if (or (null? args) (null? (cdr args)))
+ #t
+ (cadr args)))
+ (precedence (operator-precedence sym))
+
+ ;; Note: We could use `pmatrix' here but it precludes line-breaking
+ ;; within equations.
+ (open-par `(if need-paren? "{ @VScale ( }" ""))
+ (close-par `(if need-paren? "{ @VScale ) }" "")))
+
+ `(markup-writer ',(symbol-append 'eq: sym)
+ (find-engine 'lout)
+ :action (lambda (node engine)
+ (let loop ((operands (markup-body node)))
+ (if (null? operands)
+ #t
+ (let* ((op (car operands))
+ (eq-op? (equation-markup? op))
+ (need-paren?
+ (and eq-op?
+ (< (operator-precedence
+ (equation-markup-name->operator
+ (markup-markup op)))
+ ,precedence)))
+ (column (port-column
+ (current-output-port))))
+
+ ;; Work around Lout's limitations...
+ (if (> column 1000) (display "\n"))
+
+ (display (string-append " { "
+ ,(if parentheses?
+ open-par
+ "")))
+ (output op engine)
+ (display (string-append ,(if parentheses?
+ close-par
+ "")
+ " }"))
+ (if (pair? (cdr operands))
+ (display ,(string-append " "
+ lout-name
+ " ")))
+ (loop (cdr operands)))))))))
+
+
+;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their
+;; operands do not need to be enclosed in parentheses. OTOH, since we use a
+;; horizontal bar of `/', we don't need to parenthesize its arguments.
+
+
+(simple-lout-markup-writer +)
(simple-lout-markup-writer * "times")
-(simple-lout-markup-writer / "over")
+(simple-lout-markup-writer - "-")
+(simple-lout-markup-writer / "over" #f)
(simple-lout-markup-writer =)
(simple-lout-markup-writer <)
(simple-lout-markup-writer >)
diff --git a/src/guile/skribilo/package/pie.scm b/src/guile/skribilo/package/pie.scm
new file mode 100644
index 0000000..8ccf858
--- /dev/null
+++ b/src/guile/skribilo/package/pie.scm
@@ -0,0 +1,314 @@
+;;; pie.scm -- An pie-chart formatting package.
+;;;
+;;; Copyright 2005, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package pie)
+ :autoload (skribilo ast) (markup? markup-ident ast-parent)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib) ;; `skribe-error' et al.
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (skribilo utils strings) ;; `make-string-replace'
+ :use-module (skribilo module)
+ :autoload (skribilo color) (skribe-color->rgb)
+ :autoload (skribilo package base) (bold)
+ :autoload (skribilo engine lout) (lout-illustration)
+ :autoload (ice-9 popen) (open-output-pipe)
+ :use-module (ice-9 optargs)
+ :export (%ploticus-program %ploticus-debug?
+ pie-sliceweight-value pie-remove-markup))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Markup.
+;;;
+
+(define-markup (pie :rest opts
+ :key (ident #f) (title "Pie Chart")
+ (initial-angle 0) (total #f) (radius 3)
+ (fingers? #t) (labels 'outside)
+ (class "pie"))
+ (new container
+ (markup 'pie)
+ (ident (or ident (symbol->string (gensym "pie"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (slice :rest opts
+ :key (ident #f) (weight 1) (color "white") (detach? #f))
+ (new container
+ (markup 'slice)
+ (ident (or ident (symbol->string (gensym "slice"))))
+ (weight weight)
+ (color color)
+ (detach? detach?)
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (sliceweight :rest opts
+ :key (ident #f) (percentage? #f))
+ (new markup
+ (markup 'sliceweight)
+ (ident (or ident (symbol->string (gensym "sliceweight"))))
+ (percentage? percentage?)
+ (options (the-options opts))
+ (body '())))
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (make-rounder pow10)
+ ;; Return a procedure that round to 10 to the -POW10.
+ (let ((times (expt 10.0 pow10)))
+ (lambda (x)
+ (/ (round (* x times)) times))))
+
+(define (pie-sliceweight-value sw-node pct?)
+ "Return the value that should be displayed by `sw-node', a
+ `sliceweight' markup node. If `pct?' is true, then this value
+ should be a percentage."
+ (let* ((the-slice (ast-parent sw-node))
+ (weight (and the-slice (markup-option the-slice :weight))))
+ (if (not the-slice)
+ (skribe-error 'lout
+ "`sliceweight' node not within a `slice' body"
+ sw-node)
+ (if pct?
+ (let* ((the-pie (ast-parent the-slice))
+ (total (and the-pie
+ (markup-option the-pie
+ '&total-weight))))
+ (if (not the-pie)
+ (skribe-error 'lout
+ "`slice' not within a `pie' body"
+ the-slice)
+ (* 100.0 (/ weight total)))) ;; flonum (FIXME: precision)
+
+ weight))))
+
+(define (pie-remove-markup node)
+ "Remove markup from `node', ie. turn something like `(it \"hello\")' into
+the string \"hello\". Implement `sliceweight' markups too."
+ (define percentage-round (make-rounder 2))
+
+ (if (markup? node)
+ (if (and node (is-markup? node 'sliceweight))
+ (let* ((pct? (markup-option node :percentage?))
+ (value (pie-sliceweight-value node pct?)))
+ (number->string (percentage-round value)))
+ (pie-remove-markup (markup-body node)))
+ (if (list? node)
+ (apply string-append (map pie-remove-markup node))
+ node)))
+
+(define strip-newlines (make-string-replace '((#\newline " "))))
+
+(define (select-output-format engine)
+ ;; Choose an ouptut format suitable for ENGINE.
+ (define %supported-formats '("png" "ps" "eps" "svg" "svgz"))
+ (define %default-format "png")
+
+ (let ((fmt (engine-custom engine 'image-format)))
+ (cond ((string? fmt) fmt)
+ ((and (list? fmt) (not (null? fmt)))
+ (let ((f (car fmt)))
+ (if (member f %supported-formats)
+ f
+ %default-format)))
+ (else %default-format))))
+
+
+;;;
+;;; Default implementation (`base' engine).
+;;;
+
+;; Ploticus-based implementation of pie charts, suitable for most engines.
+;; See http://ploticus.sf.net for info about Ploticus.
+
+(define %ploticus-program "ploticus")
+(define %ploticus-debug? #f)
+
+(define (color-spec->ploticus color-spec)
+ (define round (make-rounder 2))
+
+ (call-with-values (lambda () (skribe-color->rgb color-spec))
+ (lambda (r g b)
+ (format #f "rgb(~a,~a,~a)"
+ (round (/ r 255.0))
+ (round (/ g 255.0))
+ (round (/ b 255.0))))))
+
+(define (ploticus-script pie)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body pie)))
+ (colors (map (lambda (slice)
+ (let ((c (markup-option slice :color)))
+ (string-append (color-spec->ploticus c)
+ " ")))
+ (markup-body pie)))
+ (total-weight (or (if (number? (markup-option pie
+ :total))
+ (markup-option pie :total)
+ #f)
+ (apply + weights)))
+
+ ;; Attach useful information to the pie and its slices
+ (-/- (markup-option-add! pie '&total-weight total-weight))
+
+ ;; One slice label per line -- so we need to remove
+ ;; newlines from labels.
+ (labels (map (lambda (b)
+ (strip-newlines (pie-remove-markup b)))
+ (markup-body pie)))
+
+; (flat-title (map pie-remove-markup
+; (markup-option pie :title)))
+ (detached (map (lambda (slice)
+ (let ((d (markup-option slice
+ :detach?)))
+ (cond ((number? d) d)
+ (d 0.5) ;; default
+ (#t 0))))
+ (markup-body pie)))
+
+ (initial-angle (or (markup-option pie :initial-angle)
+ 0))
+ (radius (or ;;FIXME
+ (markup-option pie :radius) 3))
+ (max-radius (+ radius (apply max detached)))
+
+ ;; center coordinates must take into account (i) the
+ ;; maxium radius when detached slices are considered and
+ ;; (ii) the fact that labels may get displayed to the
+ ;; left of the pie.
+ ;; FIXME: labels to the left (ii) end up being truncated
+ ;; when the radius is e.g. < 2.
+ (center `(,(+ max-radius
+ (* max-radius max-radius)) .
+ ,(* max-radius max-radius))))
+
+ (apply string-append
+ (append (list "#proc getdata\n" "data: ")
+ (map (lambda (weight)
+ (string-append (number->string weight)
+ "\n"))
+ weights)
+ `("\n"
+; "#proc page\n"
+; "title " ,@flat-title
+; "\n"
+ "#proc pie\n"
+ "total: "
+ ,(number->string total-weight)
+ "\n"
+ "datafield: " "1" "\n")
+ `("firstslice: " ,(number->string initial-angle) "\n")
+ `("radius: " ,(number->string radius) "\n")
+ `("center: " ,(number->string (car center))
+ " " ,(number->string (cdr center)) "\n")
+ `("labelmode: "
+ ,(case (markup-option
+ pie :labels)
+ ((outside) "line+label")
+ ((inside) "labelonly")
+ ((legend) "legend")
+ (else "legend"))
+ "\n"
+ "labels: " ,@(map (lambda (label)
+ (string-append label "\n"))
+ labels)
+ "\n")
+ `("explode: "
+ ,@(map (lambda (number)
+ (string-append (number->string number)
+ " "))
+ detached)
+ "\n")
+ `("colors: " ,@colors "\n")))))
+
+(markup-writer 'pie (find-engine 'base)
+ :action (lambda (node engine)
+ (let* ((fmt (select-output-format engine))
+ (pie-file (string-append (markup-ident node) "."
+ fmt))
+ (port (open-output-pipe
+ (string-append %ploticus-program
+ " -o " pie-file
+ " -cm -" fmt " -stdin")))
+ (script (ploticus-script node)))
+
+
+ (if %ploticus-debug?
+ (format (current-error-port) "** Ploticus script: ~a"
+ script))
+
+ (display script port)
+
+ (let ((exit-val (status:exit-val (close-pipe port))))
+ (if (not (eqv? 0 exit-val))
+ (skribe-error 'pie/ploticus
+ "ploticus exited with error code"
+ exit-val)))
+
+ (if (not (file-exists? pie-file))
+ (skribe-error 'ploticus
+ "Ploticus did not create the image file"
+ script))
+
+ (if (markup-option node :title)
+ (output (list (bold (markup-option node :title))
+ (linebreak))
+ engine))
+
+ (output (image :file pie-file
+ :class (markup-option node :class)
+ (or (markup-option node :title)
+ "A Pie Chart"))
+ engine))))
+
+(markup-writer 'slice (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here
+ (error "slice: this writer should never be invoked")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here.
+ (error "sliceweight: this writer should never be invoked")))
+
+
+;;;
+;;; Initialization.
+;;;
+
+(when-engine-is-loaded 'lout
+ (lambda ()
+ (resolve-module '(skribilo package pie lout))))
+
+
+;;; arch-tag: 8095d8f6-b810-4619-9fdb-23fb94a77ee3
diff --git a/src/guile/skribilo/package/pie/Makefile.am b/src/guile/skribilo/package/pie/Makefile.am
new file mode 100644
index 0000000..3b4fafd
--- /dev/null
+++ b/src/guile/skribilo/package/pie/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package/pie
+dist_guilemodule_DATA = lout.scm
+
+## arch-tag: e6a03451-14c9-4331-8b96-71bde92ac142
diff --git a/src/guile/skribilo/package/pie/lout.scm b/src/guile/skribilo/package/pie/lout.scm
new file mode 100644
index 0000000..61dbcb7
--- /dev/null
+++ b/src/guile/skribilo/package/pie/lout.scm
@@ -0,0 +1,132 @@
+;;; lout.scm -- Lout implementation of the `pie' package.
+;;;
+;;; Copyright 2005, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package pie lout)
+ :use-module (skribilo package pie)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :autoload (skribilo engine lout) (lout-color-specification)
+ :use-module (ice-9 optargs))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(let ((lout (find-engine 'lout)))
+ (if lout
+ (engine-custom-set! lout 'includes
+ (string-append (engine-custom lout 'includes)
+ "\n@SysInclude { pie } # Pie Charts\n"))))
+
+
+
+;;;
+;;; Writers.
+;;;
+
+(markup-writer 'pie (find-engine 'lout)
+ :before (lambda (node engine)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body node)))
+ (total-weight (or (if (number? (markup-option node
+ :total))
+ (markup-option node :total)
+ #f)
+ (apply + weights))))
+
+ (if (= 0 total-weight)
+ (skribe-error 'lout
+ "Slices weight sum should not be zero"
+ total-weight))
+
+ ;; Attach useful information to the pie and its slices
+ (markup-option-add! node '&total-weight total-weight)
+
+ (display "\n@Pie\n")
+ (display " abovecaption { ")
+ (if (markup-option node :title)
+ (output (markup-option node :title) engine))
+ (display " }\n")
+ (format #t " totalweight { ~a }\n" total-weight)
+ (format #t " initialangle { ~a }\n"
+ (or (markup-option node :initial-angle) 0))
+ (format #t " finger { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside) (if (markup-option node :fingers?)
+ "yes" "no"))
+ (else "no")))
+
+ ;; We assume `:radius' to be centimeters
+ (if (markup-option node :radius)
+ (format #t " radius { ~ac }\n"
+ (markup-option node :radius)))
+
+ (format #t " labelradius { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside #f) "external") ; FIXME: options are
+ ; not availble within
+ ; :before? (hence the #f)
+
+ ((inside) "internal")
+ (else
+ (skribe-error 'lout
+ "`:labels' should be one of 'inside or 'outside."
+ (markup-option node :labels)))))
+ (display "{\n")))
+ :after "\n} # @Pie\n")
+
+(markup-writer 'slice (find-engine 'lout)
+ :options '(:weight :detach? :color)
+ :action (lambda (node engine)
+ (display " @Slice\n")
+ (format #t " detach { ~a }\n"
+ (if (markup-option node :detach?)
+ "yes"
+ "no"))
+ (format #t " paint { ~a }\n"
+ (lout-color-specification (markup-option node
+ :color)))
+ (format #t " weight { ~a }\n"
+ (markup-option node :weight))
+
+ (display " label { ")
+ (output (markup-body node) engine)
+ (display " }\n")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ ;; This writer should work for every engine, provided the `pie' markup has
+ ;; a proper `&total-weight' option.
+ :action (lambda (node engine)
+ (let ((pct? (markup-option node :percentage?)))
+ (output (number->string
+ (pie-sliceweight-value node pct?))
+ engine))))
+
+;;; arch-tag: b5221e30-f80e-4b72-a281-83ce19ddb755
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
index 629abdf..8c4582c 100644
--- a/src/guile/skribilo/package/slide.scm
+++ b/src/guile/skribilo/package/slide.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm
index 128b7e3..58348df 100644
--- a/src/guile/skribilo/package/slide/html.scm
+++ b/src/guile/skribilo/package/slide/html.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo package slide html)
diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm
index 4105e74..e187d3c 100644
--- a/src/guile/skribilo/package/slide/latex.scm
+++ b/src/guile/skribilo/package/slide/latex.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo package slide latex)
diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm
index c36c793..817d0ed 100644
--- a/src/guile/skribilo/package/slide/lout.scm
+++ b/src/guile/skribilo/package/slide/lout.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo package slide lout)
diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm
index a954c7a..e52bdc3 100644
--- a/src/guile/skribilo/package/web-book.scm
+++ b/src/guile/skribilo/package/web-book.scm
@@ -35,10 +35,11 @@
(center
(table :width 97. :border 1 :frame 'box
:cellpadding 0 :cellspacing 0
- (tr :bg (engine-custom e 'title-background)
- (th (color :fg (engine-custom e 'background)
- (bold "main page"))))
- (tr :bg (engine-custom e 'background)
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((text (bold "main page"))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg bg text) text))))
+ (tr :bg (engine-custom e 'background)
(td (apply table :width 100. :border 0
(tr (td :align 'left
:valign 'top
@@ -60,12 +61,13 @@
(define chapter-browsing
(lambda (n e)
(center
- (table :width 97. :border 1 :frame 'box
+ (table :width 97. :border 1 :frame 'box
:cellpadding 0 :cellspacing 0
- (tr :bg (engine-custom e 'title-background)
- (th (color :fg (engine-custom e 'background)
- (bold (markup-option n :title)))))
- (tr :bg (engine-custom e 'background)
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((title (bold (markup-option n :title)))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg title) title))))
+ (tr :bg (engine-custom e 'background)
(td (toc (handle n) :chapter #t :section #t :subsection #t)))))))
;*---------------------------------------------------------------------*/
@@ -79,10 +81,11 @@
(center
(table :width 97. :border 1 :frame 'box
:cellpadding 0 :cellspacing 0
- (tr :bg (engine-custom e 'title-background)
- (th (color :fg (engine-custom e 'background)
- (bold (if chap "Chapters" "Sections")))))
- (tr :bg (engine-custom e 'background)
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((text (bold (if chap "Chapters" "Sections")))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg bg text) text))))
+ (tr :bg (engine-custom e 'background)
(td (if chap
(toc (handle n) :chapter #t :section #f)
(toc (handle n) :section #t :subsection #t)))))))))
diff --git a/src/guile/skribilo/parameters.scm b/src/guile/skribilo/parameters.scm
index 04517e7..5893851 100644
--- a/src/guile/skribilo/parameters.scm
+++ b/src/guile/skribilo/parameters.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo parameters)
diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm
index 87b964b..6ef41ee 100644
--- a/src/guile/skribilo/prog.scm
+++ b/src/guile/skribilo/prog.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo prog)
diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm
index 95e545b..871d92c 100644
--- a/src/guile/skribilo/reader.scm
+++ b/src/guile/skribilo/reader.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo reader)
diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm
index 4b7d00d..09792f5 100644
--- a/src/guile/skribilo/reader/outline.scm
+++ b/src/guile/skribilo/reader/outline.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo reader outline)
@@ -133,13 +133,13 @@ line or a line comment."
(match:substring m 1)
(match:suffix m)
(lambda (body) `(bold ,body)))))
- ("``(([^`]|[^'])+)''" .
+ ("``(([^`^'])+)''" .
,(lambda (m)
(values (match:prefix m)
(match:substring m 1)
(match:suffix m)
(lambda (body) `(q ,body)))))
- ("`(([^`]|[^'])+)'" .
+ ("`(([^`^'])+)'" .
,(lambda (m)
(values (match:prefix m)
(match:substring m 1)
diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm
index f92f13b..d3dbb5f 100644
--- a/src/guile/skribilo/reader/skribe.scm
+++ b/src/guile/skribilo/reader/skribe.scm
@@ -1,6 +1,6 @@
;;; skribe.scm -- A reader for the Skribe syntax.
;;;
-;;; 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
@@ -15,12 +15,13 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo reader skribe)
:use-module (skribilo reader)
:use-module (ice-9 optargs)
+ :use-module (srfi srfi-1)
;; the Scheme reader composition framework
:use-module ((system reader) #:renamer (symbol-prefix-proc 'r:))
@@ -46,6 +47,17 @@ the Skribe syntax."
(error "make-skribe-reader: unsupported version" version)
%skribe-reader))
+(define (make-colon-free-token-reader tr)
+ ;; Stolen from `guile-reader' 0.3.
+ "If token reader @var{tr} handles the @code{:} (colon) character, remove it
+from its specification and return the new token reader."
+ (let* ((spec (r:token-reader-specification tr))
+ (proc (r:token-reader-procedure tr)))
+ (r:make-token-reader (filter (lambda (chr)
+ (not (char=? chr #\:)))
+ spec)
+ proc)))
+
(define &sharp-reader
;; The reader for what comes after a `#' character.
(let* ((dsssl-keyword-reader ;; keywords à la `#!key'
@@ -65,18 +77,23 @@ the Skribe syntax."
(let ((colon-keywords ;; keywords à la `:key' fashion
(r:make-token-reader #\:
(r:token-reader-procedure
- (r:standard-token-reader 'keyword)))))
+ (r:standard-token-reader 'keyword))))
+ (symbol-misc-chars-tr
+ ;; Make sure `:' is handled only by the keyword token reader.
+ (make-colon-free-token-reader
+ (r:standard-token-reader 'r6rs-symbol-misc-chars))))
+
;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since
;; they consider square brackets as delimiters.
(r:make-reader (cons* (r:make-token-reader #\# &sharp-reader)
colon-keywords
+ symbol-misc-chars-tr
(map r:standard-token-reader
`(whitespace
sexp string r6rs-number
r6rs-symbol-lower-case
r6rs-symbol-upper-case
- r6rs-symbol-misc-chars
quote-quasiquote-unquote
semicolon-comment
skribe-exp)))
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 34d6bde..224bc06 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -16,24 +16,70 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo resolve)
:use-module (skribilo debug)
- :use-module (skribilo runtime)
:use-module (skribilo ast)
:use-module (skribilo utils syntax)
:use-module (oop goops)
:use-module (srfi srfi-39)
+ :use-module (skribilo condition)
+ :use-module (srfi srfi-34)
+ :use-module (srfi srfi-35)
+
:export (resolve! resolve-search-parent resolve-children resolve-children*
- find1 resolve-counter resolve-parent resolve-ident))
+ find1 resolve-counter resolve-parent resolve-ident
+
+ &resolution-error resolution-error?
+ &resolution-orphan-error resolution-orphan-error?
+ resolution-orphan-error:ast))
(fluid-set! current-reader %skribilo-module-reader)
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &resolution-error &skribilo-error
+ resolution-error?)
+
+(define-condition-type &resolution-orphan-error &resolution-error
+ resolution-orphan-error?
+ (ast resolution-orphan-error:ast))
+
+
+(define (handle-resolution-error c)
+ ;; Issue a user-friendly error message for error condition C.
+ (cond ((resolution-orphan-error? c)
+ (let* ((node (resolution-orphan-error:ast c))
+ (location (and (ast? node) (ast-loc node))))
+ (format (current-error-port) "orphan node: ~a~a~%"
+ node
+ (if (location? location)
+ (string-append " "
+ (location-file location) ":"
+ (location-line location))
+ ""))))
+
+ (else
+ (format (current-error-port) "undefined resolution error: ~a~%"
+ c))))
+
+(register-error-condition-handler! resolution-error?
+ handle-resolution-error)
+
+
+
+;;;
+;;; Resolving nodes.
+;;;
+
(define *unresolved* (make-parameter #f))
(define-generic do-resolve!)
@@ -81,7 +127,9 @@
(set-car! n* (do-resolve! (car n*) engine env))
(set-cdr! n* (do-resolve! (cdr n*) engine env)))
(else
- (error 'do-resolve "illegal argument" n*)))))
+ (raise (condition (&invalid-argument-error
+ (proc-name "do-resolve!<pair>")
+ (argument n*))))))))
(define-method (do-resolve! (node <node>) engine env)
@@ -186,7 +234,7 @@
(cadr c)
n)))
((eq? (slot-ref n 'parent) 'unspecified)
- (skribe-error 'resolve-parent "orphan node" n))
+ (raise (condition (&resolution-orphan-error (ast n)))))
(else
(slot-ref n 'parent)))))
@@ -219,7 +267,7 @@
(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)
+ (raise (condition (&resolution-orphan-error (ast n))))
(begin
(set-cdr! (last-pair e)
(list (list (symbol-append cnt '-counter) 0)
@@ -252,10 +300,9 @@
(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")
+ (raise (condition (&invalid-argument-error ;; type error
+ (proc-name "resolve-ident")
+ (argument ident))))
(let ((mks (find-markups ident)))
(and mks
(if (not markup)
diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am
index e005313..4b5797f 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 bib.scm index.scm param.scm sui.scm utils.scm
+dist_guilemodule_DATA = param.scm sui.scm
diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm
deleted file mode 100644
index 2bc2238..0000000
--- a/src/guile/skribilo/skribe/bib.scm
+++ /dev/null
@@ -1,215 +0,0 @@
-;;; lib.scm
-;;;
-;;; Copyright 2001, 2002, 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 bib)
- :use-module (skribilo biblio))
-
-;;; Author: Manuel Serrano
-;;; Commentary:
-;;;
-;;; A library of bibliography-related functions.
-;;;
-;;; Code:
-
-
-;;; The contents of the file below are unchanged compared to Skribe 1.2d's
-;;; `bib.scm' file found in the `common' directory.
-
-;*---------------------------------------------------------------------*/
-;* bib-load! ... */
-;*---------------------------------------------------------------------*/
-(define-public (bib-load! table filename command)
- (if (not (bib-table? table))
- (skribe-error 'bib-load "Illegal bibliography table" table)
- ;; read the file
- (let ((p (skribe-open-bib-file filename command)))
- (if (not (input-port? p))
- (skribe-error 'bib-load "Can't open data base" filename)
- (unwind-protect
- (parse-bib table p)
- (close-input-port p))))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-bib ... */
-;*---------------------------------------------------------------------*/
-(define-public (resolve-bib table ident)
- (if (not (bib-table? table))
- (skribe-error 'resolve-bib "Illegal bibliography table" table)
- (let* ((i (cond
- ((string? ident) ident)
- ((symbol? ident) (symbol->string ident))
- (else (skribe-error 'resolve-bib "Illegal ident" ident))))
- (en (hashtable-get table i)))
- (if (is-markup? en '&bib-entry)
- en
- #f))))
-
-;*---------------------------------------------------------------------*/
-;* make-bib-entry ... */
-;*---------------------------------------------------------------------*/
-(define-public (make-bib-entry kind ident fields from)
- (let* ((m (new markup
- (markup '&bib-entry)
- (ident ident)
- (options `((kind ,kind) (from ,from)))))
- (h (new handle
- (ast m))))
- (for-each (lambda (f)
- (if (and (pair? f)
- (pair? (cdr f))
- (null? (cddr f))
- (symbol? (car f)))
- (markup-option-add! m
- (car f)
- (new markup
- (markup (symbol-append
- '&bib-entry-
- (car f)))
- (parent h)
- (body (cadr f))))
- (bib-parse-error f)))
- fields)
- m))
-
-;*---------------------------------------------------------------------*/
-;* bib-sort/authors ... */
-;*---------------------------------------------------------------------*/
-(define-public (bib-sort/authors l)
- (define (cmp i1 i2 def)
- (cond
- ((and (markup? i1) (markup? i2))
- (cmp (markup-body i1) (markup-body i2) def))
- ((markup? i1)
- (cmp (markup-body i1) i2 def))
- ((markup? i2)
- (cmp i1 (markup-body i2) def))
- ((and (string? i1) (string? i2))
- (if (string=? i1 i2)
- (def)
- (string<? i1 i2)))
- ((string? i1)
- #f)
- ((string? i2)
- #t)
- (else
- (def))))
- (sort l (lambda (e1 e2)
- (cmp (markup-option e1 'author)
- (markup-option e2 'author)
- (lambda ()
- (cmp (markup-option e1 'year)
- (markup-option e2 'year)
- (lambda ()
- (cmp (markup-option e1 'title)
- (markup-option e2 'title)
- (lambda ()
- (cmp (markup-ident e1)
- (markup-ident e2)
- (lambda ()
- #t)))))))))))
-
-;*---------------------------------------------------------------------*/
-;* bib-sort/idents ... */
-;*---------------------------------------------------------------------*/
-(define-public (bib-sort/idents l)
- (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f)))))
-
-;*---------------------------------------------------------------------*/
-;* bib-sort/dates ... */
-;*---------------------------------------------------------------------*/
-(define-public (bib-sort/dates l)
- (sort l (lambda (p1 p2)
- (define (month-num m)
- (let ((body (markup-body m)))
- (if (not (string? body))
- 13
- (let* ((s (if (> (string-length body) 3)
- (substring body 0 3)
- body))
- (sy (string->symbol (string-downcase body)))
- (c (assq sy '((jan . 1)
- (feb . 2)
- (mar . 3)
- (apr . 4)
- (may . 5)
- (jun . 6)
- (jul . 7)
- (aug . 8)
- (sep . 9)
- (oct . 10)
- (nov . 11)
- (dec . 12)))))
- (if (pair? c) (cdr c) 13)))))
- (let ((d1 (markup-option p1 'year))
- (d2 (markup-option p2 'year)))
- (cond
- ((not (markup? d1)) #f)
- ((not (markup? d2)) #t)
- (else
- (let ((y1 (markup-body d1))
- (y2 (markup-body d2)))
- (cond
- ((string>? y1 y2) #t)
- ((string<? y1 y2) #f)
- (else
- (let ((d1 (markup-option p1 'month))
- (d2 (markup-option p2 'month)))
- (cond
- ((not (markup? d1)) #f)
- ((not (markup? d2)) #t)
- (else
- (let ((m1 (month-num d1))
- (m2 (month-num d2)))
- (> m1 m2))))))))))))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-the-bib ... */
-;*---------------------------------------------------------------------*/
-(define-public (resolve-the-bib table n sort pred count opts)
- (define (count! entries)
- (let loop ((es entries)
- (i 1))
- (if (pair? es)
- (begin
- (markup-option-add! (car es)
- :title
- (new markup
- (markup '&bib-entry-ident)
- (parent (car es))
- (options `((number ,i)))
- (body (new handle
- (ast (car es))))))
- (loop (cdr es) (+ i 1))))))
- (if (not (bib-table? table))
- (skribe-error 'resolve-the-bib "Illegal bibliography table" table)
- (let* ((es (sort (hashtable->list table)))
- (fes (filter (if (procedure? pred)
- (lambda (m) (pred m n))
- (lambda (m) (pair? (markup-option m 'used))))
- es)))
- (count! (if (eq? count 'full) es fes))
- (new markup
- (markup '&the-bibliography)
- (options opts)
- (body fes)))))
-
-
-;;; bib.scm ends here
diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm
index 6aebd0a..2084b00 100644
--- a/src/guile/skribilo/skribe/param.scm
+++ b/src/guile/skribilo/skribe/param.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo skribe param))
diff --git a/src/guile/skribilo/skribe/sui.scm b/src/guile/skribilo/skribe/sui.scm
index 9baa36a..333e794 100644
--- a/src/guile/skribilo/skribe/sui.scm
+++ b/src/guile/skribilo/skribe/sui.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-skribe-module (skribilo skribe sui))
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/source.scm b/src/guile/skribilo/source.scm
index 24e4b67..a61de4f 100644
--- a/src/guile/skribilo/source.scm
+++ b/src/guile/skribilo/source.scm
@@ -16,7 +16,7 @@
;;;;
;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am
index fa693a1..9d9df6f 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 strings.scm
## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f
diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm
index 24ce784..c8c3bd0 100644
--- a/src/guile/skribilo/utils/compat.scm
+++ b/src/guile/skribilo/utils/compat.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
@@ -32,6 +32,7 @@
:autoload (skribilo ast) (ast?)
:autoload (skribilo condition) (file-search-error? &file-search-error)
:autoload (skribilo reader) (make-reader)
+ :autoload (skribilo lib) (type-name)
:use-module (skribilo debug)
:re-export (file-size) ;; re-exported from `(skribilo utils files)'
:replace (gensym))
@@ -169,7 +170,7 @@
(define-public skribe-eval-port evaluate-document-from-port)
(set! %skribe-reader #f)
-(define* (skribe-read #:optional (port (current-input-port)))
+(define*-public (skribe-read #:optional (port (current-input-port)))
(if (not %skribe-reader)
(set! %skribe-reader (make-reader 'skribe)))
(%skribe-reader port))
@@ -248,20 +249,11 @@
(hash-set! table key init-value)
(set-cdr! handle (update-proc (cdr handle))))))
-(define-public hashtable->list (lambda (h)
- (map cdr (hash-map->list cons h))))
+(define-public (hashtable->list h)
+ (hash-map->list (lambda (key val) val) h))
(define-public (find-runtime-type obj)
- (cond ((string? obj) "string")
- ((ast? obj) "ast")
- ((list? obj) "list")
- ((pair? obj) "pair")
- ((number? obj) "number")
- ((char? obj) "character")
- ((keyword? obj) "keyword")
- (else (with-output-to-string
- (lambda () (write obj))))))
-
+ (type-name obj))
;;;
@@ -270,7 +262,17 @@
(use-modules ((srfi srfi-19) #:renamer (symbol-prefix-proc 's19:)))
-(define (date)
+(define-public (date)
(s19:date->string (s19:current-date) "~c"))
+(define-public (correct-arity? proc argcount)
+ (let ((a (procedure-property proc 'arity)))
+ (and (pair? a)
+ (let ((compulsory (car a))
+ (optional (cadr a))
+ (rest? (caddr a)))
+ (or rest?
+ (>= (+ compulsory optional) argcount))))))
+
+
;;; compat.scm ends here
diff --git a/src/guile/skribilo/utils/files.scm b/src/guile/skribilo/utils/files.scm
index 7eb1cf2..6d89d4d 100644
--- a/src/guile/skribilo/utils/files.scm
+++ b/src/guile/skribilo/utils/files.scm
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo utils files)
diff --git a/src/guile/skribilo/utils/images.scm b/src/guile/skribilo/utils/images.scm
index 2d163bc..24405d6 100644
--- a/src/guile/skribilo/utils/images.scm
+++ b/src/guile/skribilo/utils/images.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo utils images)
diff --git a/src/guile/skribilo/utils/keywords.scm b/src/guile/skribilo/utils/keywords.scm
new file mode 100644
index 0000000..1bcd5dc
--- /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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; 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
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/utils/strings.scm
index 73d776c..e8e8f8f 100644
--- a/src/guile/skribilo/runtime.scm
+++ b/src/guile/skribilo/utils/strings.scm
@@ -1,4 +1,4 @@
-;;; runtime.scm -- Skribilo runtime system
+;;; strings.scm -- Convenience functions to manipulate strings.
;;;
;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
@@ -15,31 +15,24 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
-(define-module (skribilo runtime)
- ;; FIXME: Useful procedures are scattered between here and
- ;; `(skribilo skribe utils)'.
- :export (;; Utilities
- strip-ref-base string-canonicalize
-
- ;; String writing
+(define-module (skribilo utils strings)
+ :export (strip-ref-base string-canonicalize
make-string-replace)
:autoload (skribilo parameters) (*ref-base*)
:use-module (skribilo lib)
:use-module (srfi srfi-13))
-
-;;; ======================================================================
+
;;;
-;;; U T I L I T I E S
+;;; Utilities.
;;;
-;;; ======================================================================
-
-;;FIXME: Remonter cette fonction
(define (strip-ref-base file)
+ ;; Given FILE, a file path (a string), remove `(*ref-base*)' from it.
+ ;; This is useful, e.g., for hyperlinks.
(if (not (string? (*ref-base*)))
file
(let ((l (string-length (*ref-base*))))
@@ -54,8 +47,9 @@
(substring file (+ l 1) (string-length file)))))))
-;; FIXME: Remonter cette fonction
(define (string-canonicalize old)
+ ;; Return a string that is a canonical summarized representation of string
+ ;; OLD. This is a one-way function.
(let* ((l (string-length old))
(new (make-string l)))
(let loop ((r 0)
@@ -88,11 +82,10 @@
-;;; ======================================================================
+
;;;
-;;; S T R I N G - W R I T I N G
+;;; String writing.
;;;
-;;; ======================================================================
;;
;; (define (%make-html-replace)
@@ -136,17 +129,17 @@
str)
(get-output-string out)))))
-(define string->html
- (%make-general-string-replace '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;")
- (#\> "&gt;"))))
+(define %html-replacements
+ '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
+
+(define %string->html
+ (%make-general-string-replace %html-replacements))
(define (make-string-replace lst)
(let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
(cond
- ((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
- string->html)
+ ((equal? l %html-replacements)
+ %string->html)
(else
(%make-general-string-replace lst)))))
-
-
diff --git a/src/guile/skribilo/utils/syntax.scm b/src/guile/skribilo/utils/syntax.scm
index f7a5990..44bff09 100644
--- a/src/guile/skribilo/utils/syntax.scm
+++ b/src/guile/skribilo/utils/syntax.scm
@@ -1,6 +1,6 @@
;;; syntax.scm -- Syntactic candy for Skribilo 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
@@ -15,7 +15,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo utils syntax)
@@ -30,21 +30,33 @@
;;;
;;; Commentary:
;;;
-;;; A reader for the Skribe syntax, i.e. roughly R5RS Scheme plus DSSSL-style
-;;; keywords and sk-exps (expressions introduced using a square bracket).
+;;; This module provides syntactic candy for Skribilo modules, i.e., a syntax
+;;; similar to Guile's default syntax with a few extensions, plus various
+;;; convenience macros.
;;;
;;; Code:
(define %skribilo-module-reader
;; The syntax used to read Skribilo modules.
- (make-alternate-guile-reader '(colon-keywords
- no-scsh-block-comments
- srfi30-block-comments
- srfi62-sexp-comments)
- (lambda (chr port read)
- (error "unexpected character in Skribilo module"
- chr))
- 'reader/record-positions))
+ (apply make-alternate-guile-reader
+ '(colon-keywords no-scsh-block-comments
+ srfi30-block-comments srfi62-sexp-comments)
+ (lambda (chr port read)
+ (let ((file (port-filename port))
+ (line (port-line port))
+ (column (port-column port)))
+ (error (string-append
+ (if (string? file)
+ (format #f "~a:~a:~a: " file line column)
+ "")
+ "unexpected character in Skribilo module")
+ chr)))
+
+ ;; By default, don't record positions: this yields a nice read
+ ;; performance improvement.
+ (if (memq 'debug (debug-options))
+ (list 'reader/record-positions)
+ '())))
(define %skribe-reader
;; The Skribe syntax reader.
diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm
index 960ca6b..052b5cc 100644
--- a/src/guile/skribilo/verify.scm
+++ b/src/guile/skribilo/verify.scm
@@ -16,18 +16,17 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo verify)
- :autoload (skribilo engine) (engine-ident)
+ :autoload (skribilo engine) (engine-ident processor-get-engine)
:autoload (skribilo writer) (writer? writer-options lookup-markup-writer)
:autoload (skribilo lib) (skribe-warning/ast skribe-warning
skribe-error)
:export (verify))
(use-modules (skribilo debug)
- (skribilo runtime)
(skribilo ast)
(skribilo utils syntax)
(oop goops))
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
index b46cddc..b16819d 100644
--- a/src/guile/skribilo/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -16,7 +16,7 @@
;;;
;;; 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,
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;; USA.
(define-module (skribilo writer)
diff --git a/src/skribilo.in b/src/skribilo.in
index 7d3a78d..8d49f84 100755
--- a/src/skribilo.in
+++ b/src/skribilo.in
@@ -15,7 +15,7 @@
#
# 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,
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
# USA.
# The `skribilo' executable.
@@ -26,10 +26,13 @@
# `--debug' had not been passed, not displaying a stack trace. See
# http://lists.gnu.org/archive/html/guile-devel/2006-01/msg00022.html
# for details.
+#
+# In any case, don't pass `--debug' by default (for performance
+# reason). When needed, the use should explicitly set the `GUILE'
+# environment variable to, e.g., "guile --debug".
main='(module-ref (resolve-module '\''(skribilo)) '\'main')'
-exec ${GUILE-@GUILE@} --debug \
- -c "
+exec ${GUILE-@GUILE@} -c "
(use-modules (skribilo condition))
(call-with-skribilo-error-catch