aboutsummaryrefslogtreecommitdiff
path: root/src/guile/skribilo
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/guile/skribilo
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/guile/skribilo')
-rw-r--r--src/guile/skribilo/Makefile.in110
-rw-r--r--src/guile/skribilo/biblio.scm159
-rw-r--r--src/guile/skribilo/color.scm621
-rw-r--r--src/guile/skribilo/coloring/c-lex.l67
-rw-r--r--src/guile/skribilo/coloring/c.scm93
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l91
-rw-r--r--src/guile/skribilo/coloring/lisp.scm293
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l64
-rw-r--r--src/guile/skribilo/coloring/xml.scm53
-rw-r--r--src/guile/skribilo/config.scm.in21
-rw-r--r--src/guile/skribilo/debug.scm161
-rw-r--r--src/guile/skribilo/engine.scm251
-rw-r--r--src/guile/skribilo/eval.scm186
-rw-r--r--src/guile/skribilo/lib.scm360
-rw-r--r--src/guile/skribilo/module.scm118
-rw-r--r--src/guile/skribilo/output.scm162
-rw-r--r--src/guile/skribilo/prog.scm218
-rw-r--r--src/guile/skribilo/reader.scm82
-rw-r--r--src/guile/skribilo/reader/skribe.scm80
-rw-r--r--src/guile/skribilo/resolve.scm260
-rw-r--r--src/guile/skribilo/runtime.scm458
-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.scm190
-rw-r--r--src/guile/skribilo/types.scm315
-rw-r--r--src/guile/skribilo/vars.scm65
-rw-r--r--src/guile/skribilo/verify.scm161
-rw-r--r--src/guile/skribilo/writer.scm217
32 files changed, 7019 insertions, 0 deletions
diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in
new file mode 100644
index 0000000..80a26de
--- /dev/null
+++ b/src/guile/skribilo/Makefile.in
@@ -0,0 +1,110 @@
+#
+# Makefile.in -- Skribe Src Makefile
+#
+# 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: 10-Aug-2003 20:26 (eg)
+# Last file update: 6-Mar-2004 16:00 (eg)
+#
+include ../../etc/stklos/Makefile.skb
+
+prefix=@PREFIX@
+
+SKR = $(wildcard ../../skr/*.skr)
+
+DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \
+ ../common/index.scm ../common/bib.scm ../common/lib.scm
+
+SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \
+ eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \
+ resolve.stk runtime.stk source.stk types.stk vars.stk \
+ verify.stk writer.stk xml.stk
+
+LEXFILES = c-lex.l lisp-lex.l xml-lex.l
+
+LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk
+
+BINDIR=../../bin
+
+EXE= $(BINDIR)/skribe.stklos
+
+PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES)
+
+SFLAGS=
+
+all: $(EXE)
+
+Makefile: Makefile.in
+ (cd ../../etc/stklos; autoconf; configure)
+
+$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS)
+ stklos-compile $(SFLAGS) -o $(EXE) main.stk && \
+ chmod $(BMASK) $(EXE)
+
+#
+# Lex files
+#
+lisp-lex.stk: lisp-lex.l
+ stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex
+
+xml-lex.stk: xml-lex.l
+ stklos-genlex xml-lex.l xml-lex.stk xml-lex
+
+c-lex.stk: c-lex.l
+ stklos-genlex c-lex.l c-lex.stk c-lex
+
+
+install: $(INSTALL_BINDIR)
+ cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \
+ && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos
+ rm -f $(INSTALL_BINDIR)/skribe
+ ln -s skribe.stklos $(INSTALL_BINDIR)/skribe
+
+uninstall:
+ rm $(INSTALL_BINDIR)/skribe
+ rm $(INSTALL_BINDIR)/skribe.stklos
+
+$(BINDIR):
+ mkdir -p $(BINDIR) && chmod a+rx $(BINDIR)
+
+$(INSTALL_BINDIR):
+ mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR)
+
+##
+## Services
+##
+tags: TAGS
+
+TAGS: $(SRCS)
+ etags -l scheme $(SRCS)
+
+pop:
+ @echo $(PRCS_FILES:%=src/stklos/%)
+
+links:
+ ln -s $(DEPS) .
+ ln -s $(SKR) .
+
+clean:
+ /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr
+
+distclean: clean
+ /bin/rm -f Makefile
+ /bin/rm -f ../common/configure.scm
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm
new file mode 100644
index 0000000..0a4fc98
--- /dev/null
+++ b/src/guile/skribilo/biblio.scm
@@ -0,0 +1,159 @@
+;;;
+;;; 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)
+
+;; Forward declarations
+(define skribe-open-bib-file #f)
+(define parse-bib #f)
+
+
+
+;;; ======================================================================
+;;;
+;;; Utilities
+;;;
+;;; ======================================================================
+
+(define (make-bib-table ident)
+ (make-hash-table))
+
+(define (bib-table? obj)
+ (hashtable? obj))
+
+(define (default-bib-table)
+ (unless *bib-table*
+ (set! *bib-table* (make-bib-table "default-bib-table")))
+ *bib-table*)
+
+;;
+;; Utilities
+;;
+(define (%bib-error who entry)
+ (let ((msg "bibliography syntax error on entry"))
+ (if (%epair? entry)
+ (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry)
+ (skribe-error who msg entry))))
+
+;;; ======================================================================
+;;;
+;;; BIB-DUPLICATE
+;;;
+;;; ======================================================================
+(define (bib-duplicate ident from old)
+ (let ((ofrom (markup-option old 'from)))
+ (skribe-warning 2
+ 'bib
+ (format "Duplicated bibliographic entry ~a'.\n" ident)
+ (if ofrom
+ (format " Using version of `~a'.\n" ofrom)
+ "")
+ (if from
+ (format " Ignoring version of `~a'." from)
+ " Ignoring redefinition."))))
+
+
+;;; ======================================================================
+;;;
+;;; PARSE-BIB
+;;;
+;;; ======================================================================
+(define (parse-bib table port)
+ (if (not (bib-table? table))
+ (skribe-error 'parse-bib "Illegal bibliography table" table)
+ (let ((from (port-file-name port)))
+ (let Loop ((entry (read port)))
+ (unless (eof-object? entry)
+ (cond
+ ((and (list? entry) (> (length entry) 2))
+ (let* ((kind (car entry))
+ (key (format "~A" (cadr entry)))
+ (fields (cddr entry))
+ (old (hashtable-get table key)))
+ (if old
+ (bib-duplicate ident from old)
+ (hash-table-put! table
+ key
+ (make-bib-entry kind key fields from)))
+ (Loop (read port))))
+ (else
+ (%bib-error 'bib-parse entry))))))))
+
+
+;;; ======================================================================
+;;;
+;;; BIB-ADD!
+;;;
+;;; ======================================================================
+(define (bib-add! table . entries)
+ (if (not (bib-table? table))
+ (skribe-error 'bib-add! "Illegal bibliography table" table)
+ (for-each (lambda (entry)
+ (cond
+ ((and (list? entry) (> (length entry) 2))
+ (let* ((kind (car entry))
+ (key (format "~A" (cadr entry)))
+ (fields (cddr entry))
+ (old (hashtable-get table ident)))
+ (if old
+ (bib-duplicate key #f old)
+ (hash-table-put! table
+ key
+ (make-bib-entry kind key fields #f)))))
+ (else
+ (%bib-error 'bib-add! entry))))
+ entries)))
+
+
+;;; ======================================================================
+;;;
+;;; SKRIBE-OPEN-BIB-FILE
+;;;
+;;; ======================================================================
+;; FIXME: Factoriser
+(define (skribe-open-bib-file file command)
+ (let ((path (find-path file *skribe-bib-path*)))
+ (if (string? path)
+ (begin
+ (when (> *skribe-verbose* 0)
+ (format (current-error-port) " [loading bibliography: ~S]\n" path))
+ (open-input-file (if (string? command)
+ (string-append "| "
+ (format command path))
+ path)))
+ (begin
+ (skribe-warning 1
+ 'bibliography
+ "Can't find bibliography -- " file)
+ #f))))
diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm
new file mode 100644
index 0000000..1e762e6
--- /dev/null
+++ b/src/guile/skribilo/color.scm
@@ -0,0 +1,621 @@
+;;;;
+;;;; color.scm -- Skribe Color Management
+;;;;
+;;;; 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: 25-Oct-2003 00:10 (eg)
+;;;; Last file update: 12-Feb-2004 18:24 (eg)
+;;;;
+
+(define-module (skribilo color)
+ :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!))
+
+(define *used-colors* '())
+
+(define *skribe-rgb-alist* '(
+ ("snow" . "255 250 250")
+ ("ghostwhite" . "248 248 255")
+ ("whitesmoke" . "245 245 245")
+ ("gainsboro" . "220 220 220")
+ ("floralwhite" . "255 250 240")
+ ("oldlace" . "253 245 230")
+ ("linen" . "250 240 230")
+ ("antiquewhite" . "250 235 215")
+ ("papayawhip" . "255 239 213")
+ ("blanchedalmond" . "255 235 205")
+ ("bisque" . "255 228 196")
+ ("peachpuff" . "255 218 185")
+ ("navajowhite" . "255 222 173")
+ ("moccasin" . "255 228 181")
+ ("cornsilk" . "255 248 220")
+ ("ivory" . "255 255 240")
+ ("lemonchiffon" . "255 250 205")
+ ("seashell" . "255 245 238")
+ ("honeydew" . "240 255 240")
+ ("mintcream" . "245 255 250")
+ ("azure" . "240 255 255")
+ ("aliceblue" . "240 248 255")
+ ("lavender" . "230 230 250")
+ ("lavenderblush" . "255 240 245")
+ ("mistyrose" . "255 228 225")
+ ("white" . "255 255 255")
+ ("black" . "0 0 0")
+ ("darkslategrey" . "47 79 79")
+ ("dimgrey" . "105 105 105")
+ ("slategrey" . "112 128 144")
+ ("lightslategrey" . "119 136 153")
+ ("grey" . "190 190 190")
+ ("lightgrey" . "211 211 211")
+ ("midnightblue" . "25 25 112")
+ ("navy" . "0 0 128")
+ ("navyblue" . "0 0 128")
+ ("cornflowerblue" . "100 149 237")
+ ("darkslateblue" . "72 61 139")
+ ("slateblue" . "106 90 205")
+ ("mediumslateblue" . "123 104 238")
+ ("lightslateblue" . "132 112 255")
+ ("mediumblue" . "0 0 205")
+ ("royalblue" . "65 105 225")
+ ("blue" . "0 0 255")
+ ("dodgerblue" . "30 144 255")
+ ("deepskyblue" . "0 191 255")
+ ("skyblue" . "135 206 235")
+ ("lightskyblue" . "135 206 250")
+ ("steelblue" . "70 130 180")
+ ("lightsteelblue" . "176 196 222")
+ ("lightblue" . "173 216 230")
+ ("powderblue" . "176 224 230")
+ ("paleturquoise" . "175 238 238")
+ ("darkturquoise" . "0 206 209")
+ ("mediumturquoise" . "72 209 204")
+ ("turquoise" . "64 224 208")
+ ("cyan" . "0 255 255")
+ ("lightcyan" . "224 255 255")
+ ("cadetblue" . "95 158 160")
+ ("mediumaquamarine" . "102 205 170")
+ ("aquamarine" . "127 255 212")
+ ("darkgreen" . "0 100 0")
+ ("darkolivegreen" . "85 107 47")
+ ("darkseagreen" . "143 188 143")
+ ("seagreen" . "46 139 87")
+ ("mediumseagreen" . "60 179 113")
+ ("lightseagreen" . "32 178 170")
+ ("palegreen" . "152 251 152")
+ ("springgreen" . "0 255 127")
+ ("lawngreen" . "124 252 0")
+ ("green" . "0 255 0")
+ ("chartreuse" . "127 255 0")
+ ("mediumspringgreen" . "0 250 154")
+ ("greenyellow" . "173 255 47")
+ ("limegreen" . "50 205 50")
+ ("yellowgreen" . "154 205 50")
+ ("forestgreen" . "34 139 34")
+ ("olivedrab" . "107 142 35")
+ ("darkkhaki" . "189 183 107")
+ ("khaki" . "240 230 140")
+ ("palegoldenrod" . "238 232 170")
+ ("lightgoldenrodyellow" . "250 250 210")
+ ("lightyellow" . "255 255 224")
+ ("yellow" . "255 255 0")
+ ("gold" . "255 215 0")
+ ("lightgoldenrod" . "238 221 130")
+ ("goldenrod" . "218 165 32")
+ ("darkgoldenrod" . "184 134 11")
+ ("rosybrown" . "188 143 143")
+ ("indianred" . "205 92 92")
+ ("saddlebrown" . "139 69 19")
+ ("sienna" . "160 82 45")
+ ("peru" . "205 133 63")
+ ("burlywood" . "222 184 135")
+ ("beige" . "245 245 220")
+ ("wheat" . "245 222 179")
+ ("sandybrown" . "244 164 96")
+ ("tan" . "210 180 140")
+ ("chocolate" . "210 105 30")
+ ("firebrick" . "178 34 34")
+ ("brown" . "165 42 42")
+ ("darksalmon" . "233 150 122")
+ ("salmon" . "250 128 114")
+ ("lightsalmon" . "255 160 122")
+ ("orange" . "255 165 0")
+ ("darkorange" . "255 140 0")
+ ("coral" . "255 127 80")
+ ("lightcoral" . "240 128 128")
+ ("tomato" . "255 99 71")
+ ("orangered" . "255 69 0")
+ ("red" . "255 0 0")
+ ("hotpink" . "255 105 180")
+ ("deeppink" . "255 20 147")
+ ("pink" . "255 192 203")
+ ("lightpink" . "255 182 193")
+ ("palevioletred" . "219 112 147")
+ ("maroon" . "176 48 96")
+ ("mediumvioletred" . "199 21 133")
+ ("violetred" . "208 32 144")
+ ("magenta" . "255 0 255")
+ ("violet" . "238 130 238")
+ ("plum" . "221 160 221")
+ ("orchid" . "218 112 214")
+ ("mediumorchid" . "186 85 211")
+ ("darkorchid" . "153 50 204")
+ ("darkviolet" . "148 0 211")
+ ("blueviolet" . "138 43 226")
+ ("purple" . "160 32 240")
+ ("mediumpurple" . "147 112 219")
+ ("thistle" . "216 191 216")
+ ("snow1" . "255 250 250")
+ ("snow2" . "238 233 233")
+ ("snow3" . "205 201 201")
+ ("snow4" . "139 137 137")
+ ("seashell1" . "255 245 238")
+ ("seashell2" . "238 229 222")
+ ("seashell3" . "205 197 191")
+ ("seashell4" . "139 134 130")
+ ("antiquewhite1" . "255 239 219")
+ ("antiquewhite2" . "238 223 204")
+ ("antiquewhite3" . "205 192 176")
+ ("antiquewhite4" . "139 131 120")
+ ("bisque1" . "255 228 196")
+ ("bisque2" . "238 213 183")
+ ("bisque3" . "205 183 158")
+ ("bisque4" . "139 125 107")
+ ("peachpuff1" . "255 218 185")
+ ("peachpuff2" . "238 203 173")
+ ("peachpuff3" . "205 175 149")
+ ("peachpuff4" . "139 119 101")
+ ("navajowhite1" . "255 222 173")
+ ("navajowhite2" . "238 207 161")
+ ("navajowhite3" . "205 179 139")
+ ("navajowhite4" . "139 121 94")
+ ("lemonchiffon1" . "255 250 205")
+ ("lemonchiffon2" . "238 233 191")
+ ("lemonchiffon3" . "205 201 165")
+ ("lemonchiffon4" . "139 137 112")
+ ("cornsilk1" . "255 248 220")
+ ("cornsilk2" . "238 232 205")
+ ("cornsilk3" . "205 200 177")
+ ("cornsilk4" . "139 136 120")
+ ("ivory1" . "255 255 240")
+ ("ivory2" . "238 238 224")
+ ("ivory3" . "205 205 193")
+ ("ivory4" . "139 139 131")
+ ("honeydew1" . "240 255 240")
+ ("honeydew2" . "224 238 224")
+ ("honeydew3" . "193 205 193")
+ ("honeydew4" . "131 139 131")
+ ("lavenderblush1" . "255 240 245")
+ ("lavenderblush2" . "238 224 229")
+ ("lavenderblush3" . "205 193 197")
+ ("lavenderblush4" . "139 131 134")
+ ("mistyrose1" . "255 228 225")
+ ("mistyrose2" . "238 213 210")
+ ("mistyrose3" . "205 183 181")
+ ("mistyrose4" . "139 125 123")
+ ("azure1" . "240 255 255")
+ ("azure2" . "224 238 238")
+ ("azure3" . "193 205 205")
+ ("azure4" . "131 139 139")
+ ("slateblue1" . "131 111 255")
+ ("slateblue2" . "122 103 238")
+ ("slateblue3" . "105 89 205")
+ ("slateblue4" . "71 60 139")
+ ("royalblue1" . "72 118 255")
+ ("royalblue2" . "67 110 238")
+ ("royalblue3" . "58 95 205")
+ ("royalblue4" . "39 64 139")
+ ("blue1" . "0 0 255")
+ ("blue2" . "0 0 238")
+ ("blue3" . "0 0 205")
+ ("blue4" . "0 0 139")
+ ("dodgerblue1" . "30 144 255")
+ ("dodgerblue2" . "28 134 238")
+ ("dodgerblue3" . "24 116 205")
+ ("dodgerblue4" . "16 78 139")
+ ("steelblue1" . "99 184 255")
+ ("steelblue2" . "92 172 238")
+ ("steelblue3" . "79 148 205")
+ ("steelblue4" . "54 100 139")
+ ("deepskyblue1" . "0 191 255")
+ ("deepskyblue2" . "0 178 238")
+ ("deepskyblue3" . "0 154 205")
+ ("deepskyblue4" . "0 104 139")
+ ("skyblue1" . "135 206 255")
+ ("skyblue2" . "126 192 238")
+ ("skyblue3" . "108 166 205")
+ ("skyblue4" . "74 112 139")
+ ("lightskyblue1" . "176 226 255")
+ ("lightskyblue2" . "164 211 238")
+ ("lightskyblue3" . "141 182 205")
+ ("lightskyblue4" . "96 123 139")
+ ("lightsteelblue1" . "202 225 255")
+ ("lightsteelblue2" . "188 210 238")
+ ("lightsteelblue3" . "162 181 205")
+ ("lightsteelblue4" . "110 123 139")
+ ("lightblue1" . "191 239 255")
+ ("lightblue2" . "178 223 238")
+ ("lightblue3" . "154 192 205")
+ ("lightblue4" . "104 131 139")
+ ("lightcyan1" . "224 255 255")
+ ("lightcyan2" . "209 238 238")
+ ("lightcyan3" . "180 205 205")
+ ("lightcyan4" . "122 139 139")
+ ("paleturquoise1" . "187 255 255")
+ ("paleturquoise2" . "174 238 238")
+ ("paleturquoise3" . "150 205 205")
+ ("paleturquoise4" . "102 139 139")
+ ("cadetblue1" . "152 245 255")
+ ("cadetblue2" . "142 229 238")
+ ("cadetblue3" . "122 197 205")
+ ("cadetblue4" . "83 134 139")
+ ("turquoise1" . "0 245 255")
+ ("turquoise2" . "0 229 238")
+ ("turquoise3" . "0 197 205")
+ ("turquoise4" . "0 134 139")
+ ("cyan1" . "0 255 255")
+ ("cyan2" . "0 238 238")
+ ("cyan3" . "0 205 205")
+ ("cyan4" . "0 139 139")
+ ("aquamarine1" . "127 255 212")
+ ("aquamarine2" . "118 238 198")
+ ("aquamarine3" . "102 205 170")
+ ("aquamarine4" . "69 139 116")
+ ("darkseagreen1" . "193 255 193")
+ ("darkseagreen2" . "180 238 180")
+ ("darkseagreen3" . "155 205 155")
+ ("darkseagreen4" . "105 139 105")
+ ("seagreen1" . "84 255 159")
+ ("seagreen2" . "78 238 148")
+ ("seagreen3" . "67 205 128")
+ ("seagreen4" . "46 139 87")
+ ("palegreen1" . "154 255 154")
+ ("palegreen2" . "144 238 144")
+ ("palegreen3" . "124 205 124")
+ ("palegreen4" . "84 139 84")
+ ("springgreen1" . "0 255 127")
+ ("springgreen2" . "0 238 118")
+ ("springgreen3" . "0 205 102")
+ ("springgreen4" . "0 139 69")
+ ("green1" . "0 255 0")
+ ("green2" . "0 238 0")
+ ("green3" . "0 205 0")
+ ("green4" . "0 139 0")
+ ("chartreuse1" . "127 255 0")
+ ("chartreuse2" . "118 238 0")
+ ("chartreuse3" . "102 205 0")
+ ("chartreuse4" . "69 139 0")
+ ("olivedrab1" . "192 255 62")
+ ("olivedrab2" . "179 238 58")
+ ("olivedrab3" . "154 205 50")
+ ("olivedrab4" . "105 139 34")
+ ("darkolivegreen1" . "202 255 112")
+ ("darkolivegreen2" . "188 238 104")
+ ("darkolivegreen3" . "162 205 90")
+ ("darkolivegreen4" . "110 139 61")
+ ("khaki1" . "255 246 143")
+ ("khaki2" . "238 230 133")
+ ("khaki3" . "205 198 115")
+ ("khaki4" . "139 134 78")
+ ("lightgoldenrod1" . "255 236 139")
+ ("lightgoldenrod2" . "238 220 130")
+ ("lightgoldenrod3" . "205 190 112")
+ ("lightgoldenrod4" . "139 129 76")
+ ("lightyellow1" . "255 255 224")
+ ("lightyellow2" . "238 238 209")
+ ("lightyellow3" . "205 205 180")
+ ("lightyellow4" . "139 139 122")
+ ("yellow1" . "255 255 0")
+ ("yellow2" . "238 238 0")
+ ("yellow3" . "205 205 0")
+ ("yellow4" . "139 139 0")
+ ("gold1" . "255 215 0")
+ ("gold2" . "238 201 0")
+ ("gold3" . "205 173 0")
+ ("gold4" . "139 117 0")
+ ("goldenrod1" . "255 193 37")
+ ("goldenrod2" . "238 180 34")
+ ("goldenrod3" . "205 155 29")
+ ("goldenrod4" . "139 105 20")
+ ("darkgoldenrod1" . "255 185 15")
+ ("darkgoldenrod2" . "238 173 14")
+ ("darkgoldenrod3" . "205 149 12")
+ ("darkgoldenrod4" . "139 101 8")
+ ("rosybrown1" . "255 193 193")
+ ("rosybrown2" . "238 180 180")
+ ("rosybrown3" . "205 155 155")
+ ("rosybrown4" . "139 105 105")
+ ("indianred1" . "255 106 106")
+ ("indianred2" . "238 99 99")
+ ("indianred3" . "205 85 85")
+ ("indianred4" . "139 58 58")
+ ("sienna1" . "255 130 71")
+ ("sienna2" . "238 121 66")
+ ("sienna3" . "205 104 57")
+ ("sienna4" . "139 71 38")
+ ("burlywood1" . "255 211 155")
+ ("burlywood2" . "238 197 145")
+ ("burlywood3" . "205 170 125")
+ ("burlywood4" . "139 115 85")
+ ("wheat1" . "255 231 186")
+ ("wheat2" . "238 216 174")
+ ("wheat3" . "205 186 150")
+ ("wheat4" . "139 126 102")
+ ("tan1" . "255 165 79")
+ ("tan2" . "238 154 73")
+ ("tan3" . "205 133 63")
+ ("tan4" . "139 90 43")
+ ("chocolate1" . "255 127 36")
+ ("chocolate2" . "238 118 33")
+ ("chocolate3" . "205 102 29")
+ ("chocolate4" . "139 69 19")
+ ("firebrick1" . "255 48 48")
+ ("firebrick2" . "238 44 44")
+ ("firebrick3" . "205 38 38")
+ ("firebrick4" . "139 26 26")
+ ("brown1" . "255 64 64")
+ ("brown2" . "238 59 59")
+ ("brown3" . "205 51 51")
+ ("brown4" . "139 35 35")
+ ("salmon1" . "255 140 105")
+ ("salmon2" . "238 130 98")
+ ("salmon3" . "205 112 84")
+ ("salmon4" . "139 76 57")
+ ("lightsalmon1" . "255 160 122")
+ ("lightsalmon2" . "238 149 114")
+ ("lightsalmon3" . "205 129 98")
+ ("lightsalmon4" . "139 87 66")
+ ("orange1" . "255 165 0")
+ ("orange2" . "238 154 0")
+ ("orange3" . "205 133 0")
+ ("orange4" . "139 90 0")
+ ("darkorange1" . "255 127 0")
+ ("darkorange2" . "238 118 0")
+ ("darkorange3" . "205 102 0")
+ ("darkorange4" . "139 69 0")
+ ("coral1" . "255 114 86")
+ ("coral2" . "238 106 80")
+ ("coral3" . "205 91 69")
+ ("coral4" . "139 62 47")
+ ("tomato1" . "255 99 71")
+ ("tomato2" . "238 92 66")
+ ("tomato3" . "205 79 57")
+ ("tomato4" . "139 54 38")
+ ("orangered1" . "255 69 0")
+ ("orangered2" . "238 64 0")
+ ("orangered3" . "205 55 0")
+ ("orangered4" . "139 37 0")
+ ("red1" . "255 0 0")
+ ("red2" . "238 0 0")
+ ("red3" . "205 0 0")
+ ("red4" . "139 0 0")
+ ("deeppink1" . "255 20 147")
+ ("deeppink2" . "238 18 137")
+ ("deeppink3" . "205 16 118")
+ ("deeppink4" . "139 10 80")
+ ("hotpink1" . "255 110 180")
+ ("hotpink2" . "238 106 167")
+ ("hotpink3" . "205 96 144")
+ ("hotpink4" . "139 58 98")
+ ("pink1" . "255 181 197")
+ ("pink2" . "238 169 184")
+ ("pink3" . "205 145 158")
+ ("pink4" . "139 99 108")
+ ("lightpink1" . "255 174 185")
+ ("lightpink2" . "238 162 173")
+ ("lightpink3" . "205 140 149")
+ ("lightpink4" . "139 95 101")
+ ("palevioletred1" . "255 130 171")
+ ("palevioletred2" . "238 121 159")
+ ("palevioletred3" . "205 104 137")
+ ("palevioletred4" . "139 71 93")
+ ("maroon1" . "255 52 179")
+ ("maroon2" . "238 48 167")
+ ("maroon3" . "205 41 144")
+ ("maroon4" . "139 28 98")
+ ("violetred1" . "255 62 150")
+ ("violetred2" . "238 58 140")
+ ("violetred3" . "205 50 120")
+ ("violetred4" . "139 34 82")
+ ("magenta1" . "255 0 255")
+ ("magenta2" . "238 0 238")
+ ("magenta3" . "205 0 205")
+ ("magenta4" . "139 0 139")
+ ("orchid1" . "255 131 250")
+ ("orchid2" . "238 122 233")
+ ("orchid3" . "205 105 201")
+ ("orchid4" . "139 71 137")
+ ("plum1" . "255 187 255")
+ ("plum2" . "238 174 238")
+ ("plum3" . "205 150 205")
+ ("plum4" . "139 102 139")
+ ("mediumorchid1" . "224 102 255")
+ ("mediumorchid2" . "209 95 238")
+ ("mediumorchid3" . "180 82 205")
+ ("mediumorchid4" . "122 55 139")
+ ("darkorchid1" . "191 62 255")
+ ("darkorchid2" . "178 58 238")
+ ("darkorchid3" . "154 50 205")
+ ("darkorchid4" . "104 34 139")
+ ("purple1" . "155 48 255")
+ ("purple2" . "145 44 238")
+ ("purple3" . "125 38 205")
+ ("purple4" . "85 26 139")
+ ("mediumpurple1" . "171 130 255")
+ ("mediumpurple2" . "159 121 238")
+ ("mediumpurple3" . "137 104 205")
+ ("mediumpurple4" . "93 71 139")
+ ("thistle1" . "255 225 255")
+ ("thistle2" . "238 210 238")
+ ("thistle3" . "205 181 205")
+ ("thistle4" . "139 123 139")
+ ("grey0" . "0 0 0")
+ ("grey1" . "3 3 3")
+ ("grey2" . "5 5 5")
+ ("grey3" . "8 8 8")
+ ("grey4" . "10 10 10")
+ ("grey5" . "13 13 13")
+ ("grey6" . "15 15 15")
+ ("grey7" . "18 18 18")
+ ("grey8" . "20 20 20")
+ ("grey9" . "23 23 23")
+ ("grey10" . "26 26 26")
+ ("grey11" . "28 28 28")
+ ("grey12" . "31 31 31")
+ ("grey13" . "33 33 33")
+ ("grey14" . "36 36 36")
+ ("grey15" . "38 38 38")
+ ("grey16" . "41 41 41")
+ ("grey17" . "43 43 43")
+ ("grey18" . "46 46 46")
+ ("grey19" . "48 48 48")
+ ("grey20" . "51 51 51")
+ ("grey21" . "54 54 54")
+ ("grey22" . "56 56 56")
+ ("grey23" . "59 59 59")
+ ("grey24" . "61 61 61")
+ ("grey25" . "64 64 64")
+ ("grey26" . "66 66 66")
+ ("grey27" . "69 69 69")
+ ("grey28" . "71 71 71")
+ ("grey29" . "74 74 74")
+ ("grey30" . "77 77 77")
+ ("grey31" . "79 79 79")
+ ("grey32" . "82 82 82")
+ ("grey33" . "84 84 84")
+ ("grey34" . "87 87 87")
+ ("grey35" . "89 89 89")
+ ("grey36" . "92 92 92")
+ ("grey37" . "94 94 94")
+ ("grey38" . "97 97 97")
+ ("grey39" . "99 99 99")
+ ("grey40" . "102 102 102")
+ ("grey41" . "105 105 105")
+ ("grey42" . "107 107 107")
+ ("grey43" . "110 110 110")
+ ("grey44" . "112 112 112")
+ ("grey45" . "115 115 115")
+ ("grey46" . "117 117 117")
+ ("grey47" . "120 120 120")
+ ("grey48" . "122 122 122")
+ ("grey49" . "125 125 125")
+ ("grey50" . "127 127 127")
+ ("grey51" . "130 130 130")
+ ("grey52" . "133 133 133")
+ ("grey53" . "135 135 135")
+ ("grey54" . "138 138 138")
+ ("grey55" . "140 140 140")
+ ("grey56" . "143 143 143")
+ ("grey57" . "145 145 145")
+ ("grey58" . "148 148 148")
+ ("grey59" . "150 150 150")
+ ("grey60" . "153 153 153")
+ ("grey61" . "156 156 156")
+ ("grey62" . "158 158 158")
+ ("grey63" . "161 161 161")
+ ("grey64" . "163 163 163")
+ ("grey65" . "166 166 166")
+ ("grey66" . "168 168 168")
+ ("grey67" . "171 171 171")
+ ("grey68" . "173 173 173")
+ ("grey69" . "176 176 176")
+ ("grey70" . "179 179 179")
+ ("grey71" . "181 181 181")
+ ("grey72" . "184 184 184")
+ ("grey73" . "186 186 186")
+ ("grey74" . "189 189 189")
+ ("grey75" . "191 191 191")
+ ("grey76" . "194 194 194")
+ ("grey77" . "196 196 196")
+ ("grey78" . "199 199 199")
+ ("grey79" . "201 201 201")
+ ("grey80" . "204 204 204")
+ ("grey81" . "207 207 207")
+ ("grey82" . "209 209 209")
+ ("grey83" . "212 212 212")
+ ("grey84" . "214 214 214")
+ ("grey85" . "217 217 217")
+ ("grey86" . "219 219 219")
+ ("grey87" . "222 222 222")
+ ("grey88" . "224 224 224")
+ ("grey89" . "227 227 227")
+ ("grey90" . "229 229 229")
+ ("grey91" . "232 232 232")
+ ("grey92" . "235 235 235")
+ ("grey93" . "237 237 237")
+ ("grey94" . "240 240 240")
+ ("grey95" . "242 242 242")
+ ("grey96" . "245 245 245")
+ ("grey97" . "247 247 247")
+ ("grey98" . "250 250 250")
+ ("grey99" . "252 252 252")
+ ("grey100" . "255 255 255")
+ ("darkgrey" . "169 169 169")
+ ("darkblue" . "0 0 139")
+ ("darkcyan" . "0 139 139")
+ ("darkmagenta" . "139 0 139")
+ ("darkred" . "139 0 0")
+ ("lightgreen" . "144 238 144")))
+
+
+(define (%convert-color str)
+ (let ((col (assoc str *skribe-rgb-alist*)))
+ (cond
+ (col
+ (let* ((p (open-input-string (cdr col)))
+ (r (read p))
+ (g (read p))
+ (b (read p)))
+ (values r g b)))
+ ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7))
+ (values (string->number (substring str 1 3) 16)
+ (string->number (substring str 3 5) 16)
+ (string->number (substring str 5 7) 16)))
+ ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13))
+ (values (string->number (substring str 1 5) 16)
+ (string->number (substring str 5 9) 16)
+ (string->number (substring str 9 13) 16)))
+ (else
+ (values 0 0 0)))))
+
+;;;
+;;; SKRIBE-COLOR->RGB
+;;;
+(define (skribe-color->rgb spec)
+ (cond
+ ((string? spec) (%convert-color spec))
+ ((integer? spec)
+ (values (bit-and #xff (bit-shift spec -16))
+ (bit-and #xff (bit-shift spec -8))
+ (bit-and #xff spec)))
+ (else
+ (values 0 0 0))))
+
+;;;
+;;; SKRIBE-GET-USED-COLORS
+;;;
+(define (skribe-get-used-colors)
+ *used-colors*)
+
+;;;
+;;; SKRIBE-USE-COLOR!
+;;;
+(define (skribe-use-color! color)
+ (set! *used-colors* (cons color *used-colors*))
+ color)
+
diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l
new file mode 100644
index 0000000..a5b337e
--- /dev/null
+++ b/src/guile/skribilo/coloring/c-lex.l
@@ -0,0 +1,67 @@
+;;;;
+;;;; c-lex.l -- C fontifier for Skribe
+;;;;
+;;;; 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: 6-Mar-2004 15:35 (eg)
+;;;; Last file update: 7-Mar-2004 00:10 (eg)
+;;;;
+
+space [ \n\9]
+letter [_a-zA-Z]
+alphanum [_a-zA-Z0-9]
+
+%%
+
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+;;Comments
+/\*.*\*/ (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+//.* (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Identifiers (only letters since we are interested in keywords only)
+[_a-zA-Z]+ (let* ((ident (string->symbol yytext))
+ (tmp (memq ident *the-keys*)))
+ (if tmp
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+ yytext))
+
+;; Regular text
+[^\"a-zA-Z]+ (begin yytext)
+
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
+
+
+
+
+
+
+ \ No newline at end of file
diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm
new file mode 100644
index 0000000..baa3e53
--- /dev/null
+++ b/src/guile/skribilo/coloring/c.scm
@@ -0,0 +1,93 @@
+;;;;
+;;;; c.stk -- C fontifier for Skribe
+;;;;
+;;;; 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: 6-Mar-2004 15:35 (eg)
+;;;; Last file update: 7-Mar-2004 00:12 (eg)
+;;;;
+
+(require "lex-rt") ;; to avoid module problems
+
+(define-module (skribilo c)
+ :export (c java)
+ :import (skribe runtime))
+
+(include "c-lex.stk") ;; SILex generated
+
+
+(define *the-keys* #f)
+
+(define *c-keys* #f)
+(define *java-keys* #f)
+
+
+(define (fontifier s)
+ (let ((lex (c-lex (open-input-string s))))
+ (let Loop ((token (lexer-next-token lex))
+ (res '()))
+ (if (eq? token 'eof)
+ (reverse! res)
+ (Loop (lexer-next-token lex)
+ (cons token res))))))
+
+;;;; ======================================================================
+;;;;
+;;;; C
+;;;;
+;;;; ======================================================================
+(define (init-c-keys)
+ (unless *c-keys*
+ (set! *c-keys* '(for while return break continue void
+ do if else typedef struct union goto switch case
+ static extern default)))
+ *c-keys*)
+
+(define (c-fontifier s)
+ (fluid-let ((*the-keys* (init-c-keys)))
+ (fontifier s)))
+
+(define c
+ (new language
+ (name "C")
+ (fontifier c-fontifier)
+ (extractor #f)))
+
+;;;; ======================================================================
+;;;;
+;;;; JAVA
+;;;;
+;;;; ======================================================================
+(define (init-java-keys)
+ (unless *java-keys*
+ (set! *java-keys* (append (init-c-keys)
+ '(public final class throw catch))))
+ *java-keys*)
+
+(define (java-fontifier s)
+ (fluid-let ((*the-keys* (init-java-keys)))
+ (fontifier s)))
+
+(define java
+ (new language
+ (name "java")
+ (fontifier java-fontifier)
+ (extractor #f)))
+
diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l
new file mode 100644
index 0000000..efad24b
--- /dev/null
+++ b/src/guile/skribilo/coloring/lisp-lex.l
@@ -0,0 +1,91 @@
+;;;; -*- Scheme -*-
+;;;;
+;;;; lisp-lex.l -- SILex input for the Lisp Languages
+;;;;
+;;;; 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: 21-Dec-2003 17:19 (eg)
+;;;; Last file update: 5-Jan-2004 18:24 (eg)
+;;;;
+
+space [ \n\9]
+letter [#?!_:a-zA-Z\-]
+digit [0-9]
+
+
+%%
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+\;.* (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Skribe text (i.e. [....])
+\[|\] (if *bracket-highlight*
+ (new markup
+ (markup '&source-bracket)
+ (body yytext))
+ yytext)
+;; Spaces & parenthesis
+[ \n\9\(\)]+ (begin
+ yytext)
+
+;; Identifier (real syntax is slightly more complicated but we are
+;; interested here in the identifiers that we will fontify)
+[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0)))
+ (cond
+ ((or (char=? c #\:)
+ (char=? (string-ref yytext
+ (- (string-length yytext) 1))
+ #\:))
+ ;; Scheme keyword
+ (new markup
+ (markup '&source-type)
+ (body yytext)))
+ ((char=? c #\<)
+ ;; STklos class
+ (let* ((len (string-length yytext))
+ (c (string-ref yytext (- len 1))))
+ (if (char=? c #\>)
+ (if *class-highlight*
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+ yytext) ; no
+ yytext))) ; no
+ (else
+ (let ((tmp (assoc (string->symbol yytext)
+ *the-keys*)))
+ (if tmp
+ (new markup
+ (markup (cdr tmp))
+ (body yytext))
+ yytext)))))
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
+
+
+; LocalWords: fontify
diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm
new file mode 100644
index 0000000..53cf670
--- /dev/null
+++ b/src/guile/skribilo/coloring/lisp.scm
@@ -0,0 +1,293 @@
+;;;;
+;;;; lisp.stk -- Lisp Family Fontification
+;;;;
+;;;; 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: 16-Oct-2003 22:17 (eg)
+;;;; Last file update: 28-Oct-2004 21:14 (eg)
+;;;;
+
+(require "lex-rt") ;; to avoid module problems
+
+(define-module (skribilo lisp)
+ :export (skribe scheme stklos bigloo lisp)
+ :import (skribe source))
+
+(include "lisp-lex.stk") ;; SILex generated
+
+(define *bracket-highlight* #f)
+(define *class-highlight* #f)
+(define *the-keys* #f)
+
+(define *lisp-keys* #f)
+(define *scheme-keys* #f)
+(define *skribe-keys* #f)
+(define *stklos-keys* #f)
+(define *lisp-keys* #f)
+
+
+;;;
+;;; DEFINITION-SEARCH
+;;;
+(define (definition-search inp tab test)
+ (let Loop ((exp (%read inp)))
+ (unless (eof-object? exp)
+ (if (test exp)
+ (let ((start (and (%epair? exp) (%epair-line exp)))
+ (stop (port-current-line inp)))
+ (source-read-lines (port-file-name inp) start stop tab))
+ (Loop (%read inp))))))
+
+
+(define (lisp-family-fontifier s)
+ (let ((lex (lisp-lex (open-input-string s))))
+ (let Loop ((token (lexer-next-token lex))
+ (res '()))
+ (if (eq? token 'eof)
+ (reverse! res)
+ (Loop (lexer-next-token lex)
+ (cons token res))))))
+
+;;;; ======================================================================
+;;;;
+;;;; LISP
+;;;;
+;;;; ======================================================================
+(define (lisp-extractor iport def tab)
+ (definition-search
+ iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or defun defmacro) ?fun ?- . ?-)
+ (and (eq? def fun) exp))
+ ((defvar ?var . ?-)
+ (and (eq? var def) exp))
+ (else
+ #f)))))
+
+(define (init-lisp-keys)
+ (unless *lisp-keys*
+ (set! *lisp-keys*
+ (append ;; key
+ (map (lambda (x) (cons x '&source-keyword))
+ '(setq if let let* letrec cond case else progn lambda))
+ ;; define
+ (map (lambda (x) (cons x '&source-define))
+ '(defun defclass defmacro)))))
+ *lisp-keys*)
+
+(define (lisp-fontifier s)
+ (fluid-let ((*the-keys* (init-lisp-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
+ (lisp-family-fontifier s)))
+
+
+(define lisp
+ (new language
+ (name "lisp")
+ (fontifier lisp-fontifier)
+ (extractor lisp-extractor)))
+
+;;;; ======================================================================
+;;;;
+;;;; SCHEME
+;;;;
+;;;; ======================================================================
+(define (scheme-extractor iport def tab)
+ (definition-search
+ iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-macro) (?fun . ?-) . ?-)
+ (and (eq? def fun) exp))
+ ((define (and (? symbol?) ?var) . ?-)
+ (and (eq? var def) exp))
+ (else
+ #f)))))
+
+
+(define (init-scheme-keys)
+ (unless *scheme-keys*
+ (set! *scheme-keys*
+ (append ;; key
+ (map (lambda (x) (cons x '&source-keyword))
+ '(set! if let let* letrec quote cond case else begin do lambda))
+ ;; define
+ (map (lambda (x) (cons x '&source-define))
+ '(define define-syntax)))))
+ *scheme-keys*)
+
+
+(define (scheme-fontifier s)
+ (fluid-let ((*the-keys* (init-scheme-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
+ (lisp-family-fontifier s)))
+
+
+(define scheme
+ (new language
+ (name "scheme")
+ (fontifier scheme-fontifier)
+ (extractor scheme-extractor)))
+
+;;;; ======================================================================
+;;;;
+;;;; STKLOS
+;;;;
+;;;; ======================================================================
+(define (stklos-extractor iport def tab)
+ (definition-search
+ iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-generic define-method define-macro)
+ (?fun . ?-) . ?-)
+ (and (eq? def fun) exp))
+ (((or define define-module) (and (? symbol?) ?var) . ?-)
+ (and (eq? var def) exp))
+ (else
+ #f)))))
+
+
+(define (init-stklos-keys)
+ (unless *stklos-keys*
+ (init-scheme-keys)
+ (set! *stklos-keys* (append *scheme-keys*
+ ;; Markups
+ (map (lambda (x) (cons x '&source-key))
+ '(select-module import export))
+ ;; Key
+ (map (lambda (x) (cons x '&source-keyword))
+ '(case-lambda dotimes match-case match-lambda))
+ ;; Define
+ (map (lambda (x) (cons x '&source-define))
+ '(define-generic define-class
+ define-macro define-method define-module))
+ ;; error
+ (map (lambda (x) (cons x '&source-error))
+ '(error call/cc)))))
+ *stklos-keys*)
+
+
+(define (stklos-fontifier s)
+ (fluid-let ((*the-keys* (init-stklos-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
+ (lisp-family-fontifier s)))
+
+
+(define stklos
+ (new language
+ (name "stklos")
+ (fontifier stklos-fontifier)
+ (extractor stklos-extractor)))
+
+;;;; ======================================================================
+;;;;
+;;;; SKRIBE
+;;;;
+;;;; ======================================================================
+(define (skribe-extractor iport def tab)
+ (definition-search
+ iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-macro define-markup) (?fun . ?-) . ?-)
+ (and (eq? def fun) exp))
+ ((define (and (? symbol?) ?var) . ?-)
+ (and (eq? var def) exp))
+ ((markup-output (quote ?mk) . ?-)
+ (and (eq? mk def) exp))
+ (else
+ #f)))))
+
+
+(define (init-skribe-keys)
+ (unless *skribe-keys*
+ (init-stklos-keys)
+ (set! *skribe-keys* (append *stklos-keys*
+ ;; Markups
+ (map (lambda (x) (cons x '&source-markup))
+ '(bold it emph tt color ref index underline
+ roman figure center pre flush hrule
+ linebreak image kbd code var samp
+ sc sf sup sub
+ itemize description enumerate item
+ table tr td th item prgm author
+ prgm hook font
+ document chapter section subsection
+ subsubsection paragraph p handle resolve
+ processor abstract margin toc
+ table-of-contents current-document
+ current-chapter current-section
+ document-sections* section-number
+ footnote print-index include skribe-load
+ slide))
+ ;; Define
+ (map (lambda (x) (cons x '&source-define))
+ '(define-markup)))))
+ *skribe-keys*)
+
+
+(define (skribe-fontifier s)
+ (fluid-let ((*the-keys* (init-skribe-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
+ (lisp-family-fontifier s)))
+
+
+(define skribe
+ (new language
+ (name "skribe")
+ (fontifier skribe-fontifier)
+ (extractor skribe-extractor)))
+
+;;;; ======================================================================
+;;;;
+;;;; BIGLOO
+;;;;
+;;;; ======================================================================
+(define (bigloo-extractor iport def tab)
+ (definition-search
+ iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-inline define-generic
+ define-method define-macro define-expander)
+ (?fun . ?-) . ?-)
+ (and (eq? def fun) exp))
+ (((or define define-struct define-library) (and (? symbol?) ?var) . ?-)
+ (and (eq? var def) exp))
+ (else
+ #f)))))
+
+(define bigloo
+ (new language
+ (name "bigloo")
+ (fontifier scheme-fontifier)
+ (extractor bigloo-extractor)))
+
diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l
new file mode 100644
index 0000000..5d9a8d9
--- /dev/null
+++ b/src/guile/skribilo/coloring/xml-lex.l
@@ -0,0 +1,64 @@
+;;;; -*- Scheme -*-
+;;;;
+;;;; xml-lex.l -- SILex input for the XML languages
+;;;;
+;;;; Copyright © 2003 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: 21-Dec-2003 17:19 (eg)
+;;;; Last file update: 21-Dec-2003 22:38 (eg)
+;;;;
+
+space [ \n\9]
+
+%%
+
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+'[^']*' (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+<!--(.|\n)*--> (new markup
+ (markup '&source-comment)
+ (body yytext))
+
+;; Markup
+<[^>\n ]+|> (new markup
+ (markup '&source-module)
+ (body yytext))
+
+;; Regular text
+[^<>\"']+ (begin yytext)
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'xml-fontifier "Parse error" yytext)
+
+
+
+
+
+
+
+
+ \ No newline at end of file
diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm
new file mode 100644
index 0000000..d71e98c
--- /dev/null
+++ b/src/guile/skribilo/coloring/xml.scm
@@ -0,0 +1,53 @@
+;;;;
+;;;; xml.stk -- XML Fontification stuff
+;;;;
+;;;; Copyright © 2003 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: 16-Oct-2003 22:33 (eg)
+;;;; Last file update: 28-Dec-2003 17:33 (eg)
+;;;;
+
+
+;(require "lex-rt") ;; to avoid module problems
+
+
+(define-module (skribilo xml)
+ :export (xml))
+
+(use-modules (skribilo source))
+
+(include "xml-lex.stk") ;; SILex generated
+
+(define (xml-fontifier s)
+ (let ((lex (xml-lex (open-input-string s))))
+ (let Loop ((token (lexer-next-token lex))
+ (res '()))
+ (if (eq? token 'eof)
+ (reverse! res)
+ (Loop (lexer-next-token lex)
+ (cons token res))))))
+
+
+(define xml
+ (new language
+ (name "xml")
+ (fontifier xml-fontifier)
+ (extractor #f)))
+
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/skribilo/debug.scm b/src/guile/skribilo/debug.scm
new file mode 100644
index 0000000..1a5478e
--- /dev/null
+++ b/src/guile/skribilo/debug.scm
@@ -0,0 +1,161 @@
+;;;
+;;; 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-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-margin-debug-level* 0)
+
+
+(define (set-skribe-debug! val)
+ (set! *skribe-debug* val))
+
+(define (add-skribe-debug-symbol s)
+ (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*)))
+
+
+(define (no-debug-color)
+ (set! *skribe-debug-color* #f))
+
+(define (skribe-debug)
+ *skribe-debug*)
+
+;;
+;; debug-port
+;;
+; (define (debug-port . o)
+; (cond
+; ((null? o)
+; *debug-port*)
+; ((output-port? (car o))
+; (set! *debug-port* o)
+; o)
+; (else
+; (error 'debug-port "Illegal debug port" (car o)))))
+;
+
+;;;
+;;; debug-color
+;;;
+(define (debug-color col . o)
+ (with-output-to-string
+ (if (and *skribe-debug-color*
+ (equal? (getenv "TERM") "xterm")
+ (interactive-port? *debug-port*))
+ (lambda ()
+ (format #t "[1;~Am" (+ 31 col))
+ (for-each display o)
+ (display ""))
+ (lambda ()
+ (for-each display o)))))
+
+;;;
+;;; debug-bold
+;;;
+(define (debug-bold . o)
+ (apply debug-color -30 o))
+
+;;;
+;;; debug-item
+;;;
+(define (debug-item . args)
+ (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)
+;; `())
+
+;;;
+;;; %with-debug-margin
+;;;
+(define (%with-debug-margin margin thunk)
+ (let ((om *debug-margin*))
+ (set! *debug-depth* (+ *debug-depth* 1))
+ (set! *debug-margin* (string-append om margin))
+ (let ((res (thunk)))
+ (set! *debug-depth* (- *debug-depth* 1))
+ (set! *debug-margin* om)
+ res)))
+
+;;;
+;;; %with-debug
+;;
+(define (%with-debug lvl lbl thunk)
+ (let ((ol *skribe-margin-debug-level*)
+ (oi *skribe-debug-item*))
+ (set! *skribe-margin-debug-level* lvl)
+ (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl))
+ (and (symbol? lbl)
+ (memq lbl *skribe-debug-symbols*)
+ (set! *skribe-debug-item* #t)))
+ (begin
+ (display *debug-margin* *debug-port*)
+ (display (if (= *debug-depth* 0)
+ (debug-color *debug-depth* "+ " lbl)
+ (debug-color *debug-depth* "--+ " lbl))
+ *debug-port*)
+ (newline *debug-port*)
+ (%with-debug-margin (debug-color *debug-depth* " |")
+ thunk))
+ (thunk))))
+ (set! *skribe-debug-item* oi)
+ (set! *skribe-margin-debug-level* ol)
+ r)))
+
+(define-macro (with-debug level label . body)
+ `(%with-debug ,level ,label (lambda () ,@body)))
+
+;;(define-macro (with-debug level label . body)
+;; `(begin ,@body))
+
+
+; Example:
+
+; (with-debug 0 'foo1.1
+; (debug-item 'foo2.1)
+; (debug-item 'foo2.2)
+; (with-debug 0 'foo2.3
+; (debug-item 'foo3.1)
+; (with-debug 0 'foo3.2
+; (debug-item 'foo4.1)
+; (debug-item 'foo4.2))
+; (debug-item 'foo3.3))
+; (debug-item 'foo2.4))
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
new file mode 100644
index 0000000..9584f5e
--- /dev/null
+++ b/src/guile/skribilo/engine.scm
@@ -0,0 +1,251 @@
+;;;
+;;; 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 lookup-engine
+ engine-custom engine-custom-set!
+ engine-format? engine-add-writer!
+ processor-get-engine
+ push-default-engine pop-default-engine))
+
+
+
+
+;;; 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)
+ *default-engine*)
+
+
+(define (default-engine-set! 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)
+
+
+(define (push-default-engine e)
+ (set! *default-engines* (cons e *default-engines*))
+ (default-engine-set! e))
+
+(define (pop-default-engine)
+ (if (null? *default-engines*)
+ (skribe-error 'pop-default-engine "Empty engine stack" '())
+ (begin
+ (set! *default-engines* (cdr *default-engines*))
+ (if (pair? *default-engines*)
+ (default-engine-set! (car *default-engines*))
+ (set! *default-engine* #f)))))
+
+
+(define (processor-get-engine combinator newe olde)
+ (cond
+ ((procedure? combinator)
+ (combinator newe olde))
+ ((engine? newe)
+ newe)
+ (else
+ olde)))
+
+
+(define (engine-format? fmt . e)
+ (let ((e (cond
+ ((pair? e) (car e))
+ ((engine? *skribe-engine*) *skribe-engine*)
+ (else (find-engine *skribe-engine*)))))
+ (if (not (engine? e))
+ (skribe-error 'engine-format? "No engine" e)
+ (string=? fmt (engine-format e)))))
+
+;;;
+;;; MAKE-ENGINE
+;;;
+(define* (make-engine ident #:key (version 'unspecified)
+ (format "raw")
+ (filter #f)
+ (delegate #f)
+ (symbol-table '())
+ (custom '())
+ (info '()))
+ (let ((e (make <engine> :ident ident :version version :format format
+ :filter filter :delegate delegate
+ :symbol-table symbol-table
+ :custom custom :info info)))
+ ;; store the engine in the global table
+ (set! *engines* (cons e *engines*))
+ ;; return it
+ e))
+
+
+;;;
+;;; COPY-ENGINE
+;;;
+(define* (copy-engine ident e #:key (version 'unspecified)
+ (filter #f)
+ (delegate #f)
+ (symbol-table #f)
+ (custom #f))
+ (let ((new (shallow-clone e)))
+ (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)))
+ (slot-set! new 'customs (or custom (slot-ref e 'customs)))
+
+ (set! *engines* (cons new *engines*))
+ new))
+
+
+;;;
+;;; FIND-ENGINE
+;;;
+(define (%find-loaded-engine id version)
+ (let loop ((es *engines*))
+ (cond
+ ((null? es) #f)
+ ((eq? (slot-ref (car es) 'ident) id)
+ (cond
+ ((eq? version 'unspecified) (car es))
+ ((eq? version (slot-ref (car es) 'version)) (car es))
+ (else (Loop (cdr es)))))
+ (else (loop (cdr es))))))
+
+
+(define* (find-engine id #:key (version 'unspecified))
+ (with-debug 5 'find-engine
+ (debug-item "id=" id " version=" version)
+
+ (or (%find-loaded-engine id version)
+ (let ((c (assq id *skribe-auto-load-alist*)))
+ (debug-item "c=" c)
+ (if (and c (string? (cdr c)))
+ (begin
+ (skribe-load (cdr c) :engine 'base)
+ (%find-loaded-engine id version))
+ #f)))))
+
+(define lookup-engine find-engine)
+
+
+;;;
+;;; ENGINE-CUSTOM
+;;;
+(define (engine-custom e id)
+ (let* ((customs (slot-ref e 'customs))
+ (c (assq id customs)))
+ (if (pair? c)
+ (cadr c)
+ 'unspecified)))
+
+
+;;;
+;;; ENGINE-CUSTOM-SET!
+;;;
+(define (engine-custom-set! e id val)
+ (let* ((customs (slot-ref e 'customs))
+ (c (assq id customs)))
+ (if (pair? c)
+ (set-car! (cdr c) val)
+ (slot-set! e 'customs (cons (list id val) customs)))))
+
+
+;;;
+;;; ENGINE-ADD-WRITER!
+;;;
+(define (engine-add-writer! e ident pred upred opt before action after class valid)
+ (define (check-procedure name proc arity)
+ (cond
+ ((not (procedure? proc))
+ (skribe-error ident "Illegal procedure" proc))
+ ((not (equal? (%procedure-arity proc) arity))
+ (skribe-error ident
+ (format #f "Illegal ~S procedure" name)
+ proc))))
+
+ (define (check-output name proc)
+ (and proc (or (string? proc) (check-procedure name proc 2))))
+
+ ;;
+ ;; Engine-add-writer! starts here
+ ;;
+ (if (not (is-a? e <engine>))
+ (skribe-error ident "Illegal engine" e))
+
+ ;; check the options
+ (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
+ (if valid
+ (check-procedure "validate" valid 2))
+
+ ;; check the correctness of the three actions
+ (check-output "before" before)
+ (check-output "action" action)
+ (check-output "after" after)
+
+ ;; create a new writer and bind it
+ (let ((n (make <writer>
+ :ident (if (symbol? ident) ident 'all)
+ :class class :pred pred :upred upred :options opt
+ :before before :action action :after after
+ :validate valid)))
+ (slot-set! e 'writers (cons n (slot-ref e 'writers)))
+ n))
+
+;;; ======================================================================
+;;;
+;;; 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.
+
+(make-engine 'base :version 'bootstrap)
diff --git a/src/guile/skribilo/eval.scm b/src/guile/skribilo/eval.scm
new file mode 100644
index 0000000..8bae8ad
--- /dev/null
+++ b/src/guile/skribilo/eval.scm
@@ -0,0 +1,186 @@
+;;;
+;;; 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 (skribilo eval)
+ :export (skribe-eval skribe-eval-port skribe-load skribe-load-options
+ skribe-include
+
+ 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-load-options* '())
+
+(define (%evaluate expr)
+ (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
+;;;
+(define* (skribe-eval a e #:key (env '()))
+ (with-debug 2 'skribe-eval
+ (debug-item "a=" a " e=" (engine-ident e))
+ (let ((a2 (resolve! a e env)))
+ (debug-item "resolved a=" a)
+ (let ((a3 (verify a2 e)))
+ (debug-item "verified a=" a3)
+ (output a3 e)))))
+
+;;;
+;;; SKRIBE-EVAL-PORT
+;;;
+(define* (skribe-eval-port port engine #:key (env '()))
+ (with-debug 2 'skribe-eval-port
+ (debug-item "engine=" engine)
+ (let ((e (if (symbol? engine) (find-engine engine) engine)))
+ (debug-item "e=" e)
+ (if (not (is-a? e <engine>))
+ (skribe-error 'skribe-eval-port "Cannot find engine" engine)
+ (let loop ((exp (read port)))
+ (with-debug 10 'skribe-eval-port
+ (debug-item "exp=" exp))
+ (unless (eof-object? exp)
+ (skribe-eval (%evaluate exp) e :env env)
+ (loop (read port))))))))
+
+;;;
+;;; SKRIBE-LOAD
+;;;
+(define *skribe-load-options* '())
+
+(define (skribe-load-options)
+ *skribe-load-options*)
+
+(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt)
+ (with-debug 4 'skribe-load
+ (debug-item " engine=" engine)
+ (debug-item " path=" path)
+ (debug-item " opt" opt)
+
+ (let* ((ei (cond
+ ((not engine) *skribe-engine*)
+ ((engine? engine) engine)
+ ((not (symbol? engine)) (skribe-error 'skribe-load
+ "Illegal engine" engine))
+ (else engine)))
+ (path (cond
+ ((not path) (skribe-path))
+ ((string? path) (list path))
+ ((not (and (list? path) (every? string? path)))
+ (skribe-error 'skribe-load "Illegal path" path))
+ (else path)))
+ (filep (find-path file path)))
+
+ (set! *skribe-load-options* opt)
+
+ (unless (and (string? filep) (file-exists? filep))
+ (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
+ ((> *skribe-verbose* 1)
+ (format (current-error-port) " [loading file: ~S ~S]\n" filep opt))
+ ((> *skribe-verbose* 0)
+ (format (current-error-port) " [loading file: ~S]\n" filep)))
+ ;; Load it
+ (with-input-from-file filep
+ (lambda ()
+ (skribe-eval-port (current-input-port) ei)))
+ (set! *skribe-loaded* (cons filep *skribe-loaded*))))))
+
+;;;
+;;; SKRIBE-INCLUDE
+;;;
+(define* (skribe-include file #:optional (path (skribe-path)))
+ (unless (every string? path)
+ (skribe-error 'skribe-include "Illegal path" path))
+
+ (let ((path (find-path file path)))
+ (unless (and (string? path) (file-exists? path))
+ (skribe-error 'skribe-load
+ (format "Cannot find ~S in path" file)
+ path))
+ (when (> *skribe-verbose* 0)
+ (format (current-error-port) " [including file: ~S]\n" path))
+ (with-input-from-file path
+ (lambda ()
+ (let Loop ((exp (read (current-input-port)))
+ (res '()))
+ (if (eof-object? exp)
+ (if (and (pair? res) (null? (cdr res)))
+ (car res)
+ (reverse! res))
+ (Loop (read (current-input-port))
+ (cons (%evaluate exp) res))))))))
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
new file mode 100644
index 0000000..26b348a
--- /dev/null
+++ b/src/guile/skribilo/lib.scm
@@ -0,0 +1,360 @@
+;;;
+;;; 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
+;;;
+(define-macro (new class . parameters)
+ `(make ,(string->symbol (format #f "<~a>" class))
+ ,@(apply append (map (lambda (x)
+ `(,(symbol->keyword (car x)) ,(cadr x)))
+ parameters))))
+
+;;;
+;;; DEFINE-MARKUP
+;;;
+(define-macro (define-markup bindings . body)
+ ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL
+ ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the
+ ;; `#:rest' argument can only appear last which not what Skribe/DSSSL
+ ;; expect, hence `fix-rest-arg'.
+ (define (fix-rest-arg args)
+ (let loop ((args args)
+ (result '())
+ (rest-arg #f))
+ (if (null? args)
+ (if rest-arg (append (reverse result) rest-arg) (reverse result))
+ (let ((is-rest-arg? (eq? (car args) #:rest)))
+ (loop (if is-rest-arg? (cddr args) (cdr args))
+ (if is-rest-arg? result (cons (car args) result))
+ (if is-rest-arg? (list (car args) (cadr args)) rest-arg))))))
+
+ (let ((name (car bindings))
+ (opts (cdr bindings)))
+ `(define* ,(cons name (fix-rest-arg opts)) ,@body)))
+
+
+;;;
+;;; DEFINE-SIMPLE-MARKUP
+;;;
+(define-macro (define-simple-markup markup)
+ `(define-markup (,markup :rest opts :key ident class loc)
+ (new markup
+ (markup ',markup)
+ (ident (or ident (symbol->string (gensym ',markup))))
+ (loc loc)
+ (class class)
+ (required-options '())
+ (options (the-options opts :ident :class :loc))
+ (body (the-body opts)))))
+
+
+;;;
+;;; DEFINE-SIMPLE-CONTAINER
+;;;
+(define-macro (define-simple-container markup)
+ `(define-markup (,markup :rest opts :key ident class loc)
+ (new container
+ (markup ',markup)
+ (ident (or ident (symbol->string (gensym ',markup))))
+ (loc loc)
+ (class class)
+ (required-options '())
+ (options (the-options opts :ident :class :loc))
+ (body (the-body opts)))))
+
+
+;;;
+;;; DEFINE-PROCESSOR-MARKUP
+;;;
+(define-macro (define-processor-markup proc)
+ `(define-markup (,proc #:rest opts)
+ (new processor
+ (engine (find-engine ',proc))
+ (body (the-body opts))
+ (options (the-options opts)))))
+
+
+;;;
+;;; SKRIBE-EVAL-LOCATION ...
+;;;
+(define (skribe-eval-location)
+ (format (current-error-port)
+ "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n")
+ #f)
+
+;;;
+;;; SKRIBE-ERROR
+;;;
+(define (skribe-ast-error proc msg obj)
+ (let ((l (ast-loc obj))
+ (shape (if (markup? obj) (markup-markup obj) obj)))
+ (if (location? l)
+ (error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape)
+ (error "~a: ~a ~s " proc msg shape))))
+
+(define (skribe-error proc msg obj)
+ (if (ast? obj)
+ (skribe-ast-error proc msg obj)
+ (error proc msg obj)))
+
+
+;;;
+;;; SKRIBE-TYPE-ERROR
+;;;
+(define (skribe-type-error proc msg obj etype)
+ (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f))
+
+
+
+;;; FIXME: Peut-être virée maintenant
+(define (skribe-line-error file line proc msg obj)
+ (error (format "%a:%a: ~a:~a ~S" file line proc msg obj)))
+
+
+;;;
+;;; SKRIBE-WARNING & SKRIBE-WARNING/AST
+;;;
+(define (%skribe-warn level file line lst)
+ (let ((port (current-error-port)))
+ (format port "**** WARNING:\n")
+ (when (and file line) (format port "~a: ~a: " file line))
+ (for-each (lambda (x) (format port "~a " x)) lst)
+ (newline port)))
+
+
+(define (skribe-warning level . obj)
+ (if (>= *skribe-warning* level)
+ (%skribe-warn level #f #f obj)))
+
+
+(define (skribe-warning/ast level ast . obj)
+ (if (>= *skribe-warning* level)
+ (let ((l (ast-loc ast)))
+ (if (location? l)
+ (%skribe-warn level (location-file l) (location-pos l) obj)
+ (%skribe-warn level #f #f obj)))))
+
+;;;
+;;; SKRIBE-MESSAGE
+;;;
+(define (skribe-message fmt . obj)
+ (when (> *skribe-verbose* 0)
+ (apply format (current-error-port) fmt obj)))
+
+;;;
+;;; FILE-PREFIX / FILE-SUFFIX
+;;;
+(define (file-prefix fn)
+ (if fn
+ (let ((match (regexp-match "(.*)\\.([^/]*$)" fn)))
+ (if match
+ (cadr match)
+ fn))
+ "./SKRIBE-OUTPUT"))
+
+(define (file-suffix s)
+ ;; Not completely correct, but sufficient here
+ (let* ((basename (regexp-replace "^(.*)/(.*)$" s "\\2"))
+ (split (string-split basename ".")))
+ (if (> (length split) 1)
+ (car (reverse! split))
+ "")))
+
+
+;;;
+;;; KEY-GET
+;;;
+;;; We need to redefine the standard key-get to be more permissive. In
+;;; STklos key-get accepts a list which is formed only of keywords. In
+;;; Skribe, parameter lists are of the form
+;;; (:title "..." :option "...." body1 body2 body3)
+;;; So is we find an element which is not a keyword, we skip it (unless it
+;;; follows a keyword of course). Since the compiler of extended lambda
+;;; uses the function key-get, it will now accept Skribe markups
+(define* (key-get lst key #:optional (default #f) default?)
+ (define (not-found)
+ (if default?
+ default
+ (error 'key-get "value ~S not found in list ~S" key lst)))
+ (let Loop ((l lst))
+ (cond
+ ((null? l)
+ (not-found))
+ ((not (pair? l))
+ (error 'key-get "bad list ~S" lst))
+ ((keyword? (car l))
+ (if (null? (cdr l))
+ (error 'key-get "bad keyword list ~S" lst)
+ (if (eq? (car l) key)
+ (cadr l)
+ (Loop (cddr l)))))
+ (else
+ (Loop (cdr l))))))
+
+
+
+;;; ======================================================================
+;;;
+;;; A C C E S S O R S
+;;;
+;;; ======================================================================
+
+;; SKRIBE-PATH
+(define (skribe-path) *skribe-path*)
+
+(define (skribe-path-set! path)
+ (if (not (and (list? path) (every string? path)))
+ (skribe-error 'skribe-path-set! "Illegal path" path)
+ (set! *skribe-path* path)))
+
+;; SKRIBE-IMAGE-PATH
+(define (skribe-image-path) *skribe-image-path*)
+
+(define (skribe-image-path-set! path)
+ (if (not (and (list? path) (every string? path)))
+ (skribe-error 'skribe-image-path-set! "Illegal path" path)
+ (set! *skribe-image-path* path)))
+
+;; SKRIBE-BIB-PATH
+(define (skribe-bib-path) *skribe-bib-path*)
+
+(define (skribe-bib-path-set! path)
+ (if (not (and (list? path) (every string? path)))
+ (skribe-error 'skribe-bib-path-set! "Illegal path" path)
+ (set! *skribe-bib-path* path)))
+
+;; SKRBE-SOURCE-PATH
+(define (skribe-source-path) *skribe-source-path*)
+
+(define (skribe-source-path-set! path)
+ (if (not (and (list? path) (every string? path)))
+ (skribe-error 'skribe-source-path-set! "Illegal path" path)
+ (set! *skribe-source-path* path)))
+
+
+;;; ======================================================================
+;;;
+;;; Compatibility with Bigloo
+;;;
+;;; ======================================================================
+
+(define (substring=? s1 s2 len)
+ (let ((l1 (string-length s1))
+ (l2 (string-length s2)))
+ (let Loop ((i 0))
+ (cond
+ ((= i len) #t)
+ ((= i l1) #f)
+ ((= i l2) #f)
+ ((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1)))
+ (else #f)))))
+
+(define (directory->list str)
+ (map basename (glob (string-append str "/*") (string-append "/.*"))))
+
+(define-macro (printf . args) `(format #t ,@args))
+(define fprintf format)
+
+
+(define prefix file-prefix)
+(define suffix file-suffix)
+(define system->string system) ;; FIXME
+(define any? any)
+(define every? every)
+(define find-file/path (lambda (. args)
+ (format #t "find-file/path: ~a~%" args)
+ #f))
+(define process-input-port #f) ;process-input)
+(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 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 find-runtime-type (lambda (obj) obj))
+
+(define-macro (unwind-protect expr1 expr2)
+ ;; 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/skribilo/output.scm b/src/guile/skribilo/output.scm
new file mode 100644
index 0000000..cc690ec
--- /dev/null
+++ b/src/guile/skribilo/output.scm
@@ -0,0 +1,162 @@
+;;;;
+;;;; output.stk -- Skribe Output Stage
+;;;;
+;;;; 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:42 (eg)
+;;;; Last file update: 5-Mar-2004 10:32 (eg)
+;;;;
+
+(define-module (skribilo output)
+ :export (output))
+
+(use-modules (skribilo debug)
+ (skribilo types)
+; (skribe engine)
+; (skribe writer)
+ (oop goops))
+
+
+(define-generic out)
+
+(define (%out/writer n e w)
+ (with-debug 5 'out/writer
+ (debug-item "n=" n " " (if (markup? n) (markup-markup n) ""))
+ (debug-item "e=" (engine-ident e))
+ (debug-item "w=" (writer-ident w))
+
+ (when (writer? w)
+ (invoke (slot-ref w 'before) n e)
+ (invoke (slot-ref w 'action) n e)
+ (invoke (slot-ref w 'after) n e))))
+
+
+
+(define (output node e . writer)
+ (with-debug 3 'output
+ (debug-item "node=" node " " (if (markup? node) (markup-markup node) ""))
+ (debug-item "writer=" writer)
+ (if (null? writer)
+ (out node e)
+ (cond
+ ((is-a? (car writer) <writer>)
+ (%out/writer node e (car writer)))
+ ((not (car writer))
+ (skribe-error 'output
+ (format "Illegal ~A user writer" (engine-ident e))
+ (if (markup? node) (markup-markup node) node)))
+ (else
+ (skribe-error 'output "Illegal user writer" (car writer)))))))
+
+
+;;;
+;;; OUT implementations
+;;;
+(define-method (out node e)
+ #f)
+
+
+(define-method (out (node <pair>) e)
+ (let Loop ((n* node))
+ (cond
+ ((pair? n*)
+ (out (car n*) e)
+ (loop (cdr n*)))
+ ((not (null? n*))
+ (skribe-error 'out "Illegal argument" n*)))))
+
+
+(define-method (out (node <string>) e)
+ (let ((f (slot-ref e 'filter)))
+ (if (procedure? f)
+ (display (f node))
+ (display node))))
+
+
+(define-method (out (node <number>) e)
+ (out (number->string node) e))
+
+
+(define-method (out (n <processor>) e)
+ (let ((combinator (slot-ref n 'combinator))
+ (engine (slot-ref n 'engine))
+ (body (slot-ref n 'body))
+ (procedure (slot-ref n 'procedure)))
+ (let ((newe (processor-get-engine combinator engine e)))
+ (out (procedure body newe) newe))))
+
+
+(define-method (out (n <command>) e)
+ (let* ((fmt (slot-ref n 'fmt))
+ (body (slot-ref n 'body))
+ (lb (length body))
+ (lf (string-length fmt)))
+ (define (loops i n)
+ (if (= i lf)
+ (begin
+ (if (> n 0)
+ (if (<= n lb)
+ (output (list-ref body (- n 1)) e)
+ (skribe-error '! "Too few arguments provided" n)))
+ lf)
+ (let ((c (string-ref fmt i)))
+ (cond
+ ((char=? c #\$)
+ (display "$")
+ (+ 1 i))
+ ((not (char-numeric? c))
+ (cond
+ ((= n 0)
+ i)
+ ((<= n lb)
+ (output (list-ref body (- n 1)) e)
+ i)
+ (else
+ (skribe-error '! "Too few arguments provided" n))))
+ (else
+ (loops (+ i 1)
+ (+ (- (char->integer c)
+ (char->integer #\0))
+ (* 10 n))))))))
+
+ (let loop ((i 0))
+ (cond
+ ((= i lf)
+ #f)
+ ((not (char=? (string-ref fmt i) #\$))
+ (display (string-ref fmt i))
+ (loop (+ i 1)))
+ (else
+ (loop (loops (+ i 1) 0)))))))
+
+
+(define-method (out (n <handle>) e)
+ 'unspecified)
+
+
+(define-method (out (n <unresolved>) e)
+ (skribe-error 'output "Orphan unresolved" n))
+
+
+(define-method (out (node <markup>) e)
+ (let ((w (lookup-markup-writer node e)))
+ (if (writer? w)
+ (%out/writer node e w)
+ (output (slot-ref node 'body) e))))
diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm
new file mode 100644
index 0000000..eb0b3db
--- /dev/null
+++ b/src/guile/skribilo/prog.scm
@@ -0,0 +1,218 @@
+;;;;
+;;;; prog.stk -- All the stuff for the prog markup
+;;;;
+;;;; Copyright © 2003 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: 31-Aug-2003 23:42 (eg)
+;;;; Last file update: 22-Oct-2003 19:35 (eg)
+;;;;
+
+(define-module SKRIBE-PROG-MODULE
+ (export make-prog-body resolve-line)
+
+;;; ======================================================================
+;;;
+;;; COMPATIBILITY
+;;;
+;;; ======================================================================
+(define pregexp-match regexp-match)
+(define pregexp-replace regexp-replace)
+(define pregexp-quote regexp-quote)
+
+
+(define (node-body-set! b v)
+ (slot-set! b 'body v))
+
+;;;
+;;; FIXME: Tout le module peut se factoriser
+;;; définir en bigloo node-body-set
+
+
+;*---------------------------------------------------------------------*/
+;* *lines* ... */
+;*---------------------------------------------------------------------*/
+(define *lines* (make-hash-table))
+
+;*---------------------------------------------------------------------*/
+;* make-line-mark ... */
+;*---------------------------------------------------------------------*/
+(define (make-line-mark m lnum b)
+ (let* ((ls (number->string lnum))
+ (n (list (mark ls) b)))
+ (hashtable-put! *lines* m n)
+ n))
+
+;*---------------------------------------------------------------------*/
+;* resolve-line ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-line id)
+ (hashtable-get *lines* id))
+
+;*---------------------------------------------------------------------*/
+;* extract-string-mark ... */
+;*---------------------------------------------------------------------*/
+(define (extract-string-mark line mark regexp)
+ (let ((m (pregexp-match regexp line)))
+ (if (pair? m)
+ (values (substring (car m)
+ (string-length mark)
+ (string-length (car m)))
+ (pregexp-replace regexp line ""))
+ (values #f line))))
+
+;*---------------------------------------------------------------------*/
+;* extract-mark ... */
+;* ------------------------------------------------------------- */
+;* Extract the prog mark from a line. */
+;*---------------------------------------------------------------------*/
+(define (extract-mark line mark regexp)
+ (cond
+ ((not regexp)
+ (values #f line))
+ ((string? line)
+ (extract-string-mark line mark regexp))
+ ((pair? line)
+ (let loop ((ls line)
+ (res '()))
+ (if (null? ls)
+ (values #f line)
+ (receive (m l)
+ (extract-mark (car ls) mark regexp)
+ (if (not m)
+ (loop (cdr ls) (cons l res))
+ (values m (append (reverse! res) (cons l (cdr ls)))))))))
+ ((node? line)
+ (receive (m l)
+ (extract-mark (node-body line) mark regexp)
+ (if (not m)
+ (values #f line)
+ (begin
+ (node-body-set! line l)
+ (values m line)))))
+ (else
+ (values #f line))))
+
+;*---------------------------------------------------------------------*/
+;* split-line ... */
+;*---------------------------------------------------------------------*/
+(define (split-line line)
+ (cond
+ ((string? line)
+ (let ((l (string-length line)))
+ (let loop ((r1 0)
+ (r2 0)
+ (res '()))
+ (cond
+ ((= r2 l)
+ (if (= r1 r2)
+ (reverse! res)
+ (reverse! (cons (substring line r1 r2) res))))
+ ((char=? (string-ref line r2) #\Newline)
+ (loop (+ r2 1)
+ (+ r2 1)
+ (if (= r1 r2)
+ (cons 'eol res)
+ (cons* 'eol (substring line r1 r2) res))))
+ (else
+ (loop r1
+ (+ r2 1)
+ res))))))
+ ((pair? line)
+ (let loop ((ls line)
+ (res '()))
+ (if (null? ls)
+ res
+ (loop (cdr ls) (append res (split-line (car ls)))))))
+ (else
+ (list line))))
+
+;*---------------------------------------------------------------------*/
+;* flat-lines ... */
+;*---------------------------------------------------------------------*/
+(define (flat-lines lines)
+ (apply append (map split-line lines)))
+
+;*---------------------------------------------------------------------*/
+;* collect-lines ... */
+;*---------------------------------------------------------------------*/
+(define (collect-lines lines)
+ (let loop ((lines (flat-lines lines))
+ (res '())
+ (tmp '()))
+ (cond
+ ((null? lines)
+ (reverse! (cons (reverse! tmp) res)))
+ ((eq? (car lines) 'eol)
+ (cond
+ ((null? (cdr lines))
+ (reverse! (cons (reverse! tmp) res)))
+ ((and (null? res) (null? tmp))
+ (loop (cdr lines)
+ res
+ '()))
+ (else
+ (loop (cdr lines)
+ (cons (reverse! tmp) res)
+ '()))))
+ (else
+ (loop (cdr lines)
+ res
+ (cons (car lines) tmp))))))
+
+;*---------------------------------------------------------------------*/
+;* make-prog-body ... */
+;*---------------------------------------------------------------------*/
+(define (make-prog-body src lnum-init ldigit mark)
+ (define (int->str i rl)
+ (let* ((s (number->string i))
+ (l (string-length s)))
+ (if (= l rl)
+ s
+ (string-append (make-string (- rl l) #\space) s))))
+
+ (let* ((regexp (and mark
+ (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+"
+ (pregexp-quote mark))))
+ (src (cond
+ ((not (pair? src)) (list src))
+ ((and (pair? (car src)) (null? (cdr src))) (car src))
+ (else src)))
+ (lines (collect-lines src))
+ (lnum (if (integer? lnum-init) lnum-init 1))
+ (s (number->string (+ (if (integer? ldigit)
+ (max lnum (expt 10 (- ldigit 1)))
+ lnum)
+ (length lines))))
+ (cs (string-length s)))
+ (let loop ((lines lines)
+ (lnum lnum)
+ (res '()))
+ (if (null? lines)
+ (reverse! res)
+ (receive (m l)
+ (extract-mark (car lines) mark regexp)
+ (let ((n (new markup
+ (markup '&prog-line)
+ (ident (and lnum-init (int->str lnum cs)))
+ (body (if m (make-line-mark m lnum l) l)))))
+ (loop (cdr lines)
+ (+ lnum 1)
+ (cons n res))))))))
+
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/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
new file mode 100644
index 0000000..2dc5e98
--- /dev/null
+++ b/src/guile/skribilo/resolve.scm
@@ -0,0 +1,260 @@
+;;;;
+;;;; resolve.stk -- Skribe Resolve Stage
+;;;;
+;;;; 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:39 (eg)
+;;;; Last file update: 17-Feb-2004 14:43 (eg)
+;;;;
+
+(define-module (skribilo resolve)
+ :use-module (skribilo debug)
+ :use-module (skribilo runtime)
+ :use-module (skribilo types)
+
+ :use-module (oop goops)
+
+ :export (resolve! resolve-search-parent resolve-children resolve-children*
+ find1 resolve-counter resolve-parent resolve-ident))
+
+
+(define *unresolved* #f)
+(define-generic do-resolve!)
+
+
+;;;; ======================================================================
+;;;;
+;;;; RESOLVE!
+;;;;
+;;;; This function iterates over an ast until all unresolved references
+;;;; are resolved.
+;;;;
+;;;; ======================================================================
+(define (resolve! ast engine env)
+ (with-debug 3 'resolve
+ (debug-item "ast=" ast)
+ (fluid-let ((*unresolved* #f))
+ (let Loop ((ast ast))
+ (set! *unresolved* #f)
+ (let ((ast (do-resolve! ast engine env)))
+ (if *unresolved*
+ (Loop ast)
+ ast))))))
+
+;;;; ======================================================================
+;;;;
+;;;; D O - R E S O L V E !
+;;;;
+;;;; ======================================================================
+
+(define-method (do-resolve! ast engine env)
+ ast)
+
+
+(define-method (do-resolve! (ast <pair>) engine env)
+ (let Loop ((n* ast))
+ (cond
+ ((pair? n*)
+ (set-car! n* (do-resolve! (car n*) engine env))
+ (Loop (cdr n*)))
+ ((not (null? n*))
+ (error 'do-resolve "Illegal argument" n*))
+ (else
+ ast))))
+
+
+(define-method (do-resolve! (node <node>) engine env)
+ (let ((body (slot-ref node 'body))
+ (options (slot-ref node 'options))
+ (parent (slot-ref node 'parent)))
+ (with-debug 5 'do-resolve<body>
+ (debug-item "body=" body)
+ (when (eq? parent 'unspecified)
+ (let ((p (assq 'parent env)))
+ (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))
+ (when (pair? options)
+ (debug-item "unresolved options=" options)
+ (for-each (lambda (o)
+ (set-car! (cdr o)
+ (do-resolve! (cadr o) engine env)))
+ options)
+ (debug-item "resolved options=" options))))
+ (slot-set! node 'body (do-resolve! body engine env))
+ node)))
+
+
+
+(define-method (do-resolve! (node <container>) engine env0)
+ (let ((body (slot-ref node 'body))
+ (options (slot-ref node 'options))
+ (env (slot-ref node 'env))
+ (parent (slot-ref node 'parent)))
+ (with-debug 5 'do-resolve<container>
+ (debug-item "markup=" (markup-markup node))
+ (debug-item "body=" body)
+ (debug-item "env0=" env0)
+ (debug-item "env=" env)
+ (when (eq? parent 'unspecified)
+ (let ((p (assq 'parent env0)))
+ (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))
+ (when (pair? options)
+ (let ((e (append `((parent ,node)) env0)))
+ (debug-item "unresolved options=" options)
+ (for-each (lambda (o)
+ (set-car! (cdr o)
+ (do-resolve! (cadr o) engine e)))
+ options)
+ (debug-item "resolved options=" options)))
+ (let ((e `((parent ,node) ,@env ,@env0)))
+ (slot-set! node 'body (do-resolve! body engine e)))))
+ node)))
+
+
+(define-method (do-resolve! (node <document>) engine env0)
+ (next-method)
+ ;; resolve the engine custom
+ (let ((env (append `((parent ,node)) env0)))
+ (for-each (lambda (c)
+ (let ((i (car c))
+ (a (cadr c)))
+ (debug-item "custom=" i " " a)
+ (set-car! (cdr c) (do-resolve! a engine env))))
+ (slot-ref engine 'customs)))
+ node)
+
+
+(define-method (do-resolve! (node <unresolved>) engine env)
+ (with-debug 5 'do-resolve<unresolved>
+ (debug-item "node=" node)
+ (let ((p (assq 'parent env)))
+ (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))))
+
+ (let* ((proc (slot-ref node 'proc))
+ (res (resolve! (proc node engine env) engine env))
+ (loc (ast-loc node)))
+ (when (ast? res)
+ (ast-loc-set! res loc))
+ (debug-item "res=" res)
+ (set! *unresolved* #t)
+ res)))
+
+
+(define-method (do-resolve! (node <handle>) engine env)
+ node)
+
+
+;;;; ======================================================================
+;;;;
+;;;; RESOLVE-PARENT
+;;;;
+;;;; ======================================================================
+(define (resolve-parent n e)
+ (with-debug 5 'resolve-parent
+ (debug-item "n=" n)
+ (cond
+ ((not (is-a? n <ast>))
+ (let ((c (assq 'parent e)))
+ (if (pair? c)
+ (cadr c)
+ n)))
+ ((eq? (slot-ref n 'parent) 'unspecified)
+ (skribe-error 'resolve-parent "Orphan node" n))
+ (else
+ (slot-ref n 'parent)))))
+
+
+;;;; ======================================================================
+;;;;
+;;;; RESOLVE-SEARCH-PARENT
+;;;;
+;;;; ======================================================================
+(define (resolve-search-parent n e pred)
+ (with-debug 5 'resolve-search-parent
+ (debug-item "node=" n)
+ (debug-item "searching=" pred)
+ (let ((p (resolve-parent n e)))
+ (debug-item "parent=" p " "
+ (if (is-a? p 'markup) (slot-ref p 'markup) "???"))
+ (cond
+ ((pred p) p)
+ ((is-a? p <unresolved>) p)
+ ((not p) #f)
+ (else (resolve-search-parent p e pred))))))
+
+;;;; ======================================================================
+;;;;
+;;;; RESOLVE-COUNTER
+;;;;
+;;;; ======================================================================
+;;FIXME: factoriser
+(define (resolve-counter n e cnt val . opt)
+ (let ((c (assq (symbol-append cnt '-counter) e)))
+ (if (not (pair? c))
+ (if (or (null? opt) (not (car opt)) (null? e))
+ (skribe-error cnt "Orphan node" n)
+ (begin
+ (set-cdr! (last-pair e)
+ (list (list (symbol-append cnt '-counter) 0)
+ (list (symbol-append cnt '-env) '())))
+ (resolve-counter n e cnt val)))
+ (let* ((num (cadr c))
+ (nval (if (integer? val)
+ val
+ (+ 1 num))))
+ (let ((c2 (assq (symbol-append cnt '-env) e)))
+ (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2))))
+ (cond
+ ((integer? val)
+ (set-car! (cdr c) val)
+ (car val))
+ ((not val)
+ val)
+ (else
+ (set-car! (cdr c) (+ 1 num))
+ (+ 1 num)))))))
+
+;;;; ======================================================================
+;;;;
+;;;; RESOLVE-IDENT
+;;;;
+;;;; ======================================================================
+(define (resolve-ident ident markup n e)
+ (with-debug 4 'resolve-ident
+ (debug-item "ident=" ident)
+ (debug-item "markup=" markup)
+ (debug-item "n=" (if (markup? n) (markup-markup n) n))
+ (if (not (string? ident))
+ (skribe-type-error 'resolve-ident
+ "Illegal ident"
+ ident
+ "string")
+ (let ((mks (find-markups ident)))
+ (and mks
+ (if (not markup)
+ (car mks)
+ (let loop ((mks mks))
+ (cond
+ ((null? mks)
+ #f)
+ ((is-markup? (car mks) markup)
+ (car mks))
+ (else
+ (loop (cdr mks)))))))))))
+
diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm
new file mode 100644
index 0000000..af76237
--- /dev/null
+++ b/src/guile/skribilo/runtime.scm
@@ -0,0 +1,458 @@
+;;;
+;;; 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
+
+ ;; Markup functions
+ markup-option markup-option-add! markup-output
+
+ ;; Container functions
+ container-env-get
+
+ ;; Images
+ convert-image
+
+ ;; String writing
+ make-string-replace
+
+ ;; AST
+ ast->string))
+
+(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
+;;;
+;;; ======================================================================
+
+
+;;FIXME: Remonter cette fonction
+(define (strip-ref-base file)
+ (if (not (string? *skribe-ref-base*))
+ file
+ (let ((l (string-length *skribe-ref-base*)))
+ (cond
+ ((not (> (string-length file) (+ l 2)))
+ file)
+ ((not (substring=? file *skribe-ref-base* l))
+ file)
+ ((not (char=? (string-ref file l) (file-separator)))
+ file)
+ (else
+ (substring file (+ l 1) (string-length file)))))))
+
+
+(define (ast->file-location ast)
+ (let ((l (ast-loc ast)))
+ (if (location? l)
+ (format "~a:~a:" (location-file l) (location-line l))
+ "")))
+
+;; FIXME: Remonter cette fonction
+(define (string-canonicalize old)
+ (let* ((l (string-length old))
+ (new (make-string l)))
+ (let loop ((r 0)
+ (w 0)
+ (s #f))
+ (cond
+ ((= r l)
+ (cond
+ ((= w 0)
+ "")
+ ((char-whitespace? (string-ref new (- w 1)))
+ (substring new 0 (- w 1)))
+ ((= w r)
+ new)
+ (else
+ (substring new 0 w))))
+ ((char-whitespace? (string-ref old r))
+ (if s
+ (loop (+ r 1) w #t)
+ (begin
+ (string-set! new w #\-)
+ (loop (+ r 1) (+ w 1) #t))))
+ ((or (char=? (string-ref old r) #\#)
+ (>= (char->integer (string-ref old r)) #x7f))
+ (string-set! new w #\-)
+ (loop (+ r 1) (+ w 1) #t))
+ (else
+ (string-set! new w (string-ref old r))
+ (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))
+;; (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))
+;; (%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))))))))
+
+(define (markup-option m opt)
+ (if (markup? m)
+ (let ((c (assq opt (slot-ref m 'options))))
+ (and (pair? c) (pair? (cdr c))
+ (cadr c)))
+ (skribe-type-error 'markup-option "Illegal markup: " m "markup")))
+
+
+(define (markup-option-add! m opt val)
+ (if (markup? m)
+ (slot-set! m 'options (cons (list opt val)
+ (slot-ref m 'options)))
+ (skribe-type-error 'markup-option "Illegal markup: " m "markup")))
+
+;;; ======================================================================
+;;;
+;;; 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
+;;;
+;;; ======================================================================
+(define (builtin-convert-image from fmt dir)
+ (let* ((s (suffix from))
+ (f (string-append (prefix (basename from)) "." fmt))
+ (to (string-append dir "/" f))) ;; FIXME:
+ (cond
+ ((string=? s fmt)
+ to)
+ ((file-exists? to)
+ to)
+ (else
+ (let ((c (if (string=? s "fig")
+ (string-append "fig2dev -L " fmt " " from " > " to)
+ (string-append "convert " from " " to))))
+ (cond
+ ((> *skribe-verbose* 1)
+ (format (current-error-port) " [converting image: ~S (~S)]" from c))
+ ((> *skribe-verbose* 0)
+ (format (current-error-port) " [converting image: ~S]" from)))
+ (and (zero? (system c))
+ to))))))
+
+(define (convert-image file formats)
+ (let ((path (find-path file (skribe-image-path))))
+ (if (not path)
+ (skribe-error 'convert-image
+ (format "Can't find `~a' image file in path: " file)
+ (skribe-image-path))
+ (let ((suf (suffix file)))
+ (if (member suf formats)
+ (let* ((dir (if (string? *skribe-dest*)
+ (dirname *skribe-dest*)
+ #f)))
+ (if dir
+ (let ((dest (basename path)))
+ (copy-file path (make-path dir dest))
+ dest)
+ path))
+ (let loop ((fmts formats))
+ (if (null? fmts)
+ #f
+ (let* ((dir (if (string? *skribe-dest*)
+ (dirname *skribe-dest*)
+ "."))
+ (p (builtin-convert-image path (car fmts) dir)))
+ (if (string? p)
+ p
+ (loop (cdr fmts)))))))))))
+
+;;; ======================================================================
+;;;
+;;; 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
+;; ;; is nothing to replace since, it does not allocate a new string
+;; (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))))
+
+
+(define (%make-general-string-replace lst)
+ ;; The general version
+ (lambda (str)
+ (let ((out (open-output-string)))
+ (dotimes (i (string-length str))
+ (let* ((ch (string-ref str i))
+ (res (assq ch lst)))
+ (display (if res (cadr res) ch) out)))
+ (get-output-string out))))
+
+
+(define (make-string-replace lst)
+ (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
+ (cond
+ ((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
+ string->html)
+ (else
+ (%make-general-string-replace lst)))))
+
+
+
+
+;;; ======================================================================
+;;;
+;;; O P T I O N S
+;;;
+;;; ======================================================================
+
+;;NEW ;;
+;;NEW ;; GET-OPTION
+;;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 ((markup? obj) (get-option (slot-ref obj 'option*) key))
+;;NEW (else #f)))
+;;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 ;;
+;;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 ((container? obj) (get-env (slot-ref obj 'env) key))
+;;NEW (else #f)))
+;;NEW
+
+
+
+
+;;; ======================================================================
+;;;
+;;; A S T
+;;;
+;;; ======================================================================
+
+(define-generic ast->string)
+
+
+(define-method (ast->string (ast <top>)) "")
+(define-method (ast->string (ast <string>)) ast)
+(define-method (ast->string (ast <number>)) (number->string ast))
+
+(define-method (ast->string (ast <pair>))
+ (let ((out (open-output-string)))
+ (let Loop ((lst ast))
+ (cond
+ ((null? lst)
+ (get-output-string out))
+ (else
+ (display (ast->string (car lst)) out)
+ (unless (null? (cdr lst))
+ (display #\space out))
+ (Loop (cdr lst)))))))
+
+(define-method (ast->string (ast <node>))
+ (ast->string (slot-ref ast 'body)))
+
+
+;;NEW ;;
+;;NEW ;; AST-PARENT
+;;NEW ;;
+;;NEW (define (ast-parent n)
+;;NEW (slot-ref n 'parent))
+;;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 ;;
+;;NEW ;; MARKUP-DOCUMENT
+;;NEW ;;
+;;NEW (define (markup-document m)
+;;NEW (let Loop ((p m)
+;;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 ;; MARKUP-CHAPTER
+;;NEW ;;
+;;NEW (define (markup-chapter m)
+;;NEW (let loop ((p m)
+;;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 ;;;; H A N D L E S
+;;NEW ;;;;
+;;NEW ;;;; ======================================================================
+;;NEW (define (handle-body h)
+;;NEW (slot-ref h 'body))
+;;NEW
+;;NEW
+;;NEW ;;;; ======================================================================
+;;NEW ;;;;
+;;NEW ;;;; F I N D
+;;NEW ;;;;
+;;NEW ;;;; ======================================================================
+;;NEW (define (find pred obj)
+;;NEW (with-debug 4 'find
+;;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 ;;;; ======================================================================
+;;NEW ;;;;
+;;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 (cond
+;;NEW ((null? opt*)
+;;NEW (reverse! res))
+;;NEW ((not (pair? opt*))
+;;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 (else
+;;NEW (loop (cdr opt*) (cons (car opt*) res))))))
+;;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 (let loop ((opt* opt+)
+;;NEW (res '()))
+;;NEW (cond
+;;NEW ((null? opt*)
+;;NEW (reverse! res))
+;;NEW ((not (pair? opt*))
+;;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 (else
+;;NEW (loop (cdr opt*) res)))))
+;;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/skribilo/source.scm b/src/guile/skribilo/source.scm
new file mode 100644
index 0000000..e56f350
--- /dev/null
+++ b/src/guile/skribilo/source.scm
@@ -0,0 +1,190 @@
+;;;;
+;;;; source.stk -- Skibe SOURCE implementation 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: 3-Sep-2003 12:22 (eg)
+;;;; Last file update: 27-Oct-2004 20:09 (eg)
+;;;;
+
+
+
+(define-module (skribilo source)
+ :export (source-read-lines source-read-definition source-fontify))
+
+
+;; Temporary solution
+(define (language-extractor lang)
+ (slot-ref lang 'extractor))
+
+(define (language-fontifier lang)
+ (slot-ref lang 'fontifier))
+
+
+;*---------------------------------------------------------------------*/
+;* source-read-lines ... */
+;*---------------------------------------------------------------------*/
+(define (source-read-lines file start stop tab)
+ (let ((p (find-path file (skribe-source-path))))
+ (if (or (not (string? p)) (not (file-exists? p)))
+ (skribe-error 'source
+ (format "Can't find `~a' source file in path" file)
+ (skribe-source-path))
+ (with-input-from-file p
+ (lambda ()
+ (if (> *skribe-verbose* 0)
+ (format (current-error-port) " [source file: ~S]\n" p))
+ (let ((startl (if (string? start) (string-length start) -1))
+ (stopl (if (string? stop) (string-length stop) -1)))
+ (let loop ((l 1)
+ (armedp (not (or (integer? start) (string? start))))
+ (s (read-line))
+ (r '()))
+ (cond
+ ((or (eof-object? s)
+ (and (integer? stop) (> l stop))
+ (and (string? stop) (substring=? stop s stopl)))
+ (apply string-append (reverse! r)))
+ (armedp
+ (loop (+ l 1)
+ #t
+ (read-line)
+ (cons* "\n" (untabify s tab) r)))
+ ((and (integer? start) (>= l start))
+ (loop (+ l 1)
+ #t
+ (read-line)
+ (cons* "\n" (untabify s tab) r)))
+ ((and (string? start) (substring=? start s startl))
+ (loop (+ l 1) #t (read-line) r))
+ (else
+ (loop (+ l 1) #f (read-line) r))))))))))
+
+;*---------------------------------------------------------------------*/
+;* untabify ... */
+;*---------------------------------------------------------------------*/
+(define (untabify obj tab)
+ (if (not tab)
+ obj
+ (let ((len (string-length obj))
+ (tabl tab))
+ (let loop ((i 0)
+ (col 1))
+ (cond
+ ((= i len)
+ (let ((nlen (- col 1)))
+ (if (= len nlen)
+ obj
+ (let ((new (make-string col #\space)))
+ (let liip ((i 0)
+ (j 0)
+ (col 1))
+ (cond
+ ((= i len)
+ new)
+ ((char=? (string-ref obj i) #\tab)
+ (let ((next-tab (* (/ (+ col tabl)
+ tabl)
+ tabl)))
+ (liip (+ i 1)
+ next-tab
+ next-tab)))
+ (else
+ (string-set! new j (string-ref obj i))
+ (liip (+ i 1) (+ j 1) (+ col 1)))))))))
+ ((char=? (string-ref obj i) #\tab)
+ (loop (+ i 1)
+ (* (/ (+ col tabl) tabl) tabl)))
+ (else
+ (loop (+ i 1) (+ col 1))))))))
+
+;*---------------------------------------------------------------------*/
+;* source-read-definition ... */
+;*---------------------------------------------------------------------*/
+(define (source-read-definition file definition tab lang)
+ (let ((p (find-path file (skribe-source-path))))
+ (cond
+ ((not (language-extractor lang))
+ (skribe-error 'source
+ "The specified language has not defined extractor"
+ (slot-ref lang 'name)))
+ ((or (not p) (not (file-exists? p)))
+ (skribe-error 'source
+ (format "Can't find `~a' program file in path" file)
+ (skribe-source-path)))
+ (else
+ (let ((ip (open-input-file p)))
+ (if (> *skribe-verbose* 0)
+ (format (current-error-port) " [source file: ~S]\n" p))
+ (if (not (input-port? ip))
+ (skribe-error 'source "Can't open file for input" p)
+ (unwind-protect
+ (let ((s ((language-extractor lang) ip definition tab)))
+ (if (not (string? s))
+ (skribe-error 'source
+ "Can't find definition"
+ definition)
+ s))
+ (close-input-port ip))))))))
+
+;*---------------------------------------------------------------------*/
+;* source-fontify ... */
+;*---------------------------------------------------------------------*/
+(define (source-fontify o language)
+ (define (fontify f o)
+ (cond
+ ((string? o) (f o))
+ ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o))
+ (else o)))
+ (let ((f (language-fontifier language)))
+ (if (procedure? f)
+ (fontify f o)
+ o)))
+
+;*---------------------------------------------------------------------*/
+;* split-string-newline ... */
+;*---------------------------------------------------------------------*/
+(define (split-string-newline str)
+ (let ((l (string-length str)))
+ (let loop ((i 0)
+ (j 0)
+ (r '()))
+ (cond
+ ((= i l)
+ (if (= i j)
+ (reverse! r)
+ (reverse! (cons (substring str j i) r))))
+ ((char=? (string-ref str i) #\Newline)
+ (loop (+ i 1)
+ (+ i 1)
+ (if (= i j)
+ (cons 'eol r)
+ (cons* 'eol (substring str j i) r))))
+ ((and (char=? (string-ref str i) #\cr)
+ (< (+ i 1) l)
+ (char=? (string-ref str (+ i 1)) #\Newline))
+ (loop (+ i 2)
+ (+ i 2)
+ (if (= i j)
+ (cons 'eol r)
+ (cons* 'eol (substring str j i) r))))
+ (else
+ (loop (+ i 1) j r))))))
+
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/skribilo/verify.scm b/src/guile/skribilo/verify.scm
new file mode 100644
index 0000000..93a1be3
--- /dev/null
+++ b/src/guile/skribilo/verify.scm
@@ -0,0 +1,161 @@
+;;;;
+;;;; verify.stk -- Skribe Verification Stage
+;;;;
+;;;; 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 11:57 (eg)
+;;;; Last file update: 27-Oct-2004 16:35 (eg)
+;;;;
+
+(define-module (skribilo verify)
+ :export (verify))
+
+(use-modules (skribilo debug)
+; (skribilo engine)
+; (skribilo writer)
+; (skribilo runtime)
+ (skribilo types)
+ (oop goops))
+
+
+
+(define-generic verify)
+
+;;;
+;;; CHECK-REQUIRED-OPTIONS
+;;;
+(define (check-required-options markup writer engine)
+ (let ((required-options (slot-ref markup 'required-options))
+ (ident (slot-ref writer 'ident))
+ (options (slot-ref writer 'options))
+ (verified? (slot-ref writer 'verified?)))
+ (or verified?
+ (eq? options 'all)
+ (begin
+ (for-each (lambda (o)
+ (if (not (memq o options))
+ (skribe-error (engine-ident engine)
+ (format "Option unsupported: ~a, supported options: ~a" o options)
+ markup)))
+ required-options)
+ (slot-set! writer 'verified? #t)))))
+
+;;;
+;;; CHECK-OPTIONS
+;;;
+(define (check-options lopts markup engine)
+
+ ;; Only keywords are checked, symbols are voluntary left unchecked. */
+ (with-debug 6 'check-options
+ (debug-item "markup=" (markup-markup markup))
+ (debug-item "options=" (slot-ref markup 'options))
+ (debug-item "lopts=" lopts)
+ (for-each
+ (lambda (o2)
+ (for-each
+ (lambda (o)
+ (if (and (keyword? o)
+ (not (eq? o :&skribe-eval-location))
+ (not (memq o lopts)))
+ (skribe-warning/ast
+ 3
+ markup
+ 'verify
+ (format "Engine ~a does not support markup ~a option `~a' -- ~a"
+ (engine-ident engine)
+ (markup-markup markup)
+ o
+ (markup-option markup o)))))
+ o2))
+ (slot-ref markup 'options))))
+
+
+;;; ======================================================================
+;;;
+;;; V E R I F Y
+;;;
+;;; ======================================================================
+
+;;; TOP
+(define-method (verify (obj <top>) e)
+ obj)
+
+;;; PAIR
+(define-method (verify (obj <pair>) e)
+ (for-each (lambda (x) (verify x e)) obj)
+ obj)
+
+;;; PROCESSOR
+(define-method (verify (obj <processor>) e)
+ (let ((combinator (slot-ref obj 'combinator))
+ (engine (slot-ref obj 'engine))
+ (body (slot-ref obj 'body)))
+ (verify body (processor-get-engine combinator engine e))
+ obj))
+
+;;; NODE
+(define-method (verify (node <node>) e)
+ ;; Verify body
+ (verify (slot-ref node 'body) e)
+ ;; Verify options
+ (for-each (lambda (o) (verify (cadr o) e))
+ (slot-ref node 'options))
+ node)
+
+;;; MARKUP
+(define-method (verify (node <markup>) e)
+ (with-debug 5 'verify::<markup>
+ (debug-item "node=" (markup-markup node))
+ (debug-item "options=" (slot-ref node 'options))
+ (debug-item "e=" (engine-ident e))
+
+ (next-method)
+
+ (let ((w (lookup-markup-writer node e)))
+ (when (writer? w)
+ (check-required-options node w e)
+ (when (pair? (writer-options w))
+ (check-options (slot-ref w 'options) node e))
+ (let ((validate (slot-ref w 'validate)))
+ (when (procedure? validate)
+ (unless (validate node e)
+ (skribe-warning
+ 1
+ node
+ (format "Node `~a' forbidden here by ~a engine"
+ (markup-markup node)
+ (engine-ident e))))))))
+ node))
+
+
+;;; DOCUMENT
+(define-method (verify (node <document>) e)
+ (next-method)
+
+ ;; verify the engine customs
+ (for-each (lambda (c)
+ (let ((i (car c))
+ (a (cadr c)))
+ (set-car! (cdr c) (verify a e))))
+ (slot-ref e 'customs))
+
+ node)
+
+
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
new file mode 100644
index 0000000..048dcfb
--- /dev/null
+++ b/src/guile/skribilo/writer.scm
@@ -0,0 +1,217 @@
+;;;;
+;;;; writer.stk -- Skribe Writer 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: 15-Sep-2003 22:21 (eg)
+;;;; Last file update: 4-Mar-2004 10:48 (eg)
+;;;;
+
+
+(define-module (skribilo writer)
+ :export (invoke markup-writer markup-writer-get markup-writer-get*
+ lookup-markup-writer copy-markup-writer))
+
+
+(use-modules (skribilo debug)
+; (skribilo engine)
+ (skribilo output)
+
+ (oop goops)
+ (ice-9 optargs))
+
+
+;;;; ======================================================================
+;;;;
+;;;; INVOKE
+;;;;
+;;;; ======================================================================
+(define (invoke proc node e)
+ (with-debug 5 'invoke
+ (debug-item "e=" (engine-ident e))
+ (debug-item "node=" node " " (if (markup? node) (markup-markup node) ""))
+
+ (if (string? proc)
+ (display proc)
+ (if (procedure? proc)
+ (proc node e)))))
+
+
+;;;; ======================================================================
+;;;;
+;;;; LOOKUP-MARKUP-WRITER
+;;;;
+;;;; ======================================================================
+(define (lookup-markup-writer node e)
+ (let ((writers (slot-ref e 'writers))
+ (delegate (slot-ref e 'delegate)))
+ (let Loop ((w* writers))
+ (cond
+ ((pair? w*)
+ (let ((pred (slot-ref (car w*) 'pred)))
+ (if (pred node e)
+ (car w*)
+ (loop (cdr w*)))))
+ ((engine? delegate)
+ (lookup-markup-writer node delegate))
+ (else
+ #f)))))
+
+;;;; ======================================================================
+;;;;
+;;;; MAKE-WRITER-PREDICATE
+;;;;
+;;;; ======================================================================
+(define (make-writer-predicate markup predicate class)
+ (let* ((t1 (if (symbol? markup)
+ (lambda (n e) (is-markup? n markup))
+ (lambda (n e) #t)))
+ (t2 (if class
+ (lambda (n e)
+ (and (t1 n e) (equal? (markup-class n) class)))
+ t1)))
+ (if predicate
+ (cond
+ ((not (procedure? predicate))
+ (skribe-error 'markup-writer
+ "Illegal predicate (procedure expected)"
+ predicate))
+ ((not (eq? (%procedure-arity predicate) 2))
+ (skribe-error 'markup-writer
+ "Illegal predicate arity (2 arguments expected)"
+ predicate))
+ (else
+ (lambda (n e)
+ (and (t2 n e) (predicate n e)))))
+ t2)))
+
+;;;; ======================================================================
+;;;;
+;;;; MARKUP-WRITER
+;;;;
+;;;; ======================================================================
+(define* (markup-writer markup #:optional engine
+ #:key (predicate #f) (class #f) (options '())
+ (validate #f)
+ (before #f) (action 'unspecified) (after #f))
+ (let ((e (or engine (default-engine))))
+ (cond
+ ((and (not (symbol? markup)) (not (eq? markup #t)))
+ (skribe-error 'markup-writer "Illegal markup" markup))
+ ((not (engine? e))
+ (skribe-error 'markup-writer "Illegal engine" e))
+ ((and (not predicate)
+ (not class)
+ (null? options)
+ (not before)
+ (eq? action 'unspecified)
+ (not after))
+ (skribe-error 'markup-writer "Illegal writer" markup))
+ (else
+ (let ((m (make-writer-predicate markup predicate class))
+ (ac (if (eq? action 'unspecified)
+ (lambda (n e) (output (markup-body n) e))
+ action)))
+ (engine-add-writer! e markup m predicate
+ options before ac after class validate))))))
+
+
+;;;; ======================================================================
+;;;;
+;;;; MARKUP-WRITER-GET
+;;;;
+;;;; ======================================================================
+(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f))
+ (let ((e (or engine (default-engine))))
+ (cond
+ ((not (symbol? markup))
+ (skribe-error 'markup-writer-get "Illegal symbol" markup))
+ ((not (engine? e))
+ (skribe-error 'markup-writer-get "Illegal engine" e))
+ (else
+ (let liip ((e e))
+ (let loop ((w* (slot-ref e 'writers)))
+ (cond
+ ((pair? w*)
+ (if (and (eq? (writer-ident (car w*)) markup)
+ (equal? (writer-class (car w*)) class)
+ (or (unspecified? pred)
+ (eq? (slot-ref (car w*) 'upred) pred)))
+ (car w*)
+ (loop (cdr w*))))
+ ((engine? (slot-ref e 'delegate))
+ (liip (slot-ref e 'delegate)))
+ (else
+ #f))))))))
+
+;;;; ======================================================================
+;;;;
+;;;; MARKUP-WRITER-GET*
+;;;;
+;;;; ======================================================================
+
+;; Finds all writers that matches MARKUP with optional CLASS attribute.
+
+(define* (markup-writer-get* markup #:optional engine #:key (class #f))
+ (let ((e (or engine (default-engine))))
+ (cond
+ ((not (symbol? markup))
+ (skribe-error 'markup-writer "Illegal symbol" markup))
+ ((not (engine? e))
+ (skribe-error 'markup-writer "Illegal engine" e))
+ (else
+ (let liip ((e e)
+ (res '()))
+ (let loop ((w* (slot-ref e 'writers))
+ (res res))
+ (cond
+ ((pair? w*)
+ (if (and (eq? (slot-ref (car w*) 'ident) markup)
+ (equal? (slot-ref (car w*) 'class) class))
+ (loop (cdr w*) (cons (car w*) res))
+ (loop (cdr w*) res)))
+ ((engine? (slot-ref e 'delegate))
+ (liip (slot-ref e 'delegate) res))
+ (else
+ (reverse! res)))))))))
+
+;;; ======================================================================
+;;;;
+;;;; COPY-MARKUP-WRITER
+;;;;
+;;;; ======================================================================
+(define* (copy-markup-writer markup old-engine :optional new-engine
+ :key (predicate 'unspecified)
+ (class 'unspecified)
+ (options 'unspecified)
+ (validate 'unspecified)
+ (before 'unspecified)
+ (action 'unspecified)
+ (after 'unspecified))
+ (let ((old (markup-writer-get markup old-engine))
+ (new-engine (or new-engine old-engine)))
+ (markup-writer markup new-engine
+ :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate)
+ :class (if (unspecified? class) (slot-ref old 'class) class)
+ :options (if (unspecified? options) (slot-ref old 'options) options)
+ :validate (if (unspecified? validate) (slot-ref old 'validate) validate)
+ :before (if (unspecified? before) (slot-ref old 'before) before)
+ :action (if (unspecified? action) (slot-ref old 'action) action)
+ :after (if (unspecified? after) (slot-ref old 'after) after))))