aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorLudovic Courtes2005-07-01 13:33:34 +0000
committerLudovic Courtes2005-07-01 13:33:34 +0000
commita85155f7c411761cfbd75431f265675ae0f394e3 (patch)
tree3b3bb9c26e2b79653f1b0fe193ae64964b2f624a /src
parentc323ee2c0207a02d8af1d0366fdf000f051fdb27 (diff)
downloadskribilo-a85155f7c411761cfbd75431f265675ae0f394e3.tar.gz
skribilo-a85155f7c411761cfbd75431f265675ae0f394e3.tar.lz
skribilo-a85155f7c411761cfbd75431f265675ae0f394e3.zip
Lots of changes.
Too many changes to describe here, among which, moving the `(skribe)' module namespace to `(skribilo)'. This is work in progress. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-1
Diffstat (limited to 'src')
-rw-r--r--src/guile/skribe/configure.scm112
-rw-r--r--src/guile/skribe/reader.scm136
-rw-r--r--src/guile/skribe/types.scm314
-rw-r--r--src/guile/skribe/vars.scm82
-rwxr-xr-xsrc/guile/skribilo.scm68
-rw-r--r--src/guile/skribilo/Makefile.in (renamed from src/guile/skribe/Makefile.in)0
-rw-r--r--src/guile/skribilo/biblio.scm (renamed from src/guile/skribe/biblio.scm)120
-rw-r--r--src/guile/skribilo/color.scm (renamed from src/guile/skribe/color.scm)2
-rw-r--r--src/guile/skribilo/coloring/c-lex.l (renamed from src/guile/skribe/c-lex.l)0
-rw-r--r--src/guile/skribilo/coloring/c.scm (renamed from src/guile/skribe/c.scm)2
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l (renamed from src/guile/skribe/lisp-lex.l)0
-rw-r--r--src/guile/skribilo/coloring/lisp.scm (renamed from src/guile/skribe/lisp.scm)2
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l (renamed from src/guile/skribe/xml-lex.l)0
-rw-r--r--src/guile/skribilo/coloring/xml.scm (renamed from src/guile/skribe/xml.scm)4
-rw-r--r--src/guile/skribilo/config.scm.in21
-rw-r--r--src/guile/skribilo/debug.scm (renamed from src/guile/skribe/debug.scm)89
-rw-r--r--src/guile/skribilo/engine.scm (renamed from src/guile/skribe/engine.scm)134
-rw-r--r--src/guile/skribilo/eval.scm (renamed from src/guile/skribe/eval.scm)113
-rw-r--r--src/guile/skribilo/lib.scm (renamed from src/guile/skribe/lib.scm)164
-rw-r--r--src/guile/skribilo/module.scm118
-rw-r--r--src/guile/skribilo/output.scm (renamed from src/guile/skribe/output.scm)6
-rw-r--r--src/guile/skribilo/prog.scm (renamed from src/guile/skribe/prog.scm)0
-rw-r--r--src/guile/skribilo/reader.scm82
-rw-r--r--src/guile/skribilo/reader/skribe.scm80
-rw-r--r--src/guile/skribilo/resolve.scm (renamed from src/guile/skribe/resolve.scm)8
-rw-r--r--src/guile/skribilo/runtime.scm (renamed from src/guile/skribe/runtime.scm)316
-rw-r--r--src/guile/skribilo/skribe/api.scm1260
-rw-r--r--src/guile/skribilo/skribe/bib.scm215
-rw-r--r--src/guile/skribilo/skribe/index.scm149
-rw-r--r--src/guile/skribilo/skribe/param.scm93
-rw-r--r--src/guile/skribilo/skribe/sui.scm187
-rw-r--r--src/guile/skribilo/skribe/utils.scm259
-rw-r--r--src/guile/skribilo/source.scm (renamed from src/guile/skribe/source.scm)2
-rw-r--r--src/guile/skribilo/types.scm315
-rw-r--r--src/guile/skribilo/vars.scm65
-rw-r--r--src/guile/skribilo/verify.scm (renamed from src/guile/skribe/verify.scm)12
-rw-r--r--src/guile/skribilo/writer.scm (renamed from src/guile/skribe/writer.scm)8
37 files changed, 3399 insertions, 1139 deletions
diff --git a/src/guile/skribe/configure.scm b/src/guile/skribe/configure.scm
deleted file mode 100644
index 36b6540..0000000
--- a/src/guile/skribe/configure.scm
+++ /dev/null
@@ -1,112 +0,0 @@
-;;;;
-;;;; configure.stk -- Skribe configuration options
-;;;;
-;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 10-Feb-2004 11:47 (eg)
-;;;; Last file update: 17-Feb-2004 09:43 (eg)
-;;;;
-
-(define-module (skribe configure)
- :export (skribe-release skribe-scheme skribe-url
- skribe-doc-dir skribe-ext-dir skribe-default-path
-
- skribe-configure skribe-enforce-configure))
-
-(define (skribe-release)
- "1.2d/skribilo")
-
-(define (skribe-scheme)
- "Guile")
-
-(define (skribe-url)
- "http://www.google.com")
-
-;; FIXME: The directory names should be defined at installation time.
-
-(define (skribe-doc-dir)
- "/usr/share/doc/skribilo")
-
-(define (skribe-ext-dir)
- "/usr/share/skribilo/ext")
-
-(define (skribe-default-path)
- "/usr/share/skribe/")
-
-
-(define %skribe-conf
- `((:release ,(skribe-release))
- (:scheme ,(skribe-scheme))
- (:url ,(skribe-url))
- (:doc-dir ,(skribe-doc-dir))
- (:ext-dir ,(skribe-ext-dir))
- (:default-path ,(skribe-default-path))))
-
-;;;
-;;; SKRIBE-CONFIGURE
-;;;
-(define (skribe-configure . opt)
- (let ((conf %skribe-conf))
- (cond
- ((null? opt)
- conf)
- ((null? (cdr opt))
- (let ((cell (assq (car opt) conf)))
- (if (pair? cell)
- (cadr cell)
- 'void)))
- (else
- (let loop ((opt opt))
- (cond
- ((null? opt)
- #t)
- ((not (keyword? (car opt)))
- #f)
- ((or (null? (cdr opt)) (keyword? (cadr opt)))
- #f)
- (else
- (let ((cell (assq (car opt) conf)))
- (if (and (pair? cell)
- (if (procedure? (cadr opt))
- ((cadr opt) (cadr cell))
- (equal? (cadr opt) (cadr cell))))
- (loop (cddr opt))
- #f)))))))))
-;;;
-;;; SKRIBE-ENFORCE-CONFIGURE ...
-;;;
-(define (skribe-enforce-configure . opt)
- (let loop ((o opt))
- (when (pair? o)
- (cond
- ((or (not (keyword? (car o)))
- (null? (cdr o)))
- (skribe-error 'skribe-enforce-configure "Illegal enforcement" opt))
- ((skribe-configure (car o) (cadr o))
- (loop (cddr o)))
- (else
- (skribe-error 'skribe-enforce-configure
- (format "Configuration mismatch: ~a" (car o))
- (if (procedure? (cadr o))
- (format "provided `~a'"
- (skribe-configure (car o)))
- (format "provided `~a', required `~a'"
- (skribe-configure (car o))
- (cadr o)))))))))
diff --git a/src/guile/skribe/reader.scm b/src/guile/skribe/reader.scm
deleted file mode 100644
index bd38562..0000000
--- a/src/guile/skribe/reader.scm
+++ /dev/null
@@ -1,136 +0,0 @@
-;;;;
-;;;; reader.stk -- Reader hook for the open bracket
-;;;;
-;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@unice.fr]
-;;;; Creation date: 6-Dec-2001 22:59 (eg)
-;;;; Last file update: 28-Feb-2004 10:22 (eg)
-;;;;
-
-;; Examples of ISO-2022-JP (here for cut'n paste tests, since my japanese
-;; is *very* limited ;-).
-;;
-;; "Japan" $BF|K\(B
-;; "China and Chinese music" $BCf9q$HCf9q$N2;3Z(B
-
-
-;;
-;; This function is a hook for the standard reader. After defining,
-;; %read-bracket, the reader calls it when it encounters an open
-;; bracket
-
-
-(define (%read-bracket in)
-
- (define (read-japanese in)
- ;; This function reads an ISO-2022-JP sequence. Susch s sequence is coded
- ;; as "^[$B......^[(B" . When entering in this function the current
- ;; character is 'B' (the opening sequence one). Function reads until the
- ;; end of the sequence and return it as a string
- (read-char in) ;; to skip the starting #\B
- (let ((res (open-output-string)))
- (let Loop ((c (peek-char in)))
- (cond
- ((eof-object? c) ;; EOF
- (error '%read-bracket "EOF encountered"))
- ((char=? c #\escape)
- (read-char in)
- (let ((next1 (peek-char in)))
- (if (char=? next1 #\()
- (begin
- (read-char in)
- (let ((next2 (peek-char in)))
- (if (char=? next2 #\B)
- (begin
- (read-char in)
- (format "\033$B~A\033(B" (get-output-string res)))
- (begin
- (format res "\033~A" next1)
- (Loop next2)))))
- (begin
- (display #\escape res)
- (Loop next1)))))
- (else (display (read-char in) res)
- (Loop (peek-char in)))))))
- ;;
- ;; Body of %read-bracket starts here
- ;;
- (let ((out (open-output-string))
- (res '())
- (in-string? #f))
-
- (read-char in) ; skip open bracket
-
- (let Loop ((c (peek-char in)))
- (cond
- ((eof-object? c) ;; EOF
- (error '%read-bracket "EOF encountered"))
-
- ((char=? c #\escape) ;; ISO-2022-JP string?
- (read-char in)
- (let ((next1 (peek-char in)))
- (if (char=? next1 #\$)
- (begin
- (read-char in)
- (let ((next2 (peek-char in)))
- (if (char=? next2 #\B)
- (begin
- (set! res
- (append! res
- (list (get-output-string out)
- (list 'unquote
- (list 'jp
- (read-japanese in))))))
- (set! out (open-output-string)))
- (format out "\033~A" next1))))
- (display #\escape out)))
- (Loop (peek-char in)))
-
- ((char=? c #\\) ;; Quote char
- (read-char in)
- (display (read-char in) out)
- (Loop (peek-char in)))
-
- ((and (not in-string?) (char=? c #\,)) ;; Comma
- (read-char in)
- (let ((next (peek-char in)))
- (if (char=? next #\()
- (begin
- (set! res (append! res (list (get-output-string out)
- (list 'unquote
- (read in)))))
- (set! out (open-output-string)))
- (display #\, out))
- (Loop (peek-char in))))
-
- ((and (not in-string?) (char=? c #\[)) ;; Open bracket
- (display (%read-bracket in) out)
- (Loop (peek-char in)))
-
- ((and (not in-string?) (char=? c #\])) ;; Close bracket
- (read-char in)
- (let ((str (get-output-string out)))
- (list 'quasiquote
- (append! res (if (string=? str "") '() (list str))))))
-
- (else (when (char=? c #\") (set! in-string? (not in-string?)))
- (display (read-char in) out)
- (Loop (peek-char in)))))))
-
diff --git a/src/guile/skribe/types.scm b/src/guile/skribe/types.scm
deleted file mode 100644
index 2ec7318..0000000
--- a/src/guile/skribe/types.scm
+++ /dev/null
@@ -1,314 +0,0 @@
-;;;;
-;;;; types.stk -- Definition of Skribe classes
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 12-Aug-2003 22:18 (eg)
-;;;; Last file update: 28-Oct-2004 16:18 (eg)
-;;;;
-
-(define-module (skribe types) ;; FIXME: Why should it be a separate module?
- :export (<ast> ast? ast-loc ast-loc-set!
- <command> command? command-fmt command-body
- <unresolved> unresolved? unresolved-proc
- <handle> handle? handle-ast
- <node> node? node-options node-loc
- <engine> engine? engine-ident engine-format engine-customs
- engine-filter engine-symbol-table
- <writer> writer? write-object
- <processor> processor? processor-combinator processor-engine
- <markup> markup? bind-markup! markup-options is-markup?
- markup-body find-markups write-object
- <container> container? container-options
- container-ident container-body
- <document> document? document-ident document-body
- document-options document-end
- <language> language?
- <location> location? ast-location
-
- *node-table*)
- :use-module (oop goops))
-
-(define *node-table* (make-hash-table))
- ; Used to stores the nodes of an AST.
- ; It permits to retrieve a node from its
- ; identifier.
-
-
-;;;; ======================================================================
-;;;;
-;;;; <AST>
-;;;;
-;;;; ======================================================================
-;;FIXME: set! location in <ast>
-(define-class <ast> ()
- (parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified)
- (loc :init-form #f))
-
-(define (ast? obj) (is-a? obj <ast>))
-(define (ast-loc obj) (slot-ref obj 'loc))
-(define (ast-loc-set! obj v) (slot-set! obj 'loc v))
-
-;;;; ======================================================================
-;;;;
-;;;; <COMMAND>
-;;;;
-;;;; ======================================================================
-(define-class <command> (<ast>)
- (fmt :init-keyword :fmt)
- (body :init-keyword :body))
-
-(define (command? obj) (is-a? obj <command>))
-(define (command-fmt obj) (slot-ref obj 'fmt))
-(define (command-body obj) (slot-ref obj 'body))
-
-;;;; ======================================================================
-;;;;
-;;;; <UNRESOLVED>
-;;;;
-;;;; ======================================================================
-(define-class <unresolved> (<ast>)
- (proc :init-keyword :proc))
-
-(define (unresolved? obj) (is-a? obj <unresolved>))
-(define (unresolved-proc obj) (slot-ref obj 'proc))
-
-;;;; ======================================================================
-;;;;
-;;;; <HANDLE>
-;;;;
-;;;; ======================================================================
-(define-class <handle> (<ast>)
- (ast :init-keyword :ast :init-form #f :getter handle-ast))
-
-(define (handle? obj) (is-a? obj <handle>))
-(define (handle-ast obj) (slot-ref obj 'ast))
-
-;;;; ======================================================================
-;;;;
-;;;; <ENGINE>
-;;;;
-;;;; ======================================================================
-(define-class <engine> ()
- (ident :init-keyword :ident :init-form '???)
- (format :init-keyword :format :init-form "raw")
- (info :init-keyword :info :init-form '())
- (version :init-keyword :version :init-form 'unspecified)
- (delegate :init-keyword :delegate :init-form #f)
- (writers :init-keyword :writers :init-form '())
- (filter :init-keyword :filter :init-form #f)
- (customs :init-keyword :custom :init-form '())
- (symbol-table :init-keyword :symbol-table :init-form '()))
-
-
-
-
-(define (engine? obj)
- (is-a? obj <engine>))
-
-(define (engine-ident obj) ;; Define it here since the doc searches it
- (slot-ref obj 'ident))
-
-(define (engine-format obj) ;; Define it here since the doc searches it
- (slot-ref obj 'format))
-
-(define (engine-customs obj) ;; Define it here since the doc searches it
- (slot-ref obj 'customs))
-
-(define (engine-filter obj) ;; Define it here since the doc searches it
- (slot-ref obj 'filter))
-
-(define (engine-symbol-table obj) ;; Define it here since the doc searches it
- (slot-ref obj 'symbol-table))
-
-;;;; ======================================================================
-;;;;
-;;;; <WRITER>
-;;;;
-;;;; ======================================================================
-(define-class <writer> ()
- (ident :init-keyword :ident :init-form '??? :getter writer-ident)
- (class :init-keyword :class :init-form 'unspecified
- :getter writer-class)
- (pred :init-keyword :pred :init-form 'unspecified)
- (upred :init-keyword :upred :init-form 'unspecified)
- (options :init-keyword :options :init-form '() :getter writer-options)
- (verified? :init-keyword :verified? :init-form #f)
- (validate :init-keyword :validate :init-form #f)
- (before :init-keyword :before :init-form #f :getter writer-before)
- (action :init-keyword :action :init-form #f :getter writer-action)
- (after :init-keyword :after :init-form #f :getter writer-after))
-
-(define (writer? obj)
- (is-a? obj <writer>))
-
-(define-method (write-object (obj <writer>) port)
- (format port "#[~A (~A) ~A]"
- (class-name (class-of obj))
- (slot-ref obj 'ident)
- (address-of obj)))
-
-;;;; ======================================================================
-;;;;
-;;;; <NODE>
-;;;;
-;;;; ======================================================================
-(define-class <node> (<ast>)
- (required-options :init-keyword :required-options :init-form '())
- (options :init-keyword :options :init-form '())
- (body :init-keyword :body :init-form #f
- :getter node-body))
-
-(define (node? obj) (is-a? obj <node>))
-(define (node-options obj) (slot-ref obj 'options))
-(define node-loc ast-loc)
-
-
-;;;; ======================================================================
-;;;;
-;;;; <PROCESSOR>
-;;;;
-;;;; ======================================================================
-(define-class <processor> (<node>)
- (combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1))
- (engine :init-keyword :engine :init-form 'unspecified)
- (procedure :init-keyword :procedure :init-form (lambda (n e) n)))
-
-(define (processor? obj) (is-a? obj <processor>))
-(define (processor-combinator obj) (slot-ref obj 'combinator))
-(define (processor-engine obj) (slot-ref obj 'engine))
-
-;;;; ======================================================================
-;;;;
-;;;; <MARKUP>
-;;;;
-;;;; ======================================================================
-(define-class <markup> (<node>)
- (ident :init-keyword :ident :getter markup-ident :init-form #f)
- (class :init-keyword :class :getter markup-class :init-form #f)
- (markup :init-keyword :markup :getter markup-markup))
-
-
-(define (bind-markup! node)
- (hash-set! *node-table*
- (markup-ident node)
- ;(lambda (cur) (cons node cur))
- (list node)))
-
-
-(define-method (initialize (self <markup>) initargs)
- (next-method)
- (bind-markup! self))
-
-
-(define (markup? obj) (is-a? obj <markup>))
-(define (markup-options obj) (slot-ref obj 'options))
-(define markup-body node-body)
-
-
-(define (is-markup? obj markup)
- (and (is-a? obj <markup>)
- (eq? (slot-ref obj 'markup) markup)))
-
-
-
-(define (find-markups ident)
- (hash-ref *node-table* ident #f))
-
-
-(define-method (write-object (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)))
-
-;;;; ======================================================================
-;;;;
-;;;; <CONTAINER>
-;;;;
-;;;; ======================================================================
-(define-class <container> (<markup>)
- (env :init-keyword :env :init-form '()))
-
-(define (container? obj) (is-a? obj <container>))
-(define (container-env obj) (slot-ref obj 'env))
-(define container-options markup-options)
-(define container-ident markup-ident)
-(define container-body node-body)
-
-
-
-;;;; ======================================================================
-;;;;
-;;;; <DOCUMENT>
-;;;;
-;;;; ======================================================================
-(define-class <document> (<container>))
-
-(define (document? obj) (is-a? obj <document>))
-(define (document-ident obj) (slot-ref obj 'ident))
-(define (document-body obj) (slot-ref obj 'body))
-(define document-options markup-options)
-(define document-env container-env)
-
-
-
-;;;; ======================================================================
-;;;;
-;;;; <LANGUAGE>
-;;;;
-;;;; ======================================================================
-(define-class <language> ()
- (name :init-keyword :name :init-form #f :getter langage-name)
- (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier)
- (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))
-
-(define (language? obj)
- (is-a? obj <language>))
-
-
-;;;; ======================================================================
-;;;;
-;;;; <LOCATION>
-;;;;
-;;;; ======================================================================
-(define-class <location> ()
- (file :init-keyword :file :getter location-file)
- (pos :init-keyword :pos :getter location-pos)
- (line :init-keyword :line :getter location-line))
-
-(define (location? obj)
- (is-a? obj <location>))
-
-(define (ast-location obj)
- (let ((loc (slot-ref obj 'loc)))
- (if (location? loc)
- (let* ((fname (location-file loc))
- (line (location-line loc))
- (pwd (getcwd))
- (len (string-length pwd))
- (lenf (string-length fname))
- (file (if (and (substring=? pwd fname len)
- (> lenf len))
- (substring fname len (+ 1 (string-length fname)))
- fname)))
- (format "~a, line ~a" file line))
- "no source location")))
diff --git a/src/guile/skribe/vars.scm b/src/guile/skribe/vars.scm
deleted file mode 100644
index d78439c..0000000
--- a/src/guile/skribe/vars.scm
+++ /dev/null
@@ -1,82 +0,0 @@
-;;;;
-;;;; vars.stk -- Skribe Globals
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 11-Aug-2003 16:18 (eg)
-;;;; Last file update: 26-Feb-2004 20:36 (eg)
-;;;;
-
-
-;;;
-;;; Switches
-;;;
-(define *skribe-verbose* 0)
-(define *skribe-warning* 5)
-(define *load-rc* #t)
-
-;;;
-;;; PATH variables
-;;;
-(define *skribe-path* #f)
-(define *skribe-bib-path* '("."))
-(define *skribe-source-path* '("."))
-(define *skribe-image-path* '("."))
-
-
-(define *skribe-rc-directory*
- (make-path (getenv "HOME") ".skribe"))
-
-
-;;;
-;;; In and out ports
-;;;
-(define *skribe-src* '())
-(define *skribe-dest* #f)
-
-;;;
-;;; Engine
-;;;
-(define *skribe-engine* 'html) ;; Use HTML by default
-
-;;;
-;;; Misc
-;;;
-(define *skribe-chapter-split* '())
-(define *skribe-ref-base* #f)
-(define *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter
-(define *skribe-variants* '())
-
-
-
-
-;;; Forward definitions (to avoid warnings when compiling Skribe)
-;;; This is a KLUDGE.
-(define mark #f)
-(define ref #f)
-;;(define invoke 3)
-(define lookup-markup-writer #f)
-
-; (define-module SKRIBE-ENGINE-MODULE
-; (define find-engine #f))
-
-; (define-module SKRIBE-OUTPUT-MODULE)
-
-; (define-module SKRIBE-RUNTIME-MODULE)
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
index e766830..c352f7f 100755
--- a/src/guile/skribilo.scm
+++ b/src/guile/skribilo.scm
@@ -6,26 +6,26 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;;;
;;;; skribilo.scm
-;;;;
+;;;;
;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 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,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 24-Jul-2003 20:33 (eg)
;;;; Last file update: 6-Mar-2004 16:13 (eg)
@@ -65,21 +65,21 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
the-arg))))))))
; (use-modules (skribe eval)
-; (skribe configure)
-; (skribe runtime)
-; (skribe engine)
-; (skribe writer)
-; (skribe verify)
-; (skribe output)
-; (skribe biblio)
-; (skribe prog)
-; (skribe resolve)
-; (skribe source)
-; (skribe lisp)
-; (skribe xml)
-; (skribe c)
-; (skribe debug)
-; (skribe color))
+; (skribe configure)
+; (skribe runtime)
+; (skribe engine)
+; (skribe writer)
+; (skribe verify)
+; (skribe output)
+; (skribe biblio)
+; (skribe prog)
+; (skribe resolve)
+; (skribe source)
+; (skribe lisp)
+; (skribe xml)
+; (skribe c)
+; (skribe debug)
+; (skribe color))
(use-modules (skribe runtime)
(skribe configure)
@@ -192,7 +192,7 @@ specifications."
(set-skribe-debug! val)
(begin
;; Use the symbol for debug
- (set-skribe-debug! 1)
+ (set-skribe-debug! 1)
(add-skribe-debug-symbol (string->symbol level))))))
(("no-color" :help "disable coloring for output")
(no-debug-color))
@@ -265,7 +265,7 @@ Processes a Skribilo/Skribe source file and produces its output.
(let ((s (keyword->string (car x))))
(printf " ~a: ~a\n" s (cadr x))))
(skribe-configure)))
-
+
;;
;; parse-args starts here
;;
@@ -286,21 +286,21 @@ Processes a Skribilo/Skribe source file and produces its output.
(("P" :arg path :help "adds <path> to image path")
(skribe-image-path-set! (cons path (skribe-image-path))))
(("split-chapters" :alternate "C" :arg chapter
- :help "emit chapter's sections in separate files")
+ :help "emit chapter's sections in separate files")
(set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
(("preload" :arg file :help "preload <file>")
(set! *skribe-preload* (cons file *skribe-preload*)))
(("use-variant" :alternate "u" :arg variant
- :help "use <variant> output format")
+ :help "use <variant> output format")
(set! *skribe-variants* (cons variant *skribe-variants*)))
(("base" :alternate "b" :arg base
- :help "base prefix to remove from hyperlinks")
+ :help "base prefix to remove from hyperlinks")
(set! *skribe-ref-base* base))
(("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>")
(set! *skribe-rc-directory* dir))
-
+
"File options:"
- (("no-init-file" :help "Dont load rc Skribe file")
+ (("no-init-file" :help "Dont load rc Skribe file")
(set! *load-rc* #f))
(("output" :alternate "o" :arg file :help "set the output to <file>")
(set! *skribe-dest* file)
@@ -310,7 +310,7 @@ Processes a Skribilo/Skribe source file and produces its output.
(set! *skribe-engine* (cdr c)))))
"Misc:"
- (("help" :alternate "h" :help "provides help for the command")
+ (("help" :alternate "h" :help "provides help for the command")
(arg-usage (current-error-port))
(exit 0))
(("options" :help "display the skribe options and exit")
@@ -320,7 +320,7 @@ Processes a Skribilo/Skribe source file and produces its output.
(version)
(exit 0))
(("query" :alternate "q"
- :help "displays informations about Skribe conf.")
+ :help "displays informations about Skribe conf.")
(query)
(exit 0))
(("verbose" :alternate "v" :arg level
@@ -339,7 +339,7 @@ Processes a Skribilo/Skribe source file and produces its output.
(set-skribe-debug! val)
(begin
;; Use the symbol for debug
- (set-skribe-debug! 1)
+ (set-skribe-debug! 1)
(add-skribe-debug-symbol (string->symbol level))))))
(("no-color" :help "disable coloring for output")
(no-debug-color))
@@ -356,10 +356,10 @@ Processes a Skribilo/Skribe source file and produces its output.
(lambda () (eval (read)))))
(else
(set! *skribe-src* other-arguments)))
-
+
;; we have to configure Skribe path according to the environment variable
(skribe-path-set! (append (let ((path (getenv "SKRIBEPATH")))
- (if path
+ (if path
(string-split path ":")
'()))
(reverse! paths)
diff --git a/src/guile/skribe/Makefile.in b/src/guile/skribilo/Makefile.in
index 80a26de..80a26de 100644
--- a/src/guile/skribe/Makefile.in
+++ b/src/guile/skribilo/Makefile.in
diff --git a/src/guile/skribe/biblio.scm b/src/guile/skribilo/biblio.scm
index 122a36b..0a4fc98 100644
--- a/src/guile/skribe/biblio.scm
+++ b/src/guile/skribilo/biblio.scm
@@ -1,51 +1,50 @@
-;;;;
-;;;; biblio.scm -- Bibliography functions
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;; 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.main.st
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 31-Aug-2003 22:07 (eg)
-;;;; Last file update: 28-Oct-2004 21:19 (eg)
-;;;;
-
-
-
-(define-module (skribe biblio)
- :use-module (skribe runtime)
+;;;
+;;; biblio.scm -- Bibliography functions
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; 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.main.st
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 31-Aug-2003 22:07 (eg)
+;;; Last file update: 28-Oct-2004 21:19 (eg)
+;;;
+
+
+
+(define-module (skribilo biblio)
+ :use-module (skribilo runtime)
:export (bib-tables? make-bib-table default-bib-table
bib-load! resolve-bib resolve-the-bib
bib-sort/authors bib-sort/idents bib-sort/dates))
-(define *bib-table* #f)
-
+(define *bib-table* #f)
+
;; Forward declarations
(define skribe-open-bib-file #f)
-(define parse-bib #f)
+(define parse-bib #f)
-(include "../common/bib.scm")
-;;;; ======================================================================
-;;;;
-;;;; Utilities
-;;;;
-;;;; ======================================================================
+
+;;; ======================================================================
+;;;
+;;; Utilities
+;;;
+;;; ======================================================================
(define (make-bib-table ident)
(make-hash-table))
@@ -67,11 +66,11 @@
(skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry)
(skribe-error who msg entry))))
-;;;; ======================================================================
-;;;;
-;;;; BIB-DUPLICATE
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; BIB-DUPLICATE
+;;;
+;;; ======================================================================
(define (bib-duplicate ident from old)
(let ((ofrom (markup-option old 'from)))
(skribe-warning 2
@@ -85,11 +84,11 @@
" Ignoring redefinition."))))
-;;;; ======================================================================
-;;;;
-;;;; PARSE-BIB
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; PARSE-BIB
+;;;
+;;; ======================================================================
(define (parse-bib table port)
(if (not (bib-table? table))
(skribe-error 'parse-bib "Illegal bibliography table" table)
@@ -112,11 +111,11 @@
(%bib-error 'bib-parse entry))))))))
-;;;; ======================================================================
-;;;;
-;;;; BIB-ADD!
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; BIB-ADD!
+;;;
+;;; ======================================================================
(define (bib-add! table . entries)
(if (not (bib-table? table))
(skribe-error 'bib-add! "Illegal bibliography table" table)
@@ -137,11 +136,11 @@
entries)))
-;;;; ======================================================================
-;;;;
-;;;; SKRIBE-OPEN-BIB-FILE
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; SKRIBE-OPEN-BIB-FILE
+;;;
+;;; ======================================================================
;; FIXME: Factoriser
(define (skribe-open-bib-file file command)
(let ((path (find-path file *skribe-bib-path*)))
@@ -158,4 +157,3 @@
'bibliography
"Can't find bibliography -- " file)
#f))))
-
diff --git a/src/guile/skribe/color.scm b/src/guile/skribilo/color.scm
index 3bca7d9..1e762e6 100644
--- a/src/guile/skribe/color.scm
+++ b/src/guile/skribilo/color.scm
@@ -24,7 +24,7 @@
;;;; Last file update: 12-Feb-2004 18:24 (eg)
;;;;
-(define-module (skribe color)
+(define-module (skribilo color)
:export (skribe-color->rgb skribe-get-used-colors skribe-use-color!))
(define *used-colors* '())
diff --git a/src/guile/skribe/c-lex.l b/src/guile/skribilo/coloring/c-lex.l
index a5b337e..a5b337e 100644
--- a/src/guile/skribe/c-lex.l
+++ b/src/guile/skribilo/coloring/c-lex.l
diff --git a/src/guile/skribe/c.scm b/src/guile/skribilo/coloring/c.scm
index 7961876..baa3e53 100644
--- a/src/guile/skribe/c.scm
+++ b/src/guile/skribilo/coloring/c.scm
@@ -26,7 +26,7 @@
(require "lex-rt") ;; to avoid module problems
-(define-module (skribe c)
+(define-module (skribilo c)
:export (c java)
:import (skribe runtime))
diff --git a/src/guile/skribe/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l
index efad24b..efad24b 100644
--- a/src/guile/skribe/lisp-lex.l
+++ b/src/guile/skribilo/coloring/lisp-lex.l
diff --git a/src/guile/skribe/lisp.scm b/src/guile/skribilo/coloring/lisp.scm
index 30a81fc..53cf670 100644
--- a/src/guile/skribe/lisp.scm
+++ b/src/guile/skribilo/coloring/lisp.scm
@@ -26,7 +26,7 @@
(require "lex-rt") ;; to avoid module problems
-(define-module (skribe lisp)
+(define-module (skribilo lisp)
:export (skribe scheme stklos bigloo lisp)
:import (skribe source))
diff --git a/src/guile/skribe/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l
index 5d9a8d9..5d9a8d9 100644
--- a/src/guile/skribe/xml-lex.l
+++ b/src/guile/skribilo/coloring/xml-lex.l
diff --git a/src/guile/skribe/xml.scm b/src/guile/skribilo/coloring/xml.scm
index 072813f..d71e98c 100644
--- a/src/guile/skribe/xml.scm
+++ b/src/guile/skribilo/coloring/xml.scm
@@ -28,10 +28,10 @@
;(require "lex-rt") ;; to avoid module problems
-(define-module (skribe xml)
+(define-module (skribilo xml)
:export (xml))
-(use-modules (skribe source))
+(use-modules (skribilo source))
(include "xml-lex.stk") ;; SILex generated
diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in
new file mode 100644
index 0000000..6e40e7f
--- /dev/null
+++ b/src/guile/skribilo/config.scm.in
@@ -0,0 +1,21 @@
+;;; -*- Scheme -*-
+;;;
+
+(define-module (skribilo config))
+
+(define-public (skribilo-release) "1.3")
+(define-public (skribilo-url) "http://www.laas.fr/~lcourtes/")
+(define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@")
+(define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@")
+(define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@")
+(define-public (skribilo-scheme) "guile")
+
+
+;; Compatibility.
+
+(define-public skribe-release skribilo-release)
+(define-public skribe-url skribilo-url)
+(define-public skribe-doc-dir skribilo-doc-directory)
+(define-public skribe-ext-dir skribilo-extension-directory)
+(define-public skribe-default-path skribilo-default-path)
+(define-public skribe-scheme skribilo-scheme)
diff --git a/src/guile/skribe/debug.scm b/src/guile/skribilo/debug.scm
index e2bff27..1a5478e 100644
--- a/src/guile/skribe/debug.scm
+++ b/src/guile/skribilo/debug.scm
@@ -1,41 +1,42 @@
-;;;;
-;;;; debug.stk -- Debug Facilities (stolen to Manuel Serrano)
-;;;;
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 10-Aug-2003 20:45 (eg)
-;;;; Last file update: 28-Oct-2004 13:16 (eg)
-;;;;
-
-
-(define-module (skribe debug)
+;;;
+;;; debug.scm -- Debug Facilities (stolen to Manuel Serrano)
+;;;
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 10-Aug-2003 20:45 (eg)
+;;; Last file update: 28-Oct-2004 13:16 (eg)
+;;;
+
+
+(define-module (skribilo debug)
:export (with-debug %with-debug
debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol
no-debug-color))
-(define *skribe-debug* 0)
+
+(define *skribe-debug* 0)
(define *skribe-debug-symbols* '())
-(define *skribe-debug-color* #t)
-(define *skribe-debug-item* #f)
-(define *debug-port* (current-error-port))
-(define *debug-depth* 0)
-(define *debug-margin* "")
+(define *skribe-debug-color* #t)
+(define *skribe-debug-item* #f)
+(define *debug-port* (current-error-port))
+(define *debug-depth* 0)
+(define *debug-margin* "")
(define *skribe-margin-debug-level* 0)
@@ -73,7 +74,7 @@
(with-output-to-string
(if (and *skribe-debug-color*
(equal? (getenv "TERM") "xterm")
- (interactive-port? *debug-port*))
+ (interactive-port? *debug-port*))
(lambda ()
(format #t "[1;~Am" (+ 31 col))
(for-each display o)
@@ -91,12 +92,13 @@
;;; debug-item
;;;
(define (debug-item . args)
- (when (or (>= *skribe-debug* *skribe-margin-debug-level*)
- *skribe-debug-item*)
- (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*)))
+ (if (or (>= *skribe-debug* *skribe-margin-debug-level*)
+ *skribe-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)
;; `())
@@ -112,7 +114,7 @@
(set! *debug-depth* (- *debug-depth* 1))
(set! *debug-margin* om)
res)))
-
+
;;;
;;; %with-debug
;;
@@ -153,8 +155,7 @@
; (with-debug 0 'foo2.3
; (debug-item 'foo3.1)
; (with-debug 0 'foo3.2
-; (debug-item 'foo4.1)
-; (debug-item 'foo4.2))
+; (debug-item 'foo4.1)
+; (debug-item 'foo4.2))
; (debug-item 'foo3.3))
; (debug-item 'foo2.4))
-
diff --git a/src/guile/skribe/engine.scm b/src/guile/skribilo/engine.scm
index 1cac168..9584f5e 100644
--- a/src/guile/skribe/engine.scm
+++ b/src/guile/skribilo/engine.scm
@@ -1,40 +1,41 @@
-;;;;
-;;;; engines.stk -- Skribe Engines Stuff
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 24-Jul-2003 20:33 (eg)
-;;;; Last file update: 28-Oct-2004 21:21 (eg)
-;;;;
-
-(define-module (skribe engine)
- :use-module (skribe debug)
-; :use-module (skribe eval)
- :use-module (skribe writer)
- :use-module (skribe types)
+;;;
+;;; engine.scm -- Skribe Engines Stuff
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; 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.
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 24-Jul-2003 20:33 (eg)
+;;; Last file update: 28-Oct-2004 21:21 (eg)
+;;;
+
+(define-module (skribilo engine)
+ :use-module (skribilo debug)
+; :use-module (skribilo eval)
+ :use-module (skribilo writer)
+ :use-module (skribilo types)
:use-module (oop goops)
:use-module (ice-9 optargs)
-
+
:export (default-engine default-engine-set!
- make-engine copy-engine find-engine
+ make-engine copy-engine find-engine lookup-engine
engine-custom engine-custom-set!
engine-format? engine-add-writer!
processor-get-engine
@@ -43,13 +44,13 @@
-;;; Module definition is split here because this file is read by the documentation
-;;; Should be changed.
+;;; Module definition is split here because this file is read by the
+;;; documentation Should be changed.
;(select-module SKRIBE-ENGINE-MODULE)
(define *engines* '())
-(define *default-engine* #f)
-(define *default-engines* '())
+(define *default-engine* #f)
+(define *default-engines* '())
(define (default-engine)
@@ -57,8 +58,8 @@
(define (default-engine-set! e)
- (unless (engine? e)
- (skribe-error 'default-engine-set! "bad engine ~S" e))
+ (if (not (engine? e))
+ (skribe-error 'default-engine-set! "bad engine ~S" e))
(set! *default-engine* e)
(set! *default-engines* (cons e *default-engines*))
e)
@@ -99,16 +100,16 @@
;;;
;;; MAKE-ENGINE
-;;;
+;;;
(define* (make-engine ident #:key (version 'unspecified)
- (format "raw")
+ (format "raw")
(filter #f)
(delegate #f)
(symbol-table '())
(custom '())
(info '()))
(let ((e (make <engine> :ident ident :version version :format format
- :filter filter :delegate delegate
+ :filter filter :delegate delegate
:symbol-table symbol-table
:custom custom :info info)))
;; store the engine in the global table
@@ -126,8 +127,8 @@
(symbol-table #f)
(custom #f))
(let ((new (shallow-clone e)))
- (slot-set! new 'ident ident)
- (slot-set! new 'version version)
+ (slot-set! new 'ident ident)
+ (slot-set! new 'version version)
(slot-set! new 'filter (or filter (slot-ref e 'filter)))
(slot-set! new 'delegate (or delegate (slot-ref e 'delegate)))
(slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table)))
@@ -138,17 +139,17 @@
;;;
-;;; FIND-ENGINE
+;;; FIND-ENGINE
;;;
(define (%find-loaded-engine id version)
- (let Loop ((es *engines*))
+ (let loop ((es *engines*))
(cond
((null? es) #f)
((eq? (slot-ref (car es) 'ident) id)
(cond
- ((eq? version 'unspecified) (car es))
+ ((eq? version 'unspecified) (car es))
((eq? version (slot-ref (car es) 'version)) (car es))
- (else (Loop (cdr es)))))
+ (else (Loop (cdr es)))))
(else (loop (cdr es))))))
@@ -165,6 +166,9 @@
(%find-loaded-engine id version))
#f)))))
+(define lookup-engine find-engine)
+
+
;;;
;;; ENGINE-CUSTOM
;;;
@@ -194,9 +198,9 @@
(define (check-procedure name proc arity)
(cond
((not (procedure? proc))
- (skribe-error ident "Illegal procedure" proc))
+ (skribe-error ident "Illegal procedure" proc))
((not (equal? (%procedure-arity proc) arity))
- (skribe-error ident
+ (skribe-error ident
(format #f "Illegal ~S procedure" name)
proc))))
@@ -206,20 +210,20 @@
;;
;; Engine-add-writer! starts here
;;
- (unless (is-a? e <engine>)
- (skribe-error ident "Illegal engine" e))
-
+ (if (not (is-a? e <engine>))
+ (skribe-error ident "Illegal engine" e))
+
;; check the options
- (unless (or (eq? opt 'all) (list? opt))
- (skribe-error ident "Illegal options" opt))
-
+ (if (not (or (eq? opt 'all) (list? opt)))
+ (skribe-error ident "Illegal options" opt))
+
;; check the correctness of the predicate
(check-procedure "predicate" pred 2)
;; check the correctness of the validation proc
- (when valid
+ (if valid
(check-procedure "validate" valid 2))
-
+
;; check the correctness of the three actions
(check-output "before" before)
(check-output "action" action)
@@ -234,16 +238,14 @@
(slot-set! e 'writers (cons n (slot-ref e 'writers)))
n))
-;;;; ======================================================================
-;;;;
-;;;; I N I T S
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; I N I T S
+;;;
+;;; ======================================================================
;; A base engine must pre-exist before anything is loaded. In
;; particular, this dummy base engine is used to load the actual
-;; definition of base.
+;; definition of base.
(make-engine 'base :version 'bootstrap)
-
-
diff --git a/src/guile/skribe/eval.scm b/src/guile/skribilo/eval.scm
index 746d763..8bae8ad 100644
--- a/src/guile/skribe/eval.scm
+++ b/src/guile/skribilo/eval.scm
@@ -1,54 +1,87 @@
-;;;;
-;;;; eval.stk -- Skribe Evaluator
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 27-Jul-2003 09:15 (eg)
-;;;; Last file update: 28-Oct-2004 15:05 (eg)
-;;;;
+;;;
+;;; eval.stk -- Skribe Evaluator
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; 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.
+;;;
+
;; FIXME; On peut implémenter maintenant skribe-warning/node
-(define-module (skribe eval)
+(define-module (skribilo eval)
:export (skribe-eval skribe-eval-port skribe-load skribe-load-options
- skribe-include))
+ skribe-include
-(use-modules (skribe debug)
- (skribe engine)
- (skribe verify)
- (skribe resolve)
- (skribe output)
+ run-time-module make-run-time-module))
+
+(use-modules (skribilo debug)
+ (skribilo engine)
+ (skribilo verify)
+ (skribilo resolve)
+ (skribilo output)
(ice-9 optargs))
-(define *skribe-loaded* '()) ;; List of already loaded files
+(define *skribe-loaded* '()) ;; List of already loaded files
(define *skribe-load-options* '())
(define (%evaluate expr)
- (with-handler
- (lambda (c)
- (flush-output-port (current-error-port))
- (raise c))
- (eval expr (find-module 'STklos))))
+ (eval expr (current-module)))
+
+
+(define *skribilo-user-module* #f)
+
+(define *skribilo-user-imports*
+ '((srfi srfi-1)
+ (oop goops)
+ (skribilo module)
+ (skribilo config)
+ (skribilo vars)
+ (skribilo runtime)
+ (skribilo biblio)
+ (skribilo lib)
+ (skribilo resolve)))
+
+
+;;;
+;;; MAKE-RUN-TIME-MODULE
+;;;
+(define (make-run-time-module)
+ "Return a new module that imports all the necessary bindings required for
+execution of Skribilo/Skribe code."
+ (let ((the-module (make-module)))
+ (for-each (lambda (iface)
+ (module-use! the-module (resolve-module iface)))
+ *skribilo-user-imports*)
+ (set-module-name! the-module '(skribilo-user))
+ the-module))
+
+;;;
+;;; RUN-TIME-MODULE
+;;;
+(define (run-time-module)
+ "Return the default instance of a Skribilo/Skribe run-time module."
+ (if (not *skribilo-user-module*)
+ (set! *skribilo-user-module* (make-run-time-module)))
+ *skribilo-user-module*)
;;;
;;; SKRIBE-EVAL
@@ -103,7 +136,7 @@
((not path) (skribe-path))
((string? path) (list path))
((not (and (list? path) (every? string? path)))
- (skribe-error 'skribe-load "Illegal path" path))
+ (skribe-error 'skribe-load "Illegal path" path))
(else path)))
(filep (find-path file path)))
@@ -113,7 +146,7 @@
(skribe-error 'skribe-load
(format "Cannot find ~S in path" file)
*skribe-path*))
-
+
;; Load this file if not already done
(unless (member filep *skribe-loaded*)
(cond
diff --git a/src/guile/skribe/lib.scm b/src/guile/skribilo/lib.scm
index fa5e962..26b348a 100644
--- a/src/guile/skribe/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,31 +1,69 @@
-;;;;
-;;;; lib.stk -- Utilities
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 11-Aug-2003 20:29 (eg)
-;;;; Last file update: 27-Oct-2004 12:41 (eg)
-;;;;
-
-(use-modules (srfi srfi-1))
+;;;
+;;; lib.stk -- Utilities
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 11-Aug-2003 20:29 (eg)
+;;; Last file update: 27-Oct-2004 12:41 (eg)
+;;;
+
+(read-set! keywords 'prefix)
+
+(define-module (skribilo lib)
+ :export (skribe-eval-location skribe-ast-error skribe-error
+ skribe-type-error skribe-line-error
+ skribe-warning skribe-warning/ast
+ skribe-message
+
+ skribe-path skribe-path-set!
+ skribe-image-path skribe-image-path-set!
+ skribe-bib-path skribe-bib-path-set!
+ skribe-source-path skribe-source-path-set!
+
+ ;; various utilities for compatiblity
+
+ substring=?
+ file-suffix file-prefix prefix suffix
+ directory->list find-file/path
+ printf fprintf
+ any? every?
+ process-input-port process-output-port process-error-port
+
+ make-hashtable hashtable?
+ hashtable-get hashtable-put! hashtable-update!
+ hashtable->list
+
+ find-runtime-type)
+ :export-syntax (new define-markup define-simple-markup
+ define-simple-container define-processor-markup
+
+ ;; for compatibility
+ unwind-protect unless when)
+
+ :use-module (srfi srfi-1)
+ :use-module (ice-9 optargs))
+
+
+
+
;;;
;;; NEW
;;;
@@ -169,7 +207,7 @@
;;;
;;; FILE-PREFIX / FILE-SUFFIX
-;;;
+;;;
(define (file-prefix fn)
(if fn
(let ((match (regexp-match "(.*)\\.([^/]*$)" fn)))
@@ -218,19 +256,14 @@
(Loop (cdr l))))))
+
+;;; ======================================================================
;;;
-;;; UNSPECIFIED?
+;;; A C C E S S O R S
;;;
-(define (unspecified? obj)
- (eq? obj 'unspecified))
-
-;;;; ======================================================================
-;;;;
-;;;; A C C E S S O R S
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
-;; SKRIBE-PATH
+;; SKRIBE-PATH
(define (skribe-path) *skribe-path*)
(define (skribe-path-set! path)
@@ -238,7 +271,7 @@
(skribe-error 'skribe-path-set! "Illegal path" path)
(set! *skribe-path* path)))
-;; SKRIBE-IMAGE-PATH
+;; SKRIBE-IMAGE-PATH
(define (skribe-image-path) *skribe-image-path*)
(define (skribe-image-path-set! path)
@@ -246,7 +279,7 @@
(skribe-error 'skribe-image-path-set! "Illegal path" path)
(set! *skribe-image-path* path)))
-;; SKRIBE-BIB-PATH
+;; SKRIBE-BIB-PATH
(define (skribe-bib-path) *skribe-bib-path*)
(define (skribe-bib-path-set! path)
@@ -254,7 +287,7 @@
(skribe-error 'skribe-bib-path-set! "Illegal path" path)
(set! *skribe-bib-path* path)))
-;; SKRBE-SOURCE-PATH
+;; SKRBE-SOURCE-PATH
(define (skribe-source-path) *skribe-source-path*)
(define (skribe-source-path-set! path)
@@ -262,11 +295,12 @@
(skribe-error 'skribe-source-path-set! "Illegal path" path)
(set! *skribe-source-path* path)))
-;;;; ======================================================================
-;;;;
-;;;; Compatibility with Bigloo
-;;;;
-;;;; ======================================================================
+
+;;; ======================================================================
+;;;
+;;; Compatibility with Bigloo
+;;;
+;;; ======================================================================
(define (substring=? s1 s2 len)
(let ((l1 (string-length s1))
@@ -285,25 +319,12 @@
(define-macro (printf . args) `(format #t ,@args))
(define fprintf format)
-(define (symbol-append . l)
- (string->symbol (apply string-append (map symbol->string l))))
-
-
-(define (make-list n . fill)
- (let ((fill (if (null? fill) (void) (car fill))))
- (let Loop ((i n) (res '()))
- (if (zero? i)
- res
- (Loop (- i 1) (cons fill res))))))
-
-(define string-capitalize string-titlecase)
-(define prefix file-prefix)
-(define suffix file-suffix)
-(define system->string system)
+(define prefix file-prefix)
+(define suffix file-suffix)
+(define system->string system) ;; FIXME
(define any? any)
(define every? every)
-(define cons* list*)
(define find-file/path (lambda (. args)
(format #t "find-file/path: ~a~%" args)
#f))
@@ -311,22 +332,29 @@
(define process-output-port #f) ;process-output)
(define process-error-port #f) ;process-error)
+
;;;
;;; h a s h t a b l e s
;;;
-(define make-hashtable (lambda () (make-hash-table)))
-(define hashtable? hash-table?)
+(define make-hashtable make-hash-table)
+(define hashtable? hash-table?)
(define hashtable-get (lambda (h k) (hash-ref h k #f)))
(define hashtable-put! hash-set!)
(define hashtable-update! hash-set!)
-(define hashtable->list (lambda (h)
- (map cdr (hash-table->list h))))
+(define hashtable->list (lambda (h)
+ (map cdr (hash-table->list h))))
-(define find-runtime-type (lambda (obj) obj))
+(define find-runtime-type (lambda (obj) obj))
(define-macro (unwind-protect expr1 expr2)
- ;; This is no completely correct.
+ ;; This is no completely correct.
`(dynamic-wind
(lambda () #f)
(lambda () ,expr1)
(lambda () ,expr2)))
+
+(define-macro (unless expr body)
+ `(if (not ,expr) ,body))
+
+(define-macro (when expr . exprs)
+ `(if ,expr (begin ,@exprs)))
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
new file mode 100644
index 0000000..4d29f31
--- /dev/null
+++ b/src/guile/skribilo/module.scm
@@ -0,0 +1,118 @@
+;;; module.scm -- Integration of Skribe code as Guile modules.
+;;;
+;;; 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-module (skribilo module)
+ :use-module (skribilo reader)
+ :use-module (skribilo eval)
+ :use-module (ice-9 optargs))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This (fake) module defines a macro called `define-skribe-module' which
+;;; allows to package Skribe code (which uses Skribe built-ins and most
+;;; importantly a Skribe syntax) as a Guile module. This module
+;;; automatically exports the macro as a core binding so that future
+;;; `use-modules' referring to Skribe modules will work as expected.
+;;;
+;;; Code:
+
+(define-macro (define-skribe-module name)
+ `(begin
+ (define-module ,name)
+
+ ;; Pull all the bindings that Skribe code may expect, plus those needed
+ ;; to actually create and read the module.
+ (use-modules (skribilo module)
+ (skribilo reader)
+ (skribilo eval) ;; `run-time-module'
+
+ (srfi srfi-1)
+ (ice-9 optargs)
+
+ (skribilo lib) ;; `define-markup', `unwind-protect', etc.
+ (skribilo runtime)
+ (skribilo vars)
+ (skribilo config))
+
+ (use-syntax (skribilo lib))
+
+ ;; The `define' below results in a module-local definition. So the
+ ;; definition of `read' in the `(guile-user)' module is left untouched.
+ ;(define read ,(make-reader 'skribe))
+
+ ;; Everything is exported.
+ (define-macro (define . things)
+ (let* ((first (car things))
+ (binding (cond ((symbol? first) first)
+ ((list? first) (car first))
+ ((pair? first) (car first))
+ (else
+ (error "define/skribe: bad formals" first)))))
+ `(begin
+ (define-public ,@things)
+ ;; Automatically push it to the run-time user module.
+; (module-define! ,(run-time-module)
+; (quote ,binding) ,binding)
+ )))))
+
+
+;; Make it available to the top-level module.
+(module-define! the-root-module
+ 'define-skribe-module define-skribe-module)
+
+
+(define-public (load-file-with-read file read module)
+ (with-input-from-file file
+ (lambda ()
+; (format #t "load-file-with-read: ~a~%" read)
+ (let loop ((sexp (read))
+ (result #f))
+ (if (eof-object? sexp)
+ result
+ (begin
+; (format #t "preparing to evaluate `~a'~%" sexp)
+ (loop (read)
+ (eval sexp module))))))))
+
+(define-public (load-skribilo-file file reader-name)
+ (load-file-with-read file (make-reader reader-name) (current-module)))
+
+(define-public *skribe-core-modules*
+ '("utils" "api" "bib" "index" "param" "sui"))
+
+(define*-public (load-skribe-modules #:optional (debug? #f))
+ "Load the core Skribe modules, both in the @code{(skribilo skribe)}
+hierarchy and in @code{(run-time-module)}."
+ (for-each (lambda (mod)
+ (if debug?
+ (format #t "loading skribe module `~a'...~%" mod))
+ (load-skribilo-file (string-append "skribe/" mod ".scm")
+ 'skribe))
+ *skribe-core-modules*)
+ (for-each (lambda (mod)
+ (module-use! (run-time-module)
+ (resolve-interface (list skribilo skribe
+ (string->symbol
+ mod)))))
+ *skribe-core-modules*))
+
+;;; module.scm ends here
diff --git a/src/guile/skribe/output.scm b/src/guile/skribilo/output.scm
index 03c251c..cc690ec 100644
--- a/src/guile/skribe/output.scm
+++ b/src/guile/skribilo/output.scm
@@ -24,11 +24,11 @@
;;;; Last file update: 5-Mar-2004 10:32 (eg)
;;;;
-(define-module (skribe output)
+(define-module (skribilo output)
:export (output))
-(use-modules (skribe debug)
- (skribe types)
+(use-modules (skribilo debug)
+ (skribilo types)
; (skribe engine)
; (skribe writer)
(oop goops))
diff --git a/src/guile/skribe/prog.scm b/src/guile/skribilo/prog.scm
index eb0b3db..eb0b3db 100644
--- a/src/guile/skribe/prog.scm
+++ b/src/guile/skribilo/prog.scm
diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm
new file mode 100644
index 0000000..a149ab1
--- /dev/null
+++ b/src/guile/skribilo/reader.scm
@@ -0,0 +1,82 @@
+;;; reader.scm -- Skribilo's front-end (aka. reader) interface.
+;;;
+;;; 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-module (skribilo reader)
+ :use-module (srfi srfi-9) ;; records
+ :use-module (srfi srfi-17) ;; generalized `set!'
+ :export (%make-reader lookup-reader make-reader)
+ :export-syntax (define-reader define-public-reader))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module contains Skribilo's front-end (aka. ``reader'') interface.
+;;; Skribilo's default reader is `(skribilo reader skribe)' which provides a
+;;; reader for the Skribe syntax.
+;;;
+;;; Code:
+
+(define-record-type <reader>
+ (%make-reader name version make)
+ reader?
+ (name reader:name reader:set-name!) ;; a symbol
+ (version reader:version reader:set-version!) ;; a string
+ (make reader:make reader:set-make!)) ;; a one-argument proc
+ ;; that returns a reader
+ ;; proc
+
+(define-public reader:name
+ (getter-with-setter reader:name reader:set-name!))
+
+(define-public reader:version
+ (getter-with-setter reader:version reader:set-version!))
+
+(define-public reader:make
+ (getter-with-setter reader:make reader:set-make!))
+
+(define-macro (define-reader name version make-proc)
+ `(define reader-specification
+ (%make-reader (quote ,name) ,version ,make-proc)))
+
+(define-macro (define-public-reader name version make-proc)
+ `(define-reader ,name ,version ,make-proc))
+
+
+
+;;; The mechanism below is inspired by Guile-VM code written by K. Nishida.
+
+(define (lookup-reader name)
+ "Look for a reader named @var{name} (a symbol) in the @code{(skribilo
+readers)} module hierarchy. If no such reader was found, an error is
+raised."
+ (let ((m (resolve-module `(skribilo reader ,name))))
+ (if (module-bound? m 'reader-specification)
+ (module-ref m 'reader-specification)
+ (error "no such reader" name))))
+
+(define (make-reader name)
+ "Look for reader @var{name} and instantiate it."
+ (let* ((spec (lookup-reader name))
+ (make (reader:make spec)))
+ (make)))
+
+
+;;; reader.scm ends here
diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm
new file mode 100644
index 0000000..673a166
--- /dev/null
+++ b/src/guile/skribilo/reader/skribe.scm
@@ -0,0 +1,80 @@
+;;; skribe.scm -- A reader for the Skribe syntax.
+;;;
+;;; 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-module (skribilo reader skribe)
+ :use-module (skribilo reader)
+ :use-module (ice-9 optargs)
+
+ ;; the Scheme reader composition framework
+ :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:))
+
+ :export (reader-specification
+ make-skribe-reader))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; 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).
+;;;
+;;; Code:
+
+
+(define* (make-skribe-reader #:optional (version "1.2d"))
+ "Return a Skribe reader (a procedure) suitable for version @var{version} of
+the Skribe syntax."
+ (if (string> version "1.2d")
+ (error "make-skribe-reader: unsupported version" version)
+ *skribe-reader*))
+
+
+(define (%make-skribe-reader)
+ (let* ((dsssl-keyword-reader ;; keywords à la `#!key'
+ (r:make-token-reader #\!
+ (r:token-reader-procedure
+ (r:standard-token-reader 'keyword))))
+ (sharp-reader (r:make-reader (cons dsssl-keyword-reader
+ (map r:standard-token-reader
+ '(character srfi-4
+ number+radix
+ boolean))))))
+ (r:make-reader (cons (r:make-token-reader #\# sharp-reader)
+ (map r:standard-token-reader
+ `(whitespace
+ sexp string number
+ symbol-lower-case
+ symbol-upper-case
+ symbol-misc-chars
+ quote-quasiquote-unquote
+ semicolon-comment
+ keyword ;; keywords à la `:key'
+ skribe-exp))))))
+
+;; We actually cache an instance here.
+(define *skribe-reader* (%make-skribe-reader))
+
+
+
+;;; The reader specification.
+
+(define-reader skribe "1.2d" make-skribe-reader)
+
+;;; skribe.scm ends here
diff --git a/src/guile/skribe/resolve.scm b/src/guile/skribilo/resolve.scm
index 166e8fc..2dc5e98 100644
--- a/src/guile/skribe/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -24,10 +24,10 @@
;;;; Last file update: 17-Feb-2004 14:43 (eg)
;;;;
-(define-module (skribe resolve)
- :use-module (skribe debug)
- :use-module (skribe runtime)
- :use-module (skribe types)
+(define-module (skribilo resolve)
+ :use-module (skribilo debug)
+ :use-module (skribilo runtime)
+ :use-module (skribilo types)
:use-module (oop goops)
diff --git a/src/guile/skribe/runtime.scm b/src/guile/skribilo/runtime.scm
index abac32c..af76237 100644
--- a/src/guile/skribe/runtime.scm
+++ b/src/guile/skribilo/runtime.scm
@@ -1,30 +1,30 @@
-;;;;
-;;;; runtime.stk -- Skribe runtime system
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 13-Aug-2003 18:47 (eg)
-;;;; Last file update: 15-Nov-2004 14:03 (eg)
-;;;;
-
-(define-module (skribe runtime)
+;;;
+;;; runtime.stk -- Skribe runtime system
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 13-Aug-2003 18:47 (eg)
+;;; Last file update: 15-Nov-2004 14:03 (eg)
+;;;
+
+(define-module (skribilo runtime)
:export (;; Utilities
strip-ref-base ast->file-location string-canonicalize
@@ -43,24 +43,24 @@
;; AST
ast->string))
-(use-modules (skribe debug)
- (skribe types)
- (skribe verify)
- (skribe resolve)
- (skribe output)
- (skribe eval)
+(use-modules (skribilo debug)
+ (skribilo types)
+ (skribilo verify)
+ (skribilo resolve)
+ (skribilo output)
+ (skribilo eval)
(oop goops))
-;;;; ======================================================================
-;;;;
-;;;; U T I L I T I E S
-;;;;
-;;;; ======================================================================
-(define skribe-load 'function-defined-below)
+;;; ======================================================================
+;;;
+;;; U T I L I T I E S
+;;;
+;;; ======================================================================
-;;FIXME: Remonter cette fonction
+
+;;FIXME: Remonter cette fonction
(define (strip-ref-base file)
(if (not (string? *skribe-ref-base*))
file
@@ -74,7 +74,7 @@
file)
(else
(substring file (+ l 1) (string-length file)))))))
-
+
(define (ast->file-location ast)
(let ((l (ast-loc ast)))
@@ -82,7 +82,7 @@
(format "~a:~a:" (location-file l) (location-line l))
"")))
-;; FIXME: Remonter cette fonction
+;; FIXME: Remonter cette fonction
(define (string-canonicalize old)
(let* ((l (string-length old))
(new (make-string l)))
@@ -115,34 +115,34 @@
(loop (+ r 1) (+ w 1) #f))))))
-;;;; ======================================================================
-;;;;
-;;;; M A R K U P S F U N C T I O N S
-;;;;
-;;;; ======================================================================
-;;; (define (markup-output markup
-;; :optional (engine #f)
-;; :key (predicate #f)
-;; (options '())
-;; (before #f)
-;; (action #f)
-;; (after #f))
+;;; ======================================================================
+;;;
+;;; M A R K U P S F U N C T I O N S
+;;;
+;;; ======================================================================
+;; (define (markup-output markup
+;; :optional (engine #f)
+;; :key (predicate #f)
+;; (options '())
+;; (before #f)
+;; (action #f)
+;; (after #f))
;; (let ((e (or engine (use-engine))))
;; (cond
;; ((not (is-a? e <engine>))
;; (skribe-error 'markup-writer "illegal engine" e))
;; ((and (not before)
-;; (not action)
-;; (not after))
+;; (not action)
+;; (not after))
;; (%find-markup-output e markup))
;; (else
-;; (let ((mp (if (procedure? predicate)
-;; (lambda (n e) (and (is-markup? n markup) (predicate n e)))
-;; (lambda (n e) (is-markup? n markup)))))
-;; (engine-output e markup mp options
-;; (or before (slot-ref e 'default-before))
-;; (or action (slot-ref e 'default-action))
-;; (or after (slot-ref e 'default-after))))))))
+;; (let ((mp (if (procedure? predicate)
+;; (lambda (n e) (and (is-markup? n markup) (predicate n e)))
+;; (lambda (n e) (is-markup? n markup)))))
+;; (engine-output e markup mp options
+;; (or before (slot-ref e 'default-before))
+;; (or action (slot-ref e 'default-action))
+;; (or after (slot-ref e 'default-after))))))))
(define (markup-option m opt)
(if (markup? m)
@@ -158,21 +158,21 @@
(slot-ref m 'options)))
(skribe-type-error 'markup-option "Illegal markup: " m "markup")))
-;;;; ======================================================================
-;;;;
-;;;; C O N T A I N E R S
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; C O N T A I N E R S
+;;;
+;;; ======================================================================
(define (container-env-get m key)
(let ((c (assq key (slot-ref m 'env))))
(and (pair? c) (cadr c))))
-;;;; ======================================================================
-;;;;
-;;;; I M A G E S
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; I M A G E S
+;;;
+;;; ======================================================================
(define (builtin-convert-image from fmt dir)
(let* ((s (suffix from))
(f (string-append (prefix (basename from)) "." fmt))
@@ -182,7 +182,7 @@
to)
((file-exists? to)
to)
- (else
+ (else
(let ((c (if (string=? s "fig")
(string-append "fig2dev -L " fmt " " from " > " to)
(string-append "convert " from " " to))))
@@ -221,13 +221,13 @@
p
(loop (cdr fmts)))))))))))
-;;;; ======================================================================
-;;;;
-;;;; S T R I N G - W R I T I N G
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; S T R I N G - W R I T I N G
+;;;
+;;; ======================================================================
-;;
+;;
;; (define (%make-html-replace)
;; ;; Ad-hoc version for HTML, a little bit faster than the
;; ;; make-general-string-replace define later (particularily if there
@@ -235,18 +235,18 @@
;; (let ((specials (string->regexp "&|\"|<|>")))
;; (lambda (str)
;; (if (regexp-match specials str)
-;; (begin
-;; (let ((out (open-output-string)))
-;; (dotimes (i (string-length str))
-;; (let ((ch (string-ref str i)))
-;; (case ch
-;; ((#\") (display "&quot;" out))
-;; ((#\&) (display "&amp;" out))
-;; ((#\<) (display "&lt;" out))
-;; ((#\>) (display "&gt;" out))
-;; (else (write-char ch out)))))
-;; (get-output-string out)))
-;; str))))
+;; (begin
+;; (let ((out (open-output-string)))
+;; (dotimes (i (string-length str))
+;; (let ((ch (string-ref str i)))
+;; (case ch
+;; ((#\") (display "&quot;" out))
+;; ((#\&) (display "&amp;" out))
+;; ((#\<) (display "&lt;" out))
+;; ((#\>) (display "&gt;" out))
+;; (else (write-char ch out)))))
+;; (get-output-string out)))
+;; str))))
(define (%make-general-string-replace lst)
@@ -264,58 +264,58 @@
(let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
(cond
((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
- string->html)
+ string->html)
(else
- (%make-general-string-replace lst)))))
+ (%make-general-string-replace lst)))))
-;;;; ======================================================================
-;;;;
-;;;; O P T I O N S
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; O P T I O N S
+;;;
+;;; ======================================================================
;;NEW ;;
;;NEW ;; GET-OPTION
-;;NEW ;;
+;;NEW ;;
;;NEW (define (get-option obj key)
;;NEW ;; This function either searches inside an a-list or a markup.
;;NEW (cond
;;NEW ((pair? obj) (let ((c (assq key obj)))
-;;NEW (and (pair? c) (pair? (cdr c)) (cadr c))))
+;;NEW (and (pair? c) (pair? (cdr c)) (cadr c))))
;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key))
;;NEW (else #f)))
-;;NEW
+;;NEW
;;NEW ;;
;;NEW ;; BIND-OPTION!
;;NEW ;;
;;NEW (define (bind-option! obj key value)
;;NEW (slot-set! obj 'option* (cons (list key value)
-;;NEW (slot-ref obj 'option*))))
-;;NEW
-;;NEW
+;;NEW (slot-ref obj 'option*))))
+;;NEW
+;;NEW
;;NEW ;;
;;NEW ;; GET-ENV
;;NEW ;;
;;NEW (define (get-env obj key)
;;NEW ;; This function either searches inside an a-list or a container
;;NEW (cond
-;;NEW ((pair? obj) (let ((c (assq key obj)))
-;;NEW (and (pair? c) (cadr c))))
+;;NEW ((pair? obj) (let ((c (assq key obj)))
+;;NEW (and (pair? c) (cadr c))))
;;NEW ((container? obj) (get-env (slot-ref obj 'env) key))
;;NEW (else #f)))
-;;NEW
+;;NEW
-;;;; ======================================================================
-;;;;
-;;;; A S T
-;;;;
-;;;; ======================================================================
+;;; ======================================================================
+;;;
+;;; A S T
+;;;
+;;; ======================================================================
(define-generic ast->string)
@@ -345,52 +345,52 @@
;;NEW ;;
;;NEW (define (ast-parent n)
;;NEW (slot-ref n 'parent))
-;;NEW
+;;NEW
;;NEW ;;
;;NEW ;; MARKUP-PARENT
;;NEW ;;
;;NEW (define (markup-parent m)
;;NEW (let ((p (slot-ref m 'parent)))
;;NEW (if (eq? p 'unspecified)
-;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m)
-;;NEW p)))
-;;NEW
-;;NEW
+;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m)
+;;NEW p)))
+;;NEW
+;;NEW
;;NEW ;;
;;NEW ;; MARKUP-DOCUMENT
;;NEW ;;
;;NEW (define (markup-document m)
;;NEW (let Loop ((p m)
-;;NEW (l #f))
+;;NEW (l #f))
;;NEW (cond
;;NEW ((is-markup? p 'document) p)
;;NEW ((or (eq? p 'unspecified) (not p)) l)
;;NEW (else (Loop (slot-ref p 'parent) p)))))
-;;NEW
+;;NEW
;;NEW ;;
;;NEW ;; MARKUP-CHAPTER
;;NEW ;;
;;NEW (define (markup-chapter m)
;;NEW (let loop ((p m)
-;;NEW (l #f))
+;;NEW (l #f))
;;NEW (cond
;;NEW ((is-markup? p 'chapter) p)
;;NEW ((or (eq? p 'unspecified) (not p)) l)
;;NEW (else (loop (slot-ref p 'parent) p)))))
-;;NEW
-;;NEW
+;;NEW
+;;NEW
;;NEW ;;;; ======================================================================
;;NEW ;;;;
-;;NEW ;;;; H A N D L E S
+;;NEW ;;;; H A N D L E S
;;NEW ;;;;
;;NEW ;;;; ======================================================================
;;NEW (define (handle-body h)
;;NEW (slot-ref h 'body))
-;;NEW
-;;NEW
+;;NEW
+;;NEW
;;NEW ;;;; ======================================================================
;;NEW ;;;;
-;;NEW ;;;; F I N D
+;;NEW ;;;; F I N D
;;NEW ;;;;
;;NEW ;;;; ======================================================================
;;NEW (define (find pred obj)
@@ -398,28 +398,28 @@
;;NEW (debug-item "obj=" obj)
;;NEW (let loop ((obj (if (is-a? obj <container>) (container-body obj) obj)))
;;NEW (cond
-;;NEW ((pair? obj)
-;;NEW (apply append (map (lambda (o) (loop o)) obj)))
-;;NEW ((is-a? obj <container>)
-;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident))
-;;NEW (if (pred obj)
-;;NEW (list (cons obj (loop (container-body obj))))
-;;NEW '()))
-;;NEW (else
-;;NEW (if (pred obj)
-;;NEW (list obj)
-;;NEW '()))))))
-;;NEW
+;;NEW ((pair? obj)
+;;NEW (apply append (map (lambda (o) (loop o)) obj)))
+;;NEW ((is-a? obj <container>)
+;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident))
+;;NEW (if (pred obj)
+;;NEW (list (cons obj (loop (container-body obj))))
+;;NEW '()))
+;;NEW (else
+;;NEW (if (pred obj)
+;;NEW (list obj)
+;;NEW '()))))))
+;;NEW
;;NEW ;;;; ======================================================================
;;NEW ;;;;
-;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G
+;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G
;;NEW ;;;
;;NEW ;;;; ======================================================================
;;NEW (define (the-body opt)
;;NEW ;; Filter out the options
;;NEW (let loop ((opt* opt)
-;;NEW (res '()))
+;;NEW (res '()))
;;NEW (cond
;;NEW ((null? opt*)
;;NEW (reverse! res))
@@ -427,18 +427,18 @@
;;NEW (skribe-error 'the-body "Illegal body" opt))
;;NEW ((keyword? (car opt*))
;;NEW (if (null? (cdr opt*))
-;;NEW (skribe-error 'the-body "Illegal option" (car opt*))
-;;NEW (loop (cddr opt*) res)))
+;;NEW (skribe-error 'the-body "Illegal option" (car opt*))
+;;NEW (loop (cddr opt*) res)))
;;NEW (else
;;NEW (loop (cdr opt*) (cons (car opt*) res))))))
-;;NEW
-;;NEW
-;;NEW
+;;NEW
+;;NEW
+;;NEW
;;NEW (define (the-options opt+ . out)
-;;NEW ;; Returns an list made of options.The OUT argument contains
-;;NEW ;; keywords that are filtered out.
+;;NEW ;; Returns an list made of options.The OUT argument contains
+;;NEW ;; keywords that are filtered out.
;;NEW (let loop ((opt* opt+)
-;;NEW (res '()))
+;;NEW (res '()))
;;NEW (cond
;;NEW ((null? opt*)
;;NEW (reverse! res))
@@ -446,15 +446,13 @@
;;NEW (skribe-error 'the-options "Illegal options" opt*))
;;NEW ((keyword? (car opt*))
;;NEW (cond
-;;NEW ((null? (cdr opt*))
-;;NEW (skribe-error 'the-options "Illegal option" (car opt*)))
-;;NEW ((memq (car opt*) out)
-;;NEW (loop (cdr opt*) res))
-;;NEW (else
-;;NEW (loop (cdr opt*)
-;;NEW (cons (list (car opt*) (cadr opt*)) res)))))
+;;NEW ((null? (cdr opt*))
+;;NEW (skribe-error 'the-options "Illegal option" (car opt*)))
+;;NEW ((memq (car opt*) out)
+;;NEW (loop (cdr opt*) res))
+;;NEW (else
+;;NEW (loop (cdr opt*)
+;;NEW (cons (list (car opt*) (cadr opt*)) res)))))
;;NEW (else
;;NEW (loop (cdr opt*) res)))))
-;;NEW
-
-
+;;NEW
diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm
new file mode 100644
index 0000000..2828908
--- /dev/null
+++ b/src/guile/skribilo/skribe/api.scm
@@ -0,0 +1,1260 @@
+;;; api.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 api))
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; This module contains all the core markups of Skribe/Skribilo.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `api.scm' file found in the `common' directory.
+
+(let ((gensym-orig gensym))
+ ;; In Skribe, `gensym' accepts a symbol. Guile's `gensym' accepts only
+ ;; strings.
+ (set! gensym
+ (lambda (obj)
+ (gensym-orig (cond ((symbol? obj) (symbol->string obj))
+ (else obj))))))
+
+;*---------------------------------------------------------------------*/
+;* include ... */
+;*---------------------------------------------------------------------*/
+(define-markup (include file)
+ (if (not (string? file))
+ (skribe-error 'include "Illegal file (string expected)" file)
+ (skribe-include file)))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(define-markup (document #!rest
+ opts
+ #!key
+ (ident #f) (class "document")
+ (title #f) (html-title #f) (author #f)
+ (ending #f) (env '()))
+ (new document
+ (markup 'document)
+ (ident (or ident
+ (ast->string title)
+ (symbol->string (gensym 'document))))
+ (class class)
+ (required-options '(:title :author :ending))
+ (options (the-options opts :ident :class :env))
+ (body (the-body opts))
+ (env (append env
+ (list (list 'chapter-counter 0) (list 'chapter-env '())
+ (list 'section-counter 0) (list 'section-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '())
+ (list 'figure-counter 0) (list 'figure-env '()))))))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(define-markup (author #!rest
+ opts
+ #!key
+ (ident #f) (class "author")
+ name
+ (title #f)
+ (affiliation #f)
+ (email #f)
+ (url #f)
+ (address #f)
+ (phone #f)
+ (photo #f)
+ (align 'center))
+ (if (not (memq align '(center left right)))
+ (skribe-error 'author "Illegal align value" align)
+ (new container
+ (markup 'author)
+ (ident (or ident (symbol->string (gensym 'author))))
+ (class class)
+ (required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
+ (options `((:name ,name)
+ (:align ,align)
+ ,@(the-options opts :ident :class)))
+ (body #f))))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(define-markup (toc #!rest
+ opts
+ #!key
+ (ident #f) (class "toc")
+ (chapter #t) (section #t) (subsection #f))
+ (let ((body (the-body opts)))
+ (new container
+ (markup 'toc)
+ (ident (or ident (symbol->string (gensym 'toc))))
+ (class class)
+ (required-options '())
+ (options `((:chapter ,chapter)
+ (:section ,section)
+ (:subsection ,subsection)
+ ,@(the-options opts :ident :class)))
+ (body (cond
+ ((null? body)
+ (new unresolved
+ (proc (lambda (n e env)
+ (handle
+ (resolve-search-parent n env document?))))))
+ ((null? (cdr body))
+ (if (handle? (car body))
+ (car body)
+ (skribe-error 'toc
+ "Illegal argument (handle expected)"
+ (if (markup? (car body))
+ (markup-markup (car body))
+ "???"))))
+ (else
+ (skribe-error 'toc "Illegal argument" body)))))))
+
+;*---------------------------------------------------------------------*/
+;* chapter ... ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:chapter@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:chapter@ */
+;*---------------------------------------------------------------------*/
+(define-markup (chapter #!rest
+ opts
+ #!key
+ (ident #f) (class "chapter")
+ title (html-title #f) (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'chapter)
+ (ident (or ident (symbol->string (gensym 'chapter))))
+ (class class)
+ (required-options '(:title :file :toc :number))
+ (options `((:toc ,toc)
+ (:number ,(and number
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n
+ env
+ 'chapter
+ number))))))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (list (list 'section-counter 0) (list 'section-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '())))))
+
+;*---------------------------------------------------------------------*/
+;* section-number ... */
+;*---------------------------------------------------------------------*/
+(define (section-number number markup)
+ (and number
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env markup number))))))
+
+;*---------------------------------------------------------------------*/
+;* section ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:section@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:sectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (section #!rest
+ opts
+ #!key
+ (ident #f) (class "section")
+ title (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'section)
+ (ident (or ident (symbol->string (gensym 'section))))
+ (class class)
+ (required-options '(:title :toc :file :toc :number))
+ (options `((:number ,(section-number number 'section))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (if file
+ (list (list 'subsection-counter 0) (list 'subsection-env '())
+ (list 'footnote-counter 0) (list 'footnote-env '()))
+ (list (list 'subsection-counter 0) (list 'subsection-env '()))))))
+
+;*---------------------------------------------------------------------*/
+;* subsection ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:subsection@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:subsectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (subsection #!rest
+ opts
+ #!key
+ (ident #f) (class "subsection")
+ title (file #f) (toc #t) (number #t))
+ (new container
+ (markup 'subsection)
+ (ident (or ident (symbol->string (gensym 'subsection))))
+ (class class)
+ (required-options '(:title :toc :file :number))
+ (options `((:number ,(section-number number 'subsection))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))
+ (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '())))))
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/sectioning.skb:subsubsection@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:subsubsectionr@ */
+;*---------------------------------------------------------------------*/
+(define-markup (subsubsection #!rest
+ opts
+ #!key
+ (ident #f) (class "subsubsection")
+ title (file #f) (toc #f) (number #t))
+ (new container
+ (markup 'subsubsection)
+ (ident (or ident (symbol->string (gensym 'subsubsection))))
+ (class class)
+ (required-options '(:title :toc :number :file))
+ (options `((:number ,(section-number number 'subsubsection))
+ (:toc ,toc)
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(define-simple-markup paragraph)
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(define-markup (footnote #!rest opts
+ #!key (ident #f) (class "footnote") (label #t))
+ ;; The `:label' option used to be called `:number'.
+ (new container
+ (markup 'footnote)
+ (ident (symbol->string (gensym 'footnote)))
+ (class class)
+ (required-options '())
+ (options `((:label
+ ,(cond ((string? label) label)
+ ((number? label) label)
+ ((not label) label)
+ (else
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env
+ 'footnote #t)))))
+ ,@(the-options opts :ident :class)))))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(define-markup (linebreak #!rest opts #!key (ident #f) (class #f))
+ (let ((ln (new markup
+ (ident (or ident (symbol->string (gensym 'linebreak))))
+ (class class)
+ (markup 'linebreak)))
+ (num (the-body opts)))
+ (cond
+ ((null? num)
+ ln)
+ ((not (null? (cdr num)))
+ (skribe-error 'linebreak "Illegal arguments" num))
+ ((not (and (integer? (car num)) (positive? (car num))))
+ (skribe-error 'linebreak "Illegal argument" (car num)))
+ (else
+ (vector->list (make-vector (car num) ln))))))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(define-markup (hrule #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width 100.) (height 1))
+ (new markup
+ (markup 'hrule)
+ (ident (or ident (symbol->string (gensym 'hrule))))
+ (class class)
+ (required-options '())
+ (options `((:width ,width)
+ (:height ,height)
+ ,@(the-options opts :ident :class)))
+ (body #f)))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(define-markup (color #!rest
+ opts
+ #!key
+ (ident #f) (class "color")
+ (bg #f) (fg #f) (width #f) (margin #f))
+ (new container
+ (markup 'color)
+ (ident (or ident (symbol->string (gensym 'color))))
+ (class class)
+ (required-options '(:bg :fg :width))
+ (options `((:bg ,(if bg (skribe-use-color! bg) bg))
+ (:fg ,(if fg (skribe-use-color! fg) fg))
+ ,@(the-options opts :ident :class :bg :fg)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(define-markup (frame #!rest
+ opts
+ #!key
+ (ident #f) (class "frame")
+ (width #f) (margin 2) (border 1))
+ (new container
+ (markup 'frame)
+ (ident (or ident (symbol->string (gensym 'frame))))
+ (class class)
+ (required-options '(:width :border :margin))
+ (options `((:margin ,margin)
+ (:border ,(cond
+ ((integer? border) border)
+ (border 1)
+ (else #f)))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(define-markup (font #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (size #f) (face #f))
+ (new container
+ (markup 'font)
+ (ident (or ident (symbol->string (gensym 'font))))
+ (class class)
+ (required-options '(:size))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(define-markup (flush #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ side)
+ (case side
+ ((center left right)
+ (new container
+ (markup 'flush)
+ (ident (or ident (symbol->string (gensym 'flush))))
+ (class class)
+ (required-options '(:side))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+ (else
+ (skribe-error 'flush "Illegal side" side))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(define-simple-container center)
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(define-simple-container pre)
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:prog@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:prog@ */
+;*---------------------------------------------------------------------*/
+(define-markup (prog #!rest
+ opts
+ #!key
+ (ident #f) (class "prog")
+ (line 1) (linedigit #f) (mark ";!"))
+ (if (not (or (string? mark) (eq? mark #f)))
+ (skribe-error 'prog "Illegal mark" mark)
+ (new container
+ (markup 'prog)
+ (ident (or ident (symbol->string (gensym 'prog))))
+ (class class)
+ (required-options '(:line :mark))
+ (options (the-options opts :ident :class :linedigit))
+ (body (make-prog-body (the-body opts) line linedigit mark)))))
+
+;*---------------------------------------------------------------------*/
+;* source ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:source@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:source@ */
+;*---------------------------------------------------------------------*/
+(define-markup (source #!rest
+ opts
+ #!key
+ language
+ (file #f) (start #f) (stop #f)
+ (definition #f) (tab 8))
+ (let ((body (the-body opts)))
+ (cond
+ ((and (not (null? body)) (or file start stop definition))
+ (skribe-error 'source
+ "file, start/stop, and definition are exclusive with body"
+ body))
+ ((and start stop definition)
+ (skribe-error 'source
+ "start/stop are exclusive with a definition"
+ body))
+ ((and (or start stop definition) (not file))
+ (skribe-error 'source
+ "start/stop and definition require a file specification"
+ file))
+ ((and definition (not language))
+ (skribe-error 'source
+ "definition requires a language specification"
+ definition))
+ ((and file (not (string? file)))
+ (skribe-error 'source "Illegal file" file))
+ ((and start (not (or (integer? start) (string? start))))
+ (skribe-error 'source "Illegal start" start))
+ ((and stop (not (or (integer? stop) (string? stop))))
+ (skribe-error 'source "Illegal start" stop))
+ ((and (integer? start) (integer? stop) (> start stop))
+ (skribe-error 'source
+ "start line > stop line"
+ (format "~a/~a" start stop)))
+ ((and language (not (language? language)))
+ (skribe-error 'source "Illegal language" language))
+ ((and tab (not (integer? tab)))
+ (skribe-error 'source "Illegal tab" tab))
+ (file
+ (let ((s (if (not definition)
+ (source-read-lines file start stop tab)
+ (source-read-definition file definition tab language))))
+ (if language
+ (source-fontify s language)
+ s)))
+ (language
+ (source-fontify body language))
+ (else
+ body))))
+
+;*---------------------------------------------------------------------*/
+;* language ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/prgm.skb:language@ */
+;*---------------------------------------------------------------------*/
+(define-markup (language #!key name (fontifier #f) (extractor #f))
+ (if (not (string? name))
+ (skribe-type-error 'language "Illegal name, " name "string")
+ (new language
+ (name name)
+ (fontifier fontifier)
+ (extractor extractor))))
+
+;*---------------------------------------------------------------------*/
+;* figure ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/figure.skb:figure@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:figure@ */
+;*---------------------------------------------------------------------*/
+(define-markup (figure #!rest
+ opts
+ #!key
+ (ident #f) (class "figure")
+ (legend #f) (number #t) (multicolumns #f))
+ (new container
+ (markup 'figure)
+ (ident (or ident
+ (let ((s (ast->string legend)))
+ (if (not (string=? s ""))
+ s
+ (symbol->string (gensym 'figure))))))
+ (class class)
+ (required-options '(:legend :number :multicolumns))
+ (options `((:number
+ ,(new unresolved
+ (proc (lambda (n e env)
+ (resolve-counter n env 'figure number)))))
+ ,@(the-options opts :ident :class)))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* parse-list-of ... */
+;* ------------------------------------------------------------- */
+;* The function table accepts two different prototypes. It */
+;* may receive its N elements in a list of N elements or in */
+;* a list of one element which is a list of N elements. This */
+;* gets rid of APPLY when calling container markup such as ITEMIZE */
+;* or TABLE. */
+;*---------------------------------------------------------------------*/
+(define (parse-list-of for markup lst)
+ (cond
+ ((null? lst)
+ '())
+ ((and (pair? lst)
+ (or (pair? (car lst)) (null? (car lst)))
+ (null? (cdr lst)))
+ (parse-list-of for markup (car lst)))
+ (else
+ (let loop ((lst lst))
+ (cond
+ ((null? lst)
+ '())
+ ((pair? (car lst))
+ (loop (car lst)))
+ (else
+ (let ((r (car lst)))
+ (if (not (is-markup? r markup))
+ (skribe-warning 2
+ for
+ (format "Illegal `~a' element, `~a' expected"
+ (if (markup? r)
+ (markup-markup r)
+ (find-runtime-type r))
+ markup)))
+ (cons r (loop (cdr lst))))))))))
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol)
+ (new container
+ (markup 'itemize)
+ (ident (or ident (symbol->string (gensym 'itemize))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'itemize 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol)
+ (new container
+ (markup 'enumerate)
+ (ident (or ident (symbol->string (gensym 'enumerate))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'enumerate 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol)
+ (new container
+ (markup 'description)
+ (ident (or ident (symbol->string (gensym 'description))))
+ (class class)
+ (required-options '(:symbol))
+ (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'description 'item (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(define-markup (item #!rest opts #!key (ident #f) (class #f) key)
+ (if (and key (not (or (string? key)
+ (number? key)
+ (markup? key)
+ (pair? key))))
+ (skribe-type-error 'item "Illegal key:" key "node")
+ (new container
+ (markup 'item)
+ (ident (or ident (symbol->string (gensym 'item))))
+ (class class)
+ (required-options '(:key))
+ (options `((:key ,key) ,@(the-options opts :ident :class :key)))
+ (body (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* table */
+;*---------------------------------------------------------------------*/
+(define-markup (table #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (border #f) (width #f)
+ (frame 'none) (rules 'none)
+ (cellstyle 'collapse) (cellpadding #f) (cellspacing #f))
+ (let ((frame (cond
+ ((string? frame)
+ (string->symbol frame))
+ ((not frame)
+ #f)
+ (else
+ frame)))
+ (rules (cond
+ ((string? rules)
+ (string->symbol rules))
+ ((not rules)
+ #f)
+ (else
+ rules)))
+ (frame-vals '(none above below hsides vsides lhs rhs box border))
+ (rules-vals '(none rows cols all header))
+ (cells-vals '(collapse separate)))
+ (cond
+ ((and frame (not (memq frame frame-vals)))
+ (skribe-error 'table
+ (format "frame should be one of \"~a\"" frame-vals)
+ frame))
+ ((and rules (not (memq rules rules-vals)))
+ (skribe-error 'table
+ (format "rules should be one of \"~a\"" rules-vals)
+ rules))
+ ((not (or (memq cellstyle cells-vals)
+ (string? cellstyle)
+ (number? cellstyle)))
+ (skribe-error 'table
+ (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals)
+ cellstyle))
+ (else
+ (new container
+ (markup 'table)
+ (ident (or ident (symbol->string (gensym 'table))))
+ (class class)
+ (required-options '(:width :frame :rules))
+ (options `((:frame ,frame)
+ (:rules ,rules)
+ (:cellstyle ,cellstyle)
+ ,@(the-options opts :ident :class)))
+ (body (parse-list-of 'table 'tr (the-body opts))))))))
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f))
+ (new container
+ (markup 'tr)
+ (ident (or ident (symbol->string (gensym 'tr))))
+ (class class)
+ (required-options '())
+ (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
+ ,@(the-options opts :ident :class :bg)))
+ (body (parse-list-of 'tr 'tc (the-body opts)))))
+
+;*---------------------------------------------------------------------*/
+;* tc... */
+;*---------------------------------------------------------------------*/
+(define-markup (tc m
+ #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (let ((align (if (string? align)
+ (string->symbol align)
+ align))
+ (valign (if (string? valign)
+ (string->symbol valign)
+ valign)))
+ (cond
+ ((not (integer? colspan))
+ (skribe-type-error 'tc "Illegal colspan, " colspan "integer"))
+ ((not (symbol? align))
+ (skribe-type-error 'tc "Illegal align, " align "align"))
+ ((not (memq align '(#f center left right)))
+ (skribe-error
+ 'tc
+ "align should be one of 'left', `center', or `right'"
+ align))
+ ((not (memq valign '(#f top middle center bottom)))
+ (skribe-error
+ 'tc
+ "valign should be one of 'top', `middle', `center', or `bottom'"
+ valign))
+ (else
+ (new container
+ (markup 'tc)
+ (ident (or ident (symbol->string (gensym 'tc))))
+ (class class)
+ (required-options '(:width :align :valign :colspan))
+ (options `((markup ,m)
+ (:align ,align)
+ (:valign ,valign)
+ (:colspan ,colspan)
+ ,@(if bg
+ `((:bg ,(if bg (skribe-use-color! bg) bg)))
+ '())
+ ,@(the-options opts :ident :class :bg :align :valign)))
+ (body (the-body opts)))))))
+
+;*---------------------------------------------------------------------*/
+;* th ... */
+;*---------------------------------------------------------------------*/
+(define-markup (th #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (apply tc 'th opts))
+
+;*---------------------------------------------------------------------*/
+;* td ... */
+;*---------------------------------------------------------------------*/
+(define-markup (td #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ (width #f) (align 'center) (valign #f)
+ (colspan 1) (bg #f))
+ (apply tc 'td opts))
+
+;*---------------------------------------------------------------------*/
+;* image ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/image.skb:image@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:image@ */
+;* latex: @ref ../../skr/latex.skr:image@ */
+;*---------------------------------------------------------------------*/
+(define-markup (image #!rest
+ opts
+ #!key
+ (ident #f) (class #f)
+ file (url #f) (width #f) (height #f) (zoom #f))
+ (cond
+ ((not (or (string? file) (string? url)))
+ (skribe-error 'image "No file or url provided" file))
+ ((and (string? file) (string? url))
+ (skribe-error 'image "Both file and url provided" (list file url)))
+ (else
+ (new markup
+ (markup 'image)
+ (ident (or ident (symbol->string (gensym 'image))))
+ (class class)
+ (required-options '(:file :url :width :height))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))))
+
+;*---------------------------------------------------------------------*/
+;* blockquote */
+;*---------------------------------------------------------------------*/
+(define-simple-markup blockquote)
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(define-simple-markup roman)
+(define-simple-markup bold)
+(define-simple-markup underline)
+(define-simple-markup strike)
+(define-simple-markup emph)
+(define-simple-markup kbd)
+(define-simple-markup it)
+(define-simple-markup tt)
+(define-simple-markup code)
+(define-simple-markup var)
+(define-simple-markup samp)
+(define-simple-markup sf)
+(define-simple-markup sc)
+(define-simple-markup sub)
+(define-simple-markup sup)
+
+;*---------------------------------------------------------------------*/
+;* char ... */
+;*---------------------------------------------------------------------*/
+(define-markup (char char)
+ (cond
+ ((char? char)
+ (string char))
+ ((integer? char)
+ (string (integer->char char)))
+ ((and (string? char) (= (string-length char) 1))
+ char)
+ (else
+ (skribe-error 'char "Illegal char" char))))
+
+;*---------------------------------------------------------------------*/
+;* symbol ... */
+;*---------------------------------------------------------------------*/
+(define-markup (symbol symbol)
+ (let ((v (cond
+ ((symbol? symbol)
+ (symbol->string symbol))
+ ((string? symbol)
+ symbol)
+ (else
+ (skribe-error 'symbol
+ "Illegal argument (symbol expected)"
+ symbol)))))
+ (new markup
+ (markup 'symbol)
+ (body v))))
+
+;*---------------------------------------------------------------------*/
+;* ! ... */
+;*---------------------------------------------------------------------*/
+(define-markup (! format #!rest node)
+ (if (not (string? format))
+ (skribe-type-error '! "Illegal format:" format "string")
+ (new command
+ (fmt format)
+ (body node))))
+
+;*---------------------------------------------------------------------*/
+;* processor ... */
+;*---------------------------------------------------------------------*/
+(define-markup (processor #!rest opts
+ #!key (combinator #f) (engine #f) (procedure #f))
+ (cond
+ ((and combinator (not (procedure? combinator)))
+ (skribe-error 'processor "Combinator not a procedure" combinator))
+ ((and engine (not (engine? engine)))
+ (skribe-error 'processor "Illegal engine" engine))
+ ((and procedure
+ (or (not (procedure? procedure))
+ (not (correct-arity? procedure 2))))
+ (skribe-error 'processor "Illegal procedure" procedure))
+ (else
+ (new processor
+ (combinator combinator)
+ (engine engine)
+ (procedure (or procedure (lambda (n e) n)))
+ (body (the-body opts))))))
+
+;*---------------------------------------------------------------------*/
+;* Processors ... */
+;*---------------------------------------------------------------------*/
+(define-processor-markup html-processor)
+(define-processor-markup tex-processor)
+
+;*---------------------------------------------------------------------*/
+;* handle ... */
+;*---------------------------------------------------------------------*/
+(define-markup (handle #!rest opts
+ #!key (ident #f) (class "handle") value section)
+ (let ((body (the-body opts)))
+ (cond
+ (section
+ (error 'handle "Illegal handle `section' option" section)
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (resolve-ident section 'section n env)))
+ (new handle
+ (ast s)))))))
+ ((and (pair? body)
+ (null? (cdr body))
+ (markup? (car body)))
+ (new handle
+ (ast (car body))))
+ (else
+ (skribe-error 'handle "Illegal handle" opts)))))
+
+;*---------------------------------------------------------------------*/
+;* mailto ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:mailto@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:mailto@ */
+;*---------------------------------------------------------------------*/
+(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text)
+ (new markup
+ (markup 'mailto)
+ (ident (or ident (symbol->string (gensym 'ident))))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* *mark-table* ... */
+;*---------------------------------------------------------------------*/
+(define *mark-table* (make-hashtable))
+
+;*---------------------------------------------------------------------*/
+;* mark ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:mark@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:mark@ */
+;*---------------------------------------------------------------------*/
+(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f))
+ (let ((bd (the-body opts)))
+ (cond
+ ((and (pair? bd) (not (null? (cdr bd))))
+ (skribe-error 'mark "Too many argument provided" bd))
+ ((null? bd)
+ (skribe-error 'mark "Missing argument" '()))
+ ((not (string? (car bd)))
+ (skribe-type-error 'mark "Illegal ident:" (car bd) "string"))
+ (ident
+ (skribe-error 'mark "Illegal `ident:' option" ident))
+ (else
+ (let* ((bs (ast->string bd))
+ (n (new markup
+ (markup 'mark)
+ (ident bs)
+ (class class)
+ (options (the-options opts :ident :class :text))
+ (body text))))
+ (hashtable-put! *mark-table* bs n)
+ n)))))
+
+;*---------------------------------------------------------------------*/
+;* ref ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/links.skb:ref@ */
+;* writer: */
+;* html: @ref ../../skr/html.skr:ref@ */
+;* latex: @ref ../../skr/latex.skr:ref@ */
+;*---------------------------------------------------------------------*/
+(define-markup (ref #!rest
+ opts
+ #!key
+ (class #f)
+ (ident #f)
+ (text #f)
+ (chapter #f)
+ (section #f)
+ (subsection #f)
+ (subsubsection #f)
+ (bib #f)
+ (bib-table (default-bib-table))
+ (url #f)
+ (figure #f)
+ (mark #f)
+ (handle #f)
+ (line #f)
+ (skribe #f)
+ (page #f))
+ (define (unref ast text kind)
+ (let ((msg (format "Can't find `~a': " kind)))
+ (if (ast? ast)
+ (begin
+ (skribe-warning/ast 1 ast 'ref msg text)
+ (new markup
+ (markup 'unref)
+ (ident (symbol->string 'unref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind) ,@(the-options opts :ident :class)))
+ (body (list text ": " (ast->file-location ast)))))
+ (begin
+ (skribe-warning 1 'ref msg text)
+ (new markup
+ (markup 'unref)
+ (ident (symbol->string 'unref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind) ,@(the-options opts :ident :class)))
+ (body text))))))
+ (define (skribe-ref skribe)
+ (let ((path (find-file/path skribe (skribe-path))))
+ (if (not path)
+ (unref #f skribe 'sui-file)
+ (let* ((sui (load-sui path))
+ (os (the-options opts :skribe :class :text))
+ (u (sui-ref->url (dirname path) sui ident os)))
+ (if (not u)
+ (unref #f os 'sui-ref)
+ (ref :url u :text text :ident ident :class class))))))
+ (define (handle-ref text)
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind handle) ,@(the-options opts :ident :class)))
+ (body text)))
+ (define (doref text kind)
+ (if (not (string? text))
+ (skribe-type-error 'ref "Illegal reference" text "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (resolve-ident text kind n env)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind)
+ (mark ,text)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n text (or kind 'ident)))))))))
+ (define (mark-ref mark)
+ (if (not (string? mark))
+ (skribe-type-error 'mark "Illegal mark, " mark "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((s (hashtable-get *mark-table* mark)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string 'ref))
+ (class class)
+ (required-options '(:text))
+ (options `((kind mark)
+ (mark ,mark)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n mark 'mark))))))))
+ (define (make-bib-ref v)
+ (let ((s (resolve-bib bib-table v)))
+ (if s
+ (let* ((n (new markup
+ (markup 'bib-ref)
+ (ident (symbol->string 'bib-ref))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (new handle
+ (ast s)))))
+ (h (new handle (ast n)))
+ (o (markup-option s 'used)))
+ (markup-option-add! s 'used (if (pair? o) (cons h o) (list h)))
+ n)
+ (unref #f v 'bib))))
+ (define (bib-ref text)
+ (if (pair? text)
+ (new markup
+ (markup 'bib-ref+)
+ (ident (symbol->string 'bib-ref+))
+ (class class)
+ (options (the-options opts :ident :class))
+ (body (map make-bib-ref text)))
+ (make-bib-ref text)))
+ (define (url-ref)
+ (new markup
+ (markup 'url-ref)
+ (ident (symbol->string 'url-ref))
+ (class class)
+ (required-options '(:url :text))
+ (options (the-options opts :ident :class))))
+ (define (line-ref line)
+ (new unresolved
+ (proc (lambda (n e env)
+ (let ((l (resolve-line line)))
+ (if (pair? l)
+ (new markup
+ (markup 'line-ref)
+ (ident (symbol->string 'line-ref))
+ (class class)
+ (options `((:text ,(markup-ident (car l)))
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast (car l)))))
+ (unref n line 'line)))))))
+ (let ((b (the-body opts)))
+ (if (not (null? b))
+ (skribe-warning 1 'ref "Arguments ignored " b))
+ (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))
+ (mark (mark-ref mark))
+ (bib (bib-ref bib))
+ (url (url-ref))
+ (line (line-ref line))
+ (else (skribe-error 'ref "Illegal reference" opts)))))
+
+;*---------------------------------------------------------------------*/
+;* resolve ... */
+;*---------------------------------------------------------------------*/
+(define-markup (resolve fun)
+ (new unresolved
+ (proc fun)))
+
+;*---------------------------------------------------------------------*/
+;* bibliography ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/bib.skb:bibliography@ */
+;*---------------------------------------------------------------------*/
+(define-markup (bibliography #!rest files
+ #!key
+ (command #f) (bib-table (default-bib-table)))
+ (for-each (lambda (f)
+ (cond
+ ((string? f)
+ (bib-load! bib-table f command))
+ ((pair? f)
+ (bib-add! bib-table f))
+ (else
+ (skribe-error "bibliography" "Illegal entry" f))))
+ (the-body files)))
+
+;*---------------------------------------------------------------------*/
+;* the-bibliography ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/bib.skb:the-bibliography@ */
+;* writer: */
+;* base: @ref ../../skr/base.skr:the-bibliography@ */
+;*---------------------------------------------------------------------*/
+(define-markup (the-bibliography #!rest opts
+ #!key
+ pred
+ (bib-table (default-bib-table))
+ (sort bib-sort/authors)
+ (count 'partial))
+ (if (not (memq count '(partial full)))
+ (skribe-error 'the-bibliography
+ "Cound must be either `partial' or `full'"
+ count)
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-the-bib bib-table
+ (new handle (ast n))
+ sort
+ pred
+ count
+ (the-options opts)))))))
+
+;*---------------------------------------------------------------------*/
+;* make-index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:make-index@ */
+;*---------------------------------------------------------------------*/
+(define-markup (make-index ident)
+ (make-index-table ident))
+
+;*---------------------------------------------------------------------*/
+;* index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:index@ */
+;*---------------------------------------------------------------------*/
+(define-markup (index #!rest
+ opts
+ #!key
+ (ident #f) (class "index")
+ (note #f) (index #f) (shape #f)
+ (url #f))
+ (let* ((entry-name (the-body opts))
+ (ename (cond
+ ((string? entry-name)
+ entry-name)
+ ((and (pair? entry-name) (every string? entry-name))
+ (apply string-append entry-name))
+ (else
+ (skribe-error
+ 'index
+ "entry-name must be either a string or a list of strings"
+ entry-name))))
+ (table (cond
+ ((not index) (default-index))
+ ((index? index) index)
+ (else (skribe-type-error 'index
+ "Illegal index table, "
+ index
+ "index"))))
+ (m (mark (symbol->string (gensym))))
+ (h (new handle (ast m)))
+ (new (new markup
+ (markup '&index-entry)
+ (ident (or ident (symbol->string (gensym 'index))))
+ (class class)
+ (options `((name ,ename) ,@(the-options opts :ident :class)))
+ (body (if url
+ (ref :url url :text (or shape ename))
+ (ref :handle h :text (or shape ename)))))))
+ ;; 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))
+ m))
+
+;*---------------------------------------------------------------------*/
+;* the-index ... */
+;* ------------------------------------------------------------- */
+;* doc: */
+;* @ref ../../doc/user/index.skb:the-index@ */
+;* writer: */
+;* base: @ref ../../skr/base.skr:the-index@ */
+;* html: @ref ../../skr/html.skr:the-index-header@ */
+;*---------------------------------------------------------------------*/
+(define-markup (the-index #!rest
+ opts
+ #!key
+ (ident #f)
+ (class "the-index")
+ (split #f)
+ (char-offset 0)
+ (header-limit 50)
+ (column 1))
+ (let ((bd (the-body opts)))
+ (cond
+ ((not (and (integer? char-offset) (>= char-offset 0)))
+ (skribe-error 'the-index "Illegal char offset" char-offset))
+ ((not (integer? column))
+ (skribe-error 'the-index "Illegal column number" column))
+ ((not (every? index? bd))
+ (skribe-error 'the-index
+ "Illegal indexes"
+ (filter (lambda (o) (not (index? o))) bd)))
+ (else
+ (new unresolved
+ (proc (lambda (n e env)
+ (resolve-the-index (ast-loc n)
+ ident class
+ bd
+ split
+ char-offset
+ header-limit
+ column))))))))
diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm
new file mode 100644
index 0000000..f1a32c1
--- /dev/null
+++ b/src/guile/skribilo/skribe/bib.scm
@@ -0,0 +1,215 @@
+;;; 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))
+
+;;; 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 (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 (hashtable-get table i)))
+ (if (is-markup? en '&bib-entry)
+ en
+ #f))))
+
+;*---------------------------------------------------------------------*/
+;* make-bib-entry ... */
+;*---------------------------------------------------------------------*/
+(define (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 (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
+ (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/index.scm b/src/guile/skribilo/skribe/index.scm
new file mode 100644
index 0000000..840a179
--- /dev/null
+++ b/src/guile/skribilo/skribe/index.scm
@@ -0,0 +1,149 @@
+;;; index.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 index))
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; A library of index-related functions.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `index.scm' file found in the `common' directory.
+
+
+;*---------------------------------------------------------------------*/
+;* index? ... */
+;*---------------------------------------------------------------------*/
+(define (index? obj)
+ (hashtable? obj))
+
+;*---------------------------------------------------------------------*/
+;* *index-table* ... */
+;*---------------------------------------------------------------------*/
+(define *index-table* #f)
+
+;*---------------------------------------------------------------------*/
+;* make-index-table ... */
+;*---------------------------------------------------------------------*/
+(define (make-index-table ident)
+ (make-hashtable))
+
+;*---------------------------------------------------------------------*/
+;* default-index ... */
+;*---------------------------------------------------------------------*/
+(define (default-index)
+ (if (not *index-table*)
+ (set! *index-table* (make-index-table "default-index")))
+ *index-table*)
+
+;*---------------------------------------------------------------------*/
+;* resolve-the-index ... */
+;*---------------------------------------------------------------------*/
+(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)))
+ (if (>= char-offset (string-length name))
+ (skribe-error 'the-index "char-offset out of bound" char-offset)
+ (string-ref name char-offset))))
+ ;; sort a bucket of entries (the entries in a bucket share there name)
+ (define (sort-entries-bucket ie)
+ (sort ie
+ (lambda (i1 i2)
+ (or (not (markup-option i1 :note))
+ (markup-option i2 :note)))))
+ ;; accumulate all the entries starting with the same letter
+ (define (letter-references refs)
+ (let ((letter (index-ref (car (car refs)))))
+ (let loop ((refs refs)
+ (acc '()))
+ (if (or (null? refs)
+ (not (char-ci=? letter (index-ref (car (car refs))))))
+ (values (char-upcase letter) acc refs)
+ (loop (cdr refs) (cons (car refs) acc))))))
+ ;; merge the buckets that comes from different index tables
+ (define (merge-buckets buckets)
+ (if (null? buckets)
+ '()
+ (let loop ((buckets buckets)
+ (res '()))
+ (cond
+ ((null? (cdr buckets))
+ (reverse! (cons (car buckets) res)))
+ ((string=? (markup-option (car (car buckets)) 'name)
+ (markup-option (car (cadr buckets)) 'name))
+ ;; we merge
+ (loop (cons (append (car buckets) (cadr buckets))
+ (cddr buckets))
+ res))
+ (else
+ (loop (cdr buckets)
+ (cons (car buckets) res)))))))
+ (let* ((entries (apply append (map hashtable->list indexes)))
+ (sorted (map sort-entries-bucket
+ (merge-buckets
+ (sort entries
+ (lambda (e1 e2)
+ (string-ci<?
+ (markup-option (car e1) 'name)
+ (markup-option (car e2) 'name))))))))
+ (if (and (not split) (< (apply + (map length sorted)) header-limit))
+ (new markup
+ (markup '&the-index)
+ (loc loc)
+ (ident i)
+ (class c)
+ (options `((:column ,col)))
+ (body sorted))
+ (let loop ((refs sorted)
+ (lrefs '())
+ (body '()))
+ (if (null? refs)
+ (new markup
+ (markup '&the-index)
+ (loc loc)
+ (ident i)
+ (class c)
+ (options `((:column ,col)
+ (header ,(new markup
+ (markup '&the-index-header)
+ (loc loc)
+ (body (reverse! lrefs))))))
+ (body (reverse! body)))
+ (call-with-values
+ (lambda () (letter-references refs))
+ (lambda (l lr next-refs)
+ (let* ((s (string l))
+ (m (mark (symbol->string (gensym s)) :text s))
+ (h (new handle (loc loc) (ast m)))
+ (r (ref :handle h :text s)))
+ (ast-loc-set! m loc)
+ (ast-loc-set! r loc)
+ (loop next-refs
+ (cons r lrefs)
+ (append lr (cons m body)))))))))))
+
+
+;;; index.scm ends here
diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm
new file mode 100644
index 0000000..8daca62
--- /dev/null
+++ b/src/guile/skribilo/skribe/param.scm
@@ -0,0 +1,93 @@
+;;; param.scm
+;;;
+;;; Copyright 2003 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 param))
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; Definition of various Skribe run-time parameters.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `param.scm' file found in the `common' directory.
+
+
+;*---------------------------------------------------------------------*/
+;* *skribe-rc-file* ... */
+;* ------------------------------------------------------------- */
+;* The "runtime command" file. */
+;*---------------------------------------------------------------------*/
+(define *skribe-rc-file* "skriberc")
+
+;*---------------------------------------------------------------------*/
+;* *skribe-auto-mode-alist* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-auto-mode-alist*
+ '(("html" . html)
+ ("sui" . sui)
+ ("tex" . latex)
+ ("ctex" . context)
+ ("xml" . xml)
+ ("info" . info)
+ ("txt" . ascii)
+ ("mgp" . mgp)
+ ("man" . man)))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-auto-load-alist* ... */
+;* ------------------------------------------------------------- */
+;* Autoload engines. */
+;*---------------------------------------------------------------------*/
+(define *skribe-auto-load-alist*
+ '((base . "base.skr")
+ (html . "html.skr")
+ (sui . "html.skr")
+ (latex . "latex.skr")
+ (context . "context.skr")
+ (xml . "xml.skr")))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-preload* ... */
+;* ------------------------------------------------------------- */
+;* The list of skribe files (e.g. styles) to be loaded at boot-time */
+;*---------------------------------------------------------------------*/
+(define *skribe-preload*
+ '("skribe.skr"))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-precustom* ... */
+;* ------------------------------------------------------------- */
+;* The list of pair <custom x value> to be assigned to the default */
+;* engine. */
+;*---------------------------------------------------------------------*/
+(define *skribe-precustom*
+ '())
+
+;*---------------------------------------------------------------------*/
+;* *skribebib-auto-mode-alist* ... */
+;*---------------------------------------------------------------------*/
+(define *skribebib-auto-mode-alist*
+ '(("bib" . "skribebibtex")))
+
+;;; param.scm ends here
diff --git a/src/guile/skribilo/skribe/sui.scm b/src/guile/skribilo/skribe/sui.scm
new file mode 100644
index 0000000..9baa36a
--- /dev/null
+++ b/src/guile/skribilo/skribe/sui.scm
@@ -0,0 +1,187 @@
+;;; sui.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 sui))
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; Library dealing with Skribe URL Indexes (SUI).
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `sui.scm' file found in the `common' directory.
+
+
+;*---------------------------------------------------------------------*/
+;* *sui-table* ... */
+;*---------------------------------------------------------------------*/
+(define *sui-table* (make-hashtable))
+
+;*---------------------------------------------------------------------*/
+;* load-sui ... */
+;* ------------------------------------------------------------- */
+;* Returns a SUI sexp if already loaded. Load it otherwise. */
+;* Raise an error if the file cannot be open. */
+;*---------------------------------------------------------------------*/
+(define (load-sui path)
+ (let ((sexp (hashtable-get *sui-table* path)))
+ (or sexp
+ (begin
+ (when (> *skribe-verbose* 0)
+ (fprintf (current-error-port) " [loading sui: ~a]\n" path))
+ (let ((p (open-input-file path)))
+ (if (not (input-port? p))
+ (skribe-error 'load-sui
+ "Can't find `Skribe Url Index' file"
+ path)
+ (unwind-protect
+ (let ((sexp (read p)))
+ (match-case sexp
+ ((sui (? string?) . ?-)
+ (hashtable-put! *sui-table* path sexp))
+ (else
+ (skribe-error 'load-sui
+ "Illegal `Skribe Url Index' file"
+ path)))
+ sexp)
+ (close-input-port p))))))))
+
+;*---------------------------------------------------------------------*/
+;* sui-ref->url ... */
+;*---------------------------------------------------------------------*/
+(define (sui-ref->url dir sui ident opts)
+ (let ((refs (sui-find-ref sui ident opts)))
+ (and (pair? refs)
+ (let ((base (sui-file sui))
+ (file (car (car refs)))
+ (mark (cdr (car refs))))
+ (format "~a/~a#~a" dir (or file base) mark)))))
+
+;*---------------------------------------------------------------------*/
+;* sui-title ... */
+;*---------------------------------------------------------------------*/
+(define (sui-title sexp)
+ (match-case sexp
+ ((sui (and ?title (? string?)) . ?-)
+ title)
+ (else
+ (skribe-error 'sui-title "Illegal `sui' format" sexp))))
+
+;*---------------------------------------------------------------------*/
+;* sui-file ... */
+;*---------------------------------------------------------------------*/
+(define (sui-file sexp)
+ (sui-key sexp :file))
+
+;*---------------------------------------------------------------------*/
+;* sui-key ... */
+;*---------------------------------------------------------------------*/
+(define (sui-key sexp key)
+ (match-case sexp
+ ((sui ?- . ?rest)
+ (let loop ((rest rest))
+ (and (pair? rest)
+ (if (eq? (car rest) key)
+ (and (pair? (cdr rest))
+ (cadr rest))
+ (loop (cdr rest))))))
+ (else
+ (skribe-error 'sui-key "Illegal `sui' format" sexp))))
+
+;*---------------------------------------------------------------------*/
+;* sui-find-ref ... */
+;*---------------------------------------------------------------------*/
+(define (sui-find-ref sui ident opts)
+ (let ((ident (assq :ident opts))
+ (mark (assq :mark opts))
+ (class (let ((c (assq :class opts)))
+ (and (pair? c) (cadr c))))
+ (chapter (assq :chapter opts))
+ (section (assq :section opts))
+ (subsection (assq :subsection opts))
+ (subsubsection (assq :subsubsection opts)))
+ (match-case sui
+ ((sui (? string?) . ?refs)
+ (cond
+ (mark (sui-search-ref 'marks refs (cadr mark) class))
+ (chapter (sui-search-ref 'chapters refs (cadr chapter) class))
+ (section (sui-search-ref 'sections refs (cadr section) class))
+ (subsection (sui-search-ref 'subsections refs (cadr subsection) class))
+ (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class))
+ (ident (sui-search-all-refs sui ident class))
+ (else '())))
+ (else
+ (skribe-error 'sui-find-ref "Illegal `sui' format" sui)))))
+
+;*---------------------------------------------------------------------*/
+;* sui-search-all-refs ... */
+;*---------------------------------------------------------------------*/
+(define (sui-search-all-refs sui id refs)
+ '())
+
+;*---------------------------------------------------------------------*/
+;* sui-search-ref ... */
+;*---------------------------------------------------------------------*/
+(define (sui-search-ref kind refs val class)
+ (define (find-ref refs val class)
+ (map (lambda (r)
+ (let ((f (memq :file r))
+ (c (memq :mark r)))
+ (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c)))))
+ (filter (if class
+ (lambda (m)
+ (and (pair? m)
+ (string? (car m))
+ (string=? (car m) val)
+ (let ((c (memq :class m)))
+ (and (pair? c)
+ (eq? (cadr c) class)))))
+ (lambda (m)
+ (and (pair? m)
+ (string? (car m))
+ (string=? (car m) val))))
+ refs)))
+ (let loop ((refs refs))
+ (if (pair? refs)
+ (if (and (pair? (car refs)) (eq? (caar refs) kind))
+ (find-ref (cdar refs) val class)
+ (loop (cdr refs)))
+ '())))
+
+;*---------------------------------------------------------------------*/
+;* sui-filter ... */
+;*---------------------------------------------------------------------*/
+(define (sui-filter sui pred1 pred2)
+ (match-case sui
+ ((sui (? string?) . ?refs)
+ (let loop ((refs refs)
+ (res '()))
+ (if (pair? refs)
+ (if (and (pred1 (car refs)))
+ (loop (cdr refs)
+ (cons (filter pred2 (cdar refs)) res))
+ (loop (cdr refs) res))
+ (reverse! res))))
+ (else
+ (skribe-error 'sui-filter "Illegal `sui' format" sui))))
diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm
new file mode 100644
index 0000000..f963020
--- /dev/null
+++ b/src/guile/skribilo/skribe/utils.scm
@@ -0,0 +1,259 @@
+;;; 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 (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 (find-markup-ident ident)
+ (let ((r (find-markups ident)))
+ (if (or (pair? r) (null? r))
+ r
+ '())))
+
+;*---------------------------------------------------------------------*/
+;* container-search-down ... */
+;*---------------------------------------------------------------------*/
+(define (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 (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 (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 (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 (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 (find1-up pred obj)
+ (let loop ((obj obj))
+ (cond
+ ((not (ast? obj))
+ #f)
+ ((pred obj)
+ obj)
+ (else
+ (loop (ast-parent obj))))))
+
+;*---------------------------------------------------------------------*/
+;* ast-document ... */
+;*---------------------------------------------------------------------*/
+(define (ast-document m)
+ (find1-up document? m))
+
+;*---------------------------------------------------------------------*/
+;* ast-chapter ... */
+;*---------------------------------------------------------------------*/
+(define (ast-chapter m)
+ (find1-up (lambda (n) (is-markup? n 'chapter)) m))
+
+;*---------------------------------------------------------------------*/
+;* ast-section ... */
+;*---------------------------------------------------------------------*/
+(define (ast-section m)
+ (find1-up (lambda (n) (is-markup? n 'section)) m))
+
+;*---------------------------------------------------------------------*/
+;* the-body ... */
+;* ------------------------------------------------------------- */
+;* Filter out the options */
+;*---------------------------------------------------------------------*/
+(define (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 (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 (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/skribe/source.scm b/src/guile/skribilo/source.scm
index 6ec0963..e56f350 100644
--- a/src/guile/skribe/source.scm
+++ b/src/guile/skribilo/source.scm
@@ -26,7 +26,7 @@
-(define-module (skribe source)
+(define-module (skribilo source)
:export (source-read-lines source-read-definition source-fontify))
diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm
new file mode 100644
index 0000000..0d51c70
--- /dev/null
+++ b/src/guile/skribilo/types.scm
@@ -0,0 +1,315 @@
+;;;
+;;; types.stk -- Definition of Skribe classes
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.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.
+;;;
+;;; Author: Erick Gallesio [eg@essi.fr]
+;;; Creation date: 12-Aug-2003 22:18 (eg)
+;;; Last file update: 28-Oct-2004 16:18 (eg)
+;;;
+
+(read-set! keywords 'prefix)
+(define-module (skribilo types) ;; FIXME: Why should it be a separate module?
+ :export (<ast> ast? ast-loc ast-loc-set!
+ <command> command? command-fmt command-body
+ <unresolved> unresolved? unresolved-proc
+ <handle> handle? handle-ast
+ <node> node? node-options node-loc
+ <engine> engine? engine-ident engine-format engine-customs
+ engine-filter engine-symbol-table
+ <writer> writer? write-object
+ <processor> processor? processor-combinator processor-engine
+ <markup> markup? bind-markup! markup-options is-markup?
+ markup-body find-markups write-object
+ <container> container? container-options
+ container-ident container-body
+ <document> document? document-ident document-body
+ document-options document-end
+ <language> language?
+ <location> location? ast-location
+
+ *node-table*)
+ :use-module (oop goops))
+
+(define *node-table* (make-hash-table))
+ ; Used to stores the nodes of an AST.
+ ; It permits to retrieve a node from its
+ ; identifier.
+
+
+;;; ======================================================================
+;;;
+;;; <AST>
+;;;
+;;; ======================================================================
+;;FIXME: set! location in <ast>
+(define-class <ast> ()
+ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified)
+ (loc :init-value #f))
+
+(define (ast? obj) (is-a? obj <ast>))
+(define (ast-loc obj) (slot-ref obj 'loc))
+(define (ast-loc-set! obj v) (slot-set! obj 'loc v))
+
+;;; ======================================================================
+;;;
+;;; <COMMAND>
+;;;
+;;; ======================================================================
+(define-class <command> (<ast>)
+ (fmt :init-keyword :fmt)
+ (body :init-keyword :body))
+
+(define (command? obj) (is-a? obj <command>))
+(define (command-fmt obj) (slot-ref obj 'fmt))
+(define (command-body obj) (slot-ref obj 'body))
+
+;;; ======================================================================
+;;;
+;;; <UNRESOLVED>
+;;;
+;;; ======================================================================
+(define-class <unresolved> (<ast>)
+ (proc :init-keyword :proc))
+
+(define (unresolved? obj) (is-a? obj <unresolved>))
+(define (unresolved-proc obj) (slot-ref obj 'proc))
+
+;;; ======================================================================
+;;;
+;;; <HANDLE>
+;;;
+;;; ======================================================================
+(define-class <handle> (<ast>)
+ (ast :init-keyword :ast :init-value #f :getter handle-ast))
+
+(define (handle? obj) (is-a? obj <handle>))
+(define (handle-ast obj) (slot-ref obj 'ast))
+
+;;; ======================================================================
+;;;
+;;; <ENGINE>
+;;;
+;;; ======================================================================
+(define-class <engine> ()
+ (ident :init-keyword :ident :init-value '???)
+ (format :init-keyword :format :init-value "raw")
+ (info :init-keyword :info :init-value '())
+ (version :init-keyword :version :init-value 'unspecified)
+ (delegate :init-keyword :delegate :init-value #f)
+ (writers :init-keyword :writers :init-value '())
+ (filter :init-keyword :filter :init-value #f)
+ (customs :init-keyword :custom :init-value '())
+ (symbol-table :init-keyword :symbol-table :init-value '()))
+
+
+
+
+(define (engine? obj)
+ (is-a? obj <engine>))
+
+(define (engine-ident obj) ;; Define it here since the doc searches it
+ (slot-ref obj 'ident))
+
+(define (engine-format obj) ;; Define it here since the doc searches it
+ (slot-ref obj 'format))
+
+(define (engine-customs obj) ;; Define it here since the doc searches it
+ (slot-ref obj 'customs))
+
+(define (engine-filter obj) ;; Define it here since the doc searches it
+ (slot-ref obj 'filter))
+
+(define (engine-symbol-table obj) ;; Define it here since the doc searches it
+ (slot-ref obj 'symbol-table))
+
+;;; ======================================================================
+;;;
+;;; <WRITER>
+;;;
+;;; ======================================================================
+(define-class <writer> ()
+ (ident :init-keyword :ident :init-value '??? :getter writer-ident)
+ (class :init-keyword :class :init-value 'unspecified
+ :getter writer-class)
+ (pred :init-keyword :pred :init-value 'unspecified)
+ (upred :init-keyword :upred :init-value 'unspecified)
+ (options :init-keyword :options :init-value '() :getter writer-options)
+ (verified? :init-keyword :verified? :init-value #f)
+ (validate :init-keyword :validate :init-value #f)
+ (before :init-keyword :before :init-value #f :getter writer-before)
+ (action :init-keyword :action :init-value #f :getter writer-action)
+ (after :init-keyword :after :init-value #f :getter writer-after))
+
+(define (writer? obj)
+ (is-a? obj <writer>))
+
+(define-method (write-object (obj <writer>) port)
+ (format port "#[~A (~A) ~A]"
+ (class-name (class-of obj))
+ (slot-ref obj 'ident)
+ (address-of obj)))
+
+;;; ======================================================================
+;;;
+;;; <NODE>
+;;;
+;;; ======================================================================
+(define-class <node> (<ast>)
+ (required-options :init-keyword :required-options :init-value '())
+ (options :init-keyword :options :init-value '())
+ (body :init-keyword :body :init-value #f
+ :getter node-body))
+
+(define (node? obj) (is-a? obj <node>))
+(define (node-options obj) (slot-ref obj 'options))
+(define node-loc ast-loc)
+
+
+;;; ======================================================================
+;;;
+;;; <PROCESSOR>
+;;;
+;;; ======================================================================
+(define-class <processor> (<node>)
+ (combinator :init-keyword :combinator :init-value (lambda (e1 e2) e1))
+ (engine :init-keyword :engine :init-value 'unspecified)
+ (procedure :init-keyword :procedure :init-value (lambda (n e) n)))
+
+(define (processor? obj) (is-a? obj <processor>))
+(define (processor-combinator obj) (slot-ref obj 'combinator))
+(define (processor-engine obj) (slot-ref obj 'engine))
+
+;;; ======================================================================
+;;;
+;;; <MARKUP>
+;;;
+;;; ======================================================================
+(define-class <markup> (<node>)
+ (ident :init-keyword :ident :getter markup-ident :init-value #f)
+ (class :init-keyword :class :getter markup-class :init-value #f)
+ (markup :init-keyword :markup :getter markup-markup))
+
+
+(define (bind-markup! node)
+ (hash-set! *node-table*
+ (markup-ident node)
+ ;(lambda (cur) (cons node cur))
+ (list node)))
+
+
+(define-method (initialize (self <markup>) initargs)
+ (next-method)
+ (bind-markup! self))
+
+
+(define (markup? obj) (is-a? obj <markup>))
+(define (markup-options obj) (slot-ref obj 'options))
+(define markup-body node-body)
+
+
+(define (is-markup? obj markup)
+ (and (is-a? obj <markup>)
+ (eq? (slot-ref obj 'markup) markup)))
+
+
+
+(define (find-markups ident)
+ (hash-ref *node-table* ident #f))
+
+
+(define-method (write-object (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)))
+
+;;; ======================================================================
+;;;
+;;; <CONTAINER>
+;;;
+;;; ======================================================================
+(define-class <container> (<markup>)
+ (env :init-keyword :env :init-value '()))
+
+(define (container? obj) (is-a? obj <container>))
+(define (container-env obj) (slot-ref obj 'env))
+(define container-options markup-options)
+(define container-ident markup-ident)
+(define container-body node-body)
+
+
+
+;;; ======================================================================
+;;;
+;;; <DOCUMENT>
+;;;
+;;; ======================================================================
+(define-class <document> (<container>))
+
+(define (document? obj) (is-a? obj <document>))
+(define (document-ident obj) (slot-ref obj 'ident))
+(define (document-body obj) (slot-ref obj 'body))
+(define document-options markup-options)
+(define document-env container-env)
+
+
+
+;;; ======================================================================
+;;;
+;;; <LANGUAGE>
+;;;
+;;; ======================================================================
+(define-class <language> ()
+ (name :init-keyword :name :init-value #f :getter langage-name)
+ (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier)
+ (extractor :init-keyword :extractor :init-value #f :getter langage-extractor))
+
+(define (language? obj)
+ (is-a? obj <language>))
+
+
+;;; ======================================================================
+;;;
+;;; <LOCATION>
+;;;
+;;; ======================================================================
+(define-class <location> ()
+ (file :init-keyword :file :getter location-file)
+ (pos :init-keyword :pos :getter location-pos)
+ (line :init-keyword :line :getter location-line))
+
+(define (location? obj)
+ (is-a? obj <location>))
+
+(define (ast-location obj)
+ (let ((loc (slot-ref obj 'loc)))
+ (if (location? loc)
+ (let* ((fname (location-file loc))
+ (line (location-line loc))
+ (pwd (getcwd))
+ (len (string-length pwd))
+ (lenf (string-length fname))
+ (file (if (and (substring=? pwd fname len)
+ (> lenf len))
+ (substring fname len (+ 1 (string-length fname)))
+ fname)))
+ (format "~a, line ~a" file line))
+ "no source location")))
diff --git a/src/guile/skribilo/vars.scm b/src/guile/skribilo/vars.scm
new file mode 100644
index 0000000..51a7ee7
--- /dev/null
+++ b/src/guile/skribilo/vars.scm
@@ -0,0 +1,65 @@
+;;;
+;;; vars.scm -- Skribe Globals
+;;;
+;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; 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-module (skribilo vars))
+
+;;;
+;;; Switches
+;;;
+(define-public *skribe-verbose* 0)
+(define-public *skribe-warning* 5)
+(define-public *load-rc* #t)
+
+;;;
+;;; PATH variables
+;;;
+(define-public *skribe-path* #f)
+(define-public *skribe-bib-path* '("."))
+(define-public *skribe-source-path* '("."))
+(define-public *skribe-image-path* '("."))
+
+
+(define-public *skribe-rc-directory*
+ (string-append (getenv "HOME") "/" ".skribilo"))
+
+
+;;;
+;;; In and out ports
+;;;
+(define-public *skribe-src* '())
+(define-public *skribe-dest* #f)
+
+;;;
+;;; Engine
+;;;
+(define-public *skribe-engine* 'html) ;; Use HTML by default
+
+;;;
+;;; Misc
+;;;
+(define-public *skribe-chapter-split* '())
+(define-public *skribe-ref-base* #f)
+(define-public *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter
+(define-public *skribe-variants* '())
+
+
diff --git a/src/guile/skribe/verify.scm b/src/guile/skribilo/verify.scm
index 7c88616..93a1be3 100644
--- a/src/guile/skribe/verify.scm
+++ b/src/guile/skribilo/verify.scm
@@ -24,14 +24,14 @@
;;;; Last file update: 27-Oct-2004 16:35 (eg)
;;;;
-(define-module (skribe verify)
+(define-module (skribilo verify)
:export (verify))
-(use-modules (skribe debug)
-; (skribe engine)
-; (skribe writer)
-; (skribe runtime)
- (skribe types)
+(use-modules (skribilo debug)
+; (skribilo engine)
+; (skribilo writer)
+; (skribilo runtime)
+ (skribilo types)
(oop goops))
diff --git a/src/guile/skribe/writer.scm b/src/guile/skribilo/writer.scm
index 9e7faf6..048dcfb 100644
--- a/src/guile/skribe/writer.scm
+++ b/src/guile/skribilo/writer.scm
@@ -25,14 +25,14 @@
;;;;
-(define-module (skribe writer)
+(define-module (skribilo writer)
:export (invoke markup-writer markup-writer-get markup-writer-get*
lookup-markup-writer copy-markup-writer))
-(use-modules (skribe debug)
-; (skribe engine)
- (skribe output)
+(use-modules (skribilo debug)
+; (skribilo engine)
+ (skribilo output)
(oop goops)
(ice-9 optargs))