aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/.arch-inventory4
-rw-r--r--src/Makefile41
-rw-r--r--src/Makefile.am4
-rw-r--r--src/bigloo/Makefile271
-rw-r--r--src/bigloo/api.bgl117
-rw-r--r--src/bigloo/api.sch91
-rw-r--r--src/bigloo/asm.scm99
-rw-r--r--src/bigloo/bib.bgl161
-rw-r--r--src/bigloo/c.scm134
-rw-r--r--src/bigloo/color.scm702
-rw-r--r--src/bigloo/configure.bgl90
-rw-r--r--src/bigloo/debug.sch54
-rw-r--r--src/bigloo/debug.scm188
-rw-r--r--src/bigloo/engine.scm262
-rw-r--r--src/bigloo/eval.scm335
-rw-r--r--src/bigloo/evapi.scm39
-rw-r--r--src/bigloo/index.bgl32
-rw-r--r--src/bigloo/lib.bgl340
-rw-r--r--src/bigloo/lisp.scm530
-rw-r--r--src/bigloo/main.scm96
-rw-r--r--src/bigloo/new.sch17
-rw-r--r--src/bigloo/output.scm167
-rw-r--r--src/bigloo/param.bgl134
-rw-r--r--src/bigloo/parseargs.scm186
-rw-r--r--src/bigloo/prog.scm196
-rw-r--r--src/bigloo/read.scm482
-rw-r--r--src/bigloo/resolve.scm281
-rw-r--r--src/bigloo/source.scm238
-rw-r--r--src/bigloo/sui.bgl34
-rw-r--r--src/bigloo/types.scm685
-rw-r--r--src/bigloo/verify.scm143
-rw-r--r--src/bigloo/writer.scm232
-rw-r--r--src/bigloo/xml.scm92
-rw-r--r--src/common/bib.scm192
-rw-r--r--src/common/configure.scm8
-rw-r--r--src/common/configure.scm.in6
-rw-r--r--src/common/lib.scm238
-rw-r--r--src/common/param.scm69
-rw-r--r--src/guile/Makefile.am5
-rw-r--r--src/guile/README63
-rw-r--r--src/guile/skribilo.scm480
-rw-r--r--src/guile/skribilo/.arch-inventory5
-rw-r--r--src/guile/skribilo/Makefile.am10
-rw-r--r--src/guile/skribilo/ast.scm602
-rw-r--r--src/guile/skribilo/biblio.scm382
-rw-r--r--src/guile/skribilo/biblio/Makefile.am4
-rw-r--r--src/guile/skribilo/biblio/abbrev.scm170
-rw-r--r--src/guile/skribilo/biblio/author.scm136
-rw-r--r--src/guile/skribilo/biblio/bibtex.scm83
-rw-r--r--src/guile/skribilo/color.scm (renamed from src/stklos/color.stk)67
-rw-r--r--src/guile/skribilo/coloring/Makefile.am16
-rw-r--r--src/guile/skribilo/coloring/c-lex.l (renamed from src/stklos/c-lex.l)2
-rw-r--r--src/guile/skribilo/coloring/c-lex.l.scm1225
-rw-r--r--src/guile/skribilo/coloring/c.scm (renamed from src/stklos/c.stk)10
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l (renamed from src/stklos/lisp-lex.l)53
-rw-r--r--src/guile/skribilo/coloring/lisp-lex.l.scm1249
-rw-r--r--src/guile/skribilo/coloring/lisp.scm (renamed from src/stklos/lisp.stk)240
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l (renamed from src/stklos/xml-lex.l)2
-rw-r--r--src/guile/skribilo/coloring/xml-lex.l.scm1221
-rw-r--r--src/guile/skribilo/coloring/xml.scm82
-rw-r--r--src/guile/skribilo/condition.scm171
-rw-r--r--src/guile/skribilo/config.scm.in20
-rw-r--r--src/guile/skribilo/debug.scm168
-rw-r--r--src/guile/skribilo/engine.scm390
-rw-r--r--src/guile/skribilo/engine/Makefile.am5
-rw-r--r--src/guile/skribilo/engine/base.scm479
-rw-r--r--src/guile/skribilo/engine/context.scm1382
-rw-r--r--src/guile/skribilo/engine/html.scm2313
-rw-r--r--src/guile/skribilo/engine/html4.scm168
-rw-r--r--src/guile/skribilo/engine/latex-simple.scm103
-rw-r--r--src/guile/skribilo/engine/latex.scm1784
-rw-r--r--src/guile/skribilo/engine/lout.scm2891
-rw-r--r--src/guile/skribilo/engine/xml.scm115
-rw-r--r--src/guile/skribilo/evaluator.scm203
-rw-r--r--src/guile/skribilo/index.scm (renamed from src/common/index.scm)86
-rw-r--r--src/guile/skribilo/lib.scm239
-rw-r--r--src/guile/skribilo/location.scm69
-rw-r--r--src/guile/skribilo/module.scm153
-rw-r--r--src/guile/skribilo/output.scm228
-rw-r--r--src/guile/skribilo/package/Makefile.am7
-rw-r--r--src/guile/skribilo/package/acmproc.scm164
-rw-r--r--src/guile/skribilo/package/base.scm (renamed from src/common/api.scm)429
-rw-r--r--src/guile/skribilo/package/eq.scm439
-rw-r--r--src/guile/skribilo/package/eq/Makefile.am4
-rw-r--r--src/guile/skribilo/package/eq/lout.scm217
-rw-r--r--src/guile/skribilo/package/french.scm30
-rw-r--r--src/guile/skribilo/package/jfp.scm328
-rw-r--r--src/guile/skribilo/package/letter.scm157
-rw-r--r--src/guile/skribilo/package/lncs.scm158
-rw-r--r--src/guile/skribilo/package/pie.scm314
-rw-r--r--src/guile/skribilo/package/pie/Makefile.am4
-rw-r--r--src/guile/skribilo/package/pie/lout.scm132
-rw-r--r--src/guile/skribilo/package/scribe.scm240
-rw-r--r--src/guile/skribilo/package/sigplan.scm166
-rw-r--r--src/guile/skribilo/package/skribe.scm85
-rw-r--r--src/guile/skribilo/package/slide.scm274
-rw-r--r--src/guile/skribilo/package/slide/Makefile.am4
-rw-r--r--src/guile/skribilo/package/slide/base.scm185
-rw-r--r--src/guile/skribilo/package/slide/html.scm144
-rw-r--r--src/guile/skribilo/package/slide/latex.scm394
-rw-r--r--src/guile/skribilo/package/slide/lout.scm151
-rw-r--r--src/guile/skribilo/package/web-article.scm241
-rw-r--r--src/guile/skribilo/package/web-book.scm121
-rw-r--r--src/guile/skribilo/parameters.scm88
-rw-r--r--src/guile/skribilo/prog.scm (renamed from src/stklos/prog.stk)87
-rw-r--r--src/guile/skribilo/reader.scm106
-rw-r--r--src/guile/skribilo/reader/Makefile.am2
-rw-r--r--src/guile/skribilo/reader/outline.scm426
-rw-r--r--src/guile/skribilo/reader/skribe.scm113
-rw-r--r--src/guile/skribilo/resolve.scm296
-rw-r--r--src/guile/skribilo/source.scm (renamed from src/stklos/source.stk)143
-rw-r--r--src/guile/skribilo/sui.scm (renamed from src/common/sui.scm)95
-rw-r--r--src/guile/skribilo/utils/Makefile.am5
-rw-r--r--src/guile/skribilo/utils/compat.scm309
-rw-r--r--src/guile/skribilo/utils/files.scm55
-rw-r--r--src/guile/skribilo/utils/images.scm99
-rw-r--r--src/guile/skribilo/utils/keywords.scm99
-rw-r--r--src/guile/skribilo/utils/strings.scm145
-rw-r--r--src/guile/skribilo/utils/syntax.scm81
-rw-r--r--src/guile/skribilo/verify.scm (renamed from src/stklos/verify.stk)99
-rw-r--r--src/guile/skribilo/writer.scm261
-rw-r--r--src/skribe-config.in64
-rwxr-xr-xsrc/skribilo.in40
-rw-r--r--src/stklos/Makefile.in110
-rw-r--r--src/stklos/biblio.stk161
-rw-r--r--src/stklos/configure.stk90
-rw-r--r--src/stklos/debug.stk161
-rw-r--r--src/stklos/engine.stk242
-rw-r--r--src/stklos/eval.stk149
-rw-r--r--src/stklos/lib.stk317
-rw-r--r--src/stklos/main.stk264
-rw-r--r--src/stklos/output.stk158
-rw-r--r--src/stklos/reader.stk136
-rw-r--r--src/stklos/resolve.stk255
-rw-r--r--src/stklos/runtime.stk456
-rw-r--r--src/stklos/types.stk294
-rw-r--r--src/stklos/vars.stk82
-rw-r--r--src/stklos/writer.stk211
-rw-r--r--src/stklos/xml.stk52
139 files changed, 23559 insertions, 10644 deletions
diff --git a/src/.arch-inventory b/src/.arch-inventory
new file mode 100644
index 0000000..55c64c1
--- /dev/null
+++ b/src/.arch-inventory
@@ -0,0 +1,4 @@
+# Generated file.
+precious ^skribilo$
+
+# arch-tag: 6042e4ec-e23e-4bf2-be59-016a0ff89518
diff --git a/src/Makefile b/src/Makefile
deleted file mode 100644
index 09e96d5..0000000
--- a/src/Makefile
+++ /dev/null
@@ -1,41 +0,0 @@
-#*=====================================================================*/
-#* serrano/prgm/project/skribe/src/Makefile */
-#* ------------------------------------------------------------- */
-#* Author : Manuel Serrano */
-#* Creation : Sat Oct 25 08:15:57 2003 */
-#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */
-#* Copyright : 2003-04 Manuel Serrano */
-#* ------------------------------------------------------------- */
-#* The meta Makefile for the sources */
-#*=====================================================================*/
-include ../etc/Makefile.config
-
-#*---------------------------------------------------------------------*/
-#* pop */
-#*---------------------------------------------------------------------*/
-.PHONY: pop
-
-pop:
- @ echo src/Makefile
- @ (cd bigloo && $(MAKE) pop)
- @ (cd stklos && $(MAKE) pop)
-
-#*---------------------------------------------------------------------*/
-#* Install/Uinstall */
-#*---------------------------------------------------------------------*/
-.PHONY: install uninstall
-
-install:
- (cd $(SYSTEM) && $(MAKE) install)
-
-uninstall:
- (cd $(SYSTEM) && $(MAKE) uninstall)
-
-#*---------------------------------------------------------------------*/
-#* clean */
-#*---------------------------------------------------------------------*/
-.PHONY: clean
-
-clean:
- (cd $(SYSTEM) && $(MAKE) clean)
-
diff --git a/src/Makefile.am b/src/Makefile.am
new file mode 100644
index 0000000..4a83f1a
--- /dev/null
+++ b/src/Makefile.am
@@ -0,0 +1,4 @@
+SUBDIRS = guile
+
+EXTRA_DIST = skribilo.in
+bin_SCRIPTS = skribilo
diff --git a/src/bigloo/Makefile b/src/bigloo/Makefile
deleted file mode 100644
index 02d2b6a..0000000
--- a/src/bigloo/Makefile
+++ /dev/null
@@ -1,271 +0,0 @@
-#*=====================================================================*/
-#* serrano/prgm/project/skribe/src/bigloo/Makefile */
-#* ------------------------------------------------------------- */
-#* Author : Manuel Serrano */
-#* Creation : Mon Jul 21 18:21:11 2003 */
-#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */
-#* Copyright : 2003-04 Manuel Serrano */
-#* ------------------------------------------------------------- */
-#* The Makefile to build the Bigloo API */
-#*=====================================================================*/
-
-#*---------------------------------------------------------------------*/
-#* General inclusion */
-#*---------------------------------------------------------------------*/
-include ../../etc/bigloo/Makefile.skb
-
-#*---------------------------------------------------------------------*/
-#* Compilers and tools */
-#*---------------------------------------------------------------------*/
-BSKBFLAGS = -I $(SRCDIR)/bigloo
-
-#*---------------------------------------------------------------------*/
-#* Targets ... */
-#*---------------------------------------------------------------------*/
-PROJECT = skribe
-CTARGET = $(SKRIBEBINDIR)/skribe.bigloo
-JVMTARGET = $(SKRIBEBINDIR)/skribe.zip
-
-PBASE = bigloo.$(PROJECT)
-ODIR = o
-CLASSDIR = class_s/bigloo/$(PROJECT)
-OBJDIR = obj/bigloo/$(PROJECT)
-
-#*---------------------------------------------------------------------*/
-#* Objects */
-#*---------------------------------------------------------------------*/
-SRCDIR = ..
-SKRIBECOMMON = param api bib index lib sui
-SKRIBEBGL = types parseargs main eval evapi \
- output resolve verify debug read prog source \
- lisp xml c asm engine writer color
-SKRIBEINCLUDE = api new debug
-
-MODULES = $(SKRIBEBGL:%=%.scm) \
- $(SKRIBECOMMON:%=%.bgl) \
- configure.bgl
-INCLUDES = $(SKRIBEINCLUDE:%=%.sch)
-SOURCES = $(MODULES) \
- $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \
- $(SRCDIR)/common/configure.scm \
- $(INCLUDES)
-OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure
-COBJECTS = $(OBJECTS:%=$(ODIR)/%.o)
-JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class)
-
-#*---------------------------------------------------------------------*/
-#* Population */
-#*---------------------------------------------------------------------*/
-POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile
-POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in
-
-#*---------------------------------------------------------------------*/
-#* Suffixes */
-#*---------------------------------------------------------------------*/
-.SUFFIXES:
-.SUFFIXES: .scm .bgl .class .o .obj
-
-#*---------------------------------------------------------------------*/
-#* All */
-#*---------------------------------------------------------------------*/
-.PHONY: c jvm dotnet
-
-all: $(TARGET)
-
-c: $(CTARGET)
-jvm: $(JVMTARGET)
-dotnet:
- echo "Not implemented yet"
-
-#*--- c ---------------------------------------------------------------*/
-$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS)
- $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS)
-
-#*--- jvm -------------------------------------------------------------*/
-$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES)
- $(RM) -f $(JVMTARGET)
- (cd $(ODIR)/class_s && \
- $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .)
-
-$(SKRIBEBINDIR):
- mkdir -p $(SKRIBEBINDIR)
-
-#*---------------------------------------------------------------------*/
-#* pop */
-#*---------------------------------------------------------------------*/
-.PHONY: pop
-
-pop:
- @ echo $(POPULATIONSCM:%=src/common/%)
- @ echo $(POPULATIONBGL:%=src/bigloo/%)
-
-#*---------------------------------------------------------------------*/
-#* ude */
-#*---------------------------------------------------------------------*/
-.PHONY: ude .etags .afile
-
-ude:
- @ $(MAKE) -f Makefile .afile .etags dep
-
-.afile:
- @ $(AFILE) -o .afile $(MODULES)
-
-.jfile:
- @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES)
-
-.etags:
- @ $(BTAGS) -o .etags $(SOURCES)
-
-dep:
- @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\
- head -`expr $$num - 1` Makefile > /tmp/Makefile.aux)
- @ $(BDEPEND) -search-path ../common \
- -search-path ../bigloo \
- -strict-obj-dir $(ODIR) \
- -strict-class-dir $(CLASSDIR) \
- -fno-mco $(SOURCES) >> /tmp/Makefile.aux
- @ mv /tmp/Makefile.aux Makefile
-
-getbinary:
- @ echo $(PROJECT)
-
-getsources:
- @ echo $(SOURCES)
-
-#*---------------------------------------------------------------------*/
-#* The implicit rules */
-#*---------------------------------------------------------------------*/
-$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm
- $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \
- $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@
-
-$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm
- $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \
- $(SRCDIR)/bigloo/$*.scm -o $@
-
-$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \
- $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm
- $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \
- $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@
-
-$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm
- $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \
- $(SRCDIR)/bigloo/$*.scm -o $@
-
-$(OBJDIR)/%.obj: src/%.scm
- $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@
-
-#*---------------------------------------------------------------------*/
-#* Ad hoc rules */
-#*---------------------------------------------------------------------*/
-$(ODIR):
- mkdir -p $(ODIR)
-
-$(CLASSDIR):
- mkdir -p $(CLASSDIR)
-
-$(OBJDIR):
- mkdir -p $(OBJDIR)
-
-
-#*---------------------------------------------------------------------*/
-#* install/uninstall */
-#*---------------------------------------------------------------------*/
-.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm
-
-install:
- $(MAKE) install-$(TARGET)
-
-uninstall:
- $(MAKE) uninstall-$(TARGET)
-
-install-c: $(DESTDIR)$(INSTALL_BINDIR)
- cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \
- && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo
- $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe
- ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe
-
-uninstall-c:
- $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo
- $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe
-
-install-jvm: $(DESTDIR)$(INSTALL_FILDIR)
- cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip
- cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR)
-
-uninstall-jvm:
- $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip
- $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip
-
-$(DESTDIR)$(INSTALL_BINDIR):
- mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)
-
-$(DESTDIR)$(INSTALL_FILDIR):
- mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR)
-
-#*---------------------------------------------------------------------*/
-#* Clean */
-#*---------------------------------------------------------------------*/
-clean:
- $(RM) -f .afile
- $(RM) -f .jfile
- $(RM) -rf $(ODIR)
- $(RM) -f $(CTARGET)
- $(RM) -f $(JVMTARGET)
-
-#*---------------------------------------------------------------------*/
-#* Cleanall */
-#*---------------------------------------------------------------------*/
-cleanall: clean
-
-#*---------------------------------------------------------------------*/
-#* Manual dependency */
-#*---------------------------------------------------------------------*/
-o/eval.o o/class/bigloo/skribe/eval.class: \
- $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm
-
-#bdepend start (don't edit)
-#*---------------------------------------------------------------------*/
-#* Dependencies ... */
-#*---------------------------------------------------------------------*/
-o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch
-o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch
-o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch
-o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch
-o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch
-o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch
-o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \
- ../bigloo/api.sch
-o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch
-o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch
-o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch
-o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch
-o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch
-o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch
-o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch
-o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch
-o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch
-o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch
-o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch
-o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch
-o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch
-o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch
-o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch
-o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch
-o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch
-o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch
-o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch
-o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch
-o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch
-o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch
-o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch
-o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch
-o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch
-o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch
-o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch
-o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch
-o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \
- ../bigloo/api.sch
-o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch
-
-#bdepend stop
diff --git a/src/bigloo/api.bgl b/src/bigloo/api.bgl
deleted file mode 100644
index 55493b0..0000000
--- a/src/bigloo/api.bgl
+++ /dev/null
@@ -1,117 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/api.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Jul 21 18:21:34 2003 */
-;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */
-;* Copyright : 2003 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Bigloo header for the API. */
-;* ------------------------------------------------------------- */
-;* Implementation: @label api@ */
-;* bigloo: @path ../common/api.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_api
-
- (include "new.sch"
- "api.sch")
-
- (import skribe_param
- skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_bib
- skribe_index
- skribe_prog
- skribe_source
- skribe_engine
- skribe_color
- skribe_sui)
-
- (export (include string)
-
- (document::%markup . opts)
- (author::%markup . opts)
- (toc::%markup . opts)
-
- (chapter::%markup . opts)
- (section::%markup . opts)
- (subsection::%markup . opts)
- (subsubsection::%markup . opts)
- (paragraph::%markup . opts)
-
- (footnote::%markup . opts)
-
- (linebreak . opts)
- (hrule::%markup . opts)
-
- (color::%markup . opts)
- (frame::%markup . opts)
- (font::%markup . opts)
-
- (flush::%markup . opts)
- (center::%markup . opts)
- (pre::%markup . opts)
- (prog::%markup . opts)
- (source::obj . opts)
- (language::obj . opts)
-
- (itemize::%markup . opts)
- (enumerate::%markup . opts)
- (description::%markup . opts)
- (item::%markup . opts)
-
- (figure::%markup . opts)
-
- (table::%markup . opts)
- (tr::%markup . opts)
- (td::%markup . opts)
- (th::%markup . opts)
-
- (image::%markup . opts)
-
- (blockquote::%markup . opts)
-
- (roman::%markup . opts)
- (bold::%markup . opts)
- (underline::%markup . opts)
- (strike::%markup . opts)
- (emph::%markup . opts)
- (kbd::%markup . opts)
- (it::%markup . opts)
- (tt::%markup . opts)
- (code::%markup . opts)
- (var::%markup . opts)
- (samp::%markup . opts)
- (sf::%markup . opts)
- (sc::%markup . opts)
- (sub::%markup . opts)
- (sup::%markup . opts)
-
- (mailto::%markup . opts)
- (mark::%markup . opts)
-
- (handle . obj)
- (ref::%ast . obj)
- (resolve::%ast ::procedure)
-
- (bibliography . files)
- (the-bibliography . opts)
-
- (make-index ::bstring)
- (index . args)
- (the-index . args)
-
- (char::bstring char)
- (symbol::%markup symbol)
- (!::%command string . args)
-
- (processor::%processor . opts)
-
- (html-processor::%processor . opts)
- (tex-processor::%processor . opts)))
diff --git a/src/bigloo/api.sch b/src/bigloo/api.sch
deleted file mode 100644
index 390b8fa..0000000
--- a/src/bigloo/api.sch
+++ /dev/null
@@ -1,91 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/api.sch */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Jul 21 18:15:25 2003 */
-;* Last change : Wed Oct 27 12:43:23 2004 (eg) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Bigloo macros for the API implementation */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* define-pervasive-macro ... */
-;*---------------------------------------------------------------------*/
-(define-macro (define-pervasive-macro proto . body)
- `(begin
- (eval '(define-macro ,proto ,@body))
- (define-macro ,proto ,@body)))
-
-;*---------------------------------------------------------------------*/
-;* define-markup ... */
-;*---------------------------------------------------------------------*/
-(define-pervasive-macro (define-markup proto . body)
- (define (s2k symbol)
- (string->keyword (string-append ":" (symbol->string symbol))))
- (if (not (pair? proto))
- (error 'define-markup "Illegal markup definition" proto)
- (let* ((id (car proto))
- (args (cdr proto))
- (dargs (dsssl-formals->scheme-formals args error)))
- `(begin
- ,(if (and (memq #!key args)
- (memq '&skribe-eval-location args))
- `(define-expander ,id
- (lambda (x e)
- (append
- (cons ',id (map (lambda (x) (e x e)) (cdr x)))
- (list :&skribe-eval-location
- '(skribe-eval-location)))))
- #unspecified)
- (define ,(cons id dargs)
- ,(make-dsssl-function-prelude proto
- args `(begin ,@body)
- error s2k))))))
-
-;*---------------------------------------------------------------------*/
-;* define-simple-markup ... */
-;*---------------------------------------------------------------------*/
-(define-pervasive-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-pervasive-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-pervasive-macro (define-processor-markup proc)
- `(define-markup (,proc #!rest opts)
- (new processor
- (engine (find-engine ',proc))
- (body (the-body opts))
- (options (the-options opts)))))
-
-;*---------------------------------------------------------------------*/
-;* new (at runtime) */
-;*---------------------------------------------------------------------*/
-(eval '(define-macro (new id . inits)
- (cons (symbol-append 'new- id)
- (map (lambda (i)
- (list 'list (list 'quote (car i)) (cadr i)))
- inits))))
diff --git a/src/bigloo/asm.scm b/src/bigloo/asm.scm
deleted file mode 100644
index 03196ac..0000000
--- a/src/bigloo/asm.scm
+++ /dev/null
@@ -1,99 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/asm.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Sep 1 12:08:39 2003 */
-;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* ASM fontification */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_asm
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api
- skribe_param
- skribe_source)
-
- (export asm))
-
-;*---------------------------------------------------------------------*/
-;* asm ... */
-;*---------------------------------------------------------------------*/
-(define asm
- (new language
- (name "asm")
- (fontifier asm-fontifier)
- (extractor #f)))
-
-;*---------------------------------------------------------------------*/
-;* asm-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (asm-fontifier s)
- (let ((g (regular-grammar ()
- ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*))))
- (+ #\*) "/")
- ;; bold comments
- (let ((c (new markup
- (markup '&source-line-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((: "//" (* all))
- ;; italic comments
- (let ((c (new markup
- (markup '&source-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((: "#" (* all))
- ;; italic comments
- (let ((c (new markup
- (markup '&source-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((+ (or #\Newline #\Space))
- ;; separators
- (let ((str (the-string)))
- (cons str (ignore))))
- ((: (* (in #\tab #\space))
- (+ (out #\: #\Space #\Tab #\Newline)) #\:)
- ;; labels
- (let ((c (new markup
- (markup '&source-define)
- (body (the-string)))))
- (cons c (ignore))))
- ((or (in "<>=!/\\+*-([])")
- #\/
- (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)))
- ;; regular text
- (let ((s (the-string)))
- (cons s (ignore))))
- ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- ;; strings
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-string)
- (body s))))
- str)
- (ignore))))
- ((+ (or #\; #\" #\# #\tab))
- (let ((str (the-string)))
- (cons str (ignore))))
- (else
- (let ((c (the-failure)))
- (if (eof-object? c)
- '()
- (error "source(asm)" "Unexpected character" c)))))))
- (read/rp g (open-input-string s))))
-
diff --git a/src/bigloo/bib.bgl b/src/bigloo/bib.bgl
deleted file mode 100644
index 6b0f7dd..0000000
--- a/src/bigloo/bib.bgl
+++ /dev/null
@@ -1,161 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Dec 7 06:12:29 2001 */
-;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */
-;* Copyright : 2001-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe Bibliography */
-;* ------------------------------------------------------------- */
-;* Implementation: @label bib@ */
-;* bigloo: @path ../common/bib.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_bib
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_read)
-
- (export (bib-table?::bool ::obj)
- (make-bib-table ::bstring)
- (default-bib-table)
- (bib-load! ::obj ::bstring ::obj)
- (bib-add! ::obj . entries)
- (resolve-bib ::obj ::obj)
- (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil)
- (bib-sort/authors::pair-nil ::pair-nil)
- (bib-sort/idents::pair-nil ::pair-nil)
- (bib-sort/dates::pair-nil ::pair-nil)))
-
-;*---------------------------------------------------------------------*/
-;* bib-table? ... */
-;*---------------------------------------------------------------------*/
-(define (bib-table? obj)
- (hashtable? obj))
-
-;*---------------------------------------------------------------------*/
-;* *bib-table* ... */
-;*---------------------------------------------------------------------*/
-(define *bib-table* #f)
-
-;*---------------------------------------------------------------------*/
-;* make-bib-table ... */
-;*---------------------------------------------------------------------*/
-(define (make-bib-table ident)
- (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* default-bib-table ... */
-;*---------------------------------------------------------------------*/
-(define (default-bib-table)
- (if (not *bib-table*)
- (set! *bib-table* (make-bib-table "default-bib-table")))
- *bib-table*)
-
-;*---------------------------------------------------------------------*/
-;* bib-parse-error ... */
-;*---------------------------------------------------------------------*/
-(define (bib-parse-error entry)
- (if (epair? entry)
- (match-case (cer entry)
- ((at ?fname ?pos ?-)
- (error/location "parse-biblio"
- "bibliography syntax error"
- entry
- fname
- pos))
- (else
- (error 'bib-parse "bibliography syntax error" entry)))
- (error 'bib-parse "bibliography syntax error" 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 (input-port-name port)))
- (let loop ((entry (skribe-read port)))
- (if (not (eof-object? entry))
- (match-case entry
- (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds)
- (let* ((ident (symbol->string ident))
- (old (hashtable-get table ident)))
- (if old
- (bib-duplicate ident from old)
- (hashtable-put! table
- ident
- (make-bib-entry kind
- ident
- fds
- from))))
- (loop (skribe-read port)))
- (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds)
- (let ((old (hashtable-get table ident)))
- (if old
- (bib-duplicate ident from old)
- (hashtable-put! table
- ident
- (make-bib-entry kind
- ident
- fds
- from))))
- (loop (skribe-read port)))
- (else
- (bib-parse-error 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)
- (match-case entry
- (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs)
- (let* ((ident (symbol->string ident))
- (old (hashtable-get table ident)))
- (if old
- (bib-duplicate ident #f old)
- (hashtable-put! table
- ident
- (make-bib-entry kind
- ident fs #f)))))
- (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs)
- (let ((old (hashtable-get table ident)))
- (if old
- (bib-duplicate ident #f old)
- (hashtable-put! table
- ident
- (make-bib-entry kind
- ident fs #f)))))
- (else
- (bib-parse-error entry))))
- entries)))
-
-
-
diff --git a/src/bigloo/c.scm b/src/bigloo/c.scm
deleted file mode 100644
index 07290ce..0000000
--- a/src/bigloo/c.scm
+++ /dev/null
@@ -1,134 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/c.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Sep 1 12:08:39 2003 */
-;* Last change : Thu May 27 10:11:24 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* C fontification */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_c
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api
- skribe_param
- skribe_source)
-
- (export C))
-
-;*---------------------------------------------------------------------*/
-;* C stamps */
-;*---------------------------------------------------------------------*/
-(define *keyword* (gensym))
-(define *cpp* (gensym))
-
-;*---------------------------------------------------------------------*/
-;* C keywords */
-;*---------------------------------------------------------------------*/
-(for-each (lambda (symbol)
- (putprop! symbol *keyword* #t))
- '(for class template while return try catch break continue
- do if else typedef struct union goto switch case
- static extern default finally throw))
-(let ((sharp (string->symbol "#")))
- (for-each (lambda (symbol)
- (putprop! (symbol-append sharp symbol) *cpp* #t))
- '(include define if ifdef ifdef else endif)))
-
-;*---------------------------------------------------------------------*/
-;* C ... */
-;*---------------------------------------------------------------------*/
-(define C
- (new language
- (name "C")
- (fontifier c-fontifier)
- (extractor #f)))
-
-;*---------------------------------------------------------------------*/
-;* c-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (c-fontifier s)
- (let ((g (regular-grammar ()
- ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*))))
- (+ #\*) "/")
- ;; bold comments
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-line-comment)
- (body s))))
- str)
- (ignore))))
- ((: "//" (* all))
- ;; italic comments
- (let ((c (new markup
- (markup '&source-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((+ (or #\Newline #\Space))
- ;; separators
- (let ((str (the-string)))
- (cons str (ignore))))
- ((in "{}")
- ;; brackets
- (let ((str (the-string)))
- (let ((c (new markup
- (markup '&source-bracket)
- (body (the-string)))))
- (cons c (ignore)))))
- ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))
- ;; keywords
- (let* ((string (the-string))
- (symbol (the-symbol)))
- (cond
- ((getprop symbol *keyword*)
- (let ((c (new markup
- (markup '&source-keyword)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- ((getprop symbol *cpp*)
- (let ((c (new markup
- (markup '&source-module)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- (else
- (cons string (ignore))))))
- ((in "<>=!/\\+*-([])")
- ;; regular text
- (let ((s (the-string)))
- (cons s (ignore))))
- ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- ;; strings
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-string)
- (body s))))
- str)
- (ignore))))
- ((+ (or #\; #\" #\# #\tab))
- (let ((str (the-string)))
- (cons str (ignore))))
- (else
- (let ((c (the-failure)))
- (if (eof-object? c)
- '()
- (error "source(C)" "Unexpected character" c)))))))
- (read/rp g (open-input-string s))))
-
diff --git a/src/bigloo/color.scm b/src/bigloo/color.scm
deleted file mode 100644
index e40638b..0000000
--- a/src/bigloo/color.scm
+++ /dev/null
@@ -1,702 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/color.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Apr 10 13:46:50 2002 */
-;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */
-;* Copyright : 2002-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Tex color manager */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_color
- (import skribe_configure)
- (export (skribe-color->rgb ::obj)
- (skribe-get-used-colors)
- (skribe-use-color! color)))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-rgb-string* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-rgb-string*
- "255 250 250 snow
-248 248 255 ghostwhite
-245 245 245 whitesmoke
-220 220 220 gainsboro
-255 250 240 floralwhite
-253 245 230 oldlace
-250 240 230 linen
-250 235 215 antiquewhite
-255 239 213 papayawhip
-255 235 205 blanchedalmond
-255 228 196 bisque
-255 218 185 peachpuff
-255 222 173 navajowhite
-255 228 181 moccasin
-255 248 220 cornsilk
-255 255 240 ivory
-255 250 205 lemonchiffon
-255 245 238 seashell
-240 255 240 honeydew
-245 255 250 mintcream
-240 255 255 azure
-240 248 255 aliceblue
-230 230 250 lavender
-255 240 245 lavenderblush
-255 228 225 mistyrose
-255 255 255 white
-0 0 0 black
-47 79 79 darkslategrey
-105 105 105 dimgrey
-112 128 144 slategrey
-119 136 153 lightslategrey
-190 190 190 grey
-211 211 211 lightgrey
-25 25 112 midnightblue
-0 0 128 navy
-0 0 128 navyblue
-100 149 237 cornflowerblue
-72 61 139 darkslateblue
-106 90 205 slateblue
-123 104 238 mediumslateblue
-132 112 255 lightslateblue
-0 0 205 mediumblue
-65 105 225 royalblue
-0 0 255 blue
-30 144 255 dodgerblue
-0 191 255 deepskyblue
-135 206 235 skyblue
-135 206 250 lightskyblue
-70 130 180 steelblue
-176 196 222 lightsteelblue
-173 216 230 lightblue
-176 224 230 powderblue
-175 238 238 paleturquoise
-0 206 209 darkturquoise
-72 209 204 mediumturquoise
-64 224 208 turquoise
-0 255 255 cyan
-224 255 255 lightcyan
-95 158 160 cadetblue
-102 205 170 mediumaquamarine
-127 255 212 aquamarine
-0 100 0 darkgreen
-85 107 47 darkolivegreen
-143 188 143 darkseagreen
-46 139 87 seagreen
-60 179 113 mediumseagreen
-32 178 170 lightseagreen
-152 251 152 palegreen
-0 255 127 springgreen
-124 252 0 lawngreen
-0 255 0 green
-127 255 0 chartreuse
-0 250 154 mediumspringgreen
-173 255 47 greenyellow
-50 205 50 limegreen
-154 205 50 yellowgreen
-34 139 34 forestgreen
-107 142 35 olivedrab
-189 183 107 darkkhaki
-240 230 140 khaki
-238 232 170 palegoldenrod
-250 250 210 lightgoldenrodyellow
-255 255 224 lightyellow
-255 255 0 yellow
-255 215 0 gold
-238 221 130 lightgoldenrod
-218 165 32 goldenrod
-184 134 11 darkgoldenrod
-188 143 143 rosybrown
-205 92 92 indianred
-139 69 19 saddlebrown
-160 82 45 sienna
-205 133 63 peru
-222 184 135 burlywood
-245 245 220 beige
-245 222 179 wheat
-244 164 96 sandybrown
-210 180 140 tan
-210 105 30 chocolate
-178 34 34 firebrick
-165 42 42 brown
-233 150 122 darksalmon
-250 128 114 salmon
-255 160 122 lightsalmon
-255 165 0 orange
-255 140 0 darkorange
-255 127 80 coral
-240 128 128 lightcoral
-255 99 71 tomato
-255 69 0 orangered
-255 0 0 red
-255 105 180 hotpink
-255 20 147 deeppink
-255 192 203 pink
-255 182 193 lightpink
-219 112 147 palevioletred
-176 48 96 maroon
-199 21 133 mediumvioletred
-208 32 144 violetred
-255 0 255 magenta
-238 130 238 violet
-221 160 221 plum
-218 112 214 orchid
-186 85 211 mediumorchid
-153 50 204 darkorchid
-148 0 211 darkviolet
-138 43 226 blueviolet
-160 32 240 purple
-147 112 219 mediumpurple
-216 191 216 thistle
-255 250 250 snow1
-238 233 233 snow2
-205 201 201 snow3
-139 137 137 snow4
-255 245 238 seashell1
-238 229 222 seashell2
-205 197 191 seashell3
-139 134 130 seashell4
-255 239 219 antiquewhite1
-238 223 204 antiquewhite2
-205 192 176 antiquewhite3
-139 131 120 antiquewhite4
-255 228 196 bisque1
-238 213 183 bisque2
-205 183 158 bisque3
-139 125 107 bisque4
-255 218 185 peachpuff1
-238 203 173 peachpuff2
-205 175 149 peachpuff3
-139 119 101 peachpuff4
-255 222 173 navajowhite1
-238 207 161 navajowhite2
-205 179 139 navajowhite3
-139 121 94 navajowhite4
-255 250 205 lemonchiffon1
-238 233 191 lemonchiffon2
-205 201 165 lemonchiffon3
-139 137 112 lemonchiffon4
-255 248 220 cornsilk1
-238 232 205 cornsilk2
-205 200 177 cornsilk3
-139 136 120 cornsilk4
-255 255 240 ivory1
-238 238 224 ivory2
-205 205 193 ivory3
-139 139 131 ivory4
-240 255 240 honeydew1
-224 238 224 honeydew2
-193 205 193 honeydew3
-131 139 131 honeydew4
-255 240 245 lavenderblush1
-238 224 229 lavenderblush2
-205 193 197 lavenderblush3
-139 131 134 lavenderblush4
-255 228 225 mistyrose1
-238 213 210 mistyrose2
-205 183 181 mistyrose3
-139 125 123 mistyrose4
-240 255 255 azure1
-224 238 238 azure2
-193 205 205 azure3
-131 139 139 azure4
-131 111 255 slateblue1
-122 103 238 slateblue2
-105 89 205 slateblue3
-71 60 139 slateblue4
-72 118 255 royalblue1
-67 110 238 royalblue2
-58 95 205 royalblue3
-39 64 139 royalblue4
-0 0 255 blue1
-0 0 238 blue2
-0 0 205 blue3
-0 0 139 blue4
-30 144 255 dodgerblue1
-28 134 238 dodgerblue2
-24 116 205 dodgerblue3
-16 78 139 dodgerblue4
-99 184 255 steelblue1
-92 172 238 steelblue2
-79 148 205 steelblue3
-54 100 139 steelblue4
-0 191 255 deepskyblue1
-0 178 238 deepskyblue2
-0 154 205 deepskyblue3
-0 104 139 deepskyblue4
-135 206 255 skyblue1
-126 192 238 skyblue2
-108 166 205 skyblue3
-74 112 139 skyblue4
-176 226 255 lightskyblue1
-164 211 238 lightskyblue2
-141 182 205 lightskyblue3
-96 123 139 lightskyblue4
-202 225 255 lightsteelblue1
-188 210 238 lightsteelblue2
-162 181 205 lightsteelblue3
-110 123 139 lightsteelblue4
-191 239 255 lightblue1
-178 223 238 lightblue2
-154 192 205 lightblue3
-104 131 139 lightblue4
-224 255 255 lightcyan1
-209 238 238 lightcyan2
-180 205 205 lightcyan3
-122 139 139 lightcyan4
-187 255 255 paleturquoise1
-174 238 238 paleturquoise2
-150 205 205 paleturquoise3
-102 139 139 paleturquoise4
-152 245 255 cadetblue1
-142 229 238 cadetblue2
-122 197 205 cadetblue3
-83 134 139 cadetblue4
-0 245 255 turquoise1
-0 229 238 turquoise2
-0 197 205 turquoise3
-0 134 139 turquoise4
-0 255 255 cyan1
-0 238 238 cyan2
-0 205 205 cyan3
-0 139 139 cyan4
-127 255 212 aquamarine1
-118 238 198 aquamarine2
-102 205 170 aquamarine3
-69 139 116 aquamarine4
-193 255 193 darkseagreen1
-180 238 180 darkseagreen2
-155 205 155 darkseagreen3
-105 139 105 darkseagreen4
-84 255 159 seagreen1
-78 238 148 seagreen2
-67 205 128 seagreen3
-46 139 87 seagreen4
-154 255 154 palegreen1
-144 238 144 palegreen2
-124 205 124 palegreen3
-84 139 84 palegreen4
-0 255 127 springgreen1
-0 238 118 springgreen2
-0 205 102 springgreen3
-0 139 69 springgreen4
-0 255 0 green1
-0 238 0 green2
-0 205 0 green3
-0 139 0 green4
-127 255 0 chartreuse1
-118 238 0 chartreuse2
-102 205 0 chartreuse3
-69 139 0 chartreuse4
-192 255 62 olivedrab1
-179 238 58 olivedrab2
-154 205 50 olivedrab3
-105 139 34 olivedrab4
-202 255 112 darkolivegreen1
-188 238 104 darkolivegreen2
-162 205 90 darkolivegreen3
-110 139 61 darkolivegreen4
-255 246 143 khaki1
-238 230 133 khaki2
-205 198 115 khaki3
-139 134 78 khaki4
-255 236 139 lightgoldenrod1
-238 220 130 lightgoldenrod2
-205 190 112 lightgoldenrod3
-139 129 76 lightgoldenrod4
-255 255 224 lightyellow1
-238 238 209 lightyellow2
-205 205 180 lightyellow3
-139 139 122 lightyellow4
-255 255 0 yellow1
-238 238 0 yellow2
-205 205 0 yellow3
-139 139 0 yellow4
-255 215 0 gold1
-238 201 0 gold2
-205 173 0 gold3
-139 117 0 gold4
-255 193 37 goldenrod1
-238 180 34 goldenrod2
-205 155 29 goldenrod3
-139 105 20 goldenrod4
-255 185 15 darkgoldenrod1
-238 173 14 darkgoldenrod2
-205 149 12 darkgoldenrod3
-139 101 8 darkgoldenrod4
-255 193 193 rosybrown1
-238 180 180 rosybrown2
-205 155 155 rosybrown3
-139 105 105 rosybrown4
-255 106 106 indianred1
-238 99 99 indianred2
-205 85 85 indianred3
-139 58 58 indianred4
-255 130 71 sienna1
-238 121 66 sienna2
-205 104 57 sienna3
-139 71 38 sienna4
-255 211 155 burlywood1
-238 197 145 burlywood2
-205 170 125 burlywood3
-139 115 85 burlywood4
-255 231 186 wheat1
-238 216 174 wheat2
-205 186 150 wheat3
-139 126 102 wheat4
-255 165 79 tan1
-238 154 73 tan2
-205 133 63 tan3
-139 90 43 tan4
-255 127 36 chocolate1
-238 118 33 chocolate2
-205 102 29 chocolate3
-139 69 19 chocolate4
-255 48 48 firebrick1
-238 44 44 firebrick2
-205 38 38 firebrick3
-139 26 26 firebrick4
-255 64 64 brown1
-238 59 59 brown2
-205 51 51 brown3
-139 35 35 brown4
-255 140 105 salmon1
-238 130 98 salmon2
-205 112 84 salmon3
-139 76 57 salmon4
-255 160 122 lightsalmon1
-238 149 114 lightsalmon2
-205 129 98 lightsalmon3
-139 87 66 lightsalmon4
-255 165 0 orange1
-238 154 0 orange2
-205 133 0 orange3
-139 90 0 orange4
-255 127 0 darkorange1
-238 118 0 darkorange2
-205 102 0 darkorange3
-139 69 0 darkorange4
-255 114 86 coral1
-238 106 80 coral2
-205 91 69 coral3
-139 62 47 coral4
-255 99 71 tomato1
-238 92 66 tomato2
-205 79 57 tomato3
-139 54 38 tomato4
-255 69 0 orangered1
-238 64 0 orangered2
-205 55 0 orangered3
-139 37 0 orangered4
-255 0 0 red1
-238 0 0 red2
-205 0 0 red3
-139 0 0 red4
-255 20 147 deeppink1
-238 18 137 deeppink2
-205 16 118 deeppink3
-139 10 80 deeppink4
-255 110 180 hotpink1
-238 106 167 hotpink2
-205 96 144 hotpink3
-139 58 98 hotpink4
-255 181 197 pink1
-238 169 184 pink2
-205 145 158 pink3
-139 99 108 pink4
-255 174 185 lightpink1
-238 162 173 lightpink2
-205 140 149 lightpink3
-139 95 101 lightpink4
-255 130 171 palevioletred1
-238 121 159 palevioletred2
-205 104 137 palevioletred3
-139 71 93 palevioletred4
-255 52 179 maroon1
-238 48 167 maroon2
-205 41 144 maroon3
-139 28 98 maroon4
-255 62 150 violetred1
-238 58 140 violetred2
-205 50 120 violetred3
-139 34 82 violetred4
-255 0 255 magenta1
-238 0 238 magenta2
-205 0 205 magenta3
-139 0 139 magenta4
-255 131 250 orchid1
-238 122 233 orchid2
-205 105 201 orchid3
-139 71 137 orchid4
-255 187 255 plum1
-238 174 238 plum2
-205 150 205 plum3
-139 102 139 plum4
-224 102 255 mediumorchid1
-209 95 238 mediumorchid2
-180 82 205 mediumorchid3
-122 55 139 mediumorchid4
-191 62 255 darkorchid1
-178 58 238 darkorchid2
-154 50 205 darkorchid3
-104 34 139 darkorchid4
-155 48 255 purple1
-145 44 238 purple2
-125 38 205 purple3
-85 26 139 purple4
-171 130 255 mediumpurple1
-159 121 238 mediumpurple2
-137 104 205 mediumpurple3
-93 71 139 mediumpurple4
-255 225 255 thistle1
-238 210 238 thistle2
-205 181 205 thistle3
-139 123 139 thistle4
-0 0 0 grey0
-3 3 3 grey1
-5 5 5 grey2
-8 8 8 grey3
-10 10 10 grey4
-13 13 13 grey5
-15 15 15 grey6
-18 18 18 grey7
-20 20 20 grey8
-23 23 23 grey9
-26 26 26 grey10
-28 28 28 grey11
-31 31 31 grey12
-33 33 33 grey13
-36 36 36 grey14
-38 38 38 grey15
-41 41 41 grey16
-43 43 43 grey17
-46 46 46 grey18
-48 48 48 grey19
-51 51 51 grey20
-54 54 54 grey21
-56 56 56 grey22
-59 59 59 grey23
-61 61 61 grey24
-64 64 64 grey25
-66 66 66 grey26
-69 69 69 grey27
-71 71 71 grey28
-74 74 74 grey29
-77 77 77 grey30
-79 79 79 grey31
-82 82 82 grey32
-84 84 84 grey33
-87 87 87 grey34
-89 89 89 grey35
-92 92 92 grey36
-94 94 94 grey37
-97 97 97 grey38
-99 99 99 grey39
-102 102 102 grey40
-105 105 105 grey41
-107 107 107 grey42
-110 110 110 grey43
-112 112 112 grey44
-115 115 115 grey45
-117 117 117 grey46
-120 120 120 grey47
-122 122 122 grey48
-125 125 125 grey49
-127 127 127 grey50
-130 130 130 grey51
-133 133 133 grey52
-135 135 135 grey53
-138 138 138 grey54
-140 140 140 grey55
-143 143 143 grey56
-145 145 145 grey57
-148 148 148 grey58
-150 150 150 grey59
-153 153 153 grey60
-156 156 156 grey61
-158 158 158 grey62
-161 161 161 grey63
-163 163 163 grey64
-166 166 166 grey65
-168 168 168 grey66
-171 171 171 grey67
-173 173 173 grey68
-176 176 176 grey69
-179 179 179 grey70
-181 181 181 grey71
-184 184 184 grey72
-186 186 186 grey73
-189 189 189 grey74
-191 191 191 grey75
-194 194 194 grey76
-196 196 196 grey77
-199 199 199 grey78
-201 201 201 grey79
-204 204 204 grey80
-207 207 207 grey81
-209 209 209 grey82
-212 212 212 grey83
-214 214 214 grey84
-217 217 217 grey85
-219 219 219 grey86
-222 222 222 grey87
-224 224 224 grey88
-227 227 227 grey89
-229 229 229 grey90
-232 232 232 grey91
-235 235 235 grey92
-237 237 237 grey93
-240 240 240 grey94
-242 242 242 grey95
-245 245 245 grey96
-247 247 247 grey97
-250 250 250 grey98
-252 252 252 grey99
-255 255 255 grey100
-169 169 169 darkgrey
-0 0 139 darkblue
-0 139 139 darkcyan
-139 0 139 darkmagenta
-139 0 0 darkred
-144 238 144 lightgreen")
-
-;*---------------------------------------------------------------------*/
-;* *rgb-port* ... */
-;*---------------------------------------------------------------------*/
-(define *rgb-port* #unspecified)
-
-;*---------------------------------------------------------------------*/
-;* same-color? ... */
-;*---------------------------------------------------------------------*/
-(define (same-color? s1 s2)
- (define (skip-rgb s)
- (let ((l (string-length s)))
- (let loop ((i 0))
- (if (=fx i l)
- l
- (let ((c (string-ref s i)))
- (if (or (char-numeric? c) (char-whitespace? c))
- (loop (+fx i 1))
- i))))))
- (let ((l1 (string-length s1))
- (l2 (string-length s2)))
- (if (>fx l1 l2)
- (let ((lc (skip-rgb s1)))
- (and (=fx (-fx l1 lc) l2)
- (let loop ((i1 (-fx l1 l2))
- (i2 0))
- (cond
- ((=fx i1 l1)
- #t)
- ((char-ci=? (string-ref s1 i1) (string-ref s2 i2))
- (loop (+fx i1 1) (+fx i2 1)))
- (else
- #f))))))))
-
-;*---------------------------------------------------------------------*/
-;* rgb-grep ... */
-;*---------------------------------------------------------------------*/
-(define (rgb-grep symbol)
- (let ((parser (regular-grammar ()
- ((bol (: #\! (* all)))
- (ignore))
- ((+ #\Newline)
- (ignore))
- ((: (* (in #\space #\tab))
- (+ digit)
- (+ (in #\space #\tab))
- (+ digit)
- (+ (in #\space #\tab))
- (+ digit)
- (+ (in #\space #\tab))
- (+ all))
- (let ((s (the-string)))
- (if (same-color? s symbol)
- (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s)))
- (values (string->number (cadr m))
- (string->number (caddr m))
- (string->number (cadddr m))))
- (ignore))))
- (else
- (values 0 0 0)))))
- ;; initialization the port reading rgb.txt file
- (with-input-from-string *skribe-rgb-string*
- (lambda ()
- (read/rp parser (current-input-port))))))
-
-;*---------------------------------------------------------------------*/
-;* *color-parser* ... */
-;*---------------------------------------------------------------------*/
-(define *color-parser*
- (regular-grammar ((blank* (* blank))
- (blank+ (+ blank)))
-
- ;; rgb color
- ((: #\# (+ xdigit))
- (let ((val (the-substring 1 (the-length))))
- (cond
- ((=fx (string-length val) 6)
- (values (string->integer (substring val 0 2) 16)
- (string->integer (substring val 2 4) 16)
- (string->integer (substring val 4 6) 16)))
- ((=fx (string-length val) 12)
- (values (string->integer (substring val 0 2) 16)
- (string->integer (substring val 4 6) 16)
- (string->integer (substring val 8 10) 16)))
- (else
- (values 0 0 0)))))
-
- ;; symbolic names
- ((+ (out #\Newline))
- (let ((name (the-string)))
- (cond
- ((string-ci=? name "none")
- (values 0 0 0))
- ((string-ci=? name "black")
- (values #xff #xff #xff))
- ((string-ci=? name "white")
- (values 0 0 0))
- (else
- (rgb-grep name)))))
-
- ;; error
- (else
- (values 0 0 0))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-color->rgb ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-color->rgb spec)
- (cond
- ((string? spec)
- (with-input-from-string spec
- (lambda ()
- (read/rp *color-parser* (current-input-port)))))
- ((fixnum? spec)
- (values (bit-and #xff (bit-rsh spec 16))
- (bit-and #xff (bit-rsh spec 8))
- (bit-and #xff spec)))
- (else
- (values 0 0 0))))
-
-;*---------------------------------------------------------------------*/
-;* *used-colors* ... */
-;*---------------------------------------------------------------------*/
-(define *used-colors* '())
-
-;*---------------------------------------------------------------------*/
-;* 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/bigloo/configure.bgl b/src/bigloo/configure.bgl
deleted file mode 100644
index e100d8d..0000000
--- a/src/bigloo/configure.bgl
+++ /dev/null
@@ -1,90 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 18:42:21 2003 */
-;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The general configuration options. */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_configure
- (export (skribe-release)
- (skribe-url)
- (skribe-doc-dir)
- (skribe-ext-dir)
- (skribe-default-path)
- (skribe-scheme)
-
- (skribe-configure . opt)
- (skribe-enforce-configure . opt)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-configuration ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-configuration)
- `((:release ,(skribe-release))
- (:scheme ,(skribe-scheme))
- (:url ,(skribe-url))
- (:doc-dir ,(skribe-doc-dir))
- (:ext-dir ,(skribe-ext-dir))
- (:default-path ,(skribe-default-path))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-configure ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-configure . opt)
- (let ((conf (skribe-configuration)))
- (cond
- ((null? opt)
- conf)
- ((null? (cdr opt))
- (let ((cell (assq (car opt) conf)))
- (if (pair? cell)
- (cadr cell)
- 'void)))
- (else
- (let loop ((opt opt))
- (cond
- ((null? opt)
- #t)
- ((not (keyword? (car opt)))
- #f)
- ((or (null? (cdr opt)) (keyword? (cadr opt)))
- #f)
- (else
- (let ((cell (assq (car opt) conf)))
- (if (and (pair? cell)
- (if (procedure? (cadr opt))
- ((cadr opt) (cadr cell))
- (equal? (cadr opt) (cadr cell))))
- (loop (cddr opt))
- #f)))))))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-enforce-configure ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-enforce-configure . opt)
- (let loop ((o opt))
- (when (pair? o)
- (cond
- ((or (not (keyword? (car o)))
- (null? (cdr o)))
- (error 'skribe-enforce-configure
- "Illegal enforcement"
- opt))
- ((skribe-configure (car o) (cadr o))
- (loop (cddr o)))
- (else
- (error 'skribe-enforce-configure
- (format "Configuration mismatch: ~a" (car o))
- (if (procedure? (cadr o))
- (format "provided `~a'"
- (skribe-configure (car o)))
- (format "provided `~a', required `~a'"
- (skribe-configure (car o))
- (cadr o)))))))))
diff --git a/src/bigloo/debug.sch b/src/bigloo/debug.sch
deleted file mode 100644
index 9b53c84..0000000
--- a/src/bigloo/debug.sch
+++ /dev/null
@@ -1,54 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/debug.sch */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Thu May 29 06:46:33 2003 */
-;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Simple debug facilities */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* directives */
-;*---------------------------------------------------------------------*/
-(directives
- (import skribe_debug))
-
-;*---------------------------------------------------------------------*/
-;* when-debug ... */
-;*---------------------------------------------------------------------*/
-(define-macro (when-debug level . exp)
- (if (and (number? *compiler-debug*) (> *compiler-debug* 0))
- `(if (>= *skribe-debug* ,level) (begin ,@exp))
- #unspecified))
-
-;*---------------------------------------------------------------------*/
-;* with-debug ... */
-;*---------------------------------------------------------------------*/
-(define-macro (with-debug level lbl . arg*)
- (if (and (number? *compiler-debug*) (> *compiler-debug* 0))
- `(%with-debug ,level ,lbl (lambda () (begin ,@arg*)))
- `(begin ,@arg*)))
-
-;*---------------------------------------------------------------------*/
-;* with-push-trace ... */
-;*---------------------------------------------------------------------*/
-(define-macro (with-push-trace lbl . arg*)
- (if (and (number? *compiler-debug*) (> *compiler-debug* 0))
- (let ((r (gensym)))
- `(let ()
- (c-push-trace ,lbl)
- (let ((,r ,@arg*))
- (c-pop-trace)
- ,r)))
- `(begin ,@arg*)))
-
-;*---------------------------------------------------------------------*/
-;* debug-item ... */
-;*---------------------------------------------------------------------*/
-(define-expander debug-item
- (lambda (x e)
- (if (and (number? *compiler-debug*) (> *compiler-debug* 0))
- `(debug-item ,@(map (lambda (x) (e x e)) (cdr x)))
- #unspecified)))
diff --git a/src/bigloo/debug.scm b/src/bigloo/debug.scm
deleted file mode 100644
index 8f1691c..0000000
--- a/src/bigloo/debug.scm
+++ /dev/null
@@ -1,188 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/debug.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jun 11 10:01:47 2003 */
-;* Last change : Thu Oct 28 21:33:00 2004 (eg) */
-;* Copyright : 2003 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Simple debug facilities */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_debug
-
- (export *skribe-debug*
- *skribe-debug-symbols*
- *skribe-debug-color*
-
- (skribe-debug::int)
- (debug-port::output-port . ::obj)
- (debug-margin::bstring)
- (debug-color::bstring ::int . ::obj)
- (debug-bold::bstring . ::obj)
- (debug-string ::obj)
- (debug-item . ::obj)
-
- (%with-debug ::obj ::obj ::procedure)))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-debug* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-debug* 0)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-debug-symbols* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-debug-symbols* '())
-
-;*---------------------------------------------------------------------*/
-;* *skribe-debug-color* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-debug-color* #t)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-debug-item* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-debug-item* #f)
-
-;*---------------------------------------------------------------------*/
-;* *debug-port* ... */
-;*---------------------------------------------------------------------*/
-(define *debug-port* (current-error-port))
-
-;*---------------------------------------------------------------------*/
-;* *debug-depth* ... */
-;*---------------------------------------------------------------------*/
-(define *debug-depth* 0)
-
-;*---------------------------------------------------------------------*/
-;* *debug-margin* ... */
-;*---------------------------------------------------------------------*/
-(define *debug-margin* "")
-
-;*---------------------------------------------------------------------*/
-;* *skribe-margin-debug-level* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-margin-debug-level* 0)
-
-;*---------------------------------------------------------------------*/
-;* skribe-debug ... */
-;*---------------------------------------------------------------------*/
-(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-margin ... */
-;*---------------------------------------------------------------------*/
-(define (debug-margin)
- *debug-margin*)
-
-;*---------------------------------------------------------------------*/
-;* debug-color ... */
-;*---------------------------------------------------------------------*/
-(define (debug-color col::int . o)
- (with-output-to-string
- (if *skribe-debug-color*
- (lambda ()
- (display* "[1;" (+ 31 col) "m")
- (apply display* o)
- (display ""))
- (lambda ()
- (apply 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 (-fx *debug-depth* 1) "- "))
- (for-each (lambda (a) (display a *debug-port*)) args)
- (newline *debug-port*))))
-
-;*---------------------------------------------------------------------*/
-;* %with-debug-margin ... */
-;*---------------------------------------------------------------------*/
-(define (%with-debug-margin margin thunk)
- (let ((om *debug-margin*))
- (set! *debug-depth* (+fx *debug-depth* 1))
- (set! *debug-margin* (string-append om margin))
- (let ((res (thunk)))
- (set! *debug-depth* (-fx *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)))
- (with-output-to-port *debug-port*
- (lambda ()
- (display (debug-margin))
- (display (if (= *debug-depth* 0)
- (debug-color *debug-depth* "+ " lbl)
- (debug-color *debug-depth* "--+ " lbl)))
- (newline)
- (%with-debug-margin (debug-color *debug-depth* " |")
- thunk)))
- (thunk))))
- (set! *skribe-debug-item* oi)
- (set! *skribe-margin-debug-level* ol)
- r)))
-
-;*---------------------------------------------------------------------*/
-;* debug-string ... */
-;*---------------------------------------------------------------------*/
-(define (debug-string o)
- (with-output-to-string
- (lambda ()
- (write o))))
-
-;*---------------------------------------------------------------------*/
-;* example */
-;*---------------------------------------------------------------------*/
-;; (%with-debug 0 'foo1.1
-;; (lambda ()
-;; (debug-item 'foo2.1)
-;; (debug-item 'foo2.2)
-;; (%with-debug 0 'foo2.3
-;; (lambda ()
-;; (debug-item 'foo3.1)
-;; (%with-debug 0 'foo3.2
-;; (lambda ()
-;; (debug-item 'foo4.1)
-;; (debug-item 'foo4.2)))
-;; (debug-item 'foo3.3)))
-;; (debug-item 'foo2.4)))
-
diff --git a/src/bigloo/engine.scm b/src/bigloo/engine.scm
deleted file mode 100644
index bd8a027..0000000
--- a/src/bigloo/engine.scm
+++ /dev/null
@@ -1,262 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/engine.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Sep 9 08:01:30 2003 */
-;* Last change : Fri May 21 16:12:32 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe engines */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_engine
-
- (option (set! dsssl-symbol->keyword
- (lambda (s)
- (string->keyword
- (string-append ":" (symbol->string s))))))
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_eval
- skribe_param
- skribe_output)
-
- (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if)
- (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st)
- (find-engine ::symbol #!key version)
-
- (default-engine::obj)
- (default-engine-set! ::%engine)
- (push-default-engine ::%engine)
- (pop-default-engine)
-
- (processor-get-engine ::obj ::obj ::%engine)
-
- (engine-format? ::bstring . e)
-
- (engine-custom::obj ::%engine ::symbol)
- (engine-custom-set! ::%engine ::symbol ::obj)
-
- (engine-add-writer! ::%engine ::obj ::procedure ::obj
- ::obj ::obj ::obj ::obj ::obj ::obj)))
-
-;*---------------------------------------------------------------------*/
-;* *engines* ... */
-;*---------------------------------------------------------------------*/
-(define *engines* '())
-
-;*---------------------------------------------------------------------*/
-;* *default-engine* ... */
-;*---------------------------------------------------------------------*/
-(define *default-engine* #f)
-(define *default-engines* '())
-
-;*---------------------------------------------------------------------*/
-;* default-engine-set! ... */
-;*---------------------------------------------------------------------*/
-(define (default-engine-set! e)
- (if (not (engine? e))
- (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e))
- (begin
- (set! *default-engine* e)
- (set! *default-engines* (cons *default-engine* *default-engines*))
- e)))
-
-;*---------------------------------------------------------------------*/
-;* default-engine ... */
-;*---------------------------------------------------------------------*/
-(define (default-engine)
- *default-engine*)
-
-;*---------------------------------------------------------------------*/
-;* push-default-engine ... */
-;*---------------------------------------------------------------------*/
-(define (push-default-engine e)
- (set! *default-engines* (cons e *default-engines*))
- (default-engine-set! e))
-
-;*---------------------------------------------------------------------*/
-;* pop-default-engine ... */
-;*---------------------------------------------------------------------*/
-(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)))))
-
-;*---------------------------------------------------------------------*/
-;* processor-get-engine ... */
-;*---------------------------------------------------------------------*/
-(define (processor-get-engine combinator newe olde)
- (cond
- ((procedure? combinator)
- (combinator newe olde))
- ((engine? newe)
- newe)
- (else
- olde)))
-
-;*---------------------------------------------------------------------*/
-;* engine-format? ... */
-;*---------------------------------------------------------------------*/
-(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 (instantiate::%engine
- (ident ident)
- (version version)
- (format format)
- (filter filter)
- (delegate delegate)
- (symbol-table symbol-table)
- (customs 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 ((e (duplicate::%engine e
- (ident ident)
- (version version)
- (filter (or filter (%engine-filter e)))
- (delegate (or delegate (%engine-delegate e)))
- (symbol-table (or symbol-table (%engine-symbol-table e)))
- (customs (or custom (%engine-customs e))))))
- (set! *engines* (cons e *engines*))
- e))
-
-;*---------------------------------------------------------------------*/
-;* find-loaded-engine ... */
-;*---------------------------------------------------------------------*/
-(define (find-loaded-engine id version)
- (let loop ((es *engines*))
- (cond
- ((null? es)
- #f)
- ((eq? (%engine-ident (car es)) id)
- (cond
- ((eq? version #unspecified)
- (car es))
- ((eq? version (%engine-version (car es)))
- (car es))
- (else
- (loop (cdr es)))))
- (else
- (loop (cdr es))))))
-
-;*---------------------------------------------------------------------*/
-;* find-engine ... */
-;*---------------------------------------------------------------------*/
-(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 (pair? c) (string? (cdr c)))
- (begin
- (skribe-load (cdr c) :engine 'base)
- (find-loaded-engine id version))
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* engine-custom ... */
-;*---------------------------------------------------------------------*/
-(define (engine-custom e id)
- (with-access::%engine e (customs)
- (let ((c (assq id customs)))
- (if (pair? c)
- (cadr c)
- #unspecified))))
-
-;*---------------------------------------------------------------------*/
-;* engine-custom-set! ... */
-;*---------------------------------------------------------------------*/
-(define (engine-custom-set! e id val)
- (with-access::%engine e (customs)
- (let ((c (assq id customs)))
- (if (pair? c)
- (set-car! (cdr c) val)
- (set! customs (cons (list id val) customs))))))
-
-;*---------------------------------------------------------------------*/
-;* engine-add-writer! ... */
-;*---------------------------------------------------------------------*/
-(define (engine-add-writer! e id pred upred opt before action after class va)
- ;; check the arity of a procedure
- (define (check-procedure name proc arity)
- (cond
- ((not (procedure? proc))
- (skribe-error id "Illegal procedure" proc))
- ((not (correct-arity? proc arity))
- (skribe-error id
- (string-append "Illegal `" name "'procedure")
- proc))))
- (define (check-output name proc)
- (and proc (or (string? proc) (check-procedure name proc 2))))
- ;; check the engine
- (if (not (engine? e))
- (skribe-error id "Illegal engine" e))
- ;; check the options
- (if (not (or (eq? opt 'all) (list? opt)))
- (skribe-error id "Illegal options" opt))
- ;; check the correctness of the predicate and the validator
- (check-procedure "predicate" pred 2)
- (when va (check-procedure "validate" va 2))
- ;; check the correctness of the three actions
- (check-output "before" before)
- (check-output "action" action)
- (check-output "after" after)
- ;; create a new writer...
- (let ((n (instantiate::%writer
- (ident (if (symbol? id) id 'all))
- (class class)
- (pred pred)
- (upred upred)
- (options opt)
- (before before)
- (action action)
- (after after)
- (validate va))))
- ;; ...and bind it
- (with-access::%engine e (writers)
- (set! writers (cons n writers))
- n)))
diff --git a/src/bigloo/eval.scm b/src/bigloo/eval.scm
deleted file mode 100644
index b5c6548..0000000
--- a/src/bigloo/eval.scm
+++ /dev/null
@@ -1,335 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/eval.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 12:48:11 2003 */
-;* Last change : Wed May 18 15:52:01 2005 (serrano) */
-;* Copyright : 2003-05 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe evaluator */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_eval
-
- (option (set! dsssl-symbol->keyword
- (lambda (s)
- (string->keyword
- (string-append ":" (symbol->string s))))))
-
- (include "debug.sch")
-
- (import skribe_param
- skribe_types
- skribe_resolve
- skribe_verify
- skribe_output
- skribe_read
- skribe_lib
- skribe_engine)
-
- (export (skribe-eval-location)
- (skribe-error ::obj ::obj ::obj)
- (skribe-type-error ::obj ::obj ::obj ::bstring)
- (skribe-warning ::int . obj)
- (skribe-warning/ast ::int ::%ast . obj)
- (skribe-message ::bstring . obj)
- (skribe-load ::bstring #!rest opt #!key engine path)
- (skribe-load-options)
- (skribe-include ::bstring . rest)
- (skribe-open-bib-file ::bstring ::obj)
- (skribe-eval-port ::input-port ::obj #!key env)
- (skribe-eval ::obj ::%engine #!key env)
- (skribe-path::pair-nil)
- (skribe-path-set! ::obj)
- (skribe-image-path::pair-nil)
- (skribe-image-path-set! ::obj)
- (skribe-bib-path::pair-nil)
- (skribe-bib-path-set! ::obj)
- (skribe-source-path::pair-nil)
- (skribe-source-path-set! ::obj)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-eval-location ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-eval-location)
- (evmeaning-location))
-
-;*---------------------------------------------------------------------*/
-;* skribe-error ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-error proc msg obj)
- (if (ast? obj)
- (skribe-ast-error proc msg obj)
- (error/evloc proc msg obj)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-type-error ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-type-error proc msg obj etype)
- (let ((ty (if (%markup? obj)
- (format "~a#~a" (markup-markup obj) (markup-ident obj))
- (find-runtime-type obj))))
- (skribe-error proc
- (bigloo-type-error-msg msg etype ty)
- obj)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-ast-error ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-ast-error proc msg obj)
- (let ((l (ast-loc obj))
- (shape (if (%markup? obj)
- (%markup-markup obj)
- (find-runtime-type obj))))
- (if (location? l)
- (error/location proc msg shape (location-file l) (location-pos l))
- (error/evloc proc msg shape))))
-
-;*---------------------------------------------------------------------*/
-;* error/evloc ... */
-;*---------------------------------------------------------------------*/
-(define (error/evloc proc msg obj)
- (let ((l (evmeaning-location)))
- (if (location? l)
- (error/location proc msg obj (location-file l) (location-pos l))
- ((begin error) proc msg obj))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-warning ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-warning level . obj)
- (if (>= *skribe-warning* level)
- (let ((l (evmeaning-location)))
- (if (location? l)
- (apply warning/location (location-file l) (location-pos l) obj)
- (apply warning obj)))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-warning/ast ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-warning/ast level ast . obj)
- (if (>= *skribe-warning* level)
- (let ((l (%ast-loc ast)))
- (if (location? l)
- (apply warning/location (location-file l) (location-pos l) obj)
- (apply skribe-warning level obj)))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-message ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-message fmt . obj)
- (if (> *skribe-verbose* 0)
- (apply fprintf (current-error-port) fmt obj)))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-loaded* ... */
-;* ------------------------------------------------------------- */
-;* This hash table stores the list of loaded files in order */
-;* to avoid one file to be loaded twice. */
-;*---------------------------------------------------------------------*/
-(define *skribe-loaded* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-load-options* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-load-options* '())
-
-;*---------------------------------------------------------------------*/
-;* skribe-load ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-load file #!rest opt #!key engine path)
- (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-file/path file path)))
- (set! *skribe-load-options* opt)
- (if (and (string? filep) (file-exists? filep))
- (if (not (hashtable-get *skribe-loaded* filep))
- (begin
- (hashtable-put! *skribe-loaded* filep #t)
- (cond
- ((>fx *skribe-verbose* 1)
- (fprint (current-error-port)
- " [loading file: " filep " " opt "]"))
- ((>fx *skribe-verbose* 0)
- (fprint (current-error-port)
- " [loading file: " filep "]")))
- (with-input-from-file filep
- (lambda ()
- (skribe-eval-port (current-input-port) ei)))))
- (skribe-error 'skribe-load
- (format "Can't find file `~a' in path" file)
- path)))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-load-options ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-load-options)
- *skribe-load-options*)
-
-;*---------------------------------------------------------------------*/
-;* evaluate ... */
-;*---------------------------------------------------------------------*/
-(define (evaluate exp)
- (try (eval exp)
- (lambda (a p m o)
- (evmeaning-notify-error p m o)
- (flush-output-port (current-error-port)))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-include ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-include file . rest)
- (let* ((path (cond
- ((or (null? rest) (null? (cdr rest)))
- (skribe-path))
- ((not (every? string? (cdr rest)))
- (skribe-error 'skribe-include "Illegal path" (cdr rest)))
- (else
- (cdr rest))))
- (filep (find-file/path file (if (null? path) (skribe-path) path))))
- (if (and (string? filep) (file-exists? filep))
- (begin
- (if (>fx *skribe-verbose* 0)
- (fprint (current-error-port)
- " [including file: " filep "]"))
- (with-input-from-file filep
- (lambda ()
- (let loop ((exp (skribe-read (current-input-port)))
- (res '()))
- (if (eof-object? exp)
- (if (and (pair? res) (null? (cdr res)))
- (car res)
- (reverse! res))
- (loop (skribe-read (current-input-port))
- (cons (evaluate exp) res)))))))
- (skribe-error 'skribe-include
- (format "Can't find file `~a 'in path" file)
- path))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-open-bib-file ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-open-bib-file file command)
- (let ((filep (find-file/path file *skribe-bib-path*)))
- (if (string? filep)
- (begin
- (if (>fx *skribe-verbose* 0)
- (fprint (current-error-port) " [loading bib: " filep "]"))
- (open-input-file (if (string? command)
- (string-append "| "
- (format command filep))
- filep)))
- (begin
- (skribe-warning 1
- 'bibliography
- "Can't find bibliography -- " file)
- #f))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-eval-port ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-eval-port port ei #!key (env '()))
- (with-debug 2 'skribe-eval-port
- (debug-item "ei=" ei)
- (let ((e (if (symbol? ei) (find-engine ei) ei)))
- (debug-item "e=" e)
- (if (not (%engine? e))
- (skribe-error 'find-engine "Can't find engine" ei)
- (let loop ((exp (skribe-read port)))
- (with-debug 10 'skribe-eval-port
- (debug-item "exp=" exp))
- (if (not (eof-object? exp))
- (begin
- (skribe-eval (evaluate exp) e :env env)
- (loop (skribe-read port)))))))))
-
-;*---------------------------------------------------------------------*/
-;* 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-path ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-path)
- *skribe-path*)
-
-;*---------------------------------------------------------------------*/
-;* skribe-path-set! ... */
-;*---------------------------------------------------------------------*/
-(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*)
-
-;*---------------------------------------------------------------------*/
-;* skribe-image-path-set! ... */
-;*---------------------------------------------------------------------*/
-(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*)
-
-;*---------------------------------------------------------------------*/
-;* skribe-bib-path-set! ... */
-;*---------------------------------------------------------------------*/
-(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)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-source-path ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-source-path)
- *skribe-source-path*)
-
-;*---------------------------------------------------------------------*/
-;* skribe-source-path-set! ... */
-;*---------------------------------------------------------------------*/
-(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)))
diff --git a/src/bigloo/evapi.scm b/src/bigloo/evapi.scm
deleted file mode 100644
index 6f0d49e..0000000
--- a/src/bigloo/evapi.scm
+++ /dev/null
@@ -1,39 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 18:57:09 2003 */
-;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Bigloo eval declarations */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_evapi
- (import skribe_types
- skribe_lib
- skribe_api
- skribe_engine
- skribe_writer
- skribe_output
- skribe_eval
- skribe_read
- skribe_resolve
- skribe_param
- skribe_source
- skribe_index
- skribe_configure
- skribe_lisp
- skribe_xml
- skribe_c
- skribe_asm
- skribe_bib
- skribe_color
- skribe_sui
- skribe_debug)
- (eval (export-all)))
-
-
diff --git a/src/bigloo/index.bgl b/src/bigloo/index.bgl
deleted file mode 100644
index 9697981..0000000
--- a/src/bigloo/index.bgl
+++ /dev/null
@@ -1,32 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/index.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Sun Aug 24 08:01:45 2003 */
-;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe indexes Bigloo module declaration */
-;* ------------------------------------------------------------- */
-;* Implementation: @label index@ */
-;* bigloo: @path ../common/index.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_index
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api)
-
- (export (index?::bool ::obj)
- (default-index)
- (make-index-table ::bstring)
- (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int)))
-
diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl
deleted file mode 100644
index 6dd6d37..0000000
--- a/src/bigloo/lib.bgl
+++ /dev/null
@@ -1,340 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 12:48:11 2003 */
-;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe runtime (i.e., the style user functions). */
-;* ------------------------------------------------------------- */
-;* Implementation: @label lib@ */
-;* bigloo: @path ../common/lib.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_lib
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_eval
- skribe_param
- skribe_output
- skribe_engine)
-
- (export (markup-option ::%markup ::obj)
- (markup-option-add! ::%markup ::obj ::obj)
- (markup-class ::%markup)
-
- (container-env-get ::%container ::symbol)
- (container-search-down::pair-nil ::procedure ::%container)
- (search-down::pair-nil ::procedure ::obj)
-
- (find-markup-ident::pair-nil ::bstring)
-
- (find-down::pair-nil ::procedure ::obj)
- (find1-down::obj ::procedure ::obj)
- (find-up::pair-nil ::procedure ::obj)
- (find1-up::obj ::procedure ::obj)
-
- (ast-document ::%ast)
- (ast-chapter ::%ast)
- (ast-section ::%ast)
-
- (the-body ::pair-nil)
- (the-options ::pair-nil . rest)
-
- (list-split::pair-nil ::pair-nil ::int . ::obj)
-
- (generic ast->string::bstring ::obj)
-
- (strip-ref-base ::bstring)
- (ast->file-location ::%ast)
-
- (convert-image ::bstring ::pair-nil)
-
- (make-string-replace ::pair-nil)
- (string-canonicalize::bstring ::bstring)
- (inline unspecified?::bool ::obj)))
-
-;*---------------------------------------------------------------------*/
-;* markup-option ... */
-;*---------------------------------------------------------------------*/
-(define (markup-option m opt)
- (if (%markup? m)
- (with-access::%markup m (options)
- (let ((c (assq opt options)))
- (and (pair? c) (pair? (cdr c)) (cadr c))))
- (skribe-type-error 'markup-option "Illegal markup:" m "markup")))
-
-;*---------------------------------------------------------------------*/
-;* markup-option-add! ... */
-;*---------------------------------------------------------------------*/
-(define (markup-option-add! m opt val)
- (if (%markup? m)
- (with-access::%markup m (options)
- (set! options (cons (list opt val) options)))
- (skribe-type-error 'markup-option "Illegal markup:" m "markup")))
-
-;*---------------------------------------------------------------------*/
-;* markup-class ... */
-;*---------------------------------------------------------------------*/
-(define (markup-class m)
- (%markup-class m))
-
-;*---------------------------------------------------------------------*/
-;* container-env-get ... */
-;*---------------------------------------------------------------------*/
-(define (container-env-get m key)
- (with-access::%container m (env)
- (let ((c (assq key env)))
- (and (pair? c) (cadr c)))))
-
-;*---------------------------------------------------------------------*/
-;* strip-ref-base ... */
-;*---------------------------------------------------------------------*/
-(define (strip-ref-base file)
- (if (not (string? *skribe-ref-base*))
- file
- (let ((l (string-length *skribe-ref-base*)))
- (cond
- ((not (>fx (string-length file) (+fx l 2)))
- file)
- ((not (substring=? file *skribe-ref-base* l))
- file)
- ((not (char=? (string-ref file l) (file-separator)))
- file)
- (else
- (substring file (+fx l 1) (string-length file)))))))
-
-;*---------------------------------------------------------------------*/
-;* ast->file-location ... */
-;*---------------------------------------------------------------------*/
-(define (ast->file-location ast)
- (let ((l (ast-loc ast)))
- (if (location? l)
- (format "~a:~a" (location-file l) (location-pos l))
- "")))
-
-;*---------------------------------------------------------------------*/
-;* builtin-convert-image ... */
-;*---------------------------------------------------------------------*/
-(define (builtin-convert-image from fmt dir)
- (let* ((s (suffix from))
- (f (string-append (prefix (basename from)) "." fmt))
- (to (make-file-name dir f)))
- (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
- ((>fx *skribe-verbose* 1)
- (fprint (current-error-port)
- " [converting image: " from " (" c ")]"))
- ((>fx *skribe-verbose* 0)
- (fprint (current-error-port)
- " [converting image: " from "]")))
- (if (=fx (system c) 0) to #f))))))
-
-;*---------------------------------------------------------------------*/
-;* convert-image ... */
-;*---------------------------------------------------------------------*/
-(define (convert-image file formats)
- (let ((path (find-file/path file (skribe-image-path))))
- (if (not (string? path))
- (skribe-error '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-file-name 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)))))))))))
-
-;*---------------------------------------------------------------------*/
-;* html-string ... */
-;*---------------------------------------------------------------------*/
-(define (html-string str)
- (let ((len (string-length str)))
- (let loop ((r 0)
- (nlen len))
- (if (=fx r len)
- (if (=fx nlen len)
- str
- (let ((res (make-string nlen)))
- (let loop ((r 0)
- (w 0))
- (if (=fx w nlen)
- res
- (let ((c (string-ref-ur str r)))
- (case c
- ((#\<)
- (blit-string! "&lt;" 0 res w 4)
- (loop (+fx r 1) (+fx w 4)))
- ((#\>)
- (blit-string! "&gt;" 0 res w 4)
- (loop (+fx r 1) (+fx w 4)))
- ((#\&)
- (blit-string! "&amp;" 0 res w 5)
- (loop (+fx r 1) (+fx w 5)))
- ((#\")
- (blit-string! "&quot;" 0 res w 6)
- (loop (+fx r 1) (+fx w 6)))
- (else
- (string-set! res w c)
- (loop (+fx r 1) (+fx w 1)))))))))
- (case (string-ref-ur str r)
- ((#\< #\>)
- (loop (+fx r 1) (+fx nlen 3)))
- ((#\&)
- (loop (+fx r 1) (+fx nlen 4)))
- ((#\")
- (loop (+fx r 1) (+fx nlen 5)))
- (else
- (loop (+fx r 1) nlen)))))))
-
-;*---------------------------------------------------------------------*/
-;* make-generic-string-replace ... */
-;*---------------------------------------------------------------------*/
-(define (make-generic-string-replace lst)
- (lambda (str)
- (let ((len (string-length str)))
- (let loop ((r 0)
- (nlen len))
- (if (=fx r len)
- (let ((res (make-string nlen)))
- (let loop ((r 0)
- (w 0))
- (if (=fx w nlen)
- res
- (let* ((c (string-ref-ur str r))
- (p (assq c lst)))
- (if (pair? p)
- (let ((pl (string-length (cadr p))))
- (blit-string! (cadr p) 0 res w pl)
- (loop (+fx r 1) (+fx w pl)))
- (begin
- (string-set! res w c)
- (loop (+fx r 1) (+fx w 1))))))))
- (let* ((c (string-ref-ur str r))
- (p (assq c lst)))
- (if (pair? p)
- (loop (+fx r 1)
- (+fx nlen (-fx (string-length (cadr p)) 1)))
- (loop (+fx r 1)
- nlen))))))))
-
-;*---------------------------------------------------------------------*/
-;* make-string-replace ... */
-;*---------------------------------------------------------------------*/
-(define (make-string-replace lst)
- (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
- (cond
- ((equal? l '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
- html-string)
- (else
- (make-generic-string-replace lst)))))
-
-;*---------------------------------------------------------------------*/
-;* ast->string ... */
-;*---------------------------------------------------------------------*/
-(define-generic (ast->string ast)
- (cond
- ((string? ast)
- ast)
- ((number? ast)
- (number->string ast))
- ((pair? ast)
- (let* ((t (map ast->string ast))
- (res (make-string
- (apply + -1 (length t) (map string-length t))
- #\space)))
- (let loop ((t t)
- (w 0))
- (if (null? t)
- res
- (let ((l (string-length (car t))))
- (blit-string! (car t) 0 res w l)
- (loop (cdr t) (+ w l 1)))))))
- (else
- "")))
-
-;*---------------------------------------------------------------------*/
-;* ast->string ::%node ... */
-;*---------------------------------------------------------------------*/
-(define-method (ast->string ast::%node)
- (ast->string (%node-body ast)))
-
-;*---------------------------------------------------------------------*/
-;* string-canonicalize ... */
-;*---------------------------------------------------------------------*/
-(define (string-canonicalize old)
- (let* ((l (string-length old))
- (new (make-string l)))
- (let loop ((r 0)
- (w 0)
- (s #f))
- (cond
- ((=fx r l)
- (cond
- ((=fx w 0)
- "")
- ((char-whitespace? (string-ref new (-fx w 1)))
- (substring new 0 (-fx w 1)))
- ((=fx w r)
- new)
- (else
- (substring new 0 w))))
- ((char-whitespace? (string-ref old r))
- (if s
- (loop (+fx r 1) w #t)
- (begin
- (string-set! new w #\-)
- (loop (+fx r 1) (+fx w 1) #t))))
- ((or (char=? (string-ref old r) #\#)
- (char=? (string-ref old r) #\,)
- (>= (char->integer (string-ref old r)) #x7f))
- (string-set! new w #\-)
- (loop (+fx r 1) (+fx w 1) #t))
- (else
- (string-set! new w (string-ref old r))
- (loop (+fx r 1) (+fx w 1) #f))))))
-
-;*---------------------------------------------------------------------*/
-;* unspecified? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (unspecified? obj)
- (eq? obj #unspecified))
-
-;*---------------------------------------------------------------------*/
-;* base */
-;* ------------------------------------------------------------- */
-;* 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/bigloo/lisp.scm b/src/bigloo/lisp.scm
deleted file mode 100644
index 65a8227..0000000
--- a/src/bigloo/lisp.scm
+++ /dev/null
@@ -1,530 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Aug 29 08:14:59 2003 */
-;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Handling of lispish source files. */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_lisp
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api
- skribe_param
- skribe_source)
-
- (export bigloo
- scheme
- lisp
- skribe))
-
-;*---------------------------------------------------------------------*/
-;* keys ... */
-;*---------------------------------------------------------------------*/
-(define *the-key* #f)
-(define *bracket-highlight* #t)
-(define *bigloo-key* #f)
-(define *scheme-key* #f)
-(define *lisp-key* #f)
-(define *skribe-key* #f)
-
-;*---------------------------------------------------------------------*/
-;* init-bigloo-fontifier! ... */
-;*---------------------------------------------------------------------*/
-(define (init-bigloo-fontifier!)
- (if (not *bigloo-key*)
- (begin
- (set! *bigloo-key* (gensym))
- ;; language keywords
- (for-each (lambda (symbol)
- (putprop! symbol *bigloo-key* 'symbol))
- '(set! if let cond case quote begin letrec let*
- lambda export extern class generic inline
- static import foreign type with-access instantiate
- duplicate labels
- match-case match-lambda
- syntax-rules pragma widen! shrink!
- wide-class profile profile/gc
- regular-grammar lalr-grammar apply))
- ;; define
- (for-each (lambda (symbol)
- (putprop! symbol *bigloo-key* 'define))
- '(define define-inline define-struct define-macro
- define-generic define-method define-syntax
- define-expander))
- ;; error
- (for-each (lambda (symbol)
- (putprop! symbol *bigloo-key* 'error))
- '(bind-exit unwind-protect call/cc error warning))
- ;; module
- (for-each (lambda (symbol)
- (putprop! symbol *bigloo-key* 'module))
- '(module import export library))
- ;; thread
- (for-each (lambda (symbol)
- (putprop! symbol *bigloo-key* 'thread))
- '(make-thread thread-start! thread-yield!
- thread-await! thread-await*!
- thread-sleep! thread-join!
- thread-terminate! thread-suspend!
- thread-resume! thread-yield!
- thread-specific thread-specific-set!
- thread-name thread-name-set!
- scheduler-react! scheduler-start!
- broadcast! scheduler-broadcast!
- current-thread thread?
- current-scheduler scheduler? make-scheduler
- make-input-signal make-output-signal
- make-connect-signal make-process-signal
- make-accept-signal make-timer-signal
- thread-get-values! thread-get-values*!)))))
-
-;*---------------------------------------------------------------------*/
-;* init-lisp-fontifier! ... */
-;*---------------------------------------------------------------------*/
-(define (init-lisp-fontifier!)
- (if (not *lisp-key*)
- (begin
- (set! *lisp-key* (gensym))
- ;; language keywords
- (for-each (lambda (symbol)
- (putprop! symbol *lisp-key* 'symbol))
- '(setq if let cond case else progn letrec let*
- lambda labels try unwind-protect apply funcall))
- ;; defun
- (for-each (lambda (symbol)
- (putprop! symbol *lisp-key* 'define))
- '(define defun defvar defmacro)))))
-
-;*---------------------------------------------------------------------*/
-;* init-skribe-fontifier! ... */
-;*---------------------------------------------------------------------*/
-(define (init-skribe-fontifier!)
- (if (not *skribe-key*)
- (begin
- (set! *skribe-key* (gensym))
- ;; language keywords
- (for-each (lambda (symbol)
- (putprop! symbol *skribe-key* 'symbol))
- '(set! bold it emph tt color ref index underline
- 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 lambda))
- ;; define
- (for-each (lambda (symbol)
- (putprop! symbol *skribe-key* 'define))
- '(define define-markup))
- ;; markup
- (for-each (lambda (symbol)
- (putprop! symbol *skribe-key* 'markup))
- '(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)))))
-
-;*---------------------------------------------------------------------*/
-;* bigloo ... */
-;*---------------------------------------------------------------------*/
-(define bigloo
- (new language
- (name "bigloo")
- (fontifier bigloo-fontifier)
- (extractor bigloo-extractor)))
-
-;*---------------------------------------------------------------------*/
-;* scheme ... */
-;*---------------------------------------------------------------------*/
-(define scheme
- (new language
- (name "scheme")
- (fontifier scheme-fontifier)
- (extractor scheme-extractor)))
-
-;*---------------------------------------------------------------------*/
-;* lisp ... */
-;*---------------------------------------------------------------------*/
-(define lisp
- (new language
- (name "lisp")
- (fontifier lisp-fontifier)
- (extractor lisp-extractor)))
-
-;*---------------------------------------------------------------------*/
-;* bigloo-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (bigloo-fontifier s)
- (init-bigloo-fontifier!)
- (set! *the-key* *bigloo-key*)
- (set! *bracket-highlight* #f)
- (fontify-lisp (open-input-string s)))
-
-;*---------------------------------------------------------------------*/
-;* bigloo-extractor ... */
-;*---------------------------------------------------------------------*/
-(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 . ?-) . ?-)
- (eq? def fun))
- (((or define define-struct define-library) (and (? symbol?) ?var) . ?-)
- (eq? var def))
- (else
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* skribe ... */
-;*---------------------------------------------------------------------*/
-(define skribe
- (new language
- (name "skribe")
- (fontifier skribe-fontifier)
- (extractor skribe-extractor)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-fontifier s)
- (init-skribe-fontifier!)
- (set! *the-key* *skribe-key*)
- (set! *bracket-highlight* #t)
- (fontify-lisp (open-input-string s)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-extractor ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-extractor iport def tab)
- (definition-search iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-macro define-markup) (?fun . ?-) . ?-)
- (eq? def fun))
- ((define (and (? symbol?) ?var) . ?-)
- (eq? var def))
- ((markup-output (quote ?mk) . ?-)
- (eq? mk def))
- (else
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* scheme-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (scheme-fontifier s) s)
-
-;*---------------------------------------------------------------------*/
-;* scheme-extractor ... */
-;*---------------------------------------------------------------------*/
-(define (scheme-extractor iport def tab)
- (definition-search iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-macro) (?fun . ?-) . ?-)
- (eq? def fun))
- ((define (and (? symbol?) ?var) . ?-)
- (eq? var def))
- (else
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* lisp-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (lisp-fontifier s)
- (init-lisp-fontifier!)
- (set! *the-key* *lisp-key*)
- (set! *bracket-highlight* #f)
- (fontify-lisp (open-input-string s)))
-
-;*---------------------------------------------------------------------*/
-;* lisp-extractor ... */
-;*---------------------------------------------------------------------*/
-(define (lisp-extractor iport def tab)
- (definition-search iport
- tab
- (lambda (exp)
- (match-case exp
- (((or defun defmacro) ?fun ?- . ?-)
- (eq? def fun))
- ((defvar ?var . ?-)
- (eq? var def))
- (else
- #f)))))
-
-;*---------------------------------------------------------------------*/
-;* definition-search ... */
-;* ------------------------------------------------------------- */
-;* This function seeks a Bigloo definition. If it finds it, it */
-;* returns two values the starting char number of the definition */
-;* and the stop char. */
-;*---------------------------------------------------------------------*/
-(define (definition-search ip tab semipred)
- (cond-expand
- (bigloo2.6
- (define (reader-current-line-number)
- (let* ((port (open-input-string "(9)"))
- (exp (read port #t)))
- (close-input-port port)
- (line-number exp)))
- (define (line-number expr)
- (and (epair? expr)
- (match-case (cer expr)
- ((at ?- ?pos ?line)
- line))))
- (reader-reset!)
- (let loop ((exp (read ip #t)))
- (if (not (eof-object? exp))
- (let ((v (semipred exp)))
- (if (not v)
- (loop (read ip #t))
- (let* ((b (line-number exp))
- (e (reader-current-line-number)))
- (source-read-lines (input-port-name ip) b e tab)))))))
- (else
- (define (char-number expr)
- (and (epair? expr)
- (match-case (cer expr)
- ((at ?- ?pos)
- pos))))
- (let loop ((exp (read ip #t)))
- (if (not (eof-object? exp))
- (let ((v (semipred exp)))
- (if (not v)
- (loop (read ip #t))
- (let* ((b (char-number exp))
- (e (input-port-position ip)))
- (source-read-chars (input-port-name ip)
- b
- e
- tab)))))))))
-
-
-;*---------------------------------------------------------------------*/
-;* fontify-lisp ... */
-;*---------------------------------------------------------------------*/
-(define (fontify-lisp port::input-port)
- (let ((g (regular-grammar ()
- ((: ";;" (* all))
- ;; italic comments
- (let ((c (new markup
- (markup '&source-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((: ";*" (* all))
- ;; bold comments
- (let ((c (new markup
- (markup '&source-line-comment)
- (body (the-string)))))
- (cons c (ignore))))
- ((: ";" (out #\; #\*) (* all))
- ;; plain comments
- (let ((str (the-string)))
- (cons str (ignore))))
- ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all))
- ;; plain comments
- (let ((str (the-substring 1 (the-length))))
- (cons str (ignore))))
- ((+ #\Space)
- ;; separators
- (let ((str (the-string)))
- (cons (highlight str) (ignore))))
- (#\(
- ;; open parenthesis
- (let ((str (highlight (the-string))))
- (pupush-highlight)
- (cons str (ignore))))
- (#\)
- ;; close parenthesis
- (let ((str (highlight (the-string) -1)))
- (cons str (ignore))))
- ((+ (in "[]"))
- ;; brackets
- (let ((s (the-string)))
- (if *bracket-highlight*
- (let ((c (new markup
- (markup '&source-bracket)
- (body s))))
- (cons c (ignore)))
- (cons s (ignore)))))
- ((+ #\Tab)
- (let ((str (the-string)))
- (cons (highlight str) (ignore))))
- ((: #\( (+ (out "; \t()[]:\"\n")))
- ;; keywords
- (let* ((string (the-substring 1 (the-length)))
- (symbol (string->symbol string))
- (key (getprop symbol *the-key*)))
- (cons
- "("
- (case key
- ((symbol)
- (let ((c (new markup
- (markup '&source-keyword)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- ((define)
- (let ((c (new markup
- (markup '&source-define)
- (body string))))
- (push-highlight (lambda (e)
- (new markup
- (markup '&source-define)
- (ident (symbol->string (gensym)))
- (body e)))
- 1)
- (cons c (ignore))))
- ((error)
- (let ((c (new markup
- (markup '&source-error)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- ((module)
- (let ((c (new markup
- (markup '&source-module)
- (ident (symbol->string (gensym)))
- (body string))))
- (push-highlight (lambda (e)
- (new markup
- (markup '&source-module)
- (ident (symbol->string (gensym)))
- (body e)))
- 1)
- (cons c (ignore))))
- ((markup)
- (let ((c (new markup
- (markup '&source-markup)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- ((thread)
- (let ((c (new markup
- (markup '&source-thread)
- (ident (symbol->string (gensym)))
- (body string))))
- (cons c (ignore))))
- (else
- (cons (highlight string 1) (ignore)))))))
- ((+ (out "; \t()[]:\"\n"))
- (let ((string (the-string)))
- (cons (highlight string 1) (ignore))))
- ((+ #\Newline)
- ;; newline
- (let ((str (the-string)))
- (cons (highlight str) (ignore))))
- ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\""))
- ;; strings
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-string)
- (ident (symbol->string (gensym)))
- (body s))))
- str)
- (ignore))))
- ((: "::" (+ (out ";\n \t()[]:\"")))
- ;; type annotations
- (let ((c (new markup
- (markup '&source-type)
- (ident (symbol->string (gensym)))
- (body (the-string)))))
- (cons c (ignore))))
- ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\"")))
- ;; keywords annotations
- (let ((c (new markup
- (markup '&source-key)
- (ident (symbol->string (gensym)))
- (body (the-string)))))
- (cons c (ignore))))
- ((+ (or #\: #\; #\"))
- (let ((str (the-string)))
- (cons (highlight str 1) (ignore))))
- ((: #\# #\\ (+ (out " \n\t")))
- ;; characters
- (let ((str (the-string)))
- (cons (highlight str 1) (ignore))))
- (else
- (let ((c (the-failure)))
- (if (eof-object? c)
- '()
- (error "source(lisp)" "Unexpected character" c)))))))
- (reset-highlight!)
- (read/rp g port)))
-
-;*---------------------------------------------------------------------*/
-;* *highlight* ... */
-;*---------------------------------------------------------------------*/
-(define *highlight* '())
-
-;*---------------------------------------------------------------------*/
-;* reset-highlight! ... */
-;*---------------------------------------------------------------------*/
-(define (reset-highlight!)
- (set! *highlight* '()))
-
-;*---------------------------------------------------------------------*/
-;* push-highlight ... */
-;*---------------------------------------------------------------------*/
-(define (push-highlight col pv)
- (set! *highlight* (cons (cons col pv) *highlight*)))
-
-;*---------------------------------------------------------------------*/
-;* pupush-highlight ... */
-;*---------------------------------------------------------------------*/
-(define (pupush-highlight)
- (if (pair? *highlight*)
- (let ((c (car *highlight*)))
- (set-cdr! c 100000))))
-
-;*---------------------------------------------------------------------*/
-;* pop-highlight ... */
-;*---------------------------------------------------------------------*/
-(define (pop-highlight pv)
- (case pv
- ((-1)
- (set! *highlight* (cdr *highlight*)))
- ((0)
- 'nop)
- (else
- (let ((c (car *highlight*)))
- (if (>fx (cdr c) 1)
- (set-cdr! c (-fx (cdr c) 1))
- (set! *highlight* (cdr *highlight*)))))))
-
-;*---------------------------------------------------------------------*/
-;* highlight ... */
-;*---------------------------------------------------------------------*/
-(define (highlight exp . pop)
- (if (pair? *highlight*)
- (let* ((c (car *highlight*))
- (r (if (>fx (cdr c) 0)
- ((car c) exp)
- exp)))
- (if (pair? pop) (pop-highlight (car pop)))
- r)
- exp))
-
-
diff --git a/src/bigloo/main.scm b/src/bigloo/main.scm
deleted file mode 100644
index 5b9e5e5..0000000
--- a/src/bigloo/main.scm
+++ /dev/null
@@ -1,96 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/main.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Jul 22 16:51:49 2003 */
-;* Last change : Wed May 18 15:45:27 2005 (serrano) */
-;* Copyright : 2003-05 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe main entry point */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_main
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_parse-args
- skribe_param
- skribe_lib
- skribe_eval
- skribe_read
- skribe_engine
- skribe_evapi)
-
- (main main))
-
-;*---------------------------------------------------------------------*/
-;* main ... */
-;*---------------------------------------------------------------------*/
-(define (main args)
- (with-debug 2 'main
- (debug-item "parse env variables...")
- (parse-env-variables)
-
- (debug-item "load rc file...")
- (load-rc)
-
- (debug-item "parse command line...")
- (parse-args args)
-
- (debug-item "load base...")
- (skribe-load "base.skr" :engine 'base)
-
- (debug-item "preload... (" *skribe-engine* ")")
- (for-each (lambda (f)
- (skribe-load f :engine *skribe-engine*))
- *skribe-preload*)
-
- ;; Load the specified variants
- (debug-item "variant... (" *skribe-variants* ")")
- (for-each (lambda (x)
- (skribe-load (format "~a.skr" x) :engine *skribe-engine*))
- (reverse! *skribe-variants*))
-
- (debug-item "body..." *skribe-engine*)
- (if (string? *skribe-dest*)
- (cond-expand
- (bigloo2.6
- (try (with-output-to-file *skribe-dest* doskribe)
- (lambda (e a b c)
- (delete-file *skribe-dest*)
- (let ((s (with-output-to-string
- (lambda () (write c)))))
- (notify-error a b s))
- (exit -1))))
- (else
- (with-exception-handler
- (lambda (e)
- (if (&warning? e)
- (raise e)
- (begin
- (delete-file *skribe-dest*)
- (if (&error? e)
- (error-notify e)
- (raise e))
- (exit 1))))
- (lambda ()
- (with-output-to-file *skribe-dest* doskribe)))))
- (doskribe))))
-
-;*---------------------------------------------------------------------*/
-;* doskribe ... */
-;*---------------------------------------------------------------------*/
-(define (doskribe)
- (let ((e (find-engine *skribe-engine*)))
- (if (and (engine? e) (pair? *skribe-precustom*))
- (for-each (lambda (cv)
- (engine-custom-set! e (car cv) (cdr cv)))
- *skribe-precustom*))
- (if (pair? *skribe-src*)
- (for-each (lambda (f) (skribe-load f :engine *skribe-engine*))
- *skribe-src*)
- (skribe-eval-port (current-input-port) *skribe-engine*))))
diff --git a/src/bigloo/new.sch b/src/bigloo/new.sch
deleted file mode 100644
index 16bb7d5..0000000
--- a/src/bigloo/new.sch
+++ /dev/null
@@ -1,17 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/new.sch */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Sun Aug 17 11:58:30 2003 */
-;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */
-;* Copyright : 2003 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The new facility */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* new ... */
-;*---------------------------------------------------------------------*/
-(define-macro (new id . inits)
- `(,(symbol-append 'instantiate::% id) ,@inits))
-
diff --git a/src/bigloo/output.scm b/src/bigloo/output.scm
deleted file mode 100644
index 4bc6271..0000000
--- a/src/bigloo/output.scm
+++ /dev/null
@@ -1,167 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/output.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 12:48:11 2003 */
-;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe engine */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_output
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_lib
- skribe_engine
- skribe_writer
- skribe_eval)
-
- (export (output ::obj ::%engine . w)))
-
-;*---------------------------------------------------------------------*/
-;* output ... */
-;*---------------------------------------------------------------------*/
-(define (output node e . writer)
- (with-debug 3 'output
- (debug-item "node=" node " " (if (markup? node) (markup-markup node) ""))
- (debug-item "writer=" writer)
- (if (pair? writer)
- (cond
- ((%writer? (car 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 node e))))
-
-;*---------------------------------------------------------------------*/
-;* out/writer ... */
-;*---------------------------------------------------------------------*/
-(define (out/writer n e w)
- (with-debug 5 'out/writer
- (debug-item "n=" (find-runtime-type n)
- " " (if (markup? n) (markup-markup n) ""))
- (debug-item "e=" (%engine-ident e))
- (debug-item "w=" (%writer-ident w))
- (if (%writer? w)
- (with-access::%writer w (before action after)
- (invoke before n e)
- (invoke action n e)
- (invoke after n e)))))
-
-;*---------------------------------------------------------------------*/
-;* out ... */
-;*---------------------------------------------------------------------*/
-(define-generic (out node e::%engine)
- (cond
- ((pair? node)
- (out* node e))
- ((string? node)
- (let ((f (%engine-filter e)))
- (if (procedure? f)
- (display (f node))
- (display node))))
- ((number? node)
- (display node))
- (else
- #f)))
-
-;*---------------------------------------------------------------------*/
-;* out ::%processor ... */
-;*---------------------------------------------------------------------*/
-(define-method (out n::%processor e::%engine)
- (with-access::%processor n (combinator engine body procedure)
- (let ((newe (processor-get-engine combinator engine e)))
- (out (procedure body newe) newe))))
-
-;*---------------------------------------------------------------------*/
-;* out ::%command ... */
-;*---------------------------------------------------------------------*/
-(define-method (out node::%command e::%engine)
- (with-access::%command node (fmt body)
- (let ((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"
- node)))
- 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"
- node))))
- (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))))))))
-
-;*---------------------------------------------------------------------*/
-;* out ::%handle ... */
-;*---------------------------------------------------------------------*/
-(define-method (out node::%handle e::%engine)
- #unspecified)
-
-;*---------------------------------------------------------------------*/
-;* out ::%unresolved ... */
-;*---------------------------------------------------------------------*/
-(define-method (out node::%unresolved e::%engine)
- (error 'output "Orphan unresolved" node))
-
-;*---------------------------------------------------------------------*/
-;* out ::%markup ... */
-;*---------------------------------------------------------------------*/
-(define-method (out node::%markup e::%engine)
- (let ((w (lookup-markup-writer node e)))
- (if (writer? w)
- (out/writer node e w)
- (output (%markup-body node) e))))
-
-;*---------------------------------------------------------------------*/
-;* out* ... */
-;*---------------------------------------------------------------------*/
-(define (out* n+ e)
- (let loop ((n* n+))
- (cond
- ((pair? n*)
- (out (car n*) e)
- (loop (cdr n*)))
- ((not (null? n*))
- (error 'output "Illegal argument" n*)))))
-
-
diff --git a/src/bigloo/param.bgl b/src/bigloo/param.bgl
deleted file mode 100644
index 6ff6b42..0000000
--- a/src/bigloo/param.bgl
+++ /dev/null
@@ -1,134 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/param.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Sat Jul 26 14:03:15 2003 */
-;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe parameters */
-;* ------------------------------------------------------------- */
-;* Implementation: @label param@ */
-;* bigloo: @path ../common/param.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_param
-
- (import skribe_configure)
-
- (export *skribe-verbose*
- *skribe-warning*
- *skribe-path*
- *skribe-bib-path*
- *skribe-source-path*
- *skribe-image-path*
- *load-rc*
-
- *skribe-src*
- *skribe-dest*
- *skribe-engine*
- *skribe-variants*
- *skribe-chapter-split*
-
- *skribe-ref-base*
-
- *skribe-rc-directory*
- *skribe-rc-file*
- *skribe-auto-mode-alist*
- *skribe-auto-load-alist*
- *skribe-preload*
- *skribe-precustom*
-
- *skribebib-auto-mode-alist*))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-verbose* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-verbose* 0)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-warning* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-warning* 5)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-path* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-path* (skribe-default-path))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-bib-path* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-bib-path* '("."))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-source-path* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-source-path* '("."))
-
-;*---------------------------------------------------------------------*/
-;* *skribe-image-path* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-image-path* '("."))
-
-;*---------------------------------------------------------------------*/
-;* *load-rc* ... */
-;*---------------------------------------------------------------------*/
-(define *load-rc* #t)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-src* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-src* '())
-
-;*---------------------------------------------------------------------*/
-;* *skribe-dest* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-dest* #f)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-engine* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-engine* 'html)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-variants* */
-;*---------------------------------------------------------------------*/
-(define *skribe-variants* '())
-
-;*---------------------------------------------------------------------*/
-;* *skribe-chapter-split* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-chapter-split* '())
-
-;*---------------------------------------------------------------------*/
-;* *skribe-ref-base* ... */
-;*---------------------------------------------------------------------*/
-(define *skribe-ref-base* #f)
-
-;*---------------------------------------------------------------------*/
-;* *skribe-rc-directory* ... */
-;* ------------------------------------------------------------- */
-;* The "runtime command" file directory. */
-;*---------------------------------------------------------------------*/
-(define *skribe-rc-directory*
- (let ((home (getenv "HOME"))
- (host (hostname)))
- (let loop ((host (if (not (string? host)) (getenv "HOST") host)))
- (if (string? host)
- (let ((home/host (string-append home "/.skribe" host)))
- (if (and (file-exists? home/host) (directory? home/host))
- home/host
- (if (string=? (suffix host) "")
- (let ((home/def (make-file-name home ".skribe")))
- (cond
- ((and (file-exists? home/def)
- (directory? home/def))
- home/def)
- (else
- home)))
- (loop (prefix host)))))))))
-
diff --git a/src/bigloo/parseargs.scm b/src/bigloo/parseargs.scm
deleted file mode 100644
index 4ce58c4..0000000
--- a/src/bigloo/parseargs.scm
+++ /dev/null
@@ -1,186 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Jul 22 16:52:53 2003 */
-;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Argument parsing */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_parse-args
-
- (include "debug.sch")
-
- (import skribe_configure
- skribe_param
- skribe_read
- skribe_types
- skribe_eval)
-
- (export (parse-env-variables)
- (parse-args ::pair)
- (load-rc)))
-
-;*---------------------------------------------------------------------*/
-;* parse-env-variables ... */
-;*---------------------------------------------------------------------*/
-(define (parse-env-variables)
- (let ((e (getenv "SKRIBEPATH")))
- (if (string? e)
- (skribe-path-set! (append (unix-path->list e) (skribe-path))))))
-
-;*---------------------------------------------------------------------*/
-;* parse-args ... */
-;*---------------------------------------------------------------------*/
-(define (parse-args args)
- (define (usage args-parse-usage)
- (print "usage: skribe [options] [input]")
- (newline)
- (args-parse-usage #f)
- (newline)
- (print "Rc file:")
- (newline)
- (print " *skribe-rc* (searched in \".\" then $HOME)")
- (newline)
- (print "Target formats:")
- (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*)
- (newline)
- (print "Shell Variables:")
- (newline)
- (for-each (lambda (var)
- (print " - " (car var) " " (cdr var)))
- '(("SKRIBEPATH" . "Skribe input path (all files)"))))
- (define (version)
- (print "skribe v" (skribe-release)))
- (define (query)
- (version)
- (newline)
- (for-each (lambda (x)
- (let ((s (keyword->string (car x))))
- (printf " ~a: ~a\n"
- (substring s 1 (string-length s))
- (cadr x))))
- (skribe-configure)))
- (let ((np '())
- (engine #f))
- (args-parse (cdr args)
- ((("-h" "--help") (help "This message"))
- (usage args-parse-usage)
- (exit 0))
- (("--options" (help "Display the skribe options and exit"))
- (args-parse-usage #t)
- (exit 0))
- (("--version" (help "The version of Skribe"))
- (version)
- (exit 0))
- ((("-q" "--query") (help "Display informations about the Skribe configuration"))
- (query)
- (exit 0))
- ((("-c" "--custom") ?key=val (synopsis "Preset custom value"))
- (let ((l (string-length key=val)))
- (let loop ((i 0))
- (cond
- ((= i l)
- (skribe-error 'skribe "Illegal option" key=val))
- ((char=? (string-ref key=val i) #\=)
- (let ((key (substring key=val 0 i))
- (val (substring key=val (+ i 1) l)))
- (set! *skribe-precustom*
- (cons (cons (string->symbol key) val)
- *skribe-precustom*))))
- (else
- (loop (+ i 1)))))))
- (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)"))
- (if (string=? level "")
- (set! *skribe-verbose* (+fx 1 *skribe-verbose*))
- (set! *skribe-verbose* (string->integer level))))
- (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)"))
- (if (string=? level "")
- (set! *skribe-warning* (+fx 1 *skribe-warning*))
- (set! *skribe-warning* (string->integer level))))
- (("-g?level" (help "Increase or set debug level"))
- (if (string=? level "")
- (set! *skribe-debug* (+fx 1 *skribe-debug*))
- (let ((l (string->integer level)))
- (if (= l 0)
- (begin
- (set! *skribe-debug* 1)
- (set! *skribe-debug-symbols*
- (cons (string->symbol level)
- *skribe-debug-symbols*)))
- (set! *skribe-debug* l)))))
- (("--no-color" (help "Disable coloring for debug"))
- (set! *skribe-debug-color* #f))
- ((("-t" "--target") ?e (help "The output target format"))
- (set! engine (string->symbol e)))
- (("-I" ?path (help "Add <path> to skribe path"))
- (set! np (cons path np)))
- (("-B" ?path (help "Add <path> to skribe bibliography path"))
- (skribe-bib-path-set! (cons path (skribe-bib-path))))
- (("-S" ?path (help "Add <path> to skribe source path"))
- (skribe-source-path-set! (cons path (skribe-source-path))))
- (("-P" ?path (help "Add <path> to skribe image path"))
- (skribe-image-path-set! (cons path (skribe-image-path))))
- ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files"))
- (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
- (("--eval" ?expr (help "Evaluate expression"))
- (with-input-from-string expr
- (lambda ()
- (eval (skribe-read)))))
- (("--no-init-file" (help "Dont load rc Skribe file"))
- (set! *load-rc* #f))
- ((("-p" "--preload") ?file (help "Preload file"))
- (set! *skribe-preload* (cons file *skribe-preload*)))
- ((("-u" "--use-variant") ?variant (help "use <variant> output format"))
- (set! *skribe-variants* (cons variant *skribe-variants*)))
- ((("-o" "--output") ?o (help "The output target name"))
- (set! *skribe-dest* o)
- (let* ((s (suffix o))
- (c (assoc s *skribe-auto-mode-alist*)))
- (if (and (pair? c) (symbol? (cdr c)))
- (set! *skribe-engine* (cdr c)))))
- ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks"))
- (set! *skribe-ref-base* base))
- ;; skribe rc directory
- ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory"))
- (set! *skribe-rc-directory* dir))
- (else
- (set! *skribe-src* (cons else *skribe-src*))))
- ;; we have to configure according to the environment variables
- (if engine (set! *skribe-engine* engine))
- (set! *skribe-src* (reverse! *skribe-src*))
- (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH")
- (reverse! np)
- (skribe-path)))))
-
-;*---------------------------------------------------------------------*/
-;* build-path-from-shell-variable ... */
-;*---------------------------------------------------------------------*/
-(define (build-path-from-shell-variable var)
- (let ((val (getenv var)))
- (if (string? val)
- (string-case val
- ((+ (out #\:))
- (let* ((str (the-string))
- (res (ignore)))
- (cons str res)))
- (#\:
- (ignore))
- (else
- '()))
- '())))
-
-;*---------------------------------------------------------------------*/
-;* load-rc ... */
-;*---------------------------------------------------------------------*/
-(define (load-rc)
- (if *load-rc*
- (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*)))
- (if (and (string? file) (file-exists? file))
- (loadq file)))))
-
diff --git a/src/bigloo/prog.scm b/src/bigloo/prog.scm
deleted file mode 100644
index baad0f0..0000000
--- a/src/bigloo/prog.scm
+++ /dev/null
@@ -1,196 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/prog.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Aug 27 09:14:28 2003 */
-;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */
-;* Copyright : 2003 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe prog bigloo implementation */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_prog
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api)
-
- (export (make-prog-body ::obj ::obj ::obj ::obj)
- (resolve-line ::bstring)))
-
-;*---------------------------------------------------------------------*/
-;* *lines* ... */
-;*---------------------------------------------------------------------*/
-(define *lines* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* make-line-mark ... */
-;*---------------------------------------------------------------------*/
-(define (make-line-mark m lnum b)
- (let* ((ls (integer->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)
- (multiple-value-bind (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)
- (multiple-value-bind (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
- ((=fx r2 l)
- (if (=fx r1 r2)
- (reverse! res)
- (reverse! (cons (substring line r1 r2) res))))
- ((char=? (string-ref line r2) #\Newline)
- (loop (+fx r2 1)
- (+fx r2 1)
- (if (=fx r1 r2)
- (cons 'eol res)
- (cons* 'eol (substring line r1 r2) res))))
- (else
- (loop r1
- (+fx 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 (integer->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 (integer->string (+fx (if (integer? ldigit)
- (max lnum (expt 10 (-fx ldigit 1)))
- lnum)
- (length lines))))
- (cs (string-length s)))
- (let loop ((lines lines)
- (lnum lnum)
- (res '()))
- (if (null? lines)
- (reverse! res)
- (multiple-value-bind (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/bigloo/read.scm b/src/bigloo/read.scm
deleted file mode 100644
index 91cd345..0000000
--- a/src/bigloo/read.scm
+++ /dev/null
@@ -1,482 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/read.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Dec 27 11:16:00 1994 */
-;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */
-;* ------------------------------------------------------------- */
-;* Skribe's reader */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* Le module */
-;*---------------------------------------------------------------------*/
-(module skribe_read
- (export (skribe-read . port)))
-
-;*---------------------------------------------------------------------*/
-;* Global counteurs ... */
-;*---------------------------------------------------------------------*/
-(define *par-open* 0)
-
-;*---------------------------------------------------------------------*/
-;* Parenthesis mismatch (or unclosing) errors. */
-;*---------------------------------------------------------------------*/
-(define *list-error-level* 20)
-(define *list-errors* (make-vector *list-error-level* #unspecified))
-(define *vector-errors* (make-vector *list-error-level* #unspecified))
-
-;*---------------------------------------------------------------------*/
-;* Control variables. */
-;*---------------------------------------------------------------------*/
-(define *end-of-list* (cons 0 0))
-(define *dotted-mark* (cons 1 1))
-
-;*---------------------------------------------------------------------*/
-;* skribe-reader-reset! ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-reader-reset!)
- (set! *par-open* 0))
-
-;*---------------------------------------------------------------------*/
-;* read-error ... */
-;*---------------------------------------------------------------------*/
-(define (read-error msg obj port)
- (let* ((obj-loc (if (epair? obj)
- (match-case (cer obj)
- ((at ?fname ?pos ?-)
- pos)
- (else
- #f))
- #f))
- (loc (if (number? obj-loc)
- obj-loc
- (cond
- ((>fx *par-open* 0)
- (let ((open-key (-fx *par-open* 1)))
- (if (<fx open-key (vector-length *list-errors*))
- (vector-ref *list-errors* open-key)
- #f)))
- (else
- #f)))))
- (if (fixnum? loc)
- (error/location "skribe-read" msg obj (input-port-name port) loc)
- (error "skribe-read" msg obj))))
-
-;*---------------------------------------------------------------------*/
-;* make-list! ... */
-;*---------------------------------------------------------------------*/
-(define (make-list! l port)
- (define (reverse-proper-list! l)
- (let nr ((l l)
- (r '()))
- (cond
- ((eq? (car l) *dotted-mark*)
- (read-error "Illegal pair" r port))
- ((null? (cdr l))
- (set-cdr! l r)
- l)
- (else
- (let ((cdrl (cdr l)))
- (nr cdrl
- (begin (set-cdr! l r)
- l)))))))
- (define (reverse-improper-list! l)
- (let nr ((l (cddr l))
- (r (car l)))
- (cond
- ((eq? (car l) *dotted-mark*)
- (read-error "Illegal pair" r port))
- ((null? (cdr l))
- (set-cdr! l r)
- l)
- (else
- (let ((cdrl (cdr l)))
- (nr cdrl
- (begin (set-cdr! l r)
- l)))))))
- (cond
- ((null? l)
- l)
- ((and (pair? l) (pair? (cdr l)) (eq? (cadr l) *dotted-mark*))
- (if (null? (cddr l))
- (car l)
- (reverse-improper-list! l)))
- (else
- (reverse-proper-list! l))))
-
-;*---------------------------------------------------------------------*/
-;* make-at ... */
-;*---------------------------------------------------------------------*/
-(define (make-at name pos)
- (cond-expand
- ((or bigloo2.4 bigloo2.5 bigloo2.6)
- `(at ,name ,pos _))
- (else
- `(at ,name ,pos))))
-
-;*---------------------------------------------------------------------*/
-;* collect-up-to ... */
-;* ------------------------------------------------------------- */
-;* The first pair of the list is special because of source file */
-;* location. We want the location to be associated to the first */
-;* open parenthesis, not the last character of the car of the list. */
-;*---------------------------------------------------------------------*/
-(define-inline (collect-up-to ignore kind port)
- (let ((name (input-port-name port)))
- (let* ((pos (input-port-position port))
- (item (ignore)))
- (if (eq? item *end-of-list*)
- '()
- (let loop ((acc (econs item '() (make-at name pos))))
- (let ((item (ignore)))
- (if (eq? item *end-of-list*)
- acc
- (loop (let ((new-pos (input-port-position port)))
- (econs item
- acc
- (make-at name new-pos)))))))))))
-
-;*---------------------------------------------------------------------*/
-;* read-quote ... */
-;*---------------------------------------------------------------------*/
-(define (read-quote kwote port ignore)
- (let* ((pos (input-port-position port))
- (obj (ignore)))
- (if (or (eof-object? obj) (eq? obj *end-of-list*))
- (error/location "read"
- "Illegal quotation"
- kwote
- (input-port-name port)
- pos))
- (econs kwote
- (cons obj '())
- (make-at (input-port-name port) pos))))
-
-;*---------------------------------------------------------------------*/
-;* *sexp-grammar* ... */
-;*---------------------------------------------------------------------*/
-(define *sexp-grammar*
- (regular-grammar ((float (or (: (* digit) "." (+ digit))
- (: (+ digit) "." (* digit))))
- (letter (in ("azAZ") (#a128 #a255)))
- (special (in "!@~$%^&*></-_+\\=?.:{}"))
- (kspecial (in "!@~$%^&*></-_+\\=?."))
- (quote (in "\",'`"))
- (paren (in "()"))
- (id (: (* digit)
- (or letter special)
- (* (or letter special digit (in ",'`")))))
- (kid (: (* digit)
- (or letter kspecial)
- (* (or letter kspecial digit (in ",'`")))))
- (blank (in #\Space #\Tab #a012 #a013)))
-
- ;; newlines
- ((+ #\Newline)
- (ignore))
-
- ;; blank lines
- ((+ blank)
- (ignore))
-
- ;; comments
- ((: ";" (* all))
- (ignore))
-
- ;; the interpreter header or the dsssl named constants
- ((: "#!" (+ (in letter)))
- (let* ((str (the-string)))
- (cond
- ((string=? str "#!optional")
- boptional)
- ((string=? str "#!rest")
- brest)
- ((string=? str "#!key")
- bkey)
- (else
- (ignore)))))
-
- ;; characters
- ((: (uncase "#a") (= 3 digit))
- (let ((string (the-string)))
- (if (not (=fx (the-length) 5))
- (error/location "skribe-read"
- "Illegal ascii character"
- string
- (input-port-name (the-port))
- (input-port-position (the-port)))
- (integer->char (string->integer (the-substring 2 5))))))
- ((: "#\\" (or letter digit special (in "|#; []" quote paren)))
- (string-ref (the-string) 2))
- ((: "#\\" (>= 2 letter))
- (let ((char-name (string->symbol
- (string-upcase!
- (the-substring 2 (the-length))))))
- (case char-name
- ((NEWLINE)
- #\Newline)
- ((TAB)
- #\tab)
- ((SPACE)
- #\space)
- ((RETURN)
- (integer->char 13))
- (else
- (error/location "skribe-read"
- "Illegal character"
- (the-string)
- (input-port-name (the-port))
- (input-port-position (the-port)))))))
-
- ;; ucs-2 characters
- ((: "#u" (= 4 xdigit))
- (integer->ucs2 (string->integer (the-substring 2 6) 16)))
-
- ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- (let ((str (the-substring 1 (-fx (the-length) 1))))
- (let ((str (the-substring 0 (-fx (the-length) 1))))
- (escape-C-string str))))
- ;; ucs2 strings
- ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- (let ((str (the-substring 3 (-fx (the-length) 1))))
- (utf8-string->ucs2-string str)))
-
- ;; fixnums
- ((: (? (in "-+")) (+ digit))
- (the-fixnum))
- ((: "#o" (? (in "-+")) (+ (in ("07"))))
- (string->integer (the-substring 2 (the-length)) 8))
- ((: "#d" (? (in "-+")) (+ (in ("09"))))
- (string->integer (the-substring 2 (the-length)) 10))
- ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af"))))))
- (string->integer (the-substring 2 (the-length)) 16))
- ((: "#e" (? (in "-+")) (+ digit))
- (string->elong (the-substring 2 (the-length)) 10))
- ((: "#l" (? (in "-+")) (+ digit))
- (string->llong (the-substring 2 (the-length)) 10))
-
- ;; flonum
- ((: (? (in "-+"))
- (or float
- (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit))))
- (the-flonum))
-
- ;; doted pairs
- ("."
- (if (<=fx *par-open* 0)
- (error/location "read"
- "Illegal token"
- #\.
- (input-port-name (the-port))
- (input-port-position (the-port)))
- *dotted-mark*))
-
- ;; unspecified and eof-object
- ((: "#" (in "ue") (+ (in "nspecified-objt")))
- (let ((symbol (string->symbol
- (string-upcase!
- (the-substring 1 (the-length))))))
- (case symbol
- ((UNSPECIFIED)
- unspec)
- ((EOF-OBJECT)
- beof)
- (else
- (error/location "read"
- "Illegal identifier"
- symbol
- (input-port-name (the-port))
- (input-port-position (the-port)))))))
-
- ;; booleans
- ((: "#" (uncase #\t))
- #t)
- ((: "#" (uncase #\f))
- #f)
-
- ;; keywords
- ((or (: ":" kid) (: kid ":"))
- ;; since the keyword expression is also matched by the id
- ;; rule, keyword rule has to be placed before the id rule.
- (the-keyword))
-
- ;; identifiers
- (id
- ;; this rule has to be placed after the rule matching the `.' char
- (the-symbol))
- ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|")
- (if (=fx (the-length) 2)
- (the-symbol)
- (let ((str (the-substring 0 (-fx (the-length) 1))))
- (string->symbol (escape-C-string str)))))
-
- ;; quotations
- ("'"
- (read-quote 'quote (the-port) ignore))
- ("`"
- (read-quote 'quasiquote (the-port) ignore))
- (","
- (read-quote 'unquote (the-port) ignore))
- (",@"
- (read-quote 'unquote-splicing (the-port) ignore))
-
- ;; lists
- (#\(
- ;; if possible, we store the opening parenthesis.
- (if (and (vector? *list-errors*)
- (<fx *par-open* (vector-length *list-errors*)))
- (vector-set! *list-errors*
- *par-open*
- (input-port-position (the-port))))
- ;; we increment the number of open parenthesis
- (set! *par-open* (+fx 1 *par-open*))
- ;; and then, we compute the result list...
- (make-list! (collect-up-to ignore "list" (the-port)) (the-port)))
- (#\)
- ;; we decrement the number of open parenthesis
- (set! *par-open* (-fx *par-open* 1))
- (if (<fx *par-open* 0)
- (begin
- (warning/location (input-port-name (the-port))
- (input-port-position (the-port))
- "read"
- "Superfluous closing parenthesis `"
- (the-string)
- "'")
- (set! *par-open* 0)
- (ignore))
- *end-of-list*))
-
- ;; list of strings
- (#\[
- (let ((exp (read/rp *text-grammar* (the-port))))
- (list 'quasiquote exp)))
-
- ;; vectors
- ("#("
- ;; if possible, we store the opening parenthesis.
- (if (and (vector? *vector-errors*)
- (<fx *par-open* (vector-length *vector-errors*)))
- (let ((pos (input-port-position (the-port))))
- (vector-set! *vector-errors* *par-open* pos)))
- ;; we increment the number of open parenthesis
- (set! *par-open* (+fx 1 *par-open*))
- (list->vector (reverse! (collect-up-to ignore "vector" (the-port)))))
-
- ;; error or eof
- (else
- (let ((port (the-port))
- (char (the-failure)))
- (if (eof-object? char)
- (cond
- ((>fx *par-open* 0)
- (let ((open-key (-fx *par-open* 1)))
- (skribe-reader-reset!)
- (if (and (<fx open-key (vector-length *list-errors*))
- (fixnum? (vector-ref *list-errors* open-key)))
- (error/location "skribe-read"
- "Unclosed list"
- char
- (input-port-name port)
- (vector-ref *list-errors* open-key))
- (error "skribe-read"
- "Unexpected end-of-file"
- "Unclosed list"))))
- (else
- (reset-eof port)
- char))
- (error/location "skribe-read"
- "Illegal char"
- (illegal-char-rep char)
- (input-port-name port)
- (input-port-position port)))))))
-
-;*---------------------------------------------------------------------*/
-;* *text-grammar* ... */
-;* ------------------------------------------------------------- */
-;* The grammar that parses texts (the [...] forms). */
-;*---------------------------------------------------------------------*/
-(define *text-grammar*
- (regular-grammar ()
- ((: (* (out ",[]\\")) #\])
- (let* ((port (the-port))
- (name (input-port-name port))
- (pos (input-port-position port))
- (loc (make-at name pos))
- (item (the-substring 0 (-fx (the-length) 1))))
- (econs item '() loc)))
- ((: (* (out ",[\\")) ",]")
- (let* ((port (the-port))
- (name (input-port-name port))
- (pos (input-port-position port))
- (loc (make-at name pos))
- (item (the-substring 0 (-fx (the-length) 1))))
- (econs item '() loc)))
- ((: (* (out ",[]\\")) #\,)
- (let* ((port (the-port))
- (name (input-port-name port))
- (pos (input-port-position port))
- (loc (make-at name pos))
- (item (the-substring 0 (-fx (the-length) 1)))
- (sexp (read/rp *sexp-grammar* (the-port)))
- (rest (ignore)))
- (if (string=? item "")
- (cons (list 'unquote sexp) rest)
- (econs item (cons (list 'unquote sexp) rest) loc))))
- ((or (+ (out ",[]\\"))
- (+ #\Newline)
- (: (* (out ",[]\\")) #\, (out "([]\\")))
- (let* ((port (the-port))
- (name (input-port-name port))
- (pos (input-port-position port))
- (loc (make-at name pos))
- (item (the-string))
- (rest (ignore)))
- (econs item rest loc)))
- ("\\\\"
- (cons "\\" (ignore)))
- ("\\n"
- (cons "\n" (ignore)))
- ("\\t"
- (cons "\t" (ignore)))
- ("\\]"
- (cons "]" (ignore)))
- ("\\["
- (cons "[" (ignore)))
- ("\\,"
- (cons "," (ignore)))
- (#\\
- (cons "\\" (ignore)))
- (else
- (let ((c (the-failure))
- (port (the-port)))
- (define (err msg)
- (error/location "skribe-read-text"
- msg
- (the-failure)
- (input-port-name port)
- (input-port-position port)))
- (cond
- ((eof-object? c)
- (err "Illegal `end of file'"))
- ((char=? c #\[)
- (err "Illegal nested `[...]' form"))
- (else
- (err "Illegal string character")))))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-read ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-read . input-port)
- (cond
- ((null? input-port)
- (read/rp *sexp-grammar* (current-input-port)))
- ((not (input-port? (car input-port)))
- (error "read" "type `input-port' expected" (car input-port)))
- (else
- (let ((port (car input-port)))
- (if (closed-input-port? port)
- (error "read" "Illegal closed input port" port)
- (read/rp *sexp-grammar* port))))))
-
diff --git a/src/bigloo/resolve.scm b/src/bigloo/resolve.scm
deleted file mode 100644
index 7507560..0000000
--- a/src/bigloo/resolve.scm
+++ /dev/null
@@ -1,281 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/resolve.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Jul 25 09:31:18 2003 */
-;* Last change : Sun Jul 11 09:17:52 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe resolve stage */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_resolve
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_lib
- skribe_bib
- skribe_eval)
-
- (import skribe_index)
-
- (export (resolve! ::obj ::%engine ::pair-nil)
- (resolve-children ::obj)
- (resolve-children* ::obj)
- (resolve-parent ::%ast ::pair-nil)
- (resolve-search-parent ::%ast ::pair-nil ::procedure)
- (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o)
- (resolve-ident ::bstring ::obj ::%ast ::obj)))
-
-;*---------------------------------------------------------------------*/
-;* *unresolved* ... */
-;*---------------------------------------------------------------------*/
-(define *unresolved* #f)
-
-;*---------------------------------------------------------------------*/
-;* 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)
- (let ((old *unresolved*))
- (let loop ((ast ast))
- (set! *unresolved* #f)
- (let ((ast (do-resolve! ast engine env)))
- (if *unresolved*
- (loop ast)
- (begin
- (set! *unresolved* old)
- ast)))))))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ... */
-;*---------------------------------------------------------------------*/
-(define-generic (do-resolve! ast engine env)
- (if (pair? ast)
- (do-resolve*! ast engine env)
- ast))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ::%node ... */
-;*---------------------------------------------------------------------*/
-(define-method (do-resolve! node::%node engine env)
- (with-access::%node node (body options parent)
- (with-debug 5 'do-resolve::body
- (debug-item "node=" (if (markup? node)
- (markup-markup node)
- (find-runtime-type node)))
- (debug-item "body=" (find-runtime-type body))
- (if (not (eq? parent #unspecified))
- node
- (let ((p (assq 'parent env)))
- (set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
- (if (pair? options)
- (begin
- (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)))))
- (set! body (do-resolve! body engine env))
- node)))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ::%container ... */
-;*---------------------------------------------------------------------*/
-(define-method (do-resolve! node::%container engine env0)
- (with-access::%container node (body options env parent)
- (with-debug 5 'do-resolve::%container
- (debug-item "markup=" (markup-markup node))
- (debug-item "body=" (find-runtime-type body))
- (debug-item "env0=" env0)
- (debug-item "env=" env)
- (if (not (eq? parent #unspecified))
- node
- (let ((p (assq 'parent env0)))
- (set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))
- (if (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)))
- (set! body (do-resolve! body engine e))
- node))))
- ;; return the container
- node))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ::%document ... */
-;*---------------------------------------------------------------------*/
-(define-method (do-resolve! node::%document engine env0)
- (with-access::%document node (env)
- (call-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))))
- (%engine-customs engine)))
- ;; return the container
- node))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ::%unresolved ... */
-;*---------------------------------------------------------------------*/
-(define-method (do-resolve! node::%unresolved engine env)
- (with-debug 5 'do-resolve::%unresolved
- (debug-item "node=" node)
- (with-access::%unresolved node (proc parent loc)
- (let ((p (assq 'parent env)))
- (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))))
- (let ((res (resolve! (proc node engine env) engine env)))
- (if (ast? res) (%ast-loc-set! res loc))
- (debug-item "res=" res)
- (set! *unresolved* #t)
- res))))
-
-;*---------------------------------------------------------------------*/
-;* do-resolve! ::handle ... */
-;*---------------------------------------------------------------------*/
-(define-method (do-resolve! node::%handle engine env)
- node)
-
-;*---------------------------------------------------------------------*/
-;* do-resolve*! ... */
-;*---------------------------------------------------------------------*/
-(define (do-resolve*! n+ engine env)
- (let loop ((n* n+))
- (cond
- ((pair? n*)
- (set-car! n* (do-resolve! (car n*) engine env))
- (loop (cdr n*)))
- ((not (null? n*))
- (skribe-error 'do-resolve "Illegal argument" n*))
- (else
- n+))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-children ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-children n)
- (if (pair? n)
- n
- (list n)))
-
-;*---------------------------------------------------------------------*/
-;* resolve-children* ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-children* n)
- (cond
- ((pair? n)
- (map resolve-children* n))
- ((%container? n)
- (cons n (resolve-children* (%container-body n))))
- (else
- (list n))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-parent ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-parent n e)
- (with-debug 5 'resolve-parent
- (debug-item "n=" n)
- (cond
- ((not (%ast? n))
- (let ((c (assq 'parent e)))
- (if (pair? c)
- (cadr c)
- n)))
- ((eq? (%ast-parent n) #unspecified)
- (skribe-error 'resolve-parent "Orphan node" n))
- (else
- (%ast-parent n)))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-search-parent ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-search-parent n e pred)
- (with-debug 5 'resolve-search-parent
- (debug-item "node=" (find-runtime-type n))
- (debug-item "searching=" pred)
- (let ((p (resolve-parent n e)))
- (debug-item "parent=" (find-runtime-type p) " "
- (if (markup? p) (markup-markup p) "???"))
- (cond
- ((pred p)
- p)
- ((%unresolved? p)
- p)
- ((not p)
- #f)
- (else
- (resolve-search-parent p e pred))))))
-
-;*---------------------------------------------------------------------*/
-;* resolve-counter ... */
-;*---------------------------------------------------------------------*/
-(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/bigloo/source.scm b/src/bigloo/source.scm
deleted file mode 100644
index babadff..0000000
--- a/src/bigloo/source.scm
+++ /dev/null
@@ -1,238 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/source.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Aug 29 07:27:25 2003 */
-;* Last change : Tue Nov 2 14:25:50 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Bigloo handling of Skribe programs. */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_source
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api
- skribe_param)
-
- (export (source-read-chars::bstring ::bstring ::int ::int ::obj)
- (source-read-lines::bstring ::bstring ::obj ::obj ::obj)
- (source-read-definition::bstring ::bstring ::obj ::obj ::obj)
- (source-fontify ::obj ::obj)
- (split-string-newline::pair-nil ::bstring)))
-
-;*---------------------------------------------------------------------*/
-;* source-read-lines ... */
-;*---------------------------------------------------------------------*/
-(define (source-read-chars file start stop tab)
- (define (readl p)
- (read/rp (regular-grammar ()
- ((: (* (out #\Newline)) (? #\Newline))
- (the-string))
- (else
- (the-failure)))
- p))
- (let ((p (find-file/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 (>fx *skribe-verbose* 0)
- (fprint (current-error-port) " [source file: " p "]"))
- (let loop ((c -1)
- (s (readl (current-input-port)))
- (r '()))
- (let ((p (input-port-position (current-input-port))))
- (cond
- ((eof-object? s)
- (apply string-append (reverse! r)))
- ((>=fx p stop)
- (let* ((len (-fx (-fx stop start) c))
- (line (untabify (substring s 0 len) tab)))
- (apply string-append
- (reverse! (cons line r)))))
- ((>=fx c 0)
- (loop (+fx (string-length s) c)
- (readl (current-input-port))
- (cons (untabify s tab) r)))
- ((>=fx p start)
- (let* ((len (string-length s))
- (nc (-fx p start)))
- (if (>fx p stop)
- (untabify
- (substring s
- (-fx len (-fx p start))
- (-fx (-fx p stop) 1))
- tab)
- (loop nc
- (readl (current-input-port))
- (list
- (untabify
- (substring s
- (-fx len (-fx p start))
- len)
- tab))))))
- (else
- (loop c (readl (current-input-port)) r))))))))))
-
-;*---------------------------------------------------------------------*/
-;* source-read-lines ... */
-;*---------------------------------------------------------------------*/
-(define (source-read-lines file start stop tab)
- (let ((p (find-file/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 (>fx *skribe-verbose* 0)
- (fprint (current-error-port) " [source file: " 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 (+fx l 1)
- #t
- (read-line)
- (cons* "\n" (untabify s tab) r)))
- ((and (integer? start) (>= l start))
- (loop (+fx l 1)
- #t
- (read-line)
- (cons* "\n" (untabify s tab) r)))
- ((and (string? start) (substring=? start s startl))
- (loop (+fx l 1) #t (read-line) r))
- (else
- (loop (+fx 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
- ((=fx i len)
- (let ((nlen (-fx col 1)))
- (if (=fx len nlen)
- obj
- (let ((new (make-string col #\space)))
- (let liip ((i 0)
- (j 0)
- (col 1))
- (cond
- ((=fx i len)
- new)
- ((char=? (string-ref obj i) #\tab)
- (let ((next-tab (*fx (/fx (+fx col tabl)
- tabl)
- tabl)))
- (liip (+fx i 1)
- next-tab
- next-tab)))
- (else
- (string-set! new j (string-ref obj i))
- (liip (+fx i 1) (+fx j 1) (+fx col 1)))))))))
- ((char=? (string-ref obj i) #\tab)
- (loop (+fx i 1)
- (*fx (/fx (+fx col tabl) tabl) tabl)))
- (else
- (loop (+fx i 1) (+fx col 1))))))))
-
-;*---------------------------------------------------------------------*/
-;* source-read-definition ... */
-;*---------------------------------------------------------------------*/
-(define (source-read-definition file definition tab lang)
- (let ((p (find-file/path file (skribe-source-path))))
- (cond
- ((not (%language-extractor lang))
- (skribe-error 'source
- "The specified language has not defined extractor"
- lang))
- ((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 (>fx *skribe-verbose* 0)
- (fprint (current-error-port) " [source file: " 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
- ((=fx i l)
- (if (=fx i j)
- (reverse! r)
- (reverse! (cons (substring str j i) r))))
- ((char=? (string-ref str i) #\Newline)
- (loop (+fx i 1)
- (+fx i 1)
- (if (=fx i j)
- (cons 'eol r)
- (cons* 'eol (substring str j i) r))))
- ((and (char=? (string-ref str i) #a013)
- (<fx (+fx i 1) l)
- (char=? (string-ref str (+fx i 1)) #\Newline))
- (loop (+fx i 2)
- (+fx i 2)
- (if (=fx i j)
- (cons 'eol r)
- (cons* 'eol (substring str j i) r))))
- (else
- (loop (+fx i 1) j r))))))
-
diff --git a/src/bigloo/sui.bgl b/src/bigloo/sui.bgl
deleted file mode 100644
index 63c5477..0000000
--- a/src/bigloo/sui.bgl
+++ /dev/null
@@ -1,34 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/sui.bgl */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 23 12:48:11 2003 */
-;* Last change : Thu Jan 1 16:16:03 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe runtime (i.e., the style user functions). */
-;* ------------------------------------------------------------- */
-;* Implementation: @label sui@ */
-;* bigloo: @path ../common/sui.scm@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_sui
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_eval
- skribe_param
- skribe_output
- skribe_engine)
-
- (export (load-sui ::bstring)
- (sui-ref->url ::bstring ::obj ::obj ::pair-nil)
- (sui-title::bstring ::pair-nil)
- (sui-file::obj ::pair-nil)
- (sui-key::obj ::pair-nil ::obj)
- (sui-filter::pair-nil ::obj ::procedure ::procedure)))
-
diff --git a/src/bigloo/types.scm b/src/bigloo/types.scm
deleted file mode 100644
index b8babd4..0000000
--- a/src/bigloo/types.scm
+++ /dev/null
@@ -1,685 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/types.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Jul 22 16:40:42 2003 */
-;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The definition of the Skribe classes */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_types
-
- (export (abstract-class %ast
- (parent (default #unspecified))
- (loc (default (evmeaning-location))))
-
- (class %command::%ast
- (fmt::bstring read-only)
- (body (default #f)))
-
- (class %unresolved::%ast
- (proc::procedure read-only))
-
- (class %handle::%ast
- (ast (default #f)))
-
- (abstract-class %node::%ast
- (required-options::pair-nil read-only (default '()))
- (options::pair-nil (default '()))
- (body (default #f)))
-
- (class %processor::%node
- (combinator (default (lambda (e1 e2) e1)))
- (procedure::procedure (default (lambda (n e) n)))
- engine)
-
- (class %markup::%node
- (markup-init)
- (ident (default #f))
- (class (default #f))
- (markup::symbol read-only))
-
- (class %container::%markup
- (env::pair-nil (default '())))
-
- (class %document::%container)
-
- (class %engine
- (ident::symbol read-only)
- (format::bstring (default "raw"))
- (info::pair-nil (default '()))
- (version::obj read-only (default #unspecified))
- (delegate read-only (default #f))
- (writers::pair-nil (default '()))
- (filter::obj (default #f))
- (customs::pair-nil (default '()))
- (symbol-table::pair-nil (default '())))
-
- (class %writer
- (ident::symbol read-only)
- (class read-only)
- (pred::procedure read-only)
- (upred read-only)
- (options::obj read-only)
- (verified?::bool (default #f))
- (validate (default #f))
- (before read-only)
- (action read-only)
- (after read-only))
-
- (class %language
- (name::bstring read-only)
- (fontifier read-only (default #f))
- (extractor read-only (default #f)))
-
- (markup-init ::%markup)
- (find-markups ::bstring)
-
- (inline ast?::bool ::obj)
- (inline ast-parent::obj ::%ast)
- (inline ast-loc::obj ::%ast)
- (inline ast-loc-set!::obj ::%ast ::obj)
- (ast-location::bstring ::%ast)
-
- (new-command . inits)
- (inline command?::bool ::obj)
- (inline command-fmt::bstring ::%command)
- (inline command-body::obj ::%command)
-
- (new-unresolved . inits)
- (inline unresolved?::bool ::obj)
- (inline unresolved-proc::procedure ::%unresolved)
-
- (new-handle . inits)
- (inline handle?::bool ::obj)
- (inline handle-ast::obj ::%handle)
-
- (inline node?::bool ::obj)
- (inline node-body::obj ::%node)
- (inline node-options::pair-nil ::%node)
- (inline node-loc::obj ::%node)
-
- (new-processor . inits)
- (inline processor?::bool ::obj)
- (inline processor-combinator::obj ::%processor)
- (inline processor-engine::obj ::%processor)
-
- (new-markup . inits)
- (inline markup?::bool ::obj)
- (inline is-markup?::bool ::obj ::symbol)
- (inline markup-markup::obj ::%markup)
- (inline markup-ident::obj ::%markup)
- (inline markup-body::obj ::%markup)
- (inline markup-options::pair-nil ::%markup)
-
- (new-container . inits)
- (inline container?::bool ::obj)
- (inline container-ident::obj ::%container)
- (inline container-body::obj ::%container)
- (inline container-options::pair-nil ::%container)
-
- (new-document . inits)
- (inline document?::bool ::obj)
- (inline document-ident::bool ::%document)
- (inline document-body::bool ::%document)
- (inline document-options::pair-nil ::%document)
- (inline document-env::pair-nil ::%document)
-
- (inline engine?::bool ::obj)
- (inline engine-ident::obj ::obj)
- (inline engine-format::obj ::obj)
- (inline engine-customs::pair-nil ::obj)
- (inline engine-filter::obj ::obj)
- (inline engine-symbol-table::pair-nil ::%engine)
-
- (inline writer?::bool ::obj)
- (inline writer-before::obj ::%writer)
- (inline writer-action::obj ::%writer)
- (inline writer-after::obj ::%writer)
- (inline writer-options::obj ::%writer)
-
- (inline language?::bool ::obj)
- (inline language-name::obj ::obj)
- (inline language-fontifier::obj ::obj)
- (inline language-extractor::obj ::obj)
-
- (new-language . inits)
-
- (location?::bool ::obj)
- (location-file::bstring ::pair)
- (location-pos::int ::pair)))
-
-;*---------------------------------------------------------------------*/
-;* skribe-instantiate ... */
-;*---------------------------------------------------------------------*/
-(define-macro (skribe-instantiate type values . slots)
- `(begin
- (skribe-instantiate-check-values ',type ,values ',slots)
- (,(symbol-append 'instantiate::% type)
- ,@(map (lambda (slot)
- (let ((id (if (pair? slot) (car slot) slot))
- (def (if (pair? slot) (cadr slot) #f)))
- `(,id (new-get-value ',id ,values ,def))))
- slots))))
-
-;*---------------------------------------------------------------------*/
-;* skribe-instantiate-check-values ... */
-;*---------------------------------------------------------------------*/
-(define (skribe-instantiate-check-values id values slots)
- (let ((bs (every (lambda (v) (not (memq (car v) slots))) values)))
- (when (pair? bs)
- (for-each (lambda (b)
- (error (symbol-append '|new | id)
- "Illegal field"
- b))
- bs))))
-
-;*---------------------------------------------------------------------*/
-;* object-print ... */
-;*---------------------------------------------------------------------*/
-(define-method (object-print obj::%ast port print-slot::procedure)
- (let* ((class (object-class obj))
- (class-name (class-name class)))
- (display "#|" port)
- (display class-name port)
- (display #\| port)))
-
-;*---------------------------------------------------------------------*/
-;* object-display ::%ast ... */
-;*---------------------------------------------------------------------*/
-(define-method (object-display n::%ast . port)
- (fprintf (if (pair? port) (car port) (current-output-port))
- "<#~a>"
- (find-runtime-type n)))
-
-;*---------------------------------------------------------------------*/
-;* object-display ::%markup ... */
-;*---------------------------------------------------------------------*/
-(define-method (object-display n::%markup . port)
- (fprintf (if (pair? port) (car port) (current-output-port))
- "<#~a:~a>"
- (find-runtime-type n)
- (markup-markup n)))
-
-;*---------------------------------------------------------------------*/
-;* object-write ::%markup ... */
-;*---------------------------------------------------------------------*/
-(define-method (object-write n::%markup . port)
- (fprintf (if (pair? port) (car port) (current-output-port))
- "<#~a:~a:~a>"
- (find-runtime-type n)
- (markup-markup n)
- (find-runtime-type (markup-body n))))
-
-;*---------------------------------------------------------------------*/
-;* *node-table* */
-;* ------------------------------------------------------------- */
-;* A private hashtable that stores all the nodes of an ast. It */
-;* is used for retreiving a node from its identifier. */
-;*---------------------------------------------------------------------*/
-(define *node-table* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* ast? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (ast? obj)
- (%ast? obj))
-
-;*---------------------------------------------------------------------*/
-;* ast-parent ... */
-;*---------------------------------------------------------------------*/
-(define-inline (ast-parent obj)
- (%ast-parent obj))
-
-;*---------------------------------------------------------------------*/
-;* ast-loc ... */
-;*---------------------------------------------------------------------*/
-(define-inline (ast-loc obj)
- (%ast-loc obj))
-
-;*---------------------------------------------------------------------*/
-;* ast-loc-set! ... */
-;*---------------------------------------------------------------------*/
-(define-inline (ast-loc-set! obj loc)
- (%ast-loc-set! obj loc))
-
-;*---------------------------------------------------------------------*/
-;* ast-location ... */
-;*---------------------------------------------------------------------*/
-(define (ast-location obj)
- (with-access::%ast obj (loc)
- (if (location? loc)
- (let* ((fname (location-file loc))
- (char (location-pos loc))
- (pwd (pwd))
- (len (string-length pwd))
- (lenf (string-length fname))
- (file (if (and (substring=? pwd fname len)
- (and (>fx lenf len)))
- (substring fname len (+fx 1 (string-length fname)))
- fname)))
- (format "~a, char ~a" file char))
- "no source location")))
-
-;*---------------------------------------------------------------------*/
-;* new-command ... */
-;*---------------------------------------------------------------------*/
-(define (new-command . init)
- (skribe-instantiate command init
- (parent #unspecified)
- (loc #f)
- fmt
- (body #f)))
-
-;*---------------------------------------------------------------------*/
-;* command? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (command? obj)
- (%command? obj))
-
-;*---------------------------------------------------------------------*/
-;* command-fmt ... */
-;*---------------------------------------------------------------------*/
-(define-inline (command-fmt cmd)
- (%command-fmt cmd))
-
-;*---------------------------------------------------------------------*/
-;* command-body ... */
-;*---------------------------------------------------------------------*/
-(define-inline (command-body cmd)
- (%command-body cmd))
-
-;*---------------------------------------------------------------------*/
-;* new-unresolved ... */
-;*---------------------------------------------------------------------*/
-(define (new-unresolved . init)
- (skribe-instantiate unresolved init
- (parent #unspecified)
- loc
- proc))
-
-;*---------------------------------------------------------------------*/
-;* unresolved? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (unresolved? obj)
- (%unresolved? obj))
-
-;*---------------------------------------------------------------------*/
-;* unresolved-proc ... */
-;*---------------------------------------------------------------------*/
-(define-inline (unresolved-proc unr)
- (%unresolved-proc unr))
-
-;*---------------------------------------------------------------------*/
-;* new-handle ... */
-;*---------------------------------------------------------------------*/
-(define (new-handle . init)
- (skribe-instantiate handle init
- (parent #unspecified)
- loc
- (ast #f)))
-
-;*---------------------------------------------------------------------*/
-;* handle? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (handle? obj)
- (%handle? obj))
-
-;*---------------------------------------------------------------------*/
-;* handle-ast ... */
-;*---------------------------------------------------------------------*/
-(define-inline (handle-ast obj)
- (%handle-ast obj))
-
-;*---------------------------------------------------------------------*/
-;* node? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (node? obj)
- (%node? obj))
-
-;*---------------------------------------------------------------------*/
-;* node-body ... */
-;*---------------------------------------------------------------------*/
-(define-inline (node-body obj)
- (%node-body obj))
-
-;*---------------------------------------------------------------------*/
-;* node-options ... */
-;*---------------------------------------------------------------------*/
-(define-inline (node-options obj)
- (%node-options obj))
-
-;*---------------------------------------------------------------------*/
-;* node-loc ... */
-;*---------------------------------------------------------------------*/
-(define-inline (node-loc obj)
- (%node-loc obj))
-
-;*---------------------------------------------------------------------*/
-;* new-processor ... */
-;*---------------------------------------------------------------------*/
-(define (new-processor . init)
- (skribe-instantiate processor init
- (parent #unspecified)
- loc
- (combinator (lambda (e1 e2) e1))
- engine
- (body #f)))
-
-;*---------------------------------------------------------------------*/
-;* processor? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (processor? obj)
- (%processor? obj))
-
-;*---------------------------------------------------------------------*/
-;* processor-combinator ... */
-;*---------------------------------------------------------------------*/
-(define-inline (processor-combinator proc)
- (%processor-combinator proc))
-
-;*---------------------------------------------------------------------*/
-;* processor-engine ... */
-;*---------------------------------------------------------------------*/
-(define-inline (processor-engine proc)
- (%processor-engine proc))
-
-;*---------------------------------------------------------------------*/
-;* new-markup ... */
-;*---------------------------------------------------------------------*/
-(define (new-markup . init)
- (skribe-instantiate markup init
- (parent #unspecified)
- (loc #f)
- markup
- ident
- (class #f)
- (body #f)
- (options '())
- (required-options '())))
-
-;*---------------------------------------------------------------------*/
-;* markup? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (markup? obj)
- (%markup? obj))
-
-;*---------------------------------------------------------------------*/
-;* is-markup? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (is-markup? obj markup)
- (and (markup? obj) (eq? (markup-markup obj) markup)))
-
-;*---------------------------------------------------------------------*/
-;* markup-init ... */
-;* ------------------------------------------------------------- */
-;* The markup constructor simply stores in the markup table the */
-;* news markups. */
-;*---------------------------------------------------------------------*/
-(define (markup-init markup)
- (bind-markup! markup))
-
-;*---------------------------------------------------------------------*/
-;* bind-markup! ... */
-;*---------------------------------------------------------------------*/
-(define (bind-markup! node)
- (hashtable-update! *node-table*
- (markup-ident node)
- (lambda (cur) (cons node cur))
- (list node)))
-
-;*---------------------------------------------------------------------*/
-;* find-markups ... */
-;*---------------------------------------------------------------------*/
-(define (find-markups ident)
- (hashtable-get *node-table* ident))
-
-;*---------------------------------------------------------------------*/
-;* markup-markup ... */
-;*---------------------------------------------------------------------*/
-(define-inline (markup-markup obj)
- (%markup-markup obj))
-
-;*---------------------------------------------------------------------*/
-;* markup-ident ... */
-;*---------------------------------------------------------------------*/
-(define-inline (markup-ident obj)
- (%markup-ident obj))
-
-;*---------------------------------------------------------------------*/
-;* markup-body ... */
-;*---------------------------------------------------------------------*/
-(define-inline (markup-body obj)
- (%markup-body obj))
-
-;*---------------------------------------------------------------------*/
-;* markup-options ... */
-;*---------------------------------------------------------------------*/
-(define-inline (markup-options obj)
- (%markup-options obj))
-
-;*---------------------------------------------------------------------*/
-;* new-container ... */
-;*---------------------------------------------------------------------*/
-(define (new-container . init)
- (skribe-instantiate container init
- (parent #unspecified)
- loc
- markup
- ident
- (class #f)
- (body #f)
- (options '())
- (required-options '())
- (env '())))
-
-;*---------------------------------------------------------------------*/
-;* container? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (container? obj)
- (%container? obj))
-
-;*---------------------------------------------------------------------*/
-;* container-ident ... */
-;*---------------------------------------------------------------------*/
-(define-inline (container-ident obj)
- (%container-ident obj))
-
-;*---------------------------------------------------------------------*/
-;* container-body ... */
-;*---------------------------------------------------------------------*/
-(define-inline (container-body obj)
- (%container-body obj))
-
-;*---------------------------------------------------------------------*/
-;* container-options ... */
-;*---------------------------------------------------------------------*/
-(define-inline (container-options obj)
- (%container-options obj))
-
-;*---------------------------------------------------------------------*/
-;* new-document ... */
-;*---------------------------------------------------------------------*/
-(define (new-document . init)
- (skribe-instantiate document init
- (parent #unspecified)
- loc
- markup
- ident
- (class #f)
- (body #f)
- (options '())
- (required-options '())
- (env '())))
-
-;*---------------------------------------------------------------------*/
-;* document? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (document? obj)
- (%document? obj))
-
-;*---------------------------------------------------------------------*/
-;* document-options ... */
-;*---------------------------------------------------------------------*/
-(define-inline (document-options doc)
- (%document-options doc))
-
-;*---------------------------------------------------------------------*/
-;* document-env ... */
-;*---------------------------------------------------------------------*/
-(define-inline (document-env doc)
- (%document-env doc))
-
-;*---------------------------------------------------------------------*/
-;* document-ident ... */
-;*---------------------------------------------------------------------*/
-(define-inline (document-ident doc)
- (%document-ident doc))
-
-;*---------------------------------------------------------------------*/
-;* document-body ... */
-;*---------------------------------------------------------------------*/
-(define-inline (document-body doc)
- (%document-body doc))
-
-;*---------------------------------------------------------------------*/
-;* engine? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine? obj)
- (%engine? obj))
-
-;*---------------------------------------------------------------------*/
-;* engine-ident ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine-ident obj)
- (%engine-ident obj))
-
-;*---------------------------------------------------------------------*/
-;* engine-format ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine-format obj)
- (%engine-format obj))
-
-;*---------------------------------------------------------------------*/
-;* engine-customs ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine-customs obj)
- (%engine-customs obj))
-
-;*---------------------------------------------------------------------*/
-;* engine-filter ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine-filter obj)
- (%engine-filter obj))
-
-;*---------------------------------------------------------------------*/
-;* engine-symbol-table ... */
-;*---------------------------------------------------------------------*/
-(define-inline (engine-symbol-table obj)
- (%engine-symbol-table obj))
-
-;*---------------------------------------------------------------------*/
-;* writer? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (writer? obj)
- (%writer? obj))
-
-;*---------------------------------------------------------------------*/
-;* writer-before ... */
-;*---------------------------------------------------------------------*/
-(define-inline (writer-before obj)
- (%writer-before obj))
-
-;*---------------------------------------------------------------------*/
-;* writer-action ... */
-;*---------------------------------------------------------------------*/
-(define-inline (writer-action obj)
- (%writer-action obj))
-
-;*---------------------------------------------------------------------*/
-;* writer-after ... */
-;*---------------------------------------------------------------------*/
-(define-inline (writer-after obj)
- (%writer-after obj))
-
-;*---------------------------------------------------------------------*/
-;* writer-options ... */
-;*---------------------------------------------------------------------*/
-(define-inline (writer-options obj)
- (%writer-options obj))
-
-;*---------------------------------------------------------------------*/
-;* language? ... */
-;*---------------------------------------------------------------------*/
-(define-inline (language? obj)
- (%language? obj))
-
-;*---------------------------------------------------------------------*/
-;* language-name ... */
-;*---------------------------------------------------------------------*/
-(define-inline (language-name lg)
- (%language-name lg))
-
-;*---------------------------------------------------------------------*/
-;* language-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define-inline (language-fontifier lg)
- (%language-fontifier lg))
-
-;*---------------------------------------------------------------------*/
-;* language-extractor ... */
-;*---------------------------------------------------------------------*/
-(define-inline (language-extractor lg)
- (%language-extractor lg))
-
-;*---------------------------------------------------------------------*/
-;* new-get-value ... */
-;*---------------------------------------------------------------------*/
-(define (new-get-value key init def)
- (let ((c (assq key init)))
- (match-case c
- ((?- ?v)
- v)
- (else
- def))))
-
-;*---------------------------------------------------------------------*/
-;* new-language ... */
-;*---------------------------------------------------------------------*/
-(define (new-language . init)
- (skribe-instantiate language init name fontifier extractor))
-
-;*---------------------------------------------------------------------*/
-;* location? ... */
-;*---------------------------------------------------------------------*/
-(define (location? o)
- (match-case o
- ((at ?- ?-)
- #t)
- (else
- #f)))
-
-;*---------------------------------------------------------------------*/
-;* location-file ... */
-;*---------------------------------------------------------------------*/
-(define (location-file o)
- (match-case o
- ((at ?fname ?-)
- fname)
- (else
- (error 'location-file "Illegal location" o))))
-
-;*---------------------------------------------------------------------*/
-;* location-pos ... */
-;*---------------------------------------------------------------------*/
-(define (location-pos o)
- (match-case o
- ((at ?- ?loc)
- loc)
- (else
- (error 'location-pos "Illegal location" o))))
diff --git a/src/bigloo/verify.scm b/src/bigloo/verify.scm
deleted file mode 100644
index 602a951..0000000
--- a/src/bigloo/verify.scm
+++ /dev/null
@@ -1,143 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/verify.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Jul 25 09:54:55 2003 */
-;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Skribe verification stage */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_verify
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_lib
- skribe_engine
- skribe_writer
- skribe_eval)
-
- (export (generic verify ::obj ::%engine)))
-
-;*---------------------------------------------------------------------*/
-;* check-required-options ... */
-;*---------------------------------------------------------------------*/
-(define (check-required-options n::%markup w::%writer e::%engine)
- (with-access::%markup n (required-options)
- (with-access::%writer w (ident options verified?)
- (or verified?
- (eq? options 'all)
- (begin
- (for-each (lambda (o)
- (if (not (memq o options))
- (skribe-error (%engine-ident e)
- (format "Option unsupported: ~a, supported options: ~a" o options)
- n)))
- required-options)
- (set! verified? #t))))))
-
-;*---------------------------------------------------------------------*/
-;* check-options ... */
-;* ------------------------------------------------------------- */
-;* Only keywords are checked, symbols are voluntary left unchecked. */
-;*---------------------------------------------------------------------*/
-(define (check-options eo*::pair-nil m::%markup e::%engine)
- (with-debug 6 'check-options
- (debug-item "markup=" (%markup-markup m))
- (debug-item "options=" (%markup-options m))
- (debug-item "eo*=" eo*)
- (for-each (lambda (o2)
- (for-each (lambda (o)
- (if (and (keyword? o)
- (not (eq? o :&skribe-eval-location))
- (not (memq o eo*)))
- (skribe-warning/ast
- 3
- m
- 'verify
- (format "Engine `~a' does not support markup `~a' option `~a' -- ~a"
- (%engine-ident e)
- (%markup-markup m)
- o
- (markup-option m o)))))
- o2))
- (%markup-options m))))
-
-;*---------------------------------------------------------------------*/
-;* verify :: ... */
-;*---------------------------------------------------------------------*/
-(define-generic (verify node e)
- (if (pair? node)
- (for-each (lambda (n) (verify n e)) node))
- node)
-
-;*---------------------------------------------------------------------*/
-;* verify ::%processor ... */
-;*---------------------------------------------------------------------*/
-(define-method (verify n::%processor e)
- (with-access::%processor n (combinator engine body)
- (verify body (processor-get-engine combinator engine e))
- n))
-
-;*---------------------------------------------------------------------*/
-;* verify ::%node ... */
-;*---------------------------------------------------------------------*/
-(define-method (verify node::%node e)
- (with-access::%node node (body options)
- (verify body e)
- (for-each (lambda (o) (verify (cadr o) e)) options)
- node))
-
-;*---------------------------------------------------------------------*/
-;* verify ::%markup ... */
-;*---------------------------------------------------------------------*/
-(define-method (verify node::%markup e)
- (with-debug 5 'verify::%markup
- (debug-item "node=" (%markup-markup node))
- (debug-item "options=" (%markup-options node))
- (debug-item "e=" (%engine-ident e))
- (call-next-method)
- (let ((w (lookup-markup-writer node e)))
- (if (%writer? w)
- (begin
- (check-required-options node w e)
- (if (pair? (%writer-options w))
- (check-options (%writer-options w) node e))
- (let ((validate (%writer-validate w)))
- (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)))))))
- ;; return the node
- node))
-
-;*---------------------------------------------------------------------*/
-;* verify ::%document ... */
-;*---------------------------------------------------------------------*/
-(define-method (verify node::%document e)
- (call-next-method)
- ;; verify the engine custom
- (for-each (lambda (c)
- (let ((i (car c))
- (a (cadr c)))
- (set-car! (cdr c) (verify a e))))
- (%engine-customs e))
- ;; return the node
- node)
-
-;*---------------------------------------------------------------------*/
-;* verify ::%handle ... */
-;*---------------------------------------------------------------------*/
-(define-method (verify node::%handle e)
- node)
-
diff --git a/src/bigloo/writer.scm b/src/bigloo/writer.scm
deleted file mode 100644
index ce515bf..0000000
--- a/src/bigloo/writer.scm
+++ /dev/null
@@ -1,232 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/writer.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Tue Sep 9 06:19:57 2003 */
-;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe writer management */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_writer
-
- (option (set! dsssl-symbol->keyword
- (lambda (s)
- (string->keyword
- (string-append ":" (symbol->string s))))))
-
- (include "debug.sch")
-
- (import skribe_types
- skribe_eval
- skribe_param
- skribe_engine
- skribe_output
- skribe_lib)
-
- (export (invoke proc node e)
-
- (lookup-markup-writer ::%markup ::%engine)
-
- (markup-writer ::obj #!optional e #!key p class opt va bef aft act)
- (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a)
- (markup-writer-get ::obj #!optional e #!key class pred)
- (markup-writer-get*::pair-nil ::obj #!optional e #!key class)))
-
-;*---------------------------------------------------------------------*/
-;* invoke ... */
-;*---------------------------------------------------------------------*/
-(define (invoke proc node e)
- (let ((id (if (markup? node)
- (string->symbol
- (format "~a#~a"
- (%engine-ident e)
- (%markup-markup node)))
- (%engine-ident e))))
- (with-push-trace id
- (with-debug 5 'invoke
- (debug-item "e=" (%engine-ident e))
- (debug-item "node=" (find-runtime-type 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)
- (with-access::%engine e (writers delegate)
- (let loop ((w* writers))
- (cond
- ((pair? w*)
- (with-access::%writer (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 (correct-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))))))
-
-;*---------------------------------------------------------------------*/
-;* 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)
- (%writer-pred old)
- predicate)
- :class (if (unspecified? class)
- (%writer-class old)
- class)
- :options (if (unspecified? options)
- (%writer-options old)
- options)
- :validate (if (unspecified? validate)
- (%writer-validate old)
- validate)
- :before (if (unspecified? before)
- (%writer-before old)
- before)
- :action (if (unspecified? action)
- (%writer-action old)
- action)
- :after (if (unspecified? after)
- (%writer-after old) after))))
-
-;*---------------------------------------------------------------------*/
-;* markup-writer-get ... */
-;* ------------------------------------------------------------- */
-;* Finds the writer that matches MARKUP with optional CLASS */
-;* attribute. */
-;*---------------------------------------------------------------------*/
-(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 "Illegal symbol" markup))
- ((not (engine? e))
- (skribe-error 'markup-writer "Illegal engine" e))
- (else
- (let liip ((e e))
- (let loop ((w* (%engine-writers e)))
- (cond
- ((pair? w*)
- (if (and (eq? (%writer-ident (car w*)) markup)
- (equal? (%writer-class (car w*)) class)
- (or (eq? pred #unspecified)
- (eq? (%writer-upred (car w*)) pred)))
- (car w*)
- (loop (cdr w*))))
- ((engine? (%engine-delegate e))
- (liip (%engine-delegate e)))
- (else
- #f))))))))
-
-;*---------------------------------------------------------------------*/
-;* markup-writer-get* ... */
-;* ------------------------------------------------------------- */
-;* Finds alll 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* (%engine-writers e))
- (res res))
- (cond
- ((pair? w*)
- (if (and (eq? (%writer-ident (car w*)) markup)
- (equal? (%writer-class (car w*)) class))
- (loop (cdr w*) (cons (car w*) res))
- (loop (cdr w*) res)))
- ((engine? (%engine-delegate e))
- (liip (%engine-delegate e) res))
- (else
- (reverse! res)))))))))
diff --git a/src/bigloo/xml.scm b/src/bigloo/xml.scm
deleted file mode 100644
index d4c662e..0000000
--- a/src/bigloo/xml.scm
+++ /dev/null
@@ -1,92 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/xml.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Sep 1 12:08:39 2003 */
-;* Last change : Mon May 17 10:14:24 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* XML fontification */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* The module */
-;*---------------------------------------------------------------------*/
-(module skribe_xml
-
- (include "new.sch")
-
- (import skribe_types
- skribe_lib
- skribe_resolve
- skribe_eval
- skribe_api
- skribe_param
- skribe_source)
-
- (export xml))
-
-;*---------------------------------------------------------------------*/
-;* xml ... */
-;*---------------------------------------------------------------------*/
-(define xml
- (new language
- (name "xml")
- (fontifier xml-fontifier)
- (extractor #f)))
-
-;*---------------------------------------------------------------------*/
-;* xml-fontifier ... */
-;*---------------------------------------------------------------------*/
-(define (xml-fontifier s)
- (let ((g (regular-grammar ()
- ((: #\; (in "<!--") (* (or all #\Newline)) "-->")
- ;; italic comments
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-line-comment)
- (body s))))
- str)
- (ignore))))
- ((+ (or #\Newline #\Space))
- ;; separators
- (let ((str (the-string)))
- (cons str (ignore))))
- ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>)
- ;; markup
- (let ((str (the-string)))
- (let ((c (new markup
- (markup '&source-module)
- (body (the-string)))))
- (cons c (ignore)))))
- ((+ (out #\< #\> #\Space #\Tab #\= #\"))
- ;; regular text
- (let ((string (the-string)))
- (cons string (ignore))))
- ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
- (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'"))
- ;; strings
- (let ((str (split-string-newline (the-string))))
- (append (map (lambda (s)
- (if (eq? s 'eol)
- "\n"
- (new markup
- (markup '&source-string)
- (body s))))
- str)
- (ignore))))
- ((in "\"=")
- (let ((str (the-string)))
- (cons str (ignore))))
- (else
- (let ((c (the-failure)))
- (if (eof-object? c)
- '()
- (error "source(xml)" "Unexpected character" c)))))))
- (with-input-from-string s
- (lambda ()
- (read/rp g (current-input-port))))))
-
diff --git a/src/common/bib.scm b/src/common/bib.scm
deleted file mode 100644
index b73c5f0..0000000
--- a/src/common/bib.scm
+++ /dev/null
@@ -1,192 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/bib.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Fri Dec 7 06:12:29 2001 */
-;* Last change : Wed Jan 14 08:02:45 2004 (serrano) */
-;* Copyright : 2001-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe Bibliography */
-;* ------------------------------------------------------------- */
-;* Implementation: @label bib@ */
-;* bigloo: @path ../bigloo/bib.bgl@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* 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)))))
-
diff --git a/src/common/configure.scm b/src/common/configure.scm
deleted file mode 100644
index 90e2339..0000000
--- a/src/common/configure.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-;; Automatically generated file (don't edit)
-(define (skribe-release) "1.2d")
-(define (skribe-url) "http://www.inria.fr/mimosa/fp/Skribe")
-(define (skribe-doc-dir) "/usr/local/doc/skribe-1.2d")
-(define (skribe-ext-dir) "/usr/local/share/skribe/extensions")
-(define (skribe-default-path) '("." "/usr/local/share/skribe/extensions" "/usr/local/share/skribe/1.2d/skr" ))
-(define (skribe-scheme) "bigloo")
-
diff --git a/src/common/configure.scm.in b/src/common/configure.scm.in
deleted file mode 100644
index 830ec4d..0000000
--- a/src/common/configure.scm.in
+++ /dev/null
@@ -1,6 +0,0 @@
-(define (skribe-release) "@SKRIBE_RELEASE@")
-(define (skribe-url) "@SKRIBE_URL@")
-(define (skribe-doc-dir) "@SKRIBE_DOC_DIR@")
-(define (skribe-ext-dir) "@SKRIBE_EXT_DIR@")
-(define (skribe-default-path) @SKRIBE_SKR_PATH@)
-(define (skribe-scheme) "@SKRIBE_SCHEME@")
diff --git a/src/common/lib.scm b/src/common/lib.scm
deleted file mode 100644
index b0fa2d0..0000000
--- a/src/common/lib.scm
+++ /dev/null
@@ -1,238 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/lib.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Sep 10 11:57:54 2003 */
-;* Last change : Wed Oct 27 12:16:40 2004 (eg) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Scheme independent lib part. */
-;* ------------------------------------------------------------- */
-;* Implementation: @label lib@ */
-;* bigloo: @path ../bigloo/lib.bgl@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* 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)))))
-
diff --git a/src/common/param.scm b/src/common/param.scm
deleted file mode 100644
index ba8d489..0000000
--- a/src/common/param.scm
+++ /dev/null
@@ -1,69 +0,0 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/param.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Jul 30 09:06:53 2003 */
-;* Last change : Thu Oct 28 21:51:49 2004 (eg) */
-;* Copyright : 2003 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Common Skribe parameters */
-;* Implementation: @label param@ */
-;* bigloo: @path ../bigloo/param.bgl@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* *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")))
diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am
new file mode 100644
index 0000000..e410a87
--- /dev/null
+++ b/src/guile/Makefile.am
@@ -0,0 +1,5 @@
+SUBDIRS = skribilo
+
+guilemoduledir = $(GUILE_SITE)
+dist_guilemodule_DATA = skribilo.scm
+EXTRA_DIST = README
diff --git a/src/guile/README b/src/guile/README
new file mode 100644
index 0000000..6c5128f
--- /dev/null
+++ b/src/guile/README
@@ -0,0 +1,63 @@
+Skribilo -*- Outline -*-
+========
+
+Skribilo is a port of Skribe to GNU Guile.
+
+Here are a few goals.
+
+* Usability
+
+** Integration with Guile's module system
+
+** Better error handling, automatic back-traces, etc.
+
+** Add useful markups
+
+- `document': add `:keywords' and `:language', maybe `:date'
+
+- numbered references
+
+- improved footnotes
+
+** Add an option to continuously watch a file and re-compile it
+
+* Font-ends (readers)
+
+** Implement a new front-end mechanism (see `(skribilo reader)')
+
+** Skribe front-end (read Skribe syntax)
+
+Done.
+
+** Texinfo front-end
+
+Use guile-library's `stexi'.
+
+** Simple markup front-end (à la `txt2tags', Emacs' outline mode, or Wiki)
+
+Almost done (Emacs `outline-mode').
+
+* Back-ends (engines)
+
+** Easier to plug-in new back-ends (no need to modify the source)
+
+** Better HTML (or XHTML?) back-end
+
+** Lout back-end (including automatic `lout' invocation?)
+
+Done, except automatic invocation.
+
+** Info back-end
+
+* Packages
+
+** Pie charts
+
+** Equations
+
+* Toys
+
+** Document browser with guile-gnome
+
+
+;;; arch-tag: 2d0a6235-5c09-4930-998c-56a4de2c0aca
diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm
new file mode 100644
index 0000000..531b0fb
--- /dev/null
+++ b/src/guile/skribilo.scm
@@ -0,0 +1,480 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(skribilo)) '\'main')'
+exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+
+;;;; skribilo.scm
+;;;;
+;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;;; USA.
+
+;;;; Commentary:
+;;;;
+;;;; Usage: skribilo [ARGS]
+;;;;
+;;;; Process a skribilo document.
+;;;;
+;;;; Code:
+
+
+
+(define-module (skribilo)
+ :autoload (skribilo module) (make-run-time-module *skribilo-user-module*)
+ :autoload (skribilo engine) (*current-engine*)
+ :autoload (skribilo reader) (*document-reader*)
+ :use-module (skribilo utils syntax))
+
+(use-modules (skribilo evaluator)
+ (skribilo debug)
+ (skribilo parameters)
+ (skribilo lib)
+
+ (srfi srfi-39)
+ (ice-9 optargs)
+ (ice-9 getopt-long))
+
+
+;; Install the Skribilo module syntax reader.
+(fluid-set! current-reader %skribilo-module-reader)
+
+(if (not (keyword? :kw))
+ (error "guile-reader sucks"))
+
+
+
+
+(define* (process-option-specs longname
+ :key (alternate #f) (arg #f) (help #f)
+ :rest thunk)
+ "Process STkLos-like option specifications and return getopt-long option
+specifications."
+ `(,(string->symbol longname)
+ ,@(if alternate
+ `((single-char ,(string-ref alternate 0)))
+ '())
+ (value ,(if arg #t #f))))
+
+(define (raw-options->getopt-long options)
+ "Converts @var{options} to a getopt-long-compatible representation."
+ (map (lambda (option-specs)
+ (apply process-option-specs (car option-specs)))
+ options))
+
+(define-macro (define-options binding . options)
+ `(define ,binding (quote ,(raw-options->getopt-long options))))
+
+(define-options skribilo-options
+ (("reader" :alternate "R" :arg reader
+ (nothing)))
+ (("target" :alternate "t" :arg target
+ :help "sets the output format to <target>")
+ (set! engine (string->symbol target)))
+ (("load-path" :alternate "I" :arg path :help "adds <path> to Skribe path")
+ (set! paths (cons path paths)))
+ (("bib-path" :alternate "B" :arg path :help "adds <path> to bibliography path")
+ (skribe-bib-path-set! (cons path (skribe-bib-path))))
+ (("source-path" :alternate "S" :arg path :help "adds <path> to source path")
+ (skribe-source-path-set! (cons path (skribe-source-path))))
+ (("image-path" :alternate "P" :arg path :help "adds <path> to image path")
+ (skribe-image-path-set! (cons path (skribe-image-path))))
+ (("split-chapters" :alternate "C" :arg chapter
+ :help "emit chapter's sections in separate files")
+ (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
+ (("preload" :arg file :help "preload <file>")
+ (set! *skribe-preload* (cons file *skribe-preload*)))
+ (("use-variant" :alternate "u" :arg variant
+ :help "use <variant> output format")
+ (set! *skribe-variants* (cons variant *skribe-variants*)))
+ (("base" :alternate "b" :arg base
+ :help "base prefix to remove from hyperlinks")
+ (set! *skribe-ref-base* base))
+ (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>")
+ (set! *skribe-rc-directory* dir))
+
+ ;;"File options:"
+ (("no-init-file" :help "Dont load rc Skribe file")
+ (set! *load-rc* #f))
+ (("output" :alternate "o" :arg file :help "set the output to <file>")
+ (set! *skribe-dest* file)
+ (let* ((s (file-suffix file))
+ (c (assoc s *skribe-auto-mode-alist*)))
+ (if (and (pair? c) (symbol? (cdr c)))
+ (set! *skribe-engine* (cdr c)))))
+
+ ;;"Misc:"
+ (("help" :alternate "h" :help "provides help for the command")
+ (arg-usage (current-error-port))
+ (exit 0))
+ (("options" :help "display the skribe options and exit")
+ (arg-usage (current-output-port) #t)
+ (exit 0))
+ (("version" :alternate "V" :help "displays the version of Skribe")
+ (version)
+ (exit 0))
+ (("query" :alternate "q"
+ :help "displays informations about Skribe conf.")
+ (query)
+ (exit 0))
+ (("verbose" :alternate "v" :arg level
+ :help "sets the verbosity to <level>. Use -v0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-verbose* val))))
+ (("warning" :alternate "w" :arg level
+ :help "sets the verbosity to <level>. Use -w0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-warning* val))))
+ (("debug" :alternate "g" :arg level :help "sets the debug <level>")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set-skribe-debug! val)
+ (begin
+ ;; Use the symbol for debug
+ (set-skribe-debug! 1)
+ (add-skribe-debug-symbol (string->symbol level))))))
+ (("no-color" :help "disable coloring for output")
+ (no-debug-color))
+ (("custom" :alternate "c" :arg key=val :help "Preset custom value")
+ (let ((args (string-split key=val "=")))
+ (if (and (list args) (= (length args) 2))
+ (let ((key (car args))
+ (val (cadr args)))
+ (set! *skribe-precustom* (cons (cons (string->symbol key) val)
+ *skribe-precustom*)))
+ (error 'parse-arguments "Bad custom ~S" key=val))))
+ (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>")
+ (with-input-from-string expr
+ (lambda () (eval (read))))))
+
+
+; (define skribilo-options
+; ;; Skribilo options in getopt-long's format, as computed by
+; ;; `raw-options->getopt-long'.
+; `((target (single-char #\t) (value #f))
+; (I (value #f))
+; (B (value #f))
+; (S (value #f))
+; (P (value #f))
+; (split-chapters (single-char #\C) (value #f))
+; (preload (value #f))
+; (use-variant (single-char #\u) (value #f))
+; (base (single-char #\b) (value #f))
+; (rc-dir (single-char #\d) (value #f))
+; (no-init-file (value #f))
+; (output (single-char #\o) (value #f))
+; (help (single-char #\h) (value #f))
+; (options (value #f))
+; (version (single-char #\V) (value #f))
+; (query (single-char #\q) (value #f))
+; (verbose (single-char #\v) (value #f))
+; (warning (single-char #\w) (value #f))
+; (debug (single-char #\g) (value #f))
+; (no-color (value #f))
+; (custom (single-char #\c) (value #f))
+; (eval (single-char #\e) (value #f))))
+
+
+(define (skribilo-show-help)
+ (format #t "Usage: skribilo [OPTIONS] [INPUT]
+
+Processes a Skribilo/Skribe source file and produces its output.
+
+ --reader=READER Use READER to parse the input file (by default,
+ the `skribe' reader is used)
+ --target=ENGINE Use ENGINE as the underlying engine
+
+ --help Give this help list
+ --version Print program version
+~%"))
+
+(define (skribilo-show-version)
+ (format #t "skribilo ~a~%" (skribilo-release)))
+
+;;;; ======================================================================
+;;;;
+;;;; P A R S E - A R G S
+;;;;
+;;;; ======================================================================
+(define (parse-args args)
+
+ (define (version)
+ (format #t "skribe v~A\n" (skribe-release)))
+
+ (define (query)
+ (version)
+ (for-each (lambda (x)
+ (let ((s (keyword->string (car x))))
+ (printf " ~a: ~a\n" s (cadr x))))
+ (skribe-configure)))
+
+ ;;
+ ;; parse-args starts here
+ ;;
+ (let ((paths '())
+ (engine #f))
+ (parse-arguments args
+ "Usage: skribe [options] [input]"
+ "General options:"
+ (("target" :alternate "t" :arg target
+ :help "sets the output format to <target>")
+ (set! engine (string->symbol target)))
+ (("I" :arg path :help "adds <path> to Skribe path")
+ (set! paths (cons path paths)))
+ (("B" :arg path :help "adds <path> to bibliography path")
+ (skribe-bib-path-set! (cons path (skribe-bib-path))))
+ (("S" :arg path :help "adds <path> to source path")
+ (skribe-source-path-set! (cons path (skribe-source-path))))
+ (("P" :arg path :help "adds <path> to image path")
+ (skribe-image-path-set! (cons path (skribe-image-path))))
+ (("split-chapters" :alternate "C" :arg chapter
+ :help "emit chapter's sections in separate files")
+ (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
+ (("preload" :arg file :help "preload <file>")
+ (set! *skribe-preload* (cons file *skribe-preload*)))
+ (("use-variant" :alternate "u" :arg variant
+ :help "use <variant> output format")
+ (set! *skribe-variants* (cons variant *skribe-variants*)))
+ (("base" :alternate "b" :arg base
+ :help "base prefix to remove from hyperlinks")
+ (set! *skribe-ref-base* base))
+ (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>")
+ (set! *skribe-rc-directory* dir))
+
+ "File options:"
+ (("no-init-file" :help "Dont load rc Skribe file")
+ (set! *load-rc* #f))
+ (("output" :alternate "o" :arg file :help "set the output to <file>")
+ (set! *skribe-dest* file)
+ (let* ((s (file-suffix file))
+ (c (assoc s *skribe-auto-mode-alist*)))
+ (if (and (pair? c) (symbol? (cdr c)))
+ (set! *skribe-engine* (cdr c)))))
+
+ "Misc:"
+ (("help" :alternate "h" :help "provides help for the command")
+ (arg-usage (current-error-port))
+ (exit 0))
+ (("options" :help "display the skribe options and exit")
+ (arg-usage (current-output-port) #t)
+ (exit 0))
+ (("version" :alternate "V" :help "displays the version of Skribe")
+ (version)
+ (exit 0))
+ (("query" :alternate "q"
+ :help "displays informations about Skribe conf.")
+ (query)
+ (exit 0))
+ (("verbose" :alternate "v" :arg level
+ :help "sets the verbosity to <level>. Use -v0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-verbose* val))))
+ (("warning" :alternate "w" :arg level
+ :help "sets the verbosity to <level>. Use -w0 for crystal silence")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set! *skribe-warning* val))))
+ (("debug" :alternate "g" :arg level :help "sets the debug <level>")
+ (let ((val (string->number level)))
+ (if (integer? val)
+ (set-skribe-debug! val)
+ (begin
+ ;; Use the symbol for debug
+ (set-skribe-debug! 1)
+ (add-skribe-debug-symbol (string->symbol level))))))
+ (("no-color" :help "disable coloring for output")
+ (no-debug-color))
+ (("custom" :alternate "c" :arg key=val :help "Preset custom value")
+ (let ((args (string-split key=val "=")))
+ (if (and (list args) (= (length args) 2))
+ (let ((key (car args))
+ (val (cadr args)))
+ (set! *skribe-precustom* (cons (cons (string->symbol key) val)
+ *skribe-precustom*)))
+ (error 'parse-arguments "Bad custom ~S" key=val))))
+ (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>")
+ (with-input-from-string expr
+ (lambda () (eval (read)))))
+ (else
+ (set! *skribe-src* other-arguments)))
+
+ ;; we have to configure Skribe path according to the environment variable
+ (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH")))
+ (if path
+ (string-split path ":")
+ '()))
+ (reverse! paths)
+ (skribe-default-path)))
+ ;; Final initializations
+ (if engine
+ (set! *skribe-engine* engine))))
+
+;;;; ======================================================================
+;;;;
+;;;; L O A D - R C
+;;;;
+;;;; ======================================================================
+(define *load-rc* #f) ;; FIXME: This should go somewhere else.
+
+(define (load-rc)
+ (if *load-rc*
+ (let ((file (make-path (*rc-directory*) (*rc-file*))))
+ (if (and file (file-exists? file))
+ (load file)))))
+
+
+;;;; ======================================================================
+;;;;
+;;;; S K R I B E
+;;;;
+;;;; ======================================================================
+; (define (doskribe)
+; (let ((e (find-engine *skribe-engine*)))
+; (if (and (engine? e) (pair? *skribe-precustom*))
+; (for-each (lambda (cv)
+; (engine-custom-set! e (car cv) (cdr cv)))
+; *skribe-precustom*))
+; (if (pair? *skribe-src*)
+; (for-each (lambda (f) (skribe-load f :engine *skribe-engine*))
+; *skribe-src*)
+; (skribe-eval-port (current-input-port) *skribe-engine*))))
+
+(define *skribilo-output-port* (make-parameter (current-output-port)))
+
+(define (doskribe)
+ (let ((output-port (current-output-port))
+ (user-module (current-module)))
+ (dynamic-wind
+ (lambda ()
+ ;; FIXME: Using this technique, anything written to `stderr' will
+ ;; also end up in the output file (e.g. Guile warnings).
+ (set-current-output-port (*skribilo-output-port*))
+ (let ((user (make-run-time-module)))
+ (set-current-module user)
+ (*skribilo-user-module* user)))
+ (lambda ()
+ ;;(format #t "engine is ~a~%" (*current-engine*))
+ (evaluate-document-from-port (current-input-port)
+ (*current-engine*)))
+ (lambda ()
+ (set-current-output-port output-port)
+ (set-current-module user-module)
+ (*skribilo-user-module* #f)))))
+
+
+
+;;;; ======================================================================
+;;;;
+;;;; M A I N
+;;;;
+;;;; ======================================================================
+(define-public (skribilo . args)
+ (let* ((options (getopt-long (cons "skribilo" args)
+ skribilo-options))
+ (reader-name (string->symbol
+ (option-ref options 'reader "skribe")))
+ (engine (string->symbol
+ (option-ref options 'target "html")))
+ (output-file (option-ref options 'output #f))
+ (debugging-level (option-ref options 'debug "0"))
+ (warning-level (option-ref options 'warning "2"))
+ (load-path (option-ref options 'load-path "."))
+ (bib-path (option-ref options 'bib-path "."))
+ (source-path (option-ref options 'source-path "."))
+ (image-path (option-ref options 'image-path "."))
+ (preload '())
+ (variants '())
+
+ (help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f)))
+
+ ;; Set up the debugging infrastructure.
+ (debug-enable 'debug)
+ (debug-enable 'backtrace)
+ (debug-enable 'procnames)
+
+ (cond (help-wanted (begin (skribilo-show-help) (exit 1)))
+ (version-wanted (begin (skribilo-show-version) (exit 1))))
+
+ ;; Parse the most important options.
+
+ (if (> (*debug*) 4)
+ (set! %load-hook
+ (lambda (file)
+ (format #t "~~ loading `~a'...~%" file))))
+
+ (parameterize ((*document-reader* (make-reader reader-name))
+ (*current-engine* engine)
+ (*document-path* (cons load-path (*document-path*)))
+ (*bib-path* (cons bib-path (*bib-path*)))
+ (*source-path* (cons source-path
+ (append %load-path
+ (*source-path*))))
+ (*image-path* (cons image-path (*image-path*)))
+ (*debug* (string->number debugging-level))
+ (*warning* (string->number warning-level))
+ (*verbose* (let ((v (option-ref options
+ 'verbose 0)))
+ (if (number? v) v
+ (if v 1 0)))))
+
+ ;; Load the user rc file
+ ;;(load-rc)
+
+ (for-each (lambda (f)
+ (skribe-load f :engine (*current-engine*)))
+ preload)
+
+ ;; Load the specified variants.
+ (for-each (lambda (x)
+ (skribe-load (format #f "~a.skr" x)
+ :engine (*current-engine*)))
+ (reverse! variants))
+
+ (let ((files (option-ref options '() '())))
+
+ (if (> (length files) 2)
+ (error "you can specify at most one input file and one output file"
+ files))
+
+ (let* ((source-file (if (null? files) #f (car files))))
+
+ (if (and output-file (file-exists? output-file))
+ (delete-file output-file))
+
+ (parameterize ((*destination-file* output-file)
+ (*source-file* source-file)
+ (*skribilo-output-port*
+ (if (string? output-file)
+ (open-output-file output-file)
+ (current-output-port))))
+
+ (setvbuf (*skribilo-output-port*) _IOFBF 16384)
+
+ ;; (start-stack 7
+ (if source-file
+ (with-input-from-file source-file doskribe)
+ (doskribe))))))))
+
+
+(define main skribilo)
+
+;;; skribilo ends here.
diff --git a/src/guile/skribilo/.arch-inventory b/src/guile/skribilo/.arch-inventory
new file mode 100644
index 0000000..d9ada5e
--- /dev/null
+++ b/src/guile/skribilo/.arch-inventory
@@ -0,0 +1,5 @@
+# Object files generated by Guile-VM's compiler + configuration file
+# generated at `configure'-time.
+precious ^(.*\.go|config.scm)$
+
+# arch-tag: c25ac71e-94bc-4246-8486-49e4179987b8
diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am
new file mode 100644
index 0000000..48fa5ca
--- /dev/null
+++ b/src/guile/skribilo/Makefile.am
@@ -0,0 +1,10 @@
+guilemoduledir = $(GUILE_SITE)/skribilo
+dist_guilemodule_DATA = biblio.scm color.scm config.scm \
+ debug.scm engine.scm evaluator.scm \
+ lib.scm module.scm output.scm prog.scm \
+ reader.scm resolve.scm \
+ source.scm parameters.scm verify.scm \
+ writer.scm ast.scm location.scm \
+ condition.scm
+
+SUBDIRS = utils reader engine package coloring biblio
diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm
new file mode 100644
index 0000000..542f629
--- /dev/null
+++ b/src/guile/skribilo/ast.scm
@@ -0,0 +1,602 @@
+;;; ast.scm -- Skribilo abstract syntax trees.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo ast)
+ :use-module (oop goops)
+
+ :use-module (srfi srfi-34)
+ :use-module (srfi srfi-35)
+ :use-module (skribilo condition)
+ :use-module (skribilo utils syntax)
+
+ :autoload (skribilo location) (location?)
+ :autoload (srfi srfi-1) (fold)
+ :export (<ast> ast? ast-loc ast-loc-set!
+ ast-parent ast->string ast->file-location
+ ast-resolved?
+
+ <command> command? command-fmt command-body
+ <unresolved> unresolved? unresolved-proc
+ <handle> handle? handle-ast handle-body
+ <node> node? node-options node-loc node-body
+ <processor> processor? processor-combinator processor-engine
+
+ <markup> markup? markup-options is-markup?
+ markup-markup markup-body markup-body-set!
+ markup-ident markup-class
+ markup-option markup-option-set!
+ markup-option-add! markup-output
+ markup-parent markup-document markup-chapter
+
+ <container> container? container-options
+ container-ident container-body
+ container-env-get
+
+ <document> document? document-ident document-body
+ document-options document-end
+ document-lookup-node document-bind-node!
+ document-bind-nodes!
+
+ ;; traversal
+ ast-fold
+ container-search-down search-down find-down find1-down
+ find-up find1-up
+ ast-document ast-chapter ast-section
+
+ ;; error conditions
+ &ast-error &ast-orphan-error &ast-cycle-error
+ &markup-unknown-option-error &markup-already-bound-error
+ ast-orphan-error? ast-orphan-error:ast
+ ast-cycle-error? ast-cycle-error:object
+ markup-unknown-option-error?
+ markup-unknown-option-error:markup
+ markup-unknown-option-error:option
+ markup-already-bound-error?
+ markup-already-bound-error:markup
+ markup-already-bound-error:ident))
+
+;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; The abstract syntax tree (AST) and its sub-types. These class form the
+;;; core of a document: each part of a document is an instance of `<ast>' or
+;;; one of its sub-classes.
+;;;
+;;; Code:
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &ast-error &skribilo-error
+ ast-error?)
+
+(define-condition-type &ast-orphan-error &ast-error
+ ast-orphan-error?
+ (ast ast-orphan-error:ast))
+
+(define-condition-type &ast-cycle-error &ast-error
+ ast-cycle-error?
+ (object ast-cycle-error:object))
+
+(define-condition-type &markup-unknown-option-error &ast-error
+ markup-unknown-option-error?
+ (markup markup-unknown-option-error:markup)
+ (option markup-unknown-option-error:option))
+
+(define-condition-type &markup-already-bound-error &ast-error
+ markup-already-bound-error?
+ (markup markup-already-bound-error:markup)
+ (ident markup-already-bound-error:ident))
+
+
+(define (handle-ast-error c)
+ ;; Issue a user-friendly error message for error condition C.
+ (cond ((ast-orphan-error? c)
+ (let* ((node (ast-orphan-error:ast c))
+ (location (and (ast? node) (ast-loc node))))
+ (format (current-error-port) "orphan node: ~a~a~%"
+ node
+ (if (location? location)
+ (string-append " "
+ (location-file location) ":"
+ (location-line location))
+ ""))))
+
+ ((ast-cycle-error? c)
+ (let ((object (ast-cycle-error:object c)))
+ (format (current-error-port)
+ "cycle found in AST: ~a~%" object)))
+
+ ((markup-unknown-option-error? c)
+ (let ((markup (markup-unknown-option-error:markup c))
+ (option (markup-unknown-option-error:option c)))
+ (format (current-error-port)
+ "~a: unknown markup option for `~a'~%"
+ option markup)))
+
+ ((markup-already-bound-error? c)
+ (let ((markup (markup-already-bound-error:markup c))
+ (ident (markup-already-bound-error:ident c)))
+ (format (current-error-port)
+ "`~a' (~a): markup identifier already bound~%"
+ ident
+ (if (markup? markup)
+ (markup-markup markup)
+ markup))))
+
+ (else
+ (format (current-error-port) "undefined resolution error: ~a~%"
+ c))))
+
+(register-error-condition-handler! ast-error? handle-ast-error)
+
+
+
+;;;
+;;; Abstract syntax tree (AST).
+;;;
+
+;;FIXME: set! location in <ast>
+(define-class <ast> ()
+ ;; Parent of this guy.
+ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified)
+
+ ;; Its source location.
+ (loc :init-value #f)
+
+ ;; This slot is used as an optimization when resolving an AST: sub-parts of
+ ;; the tree are marked as resolved as soon as they are and don't need to be
+ ;; traversed again.
+ (resolved? :accessor ast-resolved? :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))
+(define (ast-parent n)
+ (slot-ref n 'parent))
+
+
+(define (ast->file-location ast)
+ (let ((l (ast-loc ast)))
+ (if (location? l)
+ (format #f "~a:~a:" (location-file l) (location-line l))
+ "")))
+
+(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)))))))
+
+
+
+;;; ======================================================================
+;;;
+;;; <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))
+(define (handle-body h) (slot-ref h 'body))
+
+;;; ======================================================================
+;;;
+;;; <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)
+
+(define-method (ast->string (ast <node>))
+ (ast->string (slot-ref ast 'body)))
+
+
+;;; ======================================================================
+;;;
+;;; <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 (markup? obj) (is-a? obj <markup>))
+(define (markup-options obj) (slot-ref obj 'options))
+(define markup-body node-body)
+(define (markup-body-set! m body)
+ (slot-set! m 'resolved? #f)
+ (slot-set! m 'body body))
+
+(define (markup-option m opt)
+ (if (markup? m)
+ (let ((c (assq opt (slot-ref m 'options))))
+ (and (pair? c) (pair? (cdr c))
+ (cadr c)))
+ (raise (condition (&invalid-argument-error
+ (proc-name "markup-option")
+ (argument m))))))
+
+(define (markup-option-set! m opt val)
+ (if (markup? m)
+ (let ((c (assq opt (slot-ref m 'options))))
+ (if (and (pair? c) (pair? (cdr c)))
+ (set-cdr! c (list val))
+ (raise (condition (&markup-unknown-option-error
+ (markup m)
+ (option opt))))))
+ (raise (condition (&invalid-argument-error
+ (proc-name "markup-option-set!")
+ (argument m))))))
+
+(define (markup-option-add! m opt val)
+ (if (markup? m)
+ (slot-set! m 'options (cons (list opt val)
+ (slot-ref m 'options)))
+ (raise (condition (&invalid-argument-error
+ (proc-name "markup-option-add!")
+ (argument m))))))
+
+
+(define (is-markup? obj markup)
+ (and (is-a? obj <markup>)
+ (eq? (slot-ref obj 'markup) markup)))
+
+
+(define (markup-parent m)
+ (let ((p (slot-ref m 'parent)))
+ (if (eq? p 'unspecified)
+ (raise (condition (&ast-orphan-error (ast m))))
+ p)))
+
+(define (markup-document m)
+ (let Loop ((p m)
+ (l #f))
+ (cond
+ ((is-markup? p 'document) p)
+ ((or (eq? p 'unspecified) (not p)) l)
+ (else (Loop (slot-ref p 'parent) p)))))
+
+(define (markup-chapter m)
+ (let loop ((p m)
+ (l #f))
+ (cond
+ ((is-markup? p 'chapter) p)
+ ((or (eq? p 'unspecified) (not p)) l)
+ (else (loop (slot-ref p 'parent) p)))))
+
+
+
+
+(define-method (write (obj <markup>) port)
+ (format port "#<~A (~A/~A) ~A>"
+ (class-name (class-of obj))
+ (slot-ref obj 'markup)
+ (slot-ref obj 'ident)
+ (object-address obj)))
+
+(define-method (write (node <unresolved>) port)
+ (let ((proc (slot-ref node 'proc)))
+ (format port "#<<unresolved> (~A~A) ~A>"
+ proc
+ (let* ((name (or (procedure-name proc) ""))
+ (source (procedure-source proc))
+ (file (and source (source-property source 'filename)))
+ (line (and source (source-property source 'line))))
+ ;;(format (current-error-port) "src=~a~%" source)
+ (string-append name
+ (if file
+ (string-append " " file
+ (if line
+ (number->string line)
+ ""))
+ "")))
+ (object-address node))))
+
+
+
+;;; XXX: This was already commented out in the original Skribe source.
+;;;
+;; (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))))))))
+
+
+
+;;; ======================================================================
+;;;
+;;; <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)
+
+(define (container-env-get m key)
+ (let ((c (assq key (slot-ref m 'env))))
+ (and (pair? c) (cadr c))))
+
+
+
+;;;
+;;; Document.
+;;;
+
+(define-class <document> (<container>)
+ (node-table :init-thunk make-hash-table :getter document-node-table)
+ (nodes-bound? :init-value #f :getter document-nodes-bound?))
+
+
+(define (document? obj) (is-a? obj <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)
+
+(define (document-lookup-node doc ident)
+ ;; Lookup the node with identifier IDENT (a string) in document DOC.
+ (hash-ref (document-node-table doc) ident))
+
+(define (document-bind-node! doc node . ident)
+ ;; Bind NODE (a markup object) to DOC (a document object).
+ (let ((ident (if (null? ident) (markup-ident node) (car ident))))
+ (if ident
+ (let ((handle (hash-get-handle (document-node-table doc) ident)))
+ ;;(format (current-error-port) "binding `~a' in `~a'~%" ident node)
+ (if (and (pair? handle) (not (eq? (cdr handle) node)))
+ (raise (condition (&markup-already-bound-error
+ (ident ident)
+ (markup node))))
+ (hash-set! (document-node-table doc) ident node))))))
+
+(define (document-bind-nodes! doc)
+ ;; Bind all the nodes contained in DOC if they are not already bound.
+ ;; Once, this is done, `document-lookup-node' can be used to search a node
+ ;; by its identifier.
+
+ ;; We assume that unresolved nodes do not introduce any new identifier,
+ ;; hence this optimization.
+ (if (document-nodes-bound? doc)
+ #t
+ (begin
+ (ast-fold (lambda (node result)
+ (if (markup? node) (document-bind-node! doc node))
+ #t)
+ #t ;; unused
+ doc)
+ (slot-set! doc 'nodes-bound? #t))))
+
+
+;;;
+;;; AST traversal utilities.
+;;;
+
+(define (ast-fold proc init ast)
+ ;; Apply PROC to each node in AST (per `node?'), in a way similar to `fold'
+ ;; (in SRFI-1).
+ (let loop ((ast ast)
+ (result init))
+ (cond ((pair? ast)
+ (fold loop result ast))
+ ((node? ast)
+ (loop (node-body ast) (proc ast result)))
+ (else result))))
+
+
+;; The procedures below are almost unchanged compared to Skribe 1.2d's
+;; `lib.scm' file found in the `common' directory, written by Manuel Serrano
+;; (I removed uses of `with-debug' et al., though).
+
+
+(define (container-search-down pred obj)
+ (let loop ((obj (markup-body obj)))
+ (cond
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((container? obj)
+ (let ((rest (loop (markup-body obj))))
+ (if (pred obj)
+ (cons obj rest)
+ rest)))
+ ((pred obj)
+ (list obj))
+ (else
+ '()))))
+
+(define (search-down pred obj)
+ (let loop ((obj (markup-body obj)))
+ (cond
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((markup? obj)
+ (let ((rest (loop (markup-body obj))))
+ (if (pred obj)
+ (cons obj rest)
+ rest)))
+ ((pred obj)
+ (list obj))
+ (else
+ '()))))
+
+(define (find-down pred obj)
+ (let loop ((obj obj))
+ (cond
+ ((pair? obj)
+ (apply append (map (lambda (o) (loop o)) obj)))
+ ((markup? obj)
+ (if (pred obj)
+ (list (cons obj (loop (markup-body obj))))
+ '()))
+ (else
+ (if (pred obj)
+ (list obj)
+ '())))))
+
+(define (find1-down pred obj)
+ (let loop ((obj obj)
+ (stack '()))
+ (cond
+ ((memq obj stack)
+ (raise (condition (&ast-cycle-error (object obj)))))
+ ((pair? obj)
+ (let liip ((obj obj))
+ (cond
+ ((null? obj)
+ #f)
+ (else
+ (or (loop (car obj) (cons obj stack))
+ (liip (cdr obj)))))))
+ ((pred obj)
+ obj)
+ ((markup? obj)
+ (loop (markup-body obj) (cons obj stack)))
+ (else
+ #f))))
+
+(define (find-up pred obj)
+ (let loop ((obj obj)
+ (res '()))
+ (cond
+ ((not (ast? obj))
+ res)
+ ((pred obj)
+ (loop (ast-parent obj) (cons obj res)))
+ (else
+ (loop (ast-parent obj) (cons obj res))))))
+
+(define (find1-up pred obj)
+ (let loop ((obj obj))
+ (cond
+ ((not (ast? obj))
+ #f)
+ ((pred obj)
+ obj)
+ (else
+ (loop (ast-parent obj))))))
+
+(define (ast-document m)
+ (find1-up document? m))
+
+(define (ast-chapter m)
+ (find1-up (lambda (n) (is-markup? n 'chapter)) m))
+
+(define (ast-section m)
+ (find1-up (lambda (n) (is-markup? n 'section)) m))
+
+
+;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7
+
+;;; ast.scm ends here
diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm
new file mode 100644
index 0000000..1fb4b78
--- /dev/null
+++ b/src/guile/skribilo/biblio.scm
@@ -0,0 +1,382 @@
+;;; biblio.scm -- Bibliography functions.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.main.st
+
+
+
+(define-module (skribilo biblio)
+ :use-module (skribilo utils strings)
+ :use-module (skribilo utils syntax) ;; `when', `unless'
+
+ :autoload (srfi srfi-34) (raise)
+ :use-module (srfi srfi-35)
+ :use-module (srfi srfi-1)
+ :autoload (skribilo condition) (&file-search-error)
+
+ :autoload (skribilo reader) (%default-reader)
+ :autoload (skribilo parameters) (*bib-path*)
+ :autoload (skribilo ast) (<markup> <handle> is-markup?)
+
+ :use-module (ice-9 optargs)
+ :use-module (oop goops)
+
+ :export (bib-table? make-bib-table default-bib-table
+ bib-add! bib-duplicate bib-for-each bib-map
+ skribe-open-bib-file parse-bib
+
+ bib-load! resolve-bib resolve-the-bib make-bib-entry
+
+ ;; sorting entries
+ bib-sort/authors bib-sort/idents bib-sort/dates))
+
+;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Provides the bibliography data type and basic bibliography handling,
+;;; including simple procedures to sort bibliography entries.
+;;;
+;;; FIXME: This module need cleanup!
+;;;
+;;; Code:
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;; FIXME: Should be a fluid?
+(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)
+ (hash-table? obj))
+
+(define (default-bib-table)
+ (unless *bib-table*
+ (set! *bib-table* (make-bib-table "default-bib-table")))
+ *bib-table*)
+
+(define (%bib-error who entry)
+ (let ((msg "bibliography syntax error on entry"))
+ (if (%epair? entry)
+ (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry)
+ (skribe-error who msg entry))))
+
+(define* (bib-for-each proc :optional (table (default-bib-table)))
+ (hash-for-each (lambda (ident entry)
+ (proc ident entry))
+ table))
+
+(define* (bib-map proc :optional (table (default-bib-table)))
+ (hash-map->list (lambda (ident entry)
+ (proc ident entry))
+ table))
+
+
+;;; ======================================================================
+;;;
+;;; BIB-DUPLICATE
+;;;
+;;; ======================================================================
+(define (bib-duplicate ident from old)
+ (let ((ofrom (markup-option old 'from)))
+ (skribe-warning 2
+ 'bib
+ (format #f "duplicated bibliographic entry ~a'.\n" ident)
+ (if ofrom
+ (format #f " using version of `~a'.\n" ofrom)
+ "")
+ (if from
+ (format #f " ignoring version of `~a'." from)
+ " ignoring redefinition."))))
+
+
+;;; ======================================================================
+;;;
+;;; PARSE-BIB
+;;;
+;;; ======================================================================
+(define (parse-bib table port)
+ (let ((read %default-reader)) ;; FIXME: We should use a fluid
+ (if (not (bib-table? table))
+ (skribe-error 'parse-bib "Illegal bibliography table" table)
+ (let ((from (port-filename port)))
+ (let Loop ((entry (read port)))
+ (unless (eof-object? entry)
+ (cond
+ ((and (list? entry) (> (length entry) 2))
+ (let* ((kind (car entry))
+ (key (format #f "~A" (cadr entry)))
+ (fields (cddr entry))
+ (old (hash-ref table key)))
+ (if old
+ (bib-duplicate ident from old)
+ (hash-set! 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 #f "~A" (cadr entry)))
+ (fields (cddr entry))
+ (old (hash-ref table key)))
+ (if old
+ (bib-duplicate key #f old)
+ (hash-set! 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 (search-path (*bib-path*) file)))
+ (if (string? path)
+ (begin
+ (when (> (*verbose*) 0)
+ (format (current-error-port) " [loading bibliography: ~S]\n" path))
+ (open-input-file (if (string? command)
+ (string-append "| "
+ (format #f command path))
+ path)))
+ (raise (condition (&file-search-error (file-name file)
+ (path (*bib-path*))))))))
+
+
+;;;
+;;; High-level API.
+;;;
+;;; The contents of the file below are unchanged compared to Skribe 1.2d's
+;;; `bib.scm' file found in the `common' directory. The copyright notice for
+;;; this file was:
+;;;
+;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano
+;;;
+
+
+;*---------------------------------------------------------------------*/
+;* bib-load! ... */
+;*---------------------------------------------------------------------*/
+(define (bib-load! table filename command)
+ (if (not (bib-table? table))
+ (skribe-error 'bib-load "Illegal bibliography table" table)
+ ;; read the file
+ (let ((p (skribe-open-bib-file filename command)))
+ (if (not (input-port? p))
+ (skribe-error 'bib-load "Can't open data base" filename)
+ (unwind-protect
+ (parse-bib table p)
+ (close-input-port p))))))
+
+;*---------------------------------------------------------------------*/
+;* resolve-bib ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-bib table ident)
+ (if (not (bib-table? table))
+ (skribe-error 'resolve-bib "Illegal bibliography table" table)
+ (let* ((i (cond
+ ((string? ident) ident)
+ ((symbol? ident) (symbol->string ident))
+ (else (skribe-error 'resolve-bib "Illegal ident" ident))))
+ (en (hash-ref table i)))
+ (if (is-markup? en '&bib-entry)
+ en
+ #f))))
+
+;*---------------------------------------------------------------------*/
+;* make-bib-entry ... */
+;*---------------------------------------------------------------------*/
+(define (make-bib-entry kind ident fields from)
+ (let* ((m (make <markup>
+ :markup '&bib-entry
+ :ident ident
+ :options `((kind ,kind) (from ,from))))
+ (h (make <handle> :ast m)))
+ (for-each (lambda (f)
+ (if (and (pair? f)
+ (pair? (cdr f))
+ (null? (cddr f))
+ (symbol? (car f)))
+ (markup-option-add! m
+ (car f)
+ (make <markup>
+ :markup (symbol-append
+ '&bib-entry-
+ (car f))
+ :parent h
+ :body (cadr f)))
+ (bib-parse-error f)))
+ fields)
+ m))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/authors ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/authors l)
+ (define (cmp i1 i2 def)
+ (cond
+ ((and (markup? i1) (markup? i2))
+ (cmp (markup-body i1) (markup-body i2) def))
+ ((markup? i1)
+ (cmp (markup-body i1) i2 def))
+ ((markup? i2)
+ (cmp i1 (markup-body i2) def))
+ ((and (string? i1) (string? i2))
+ (if (string=? i1 i2)
+ (def)
+ (string<? i1 i2)))
+ ((string? i1)
+ #f)
+ ((string? i2)
+ #t)
+ (else
+ (def))))
+ (sort l (lambda (e1 e2)
+ (cmp (markup-option e1 'author)
+ (markup-option e2 'author)
+ (lambda ()
+ (cmp (markup-option e1 'year)
+ (markup-option e2 'year)
+ (lambda ()
+ (cmp (markup-option e1 'title)
+ (markup-option e2 'title)
+ (lambda ()
+ (cmp (markup-ident e1)
+ (markup-ident e2)
+ (lambda ()
+ #t)))))))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/idents ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/idents l)
+ (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f)))))
+
+;*---------------------------------------------------------------------*/
+;* bib-sort/dates ... */
+;*---------------------------------------------------------------------*/
+(define (bib-sort/dates l)
+ (sort l (lambda (p1 p2)
+ (define (month-num m)
+ (let ((body (markup-body m)))
+ (if (not (string? body))
+ 13
+ (let* ((s (if (> (string-length body) 3)
+ (substring body 0 3)
+ body))
+ (sy (string->symbol (string-downcase body)))
+ (c (assq sy '((jan . 1)
+ (feb . 2)
+ (mar . 3)
+ (apr . 4)
+ (may . 5)
+ (jun . 6)
+ (jul . 7)
+ (aug . 8)
+ (sep . 9)
+ (oct . 10)
+ (nov . 11)
+ (dec . 12)))))
+ (if (pair? c) (cdr c) 13)))))
+ (let ((d1 (markup-option p1 'year))
+ (d2 (markup-option p2 'year)))
+ (cond
+ ((not (markup? d1)) #f)
+ ((not (markup? d2)) #t)
+ (else
+ (let ((y1 (markup-body d1))
+ (y2 (markup-body d2)))
+ (cond
+ ((string>? y1 y2) #t)
+ ((string<? y1 y2) #f)
+ (else
+ (let ((d1 (markup-option p1 'month))
+ (d2 (markup-option p2 'month)))
+ (cond
+ ((not (markup? d1)) #f)
+ ((not (markup? d2)) #t)
+ (else
+ (let ((m1 (month-num d1))
+ (m2 (month-num d2)))
+ (> m1 m2))))))))))))))
+
+;*---------------------------------------------------------------------*/
+;* resolve-the-bib ... */
+;*---------------------------------------------------------------------*/
+(define (resolve-the-bib table n sort pred count opts)
+ (define (count! entries)
+ (let loop ((es entries)
+ (i 1))
+ (if (pair? es)
+ (begin
+ (markup-option-add! (car es)
+ :title
+ (make <markup>
+ :markup '&bib-entry-ident
+ :parent (car es)
+ :options `((number ,i))
+ :body (make <handle> :ast (car es))))
+ (loop (cdr es) (+ i 1))))))
+ (if (not (bib-table? table))
+ (skribe-error 'resolve-the-bib "Illegal bibliography table" table)
+ (let* ((es (sort (hash-map->list (lambda (key val) val) table)))
+ (fes (filter (if (procedure? pred)
+ (lambda (m) (pred m n))
+ (lambda (m) (pair? (markup-option m 'used))))
+ es)))
+ (count! (if (eq? count 'full) es fes))
+ (make <markup>
+ :markup '&the-bibliography
+ :options opts
+ :body fes))))
+
+
+;;; biblio.scm ends here
diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am
new file mode 100644
index 0000000..9442562
--- /dev/null
+++ b/src/guile/skribilo/biblio/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/biblio
+dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm
+
+## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657
diff --git a/src/guile/skribilo/biblio/abbrev.scm b/src/guile/skribilo/biblio/abbrev.scm
new file mode 100644
index 0000000..9c88b6a
--- /dev/null
+++ b/src/guile/skribilo/biblio/abbrev.scm
@@ -0,0 +1,170 @@
+;;; abbrev.scm -- Determining abbreviations.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo biblio abbrev)
+ :use-module (srfi srfi-13)
+ :autoload (skribilo ast) (markup? markup-body-set!)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :autoload (ice-9 regex) (regexp-substitute/global)
+ :export (is-abbreviation? is-acronym? abbreviate-word
+ abbreviate-string abbreviate-markup
+
+ %cs-conference-abbreviations
+ %ordinal-number-abbreviations
+ %common-booktitle-abbreviations))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to identify or generate abbreviations. This module
+;;; particularly targets booktitle abbreviations (in bibliography entries).
+;;;
+;;; Code:
+
+(define (is-abbreviation? str)
+ ;; Return #t if STR denotes an abbreviation or name initial.
+ (and (>= (string-length str) 2)
+ (char=? (string-ref str 1) #\.)))
+
+(define (is-acronym? str)
+ (string=? str (string-upcase str)))
+
+(define (abbreviate-word word)
+ (if (or (string=? "" word)
+ (and (>= (string-length word) 3)
+ (string=? "and" (substring word 0 3)))
+ (is-acronym? word))
+ word
+ (let ((dash (string-index word #\-))
+ (abbr (string (string-ref word 0) #\.)))
+ (if (not dash)
+ abbr
+ (string-append (string (string-ref word 0)) "-"
+ (abbreviate-word
+ (substring word (+ 1 dash)
+ (string-length word))))))))
+
+(define (abbreviate-string subst title)
+ ;; Abbreviate common conference names within TITLE based on the SUBST list
+ ;; of regexp-substitution pairs (see examples below). This function also
+ ;; removes the abbreviation if it appears in parentheses right after the
+ ;; substitution regexp. Example:
+ ;;
+ ;; "Symposium on Operating Systems Principles (SOSP 2004)"
+ ;;
+ ;; yields
+ ;;
+ ;; "SOSP"
+ ;;
+ (let loop ((title title)
+ (subst subst))
+ (if (null? subst)
+ title
+ (let* ((abbr (cdar subst))
+ (abbr-rexp (string-append "( \\(" abbr "[^\\)]*\\))?"))
+ (to-replace (string-append (caar subst) abbr-rexp)))
+ (loop (regexp-substitute/global #f to-replace title
+ 'pre abbr 'post)
+ (cdr subst))))))
+
+(define (abbreviate-markup subst markup)
+ ;; A version of `abbreviate-string' generalized to arbitrary markup
+ ;; objects.
+ (let loop ((markup markup))
+ (cond ((string? markup)
+ (let ((purify (make-string-replace '((#\newline " ")
+ (#\tab " ")))))
+ (abbreviate-string subst (purify markup))))
+ ((list? markup)
+ (map loop markup))
+ ((markup? markup)
+ (markup-body-set! markup (loop (markup-body title)))
+ markup)
+ (else markup))))
+
+
+;;;
+;;; Common English abbreviations.
+;;;
+
+;; The following abbreviation alists may be passed to `abbreviate-string'
+;; and `abbreviate-markup'.
+
+(define %cs-conference-abbreviations
+ ;; Common computer science conferences and their acronym.
+ '(("(Symposium [oO]n )?Operating Systems? Design and [iI]mplementation"
+ . "OSDI")
+ ("(Symposium [oO]n )?Operating Systems? Principles"
+ . "SOSP")
+ ("([wW]orkshop [oO]n )?Hot Topics [iI]n Operating Systems"
+ . "HotOS")
+ ("([cC]onference [oO]n )?[fF]ile [aA]nd [sS]torage [tT]echnologies"
+ . "FAST")
+ ("([tT]he )?([iI]nternational )?[cC]onference [oO]n [aA]rchitectural Support [fF]or Programming Languages [aA]nd Operating Systems"
+ . "ASPLOS")
+ ("([tT]he )?([iI]nternational )?[cC]onference [oO]n Peer-[tT]o-[pP]eer Computing"
+ . "P2P")
+ ("([iI]nternational )?[cC]onference [oO]n [dD]ata [eE]ngineering"
+ . "ICDE")
+ ("([cC]onference [oO]n )?[mM]ass [sS]torage [sS]ystems( [aA]nd [tT]echnologies)?"
+ . "MSS")
+ ("([sS]ymposium [oO]n )?[nN]etworked [sS]ystems [dD]esign [aA]nd [Ii]mplementation"
+ . "NSDI")))
+
+
+(define %ordinal-number-abbreviations
+ ;; The poor man's abbreviation system.
+
+ ;; FIXME: Given the current `abbreviate-string', there is no clean way to
+ ;; make it ignore things like "twenty-first" (instead of yielding an awful
+ ;; "twenty-1st").
+ '(("[Ff]irst" . "1st")
+ ("[sS]econd" . "2nd")
+ ("[Tt]hird" . "3rd")
+ ("[Ff]ourth" . "4th")
+ ("[Ff]ifth" . "5th")
+ ("[Ss]ixth" . "6th")
+ ("[Ss]eventh" . "7th")
+ ("[eE]ighth" . "8th")
+ ("[Nn]inth" . "9th")
+ ("[Tt]enth" . "10th")
+ ("[Ee]leventh" . "11th")
+ ("[Tt]welfth" . "12th")
+ ("[Tt]hirteenth" . "13th")
+ ("[Ff]ourteenth" . "14th")
+ ("[Ff]ifteenth" . "15th")
+ ("[Ss]ixteenth" . "16th")
+ ("[Ss]eventeenth" . "17th")
+ ("[Ee]ighteenth" . "18th")
+ ("[Nn]ineteenth" . "19th")))
+
+(define %common-booktitle-abbreviations
+ ;; Common book title abbreviations. This is used by
+ ;; `abbreviate-booktitle'.
+ '(("[pP]roceedings?" . "Proc.")
+ ("[iI]nternational" . "Int.")
+ ("[sS]ymposium" . "Symp.")
+ ("[cC]onference" . "Conf.")))
+
+
+;;; arch-tag: 34e0c5bb-592f-467b-b59a-d6f7d130ae4e
+
+;;; abbrev.scm ends here
diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm
new file mode 100644
index 0000000..ea15f4c
--- /dev/null
+++ b/src/guile/skribilo/biblio/author.scm
@@ -0,0 +1,136 @@
+;;; author.scm -- Handling author names.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo biblio author)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (skribilo biblio abbrev)
+ :autoload (skribilo ast) (markup-option markup-body markup-ident)
+ :autoload (skribilo lib) (skribe-error)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :export (comma-separated->author-list
+ comma-separated->and-separated-authors
+
+ extract-first-author-name
+ abbreviate-author-first-names
+ abbreviate-first-names
+ first-author-last-name
+
+ bib-sort/first-author-last-name))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Heuristics to manipulate author names as strings.
+;;;
+;;; Code:
+
+(define (comma-separated->author-list authors)
+ ;; Return a list of strings where each individual string is an author
+ ;; name. AUTHORS is a string representing a list of author names separated
+ ;; by a comma.
+
+ ;; XXX: I should use SRFI-13 instead.
+ (string-split authors #\,))
+
+(define (comma-separated->and-separated-authors authors)
+ ;; Take AUTHORS, a string containing comma-separated author names, and
+ ;; return a string where author names are separated by " and " (suitable
+ ;; for BibTeX).
+ (string-join (comma-separated->author-list authors)
+ " and " 'infix))
+
+
+(define (extract-first-author-name names)
+ ;; Extract the name of the first author from string
+ ;; NAMES that is a comma-separated list of authors.
+ (let ((author-name-end (or (string-index names #\,)
+ (string-length names))))
+ (substring names 0 author-name-end)))
+
+(define (abbreviate-author-first-names name)
+ ;; Abbreviate author first names
+ (let* ((components (string-split name #\space))
+ (component-number (length components)))
+ (apply string-append
+ (append
+ (map (lambda (c)
+ (string-append (abbreviate-word c) " "))
+ (list-head components
+ (- component-number 1)))
+ (list-tail components (- component-number 1))))))
+
+(define (abbreviate-first-names names)
+ ;; Abbreviate first names in NAMES. NAMES is supposed to be
+ ;; something like "Ludovic Courtès, Marc-Olivier Killijian".
+ (let loop ((names ((make-string-replace '((#\newline " ")
+ (#\tab " ")))
+ names))
+ (result ""))
+ (if (string=? names "")
+ result
+ (let* ((len (string-length names))
+ (first-author-names-end (or (string-index names #\,)
+ len))
+ (first-author-names (substring names 0
+ first-author-names-end))
+ (next (substring names
+ (min (+ 1 first-author-names-end) len)
+ len)))
+ (loop next
+ (string-append result
+ (if (string=? "" result) "" ", ")
+ (abbreviate-author-first-names
+ first-author-names)))))))
+
+
+(define (first-author-last-name authors)
+ ;; Return a string containing exactly the last name of the first author.
+ ;; Author names in AUTHORS are assumed to be comma separated.
+ (let loop ((first-author (extract-first-author-name authors)))
+ (let ((space (string-index first-author #\space)))
+ (if (not space)
+ first-author
+ (loop (substring first-author (+ space 1)
+ (string-length first-author)))))))
+
+(define (bib-sort/first-author-last-name entries)
+ ;; May be passed as the `:sort' argument of `the-bibliography'.
+ (let ((check-author (lambda (e)
+ (if (not (markup-option e 'author))
+ (skribe-error 'web
+ "No author for this bib entry"
+ (markup-ident e))
+ #t))))
+ (sort entries
+ (lambda (e1 e2)
+ (let* ((x1 (check-author e1))
+ (x2 (check-author e2))
+ (a1 (first-author-last-name
+ (markup-body (markup-option e1 'author))))
+ (a2 (first-author-last-name
+ (markup-body (markup-option e2 'author)))))
+ (string-ci<=? a1 a2))))))
+
+
+;;; arch-tag: c9a1ef10-a2cd-4a06-bd35-fbdee1abf09a
+
+;;; author.scm ends here
diff --git a/src/guile/skribilo/biblio/bibtex.scm b/src/guile/skribilo/biblio/bibtex.scm
new file mode 100644
index 0000000..319df1d
--- /dev/null
+++ b/src/guile/skribilo/biblio/bibtex.scm
@@ -0,0 +1,83 @@
+;;; bibtex.scm -- Handling BibTeX references.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo biblio bibtex)
+ :autoload (skribilo utils strings) (make-string-replace)
+ :autoload (skribilo ast) (markup-option ast->string)
+ :autoload (skribilo engine) (engine-filter find-engine)
+ :use-module (skribilo biblio author)
+ :use-module (srfi srfi-39)
+ :export (print-as-bibtex-entry))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; A set of BibTeX tools, e.g., issuing a BibTeX entry from a `&bib-entry'
+;;; markup object.
+;;;
+;;; Code:
+
+(define *bibtex-author-filter*
+ ;; Defines how the `author' field is to be filtered.
+ (make-parameter comma-separated->and-separated-authors))
+
+(define (print-as-bibtex-entry entry)
+ "Display @code{&bib-entry} object @var{entry} as a BibTeX entry."
+ (let ((show-option (lambda (opt)
+ (let* ((o (markup-option entry opt))
+ (f (make-string-replace '((#\newline " "))))
+ (g (if (eq? opt 'author)
+ (lambda (a)
+ ((*bibtex-author-filter*) (f a)))
+ f)))
+ (if (not o)
+ #f
+ `(,(symbol->string opt)
+ " = \""
+ ,(g (ast->string (markup-body o)))
+ "\","))))))
+ (format #t "@~a{~a,~%"
+ (markup-option entry 'kind)
+ (markup-ident entry))
+ (for-each (lambda (opt)
+ (let* ((o (show-option opt))
+ (tex-filter (engine-filter
+ (find-engine 'latex)))
+ (filter (lambda (n)
+ (tex-filter (ast->string n))))
+ (id (lambda (a) a)))
+ (if o
+ (display
+ (apply string-append
+ `(,@(map (if (eq? 'url opt)
+ id filter)
+ (cons " " o))
+ "\n"))))))
+ '(author institution title
+ booktitle journal number
+ year month url pages address publisher))
+ (display "}\n")))
+
+
+;;; arch-tag: 8b5913cc-9077-4e92-839e-c4c633b7bd46
+
+;;; bibtex.scm ends here
diff --git a/src/stklos/color.stk b/src/guile/skribilo/color.scm
index 0cb829f..8b6205f 100644
--- a/src/stklos/color.stk
+++ b/src/guile/skribilo/color.scm
@@ -1,32 +1,33 @@
-;;;;
-;;;; color.stk -- 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)
-;;;;
+;;; color.scm -- Color management.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
-(define-module SKRIBE-COLOR-MODULE
- (export skribe-color->rgb skribe-get-used-colors skribe-use-color!)
+(define-module (skribilo color)
+ :autoload (srfi srfi-60) (bitwise-and arithmetic-shift)
+ :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!))
+
+;; FIXME: This module should be generalized and the `skribe-' procedures
+;; moved to `compat.scm'.
+
+;; FIXME: Use a fluid? Or remove it?
(define *used-colors* '())
(define *skribe-rgb-alist* '(
@@ -571,7 +572,7 @@
("darkmagenta" . "139 0 139")
("darkred" . "139 0 0")
("lightgreen" . "144 238 144")))
-
+
(define (%convert-color str)
(let ((col (assoc str *skribe-rgb-alist*)))
@@ -590,7 +591,7 @@
(values (string->number (substring str 1 5) 16)
(string->number (substring str 5 9) 16)
(string->number (substring str 9 13) 16)))
- (else
+ (else
(values 0 0 0)))))
;;;
@@ -600,9 +601,9 @@
(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)))
+ (values (bitwise-and #xff (arithmetic-shift spec -16))
+ (bitwise-and #xff (arithmetic-shift spec -8))
+ (bitwise-and #xff spec)))
(else
(values 0 0 0))))
@@ -618,5 +619,3 @@
(define (skribe-use-color! color)
(set! *used-colors* (cons color *used-colors*))
color)
-
-) \ No newline at end of file
diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am
new file mode 100644
index 0000000..b952237
--- /dev/null
+++ b/src/guile/skribilo/coloring/Makefile.am
@@ -0,0 +1,16 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/coloring
+dist_guilemodule_DATA = c.scm lisp.scm xml.scm \
+ lisp-lex.l.scm xml-lex.l.scm c-lex.l.scm
+
+
+EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l
+
+# Building the lexers with SILex. You must previously run
+# `tla build-config ./arch-config' for this to run.
+#
+# Note: Those files should normally be part of the distribution, making
+# this rule useless to the user.
+%.l.scm: %.l
+ $(GUILE) -L $(top_srcdir)/src/guile/silex \
+ -c '(load-from-path "lex.scm") (lex "$^" "$@")'
+
diff --git a/src/stklos/c-lex.l b/src/guile/skribilo/coloring/c-lex.l
index a5b337e..7d7b1ce 100644
--- a/src/stklos/c-lex.l
+++ b/src/guile/skribilo/coloring/c-lex.l
@@ -16,7 +16,7 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm
new file mode 100644
index 0000000..d78e09e
--- /dev/null
+++ b/src/guile/skribilo/coloring/c-lex.l.scm
@@ -0,0 +1,1225 @@
+; *** This file starts with a copy of the file multilex.scm ***
+; SILex - Scheme Implementation of Lex
+; Copyright (C) 2001 Danny Dube'
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; as published by the Free Software Foundation; either version 2
+; of the License, or (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+ (lambda (buffer read-ptr input-f counters)
+ (let ((input-f input-f) ; Entree reelle
+ (buffer buffer) ; Buffer
+ (buflen (string-length buffer))
+ (read-ptr read-ptr)
+ (start-ptr 1) ; Marque de debut de lexeme
+ (start-line 1)
+ (start-column 1)
+ (start-offset 0)
+ (end-ptr 1) ; Marque de fin de lexeme
+ (point-ptr 1) ; Le point
+ (user-ptr 1) ; Marque de l'usager
+ (user-line 1)
+ (user-column 1)
+ (user-offset 0)
+ (user-up-to-date? #t)) ; Concerne la colonne seul.
+ (letrec
+ ((start-go-to-end-none ; Fonctions de depl. des marques
+ (lambda ()
+ (set! start-ptr end-ptr)))
+ (start-go-to-end-line
+ (lambda ()
+ (let loop ((ptr start-ptr) (line start-line))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1))
+ (loop (+ ptr 1) line))))))
+ (start-go-to-end-all
+ (lambda ()
+ (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+ (let loop ((ptr start-ptr)
+ (line start-line)
+ (column start-column))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1) 1)
+ (loop (+ ptr 1) line (+ column 1)))))))
+ (start-go-to-user-none
+ (lambda ()
+ (set! start-ptr user-ptr)))
+ (start-go-to-user-line
+ (lambda ()
+ (set! start-ptr user-ptr)
+ (set! start-line user-line)))
+ (start-go-to-user-all
+ (lambda ()
+ (set! start-line user-line)
+ (set! start-offset user-offset)
+ (if user-up-to-date?
+ (begin
+ (set! start-ptr user-ptr)
+ (set! start-column user-column))
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1))))))))
+ (end-go-to-point
+ (lambda ()
+ (set! end-ptr point-ptr)))
+ (point-go-to-start
+ (lambda ()
+ (set! point-ptr start-ptr)))
+ (user-go-to-start-none
+ (lambda ()
+ (set! user-ptr start-ptr)))
+ (user-go-to-start-line
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)))
+ (user-go-to-start-all
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)
+ (set! user-column start-column)
+ (set! user-offset start-offset)
+ (set! user-up-to-date? #t)))
+ (init-lexeme-none ; Debute un nouveau lexeme
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-none))
+ (point-go-to-start)))
+ (init-lexeme-line
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-line))
+ (point-go-to-start)))
+ (init-lexeme-all
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-all))
+ (point-go-to-start)))
+ (get-start-line ; Obtention des stats du debut du lxm
+ (lambda ()
+ start-line))
+ (get-start-column
+ (lambda ()
+ start-column))
+ (get-start-offset
+ (lambda ()
+ start-offset))
+ (peek-left-context ; Obtention de caracteres (#f si EOF)
+ (lambda ()
+ (char->integer (string-ref buffer (- start-ptr 1)))))
+ (peek-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (char->integer (string-ref buffer point-ptr))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (read-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (let ((c (string-ref buffer point-ptr)))
+ (set! point-ptr (+ point-ptr 1))
+ (char->integer c))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (set! point-ptr read-ptr)
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (get-start-end-text ; Obtention du lexeme
+ (lambda ()
+ (substring buffer start-ptr end-ptr)))
+ (get-user-line-line ; Fonctions pour l'usager
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ user-line))
+ (get-user-line-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-line))
+ (get-user-column-all
+ (lambda ()
+ (cond ((< user-ptr start-ptr)
+ (user-go-to-start-all)
+ user-column)
+ (user-up-to-date?
+ user-column)
+ (else
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! user-column column)
+ (set! user-up-to-date? #t)
+ column)
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1)))))))))
+ (get-user-offset-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-offset))
+ (user-getc-none
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-none))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-line
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-ungetc-none
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (set! user-ptr (- user-ptr 1)))))
+ (user-ungetc-line
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (set! user-line (- user-line 1))))))))
+ (user-ungetc-all
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (- user-line 1))
+ (set! user-up-to-date? #f))
+ (set! user-column (- user-column 1)))
+ (set! user-offset (- user-offset 1)))))))
+ (reorganize-buffer ; Decaler ou agrandir le buffer
+ (lambda ()
+ (if (< (* 2 start-ptr) buflen)
+ (let* ((newlen (* 2 buflen))
+ (newbuf (make-string newlen))
+ (delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! newbuf
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! buffer newbuf)
+ (set! buflen newlen)
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))
+ (let ((delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! buffer
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))))))
+ (list (cons 'start-go-to-end
+ (cond ((eq? counters 'none) start-go-to-end-none)
+ ((eq? counters 'line) start-go-to-end-line)
+ ((eq? counters 'all ) start-go-to-end-all)))
+ (cons 'end-go-to-point
+ end-go-to-point)
+ (cons 'init-lexeme
+ (cond ((eq? counters 'none) init-lexeme-none)
+ ((eq? counters 'line) init-lexeme-line)
+ ((eq? counters 'all ) init-lexeme-all)))
+ (cons 'get-start-line
+ get-start-line)
+ (cons 'get-start-column
+ get-start-column)
+ (cons 'get-start-offset
+ get-start-offset)
+ (cons 'peek-left-context
+ peek-left-context)
+ (cons 'peek-char
+ peek-char)
+ (cons 'read-char
+ read-char)
+ (cons 'get-start-end-text
+ get-start-end-text)
+ (cons 'get-user-line
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) get-user-line-line)
+ ((eq? counters 'all ) get-user-line-all)))
+ (cons 'get-user-column
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-column-all)))
+ (cons 'get-user-offset
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-offset-all)))
+ (cons 'user-getc
+ (cond ((eq? counters 'none) user-getc-none)
+ ((eq? counters 'line) user-getc-line)
+ ((eq? counters 'all ) user-getc-all)))
+ (cons 'user-ungetc
+ (cond ((eq? counters 'none) user-ungetc-none)
+ ((eq? counters 'line) user-ungetc-line)
+ ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+ (lambda (input-type input . largs)
+ (let ((counters-type (cond ((null? largs)
+ 'line)
+ ((memq (car largs) '(none line all))
+ (car largs))
+ (else
+ 'line))))
+ (cond ((and (eq? input-type 'port) (input-port? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f (lambda () (read-char input))))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'procedure) (procedure? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f input))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'string) (string? input))
+ (let* ((buffer (string-append (string #\newline) input))
+ (read-ptr (string-length buffer))
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ (else
+ (let* ((buffer (string #\newline))
+ (read-ptr 1)
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+; lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+ (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+ (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+ (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+ (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+ (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+ (lambda (tables IS)
+ (letrec
+ (; Contenu de la table
+ (counters-type (vector-ref tables 0))
+ (<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-actions (vector-ref tables 3))
+ (table-nl-start (vector-ref tables 5))
+ (table-no-nl-start (vector-ref tables 6))
+ (trees-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8))
+
+ ; Contenu du IS
+ (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
+ (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
+ (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
+ (IS-get-start-line (cdr (assq 'get-start-line IS)))
+ (IS-get-start-column (cdr (assq 'get-start-column IS)))
+ (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
+ (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
+ (IS-peek-char (cdr (assq 'peek-char IS)))
+ (IS-read-char (cdr (assq 'read-char IS)))
+ (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+ (IS-get-user-line (cdr (assq 'get-user-line IS)))
+ (IS-get-user-column (cdr (assq 'get-user-column IS)))
+ (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
+ (IS-user-getc (cdr (assq 'user-getc IS)))
+ (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
+
+ ; Resultats
+ (<<EOF>>-action #f)
+ (<<ERROR>>-action #f)
+ (rules-actions #f)
+ (states #f)
+ (final-lexer #f)
+
+ ; Gestion des hooks
+ (hook-list '())
+ (add-hook
+ (lambda (thunk)
+ (set! hook-list (cons thunk hook-list))))
+ (apply-hooks
+ (lambda ()
+ (let loop ((l hook-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))))
+
+ ; Preparation des actions
+ (set-action-statics
+ (lambda (pre-action)
+ (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+ (prepare-special-action-none
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda ()
+ (action "")))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-line
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline)
+ (action "" yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-all
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (action "" yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-special-action-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-special-action-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-special-action-all pre-action)))))
+ (prepare-action-yytext-none
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-line
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-all
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline yycolumn yyoffset))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-yytext-all pre-action)))))
+ (prepare-action-no-yytext-none
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (start-go-to-end)
+ (action)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-line
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (start-go-to-end)
+ (action yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-all
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (start-go-to-end)
+ (action yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-no-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-no-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-no-yytext-all pre-action)))))
+
+ ; Fabrique les fonctions de dispatch
+ (prepare-dispatch-err
+ (lambda (leaf)
+ (lambda (c)
+ #f)))
+ (prepare-dispatch-number
+ (lambda (leaf)
+ (let ((state-function #f))
+ (let ((result
+ (lambda (c)
+ state-function))
+ (hook
+ (lambda ()
+ (set! state-function (vector-ref states leaf)))))
+ (add-hook hook)
+ result))))
+ (prepare-dispatch-leaf
+ (lambda (leaf)
+ (if (eq? leaf 'err)
+ (prepare-dispatch-err leaf)
+ (prepare-dispatch-number leaf))))
+ (prepare-dispatch-<
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 1))
+ (right-tree (list-ref tree 2)))
+ (let ((bound (list-ref tree 0))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (< c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-=
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 2))
+ (right-tree (list-ref tree 3)))
+ (let ((bound (list-ref tree 1))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (= c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-tree
+ (lambda (tree)
+ (cond ((not (pair? tree))
+ (prepare-dispatch-leaf tree))
+ ((eq? (car tree) '=)
+ (prepare-dispatch-= tree))
+ (else
+ (prepare-dispatch-< tree)))))
+ (prepare-dispatch
+ (lambda (tree)
+ (let ((dicho-func (prepare-dispatch-tree tree)))
+ (lambda (c)
+ (and c (dicho-func c))))))
+
+ ; Fabrique les fonctions de transition (read & go) et (abort)
+ (prepare-read-n-go
+ (lambda (tree)
+ (let ((dispatch-func (prepare-dispatch tree))
+ (read-char IS-read-char))
+ (lambda ()
+ (dispatch-func (read-char))))))
+ (prepare-abort
+ (lambda (tree)
+ (lambda ()
+ #f)))
+ (prepare-transition
+ (lambda (tree)
+ (if (eq? tree 'err)
+ (prepare-abort tree)
+ (prepare-read-n-go tree))))
+
+ ; Fabrique les fonctions d'etats ([set-end] & trans)
+ (prepare-state-no-acc
+ (lambda (s r1 r2)
+ (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+ (lambda (action)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state action)
+ action))))))
+ (prepare-state-yes-no
+ (lambda (s r1 r2)
+ (let ((peek-char IS-peek-char)
+ (end-go-to-point IS-end-go-to-point)
+ (new-action1 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ (begin
+ (end-go-to-point)
+ new-action1)
+ action))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-diff-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (peek-char IS-peek-char)
+ (new-action1 #f)
+ (new-action2 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ new-action1
+ new-action2))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1))
+ (set! new-action2 (vector-ref rules-actions r2)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-same-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (trans-func (prepare-transition (vector-ref trees-v s)))
+ (new-action #f))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state
+ (lambda (s)
+ (let* ((acc (vector-ref acc-v s))
+ (r1 (car acc))
+ (r2 (cdr acc)))
+ (cond ((not r1) (prepare-state-no-acc s r1 r2))
+ ((not r2) (prepare-state-yes-no s r1 r2))
+ ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+ (else (prepare-state-same-acc s r1 r2))))))
+
+ ; Fabrique la fonction de lancement du lexage a l'etat de depart
+ (prepare-start-same
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (start-state #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (if (not (peek-char))
+ eof-action
+ (start-state error-action))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state (vector-ref states s1))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start-diff
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (peek-left-context IS-peek-left-context)
+ (start-state1 #f)
+ (start-state2 #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (cond ((not (peek-char))
+ eof-action)
+ ((= (peek-left-context) lexer-integer-newline)
+ (start-state1 error-action))
+ (else
+ (start-state2 error-action)))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state1 (vector-ref states s1))
+ (set! start-state2 (vector-ref states s2))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start
+ (lambda ()
+ (let ((s1 table-nl-start)
+ (s2 table-no-nl-start))
+ (if (= s1 s2)
+ (prepare-start-same s1 s2)
+ (prepare-start-diff s1 s2)))))
+
+ ; Fabrique la fonction principale
+ (prepare-lexer-none
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ ((start-func))))))
+ (prepare-lexer-line
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line)))
+ ((start-func) yyline))))))
+ (prepare-lexer-all
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (get-start-column IS-get-start-column)
+ (get-start-offset IS-get-start-offset)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line))
+ (yycolumn (get-start-column))
+ (yyoffset (get-start-offset)))
+ ((start-func) yyline yycolumn yyoffset))))))
+ (prepare-lexer
+ (lambda ()
+ (cond ((eq? counters-type 'none) (prepare-lexer-none))
+ ((eq? counters-type 'line) (prepare-lexer-line))
+ ((eq? counters-type 'all) (prepare-lexer-all))))))
+
+ ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+ (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
+ (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+ ; Calculer la valeur de rules-actions
+ (let* ((len (quotient (vector-length rules-pre-actions) 2))
+ (v (make-vector len)))
+ (let loop ((r (- len 1)))
+ (if (< r 0)
+ (set! rules-actions v)
+ (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+ (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+ (action (if yytext?
+ (prepare-action-yytext pre-action)
+ (prepare-action-no-yytext pre-action))))
+ (vector-set! v r action)
+ (loop (- r 1))))))
+
+ ; Calculer la valeur de states
+ (let* ((len (vector-length trees-v))
+ (v (make-vector len)))
+ (let loop ((s (- len 1)))
+ (if (< s 0)
+ (set! states v)
+ (begin
+ (vector-set! v s (prepare-state s))
+ (loop (- s 1))))))
+
+ ; Calculer la valeur de final-lexer
+ (set! final-lexer (prepare-lexer))
+
+ ; Executer les hooks
+ (apply-hooks)
+
+ ; Resultat
+ final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+ (let* ((char->class
+ (lambda (c)
+ (let ((n (char->integer c)))
+ (list (cons n n)))))
+ (merge-sort
+ (lambda (l combine zero-elt)
+ (if (null? l)
+ zero-elt
+ (let loop1 ((l l))
+ (if (null? (cdr l))
+ (car l)
+ (loop1
+ (let loop2 ((l l))
+ (cond ((null? l)
+ l)
+ ((null? (cdr l))
+ l)
+ (else
+ (cons (combine (car l) (cadr l))
+ (loop2 (cddr l))))))))))))
+ (finite-class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (<= r1start r2start)
+ (cond ((< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((>= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+ (char-list->class
+ (lambda (cl)
+ (let ((classes (map char->class cl)))
+ (merge-sort classes finite-class-union '()))))
+ (class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+ (finite-class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (loop (cdr c) (+ rend 1))))))))
+ (tagged-chars->class
+ (lambda (tcl)
+ (let* ((inverse? (car tcl))
+ (cl (cdr tcl))
+ (class-tmp (char-list->class cl)))
+ (if inverse? (finite-class-compl class-tmp) class-tmp))))
+ (charc->arc
+ (lambda (charc)
+ (let* ((tcl (car charc))
+ (dest (cdr charc))
+ (class (tagged-chars->class tcl)))
+ (cons class dest))))
+ (arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+ (class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+ (sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+ (merge-sharcs
+ (lambda (l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((sharc1 (car l1))
+ (sharc2 (car l2)))
+ (if (sharc-<= sharc1 sharc2)
+ (cons sharc1 (loop (cdr l1) l2))
+ (cons sharc2 (loop l1 (cdr l2))))))))))
+ (class-= eqv?)
+ (fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err)
+ (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err)
+ (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+ (charcs->tree
+ (lambda (charcs)
+ (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+ (sharcs-l (map op charcs))
+ (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+ (full-sharcs (fill-error sorted-sharcs))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op full-sharcs))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right))))))))))
+ (lambda (tables IS)
+ (let ((counters (vector-ref tables 0))
+ (<<EOF>>-action (vector-ref tables 1))
+ (<<ERROR>>-action (vector-ref tables 2))
+ (rules-actions (vector-ref tables 3))
+ (nl-start (vector-ref tables 5))
+ (no-nl-start (vector-ref tables 6))
+ (charcs-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8)))
+ (let* ((len (vector-length charcs-v))
+ (v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+ (loop (- i 1)))
+ (lexer-make-tree-lexer
+ (vector counters
+ <<EOF>>-action
+ <<ERROR>>-action
+ rules-actions
+ 'decision-trees
+ nl-start
+ no-nl-start
+ v
+ acc-v)
+ IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+ (lambda (tables IS)
+ (let ((<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-action (vector-ref tables 3))
+ (code (vector-ref tables 5)))
+ (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+ (lambda (tables IS)
+ (let ((automaton-type (vector-ref tables 4)))
+ (cond ((eq? automaton-type 'decision-trees)
+ (lexer-make-tree-lexer tables IS))
+ ((eq? automaton-type 'tagged-chars-lists)
+ (lexer-make-char-lexer tables IS))
+ ((eq? automaton-type 'code)
+ (lexer-make-code-lexer tables IS))))))
+
+;
+; Table generated from the file c-lex.l by SILex 1.0
+;
+
+(define lexer-default-table
+ (vector
+ 'line
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ 'eof
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (skribe-error 'lisp-fontifier "Parse error" yytext)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-string)
+ (body yytext))
+;;Comments
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Identifiers (only letters since we are interested in keywords only)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (let* ((ident (string->symbol yytext))
+ (tmp (memq ident *the-keys*)))
+ (if tmp
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+ yytext))
+
+;; Regular text
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (begin yytext)
+ )))
+ 'decision-trees
+ 0
+ 0
+ '#((65 (35 (34 1 5) (= 47 4 1)) (96 (91 3 (95 1 2)) (97 1 (123 3 1))))
+ (65 (= 34 err 1) (97 (91 err 1) (123 err 1))) (91 (35 (34 1 err) (65 1
+ 3)) (96 (95 1 2) (97 1 (123 3 1)))) (95 (65 err (91 3 err)) (97 (96 3
+ err) (123 3 err))) (47 (35 (34 1 err) (= 42 7 1)) (91 (48 6 (65 1 err))
+ (97 1 (123 err 1)))) (= 34 8 5) (35 (11 (10 6 1) (34 6 9)) (91 (65 6 9)
+ (97 6 (123 9 6)))) (42 (11 (10 7 1) (= 34 10 7)) (91 (43 11 (65 7 10))
+ (97 7 (123 10 7)))) err (= 10 err 9) (11 (10 10 err) (= 42 12 10)) (43
+ (34 (= 10 1 7) (35 10 (42 7 11))) (65 (= 47 13 7) (97 (91 10 7) (123 10
+ 7)))) (42 (= 10 err 10) (47 (43 12 10) (48 14 10))) (42 (11 (10 7 1) (=
+ 34 10 7)) (91 (43 11 (65 7 10)) (97 7 (123 10 7)))) (11 (10 10 err) (=
+ 42 12 10)))
+ '#((#f . #f) (4 . 4) (3 . 3) (3 . 3) (4 . 4) (#f . #f) (2 . 2) (4 . 4)
+ (0 . 0) (2 . 2) (#f . #f) (4 . 4) (#f . #f) (1 . 1) (1 . 1))))
+
+;
+; User functions
+;
+
+(define lexer #f)
+
+(define lexer-get-line #f)
+(define lexer-getc #f)
+(define lexer-ungetc #f)
+
+(define lexer-init
+ (lambda (input-type input)
+ (let ((IS (lexer-make-IS input-type input 'line)))
+ (set! lexer (lexer-make-lexer lexer-default-table IS))
+ (set! lexer-get-line (lexer-get-func-line IS))
+ (set! lexer-getc (lexer-get-func-getc IS))
+ (set! lexer-ungetc (lexer-get-func-ungetc IS)))))
diff --git a/src/stklos/c.stk b/src/guile/skribilo/coloring/c.scm
index 265c421..d2a2b9f 100644
--- a/src/stklos/c.stk
+++ b/src/guile/skribilo/coloring/c.scm
@@ -16,7 +16,7 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
@@ -26,9 +26,9 @@
(require "lex-rt") ;; to avoid module problems
-(define-module SKRIBE-C-MODULE
- (export c java)
- (import SKRIBE-SOURCE-MODULE)
+(define-module (skribilo c)
+ :export (c java)
+ :import (skribe runtime))
(include "c-lex.stk") ;; SILex generated
@@ -91,5 +91,3 @@
(fontifier java-fontifier)
(extractor #f)))
-)
-
diff --git a/src/stklos/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l
index efad24b..30b6a44 100644
--- a/src/stklos/lisp-lex.l
+++ b/src/guile/skribilo/coloring/lisp-lex.l
@@ -1,29 +1,24 @@
-;;;; -*- 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)
-;;;;
+;;; lisp-lex.l -- SILex input for the Lisp Languages
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
space [ \n\9]
letter [#?!_:a-zA-Z\-]
@@ -42,7 +37,7 @@ digit [0-9]
(body yytext))
;; Skribe text (i.e. [....])
-\[|\] (if *bracket-highlight*
+\[|\] (if (*bracket-highlight*)
(new markup
(markup '&source-bracket)
(body yytext))
@@ -68,7 +63,7 @@ digit [0-9]
(let* ((len (string-length yytext))
(c (string-ref yytext (- len 1))))
(if (char=? c #\>)
- (if *class-highlight*
+ (if (*class-highlight*)
(new markup
(markup '&source-module)
(body yytext))
@@ -76,7 +71,7 @@ digit [0-9]
yytext))) ; no
(else
(let ((tmp (assoc (string->symbol yytext)
- *the-keys*)))
+ (*the-keys*))))
(if tmp
(new markup
(markup (cdr tmp))
diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm
new file mode 100644
index 0000000..6ae7fe6
--- /dev/null
+++ b/src/guile/skribilo/coloring/lisp-lex.l.scm
@@ -0,0 +1,1249 @@
+; *** This file starts with a copy of the file multilex.scm ***
+; SILex - Scheme Implementation of Lex
+; Copyright (C) 2001 Danny Dube'
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; as published by the Free Software Foundation; either version 2
+; of the License, or (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+ (lambda (buffer read-ptr input-f counters)
+ (let ((input-f input-f) ; Entree reelle
+ (buffer buffer) ; Buffer
+ (buflen (string-length buffer))
+ (read-ptr read-ptr)
+ (start-ptr 1) ; Marque de debut de lexeme
+ (start-line 1)
+ (start-column 1)
+ (start-offset 0)
+ (end-ptr 1) ; Marque de fin de lexeme
+ (point-ptr 1) ; Le point
+ (user-ptr 1) ; Marque de l'usager
+ (user-line 1)
+ (user-column 1)
+ (user-offset 0)
+ (user-up-to-date? #t)) ; Concerne la colonne seul.
+ (letrec
+ ((start-go-to-end-none ; Fonctions de depl. des marques
+ (lambda ()
+ (set! start-ptr end-ptr)))
+ (start-go-to-end-line
+ (lambda ()
+ (let loop ((ptr start-ptr) (line start-line))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1))
+ (loop (+ ptr 1) line))))))
+ (start-go-to-end-all
+ (lambda ()
+ (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+ (let loop ((ptr start-ptr)
+ (line start-line)
+ (column start-column))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1) 1)
+ (loop (+ ptr 1) line (+ column 1)))))))
+ (start-go-to-user-none
+ (lambda ()
+ (set! start-ptr user-ptr)))
+ (start-go-to-user-line
+ (lambda ()
+ (set! start-ptr user-ptr)
+ (set! start-line user-line)))
+ (start-go-to-user-all
+ (lambda ()
+ (set! start-line user-line)
+ (set! start-offset user-offset)
+ (if user-up-to-date?
+ (begin
+ (set! start-ptr user-ptr)
+ (set! start-column user-column))
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1))))))))
+ (end-go-to-point
+ (lambda ()
+ (set! end-ptr point-ptr)))
+ (point-go-to-start
+ (lambda ()
+ (set! point-ptr start-ptr)))
+ (user-go-to-start-none
+ (lambda ()
+ (set! user-ptr start-ptr)))
+ (user-go-to-start-line
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)))
+ (user-go-to-start-all
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)
+ (set! user-column start-column)
+ (set! user-offset start-offset)
+ (set! user-up-to-date? #t)))
+ (init-lexeme-none ; Debute un nouveau lexeme
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-none))
+ (point-go-to-start)))
+ (init-lexeme-line
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-line))
+ (point-go-to-start)))
+ (init-lexeme-all
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-all))
+ (point-go-to-start)))
+ (get-start-line ; Obtention des stats du debut du lxm
+ (lambda ()
+ start-line))
+ (get-start-column
+ (lambda ()
+ start-column))
+ (get-start-offset
+ (lambda ()
+ start-offset))
+ (peek-left-context ; Obtention de caracteres (#f si EOF)
+ (lambda ()
+ (char->integer (string-ref buffer (- start-ptr 1)))))
+ (peek-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (char->integer (string-ref buffer point-ptr))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (read-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (let ((c (string-ref buffer point-ptr)))
+ (set! point-ptr (+ point-ptr 1))
+ (char->integer c))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (set! point-ptr read-ptr)
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (get-start-end-text ; Obtention du lexeme
+ (lambda ()
+ (substring buffer start-ptr end-ptr)))
+ (get-user-line-line ; Fonctions pour l'usager
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ user-line))
+ (get-user-line-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-line))
+ (get-user-column-all
+ (lambda ()
+ (cond ((< user-ptr start-ptr)
+ (user-go-to-start-all)
+ user-column)
+ (user-up-to-date?
+ user-column)
+ (else
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! user-column column)
+ (set! user-up-to-date? #t)
+ column)
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1)))))))))
+ (get-user-offset-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-offset))
+ (user-getc-none
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-none))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-line
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-ungetc-none
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (set! user-ptr (- user-ptr 1)))))
+ (user-ungetc-line
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (set! user-line (- user-line 1))))))))
+ (user-ungetc-all
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (- user-line 1))
+ (set! user-up-to-date? #f))
+ (set! user-column (- user-column 1)))
+ (set! user-offset (- user-offset 1)))))))
+ (reorganize-buffer ; Decaler ou agrandir le buffer
+ (lambda ()
+ (if (< (* 2 start-ptr) buflen)
+ (let* ((newlen (* 2 buflen))
+ (newbuf (make-string newlen))
+ (delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! newbuf
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! buffer newbuf)
+ (set! buflen newlen)
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))
+ (let ((delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! buffer
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))))))
+ (list (cons 'start-go-to-end
+ (cond ((eq? counters 'none) start-go-to-end-none)
+ ((eq? counters 'line) start-go-to-end-line)
+ ((eq? counters 'all ) start-go-to-end-all)))
+ (cons 'end-go-to-point
+ end-go-to-point)
+ (cons 'init-lexeme
+ (cond ((eq? counters 'none) init-lexeme-none)
+ ((eq? counters 'line) init-lexeme-line)
+ ((eq? counters 'all ) init-lexeme-all)))
+ (cons 'get-start-line
+ get-start-line)
+ (cons 'get-start-column
+ get-start-column)
+ (cons 'get-start-offset
+ get-start-offset)
+ (cons 'peek-left-context
+ peek-left-context)
+ (cons 'peek-char
+ peek-char)
+ (cons 'read-char
+ read-char)
+ (cons 'get-start-end-text
+ get-start-end-text)
+ (cons 'get-user-line
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) get-user-line-line)
+ ((eq? counters 'all ) get-user-line-all)))
+ (cons 'get-user-column
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-column-all)))
+ (cons 'get-user-offset
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-offset-all)))
+ (cons 'user-getc
+ (cond ((eq? counters 'none) user-getc-none)
+ ((eq? counters 'line) user-getc-line)
+ ((eq? counters 'all ) user-getc-all)))
+ (cons 'user-ungetc
+ (cond ((eq? counters 'none) user-ungetc-none)
+ ((eq? counters 'line) user-ungetc-line)
+ ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+ (lambda (input-type input . largs)
+ (let ((counters-type (cond ((null? largs)
+ 'line)
+ ((memq (car largs) '(none line all))
+ (car largs))
+ (else
+ 'line))))
+ (cond ((and (eq? input-type 'port) (input-port? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f (lambda () (read-char input))))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'procedure) (procedure? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f input))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'string) (string? input))
+ (let* ((buffer (string-append (string #\newline) input))
+ (read-ptr (string-length buffer))
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ (else
+ (let* ((buffer (string #\newline))
+ (read-ptr 1)
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+; lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+ (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+ (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+ (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+ (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+ (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+ (lambda (tables IS)
+ (letrec
+ (; Contenu de la table
+ (counters-type (vector-ref tables 0))
+ (<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-actions (vector-ref tables 3))
+ (table-nl-start (vector-ref tables 5))
+ (table-no-nl-start (vector-ref tables 6))
+ (trees-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8))
+
+ ; Contenu du IS
+ (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
+ (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
+ (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
+ (IS-get-start-line (cdr (assq 'get-start-line IS)))
+ (IS-get-start-column (cdr (assq 'get-start-column IS)))
+ (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
+ (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
+ (IS-peek-char (cdr (assq 'peek-char IS)))
+ (IS-read-char (cdr (assq 'read-char IS)))
+ (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+ (IS-get-user-line (cdr (assq 'get-user-line IS)))
+ (IS-get-user-column (cdr (assq 'get-user-column IS)))
+ (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
+ (IS-user-getc (cdr (assq 'user-getc IS)))
+ (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
+
+ ; Resultats
+ (<<EOF>>-action #f)
+ (<<ERROR>>-action #f)
+ (rules-actions #f)
+ (states #f)
+ (final-lexer #f)
+
+ ; Gestion des hooks
+ (hook-list '())
+ (add-hook
+ (lambda (thunk)
+ (set! hook-list (cons thunk hook-list))))
+ (apply-hooks
+ (lambda ()
+ (let loop ((l hook-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))))
+
+ ; Preparation des actions
+ (set-action-statics
+ (lambda (pre-action)
+ (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+ (prepare-special-action-none
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda ()
+ (action "")))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-line
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline)
+ (action "" yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-all
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (action "" yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-special-action-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-special-action-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-special-action-all pre-action)))))
+ (prepare-action-yytext-none
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-line
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-all
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline yycolumn yyoffset))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-yytext-all pre-action)))))
+ (prepare-action-no-yytext-none
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (start-go-to-end)
+ (action)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-line
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (start-go-to-end)
+ (action yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-all
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (start-go-to-end)
+ (action yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-no-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-no-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-no-yytext-all pre-action)))))
+
+ ; Fabrique les fonctions de dispatch
+ (prepare-dispatch-err
+ (lambda (leaf)
+ (lambda (c)
+ #f)))
+ (prepare-dispatch-number
+ (lambda (leaf)
+ (let ((state-function #f))
+ (let ((result
+ (lambda (c)
+ state-function))
+ (hook
+ (lambda ()
+ (set! state-function (vector-ref states leaf)))))
+ (add-hook hook)
+ result))))
+ (prepare-dispatch-leaf
+ (lambda (leaf)
+ (if (eq? leaf 'err)
+ (prepare-dispatch-err leaf)
+ (prepare-dispatch-number leaf))))
+ (prepare-dispatch-<
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 1))
+ (right-tree (list-ref tree 2)))
+ (let ((bound (list-ref tree 0))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (< c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-=
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 2))
+ (right-tree (list-ref tree 3)))
+ (let ((bound (list-ref tree 1))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (= c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-tree
+ (lambda (tree)
+ (cond ((not (pair? tree))
+ (prepare-dispatch-leaf tree))
+ ((eq? (car tree) '=)
+ (prepare-dispatch-= tree))
+ (else
+ (prepare-dispatch-< tree)))))
+ (prepare-dispatch
+ (lambda (tree)
+ (let ((dicho-func (prepare-dispatch-tree tree)))
+ (lambda (c)
+ (and c (dicho-func c))))))
+
+ ; Fabrique les fonctions de transition (read & go) et (abort)
+ (prepare-read-n-go
+ (lambda (tree)
+ (let ((dispatch-func (prepare-dispatch tree))
+ (read-char IS-read-char))
+ (lambda ()
+ (dispatch-func (read-char))))))
+ (prepare-abort
+ (lambda (tree)
+ (lambda ()
+ #f)))
+ (prepare-transition
+ (lambda (tree)
+ (if (eq? tree 'err)
+ (prepare-abort tree)
+ (prepare-read-n-go tree))))
+
+ ; Fabrique les fonctions d'etats ([set-end] & trans)
+ (prepare-state-no-acc
+ (lambda (s r1 r2)
+ (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+ (lambda (action)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state action)
+ action))))))
+ (prepare-state-yes-no
+ (lambda (s r1 r2)
+ (let ((peek-char IS-peek-char)
+ (end-go-to-point IS-end-go-to-point)
+ (new-action1 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ (begin
+ (end-go-to-point)
+ new-action1)
+ action))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-diff-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (peek-char IS-peek-char)
+ (new-action1 #f)
+ (new-action2 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ new-action1
+ new-action2))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1))
+ (set! new-action2 (vector-ref rules-actions r2)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-same-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (trans-func (prepare-transition (vector-ref trees-v s)))
+ (new-action #f))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state
+ (lambda (s)
+ (let* ((acc (vector-ref acc-v s))
+ (r1 (car acc))
+ (r2 (cdr acc)))
+ (cond ((not r1) (prepare-state-no-acc s r1 r2))
+ ((not r2) (prepare-state-yes-no s r1 r2))
+ ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+ (else (prepare-state-same-acc s r1 r2))))))
+
+ ; Fabrique la fonction de lancement du lexage a l'etat de depart
+ (prepare-start-same
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (start-state #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (if (not (peek-char))
+ eof-action
+ (start-state error-action))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state (vector-ref states s1))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start-diff
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (peek-left-context IS-peek-left-context)
+ (start-state1 #f)
+ (start-state2 #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (cond ((not (peek-char))
+ eof-action)
+ ((= (peek-left-context) lexer-integer-newline)
+ (start-state1 error-action))
+ (else
+ (start-state2 error-action)))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state1 (vector-ref states s1))
+ (set! start-state2 (vector-ref states s2))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start
+ (lambda ()
+ (let ((s1 table-nl-start)
+ (s2 table-no-nl-start))
+ (if (= s1 s2)
+ (prepare-start-same s1 s2)
+ (prepare-start-diff s1 s2)))))
+
+ ; Fabrique la fonction principale
+ (prepare-lexer-none
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ ((start-func))))))
+ (prepare-lexer-line
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line)))
+ ((start-func) yyline))))))
+ (prepare-lexer-all
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (get-start-column IS-get-start-column)
+ (get-start-offset IS-get-start-offset)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line))
+ (yycolumn (get-start-column))
+ (yyoffset (get-start-offset)))
+ ((start-func) yyline yycolumn yyoffset))))))
+ (prepare-lexer
+ (lambda ()
+ (cond ((eq? counters-type 'none) (prepare-lexer-none))
+ ((eq? counters-type 'line) (prepare-lexer-line))
+ ((eq? counters-type 'all) (prepare-lexer-all))))))
+
+ ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+ (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
+ (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+ ; Calculer la valeur de rules-actions
+ (let* ((len (quotient (vector-length rules-pre-actions) 2))
+ (v (make-vector len)))
+ (let loop ((r (- len 1)))
+ (if (< r 0)
+ (set! rules-actions v)
+ (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+ (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+ (action (if yytext?
+ (prepare-action-yytext pre-action)
+ (prepare-action-no-yytext pre-action))))
+ (vector-set! v r action)
+ (loop (- r 1))))))
+
+ ; Calculer la valeur de states
+ (let* ((len (vector-length trees-v))
+ (v (make-vector len)))
+ (let loop ((s (- len 1)))
+ (if (< s 0)
+ (set! states v)
+ (begin
+ (vector-set! v s (prepare-state s))
+ (loop (- s 1))))))
+
+ ; Calculer la valeur de final-lexer
+ (set! final-lexer (prepare-lexer))
+
+ ; Executer les hooks
+ (apply-hooks)
+
+ ; Resultat
+ final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+ (let* ((char->class
+ (lambda (c)
+ (let ((n (char->integer c)))
+ (list (cons n n)))))
+ (merge-sort
+ (lambda (l combine zero-elt)
+ (if (null? l)
+ zero-elt
+ (let loop1 ((l l))
+ (if (null? (cdr l))
+ (car l)
+ (loop1
+ (let loop2 ((l l))
+ (cond ((null? l)
+ l)
+ ((null? (cdr l))
+ l)
+ (else
+ (cons (combine (car l) (cadr l))
+ (loop2 (cddr l))))))))))))
+ (finite-class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (<= r1start r2start)
+ (cond ((< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((>= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+ (char-list->class
+ (lambda (cl)
+ (let ((classes (map char->class cl)))
+ (merge-sort classes finite-class-union '()))))
+ (class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+ (finite-class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (loop (cdr c) (+ rend 1))))))))
+ (tagged-chars->class
+ (lambda (tcl)
+ (let* ((inverse? (car tcl))
+ (cl (cdr tcl))
+ (class-tmp (char-list->class cl)))
+ (if inverse? (finite-class-compl class-tmp) class-tmp))))
+ (charc->arc
+ (lambda (charc)
+ (let* ((tcl (car charc))
+ (dest (cdr charc))
+ (class (tagged-chars->class tcl)))
+ (cons class dest))))
+ (arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+ (class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+ (sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+ (merge-sharcs
+ (lambda (l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((sharc1 (car l1))
+ (sharc2 (car l2)))
+ (if (sharc-<= sharc1 sharc2)
+ (cons sharc1 (loop (cdr l1) l2))
+ (cons sharc2 (loop l1 (cdr l2))))))))))
+ (class-= eqv?)
+ (fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err)
+ (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err)
+ (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+ (charcs->tree
+ (lambda (charcs)
+ (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+ (sharcs-l (map op charcs))
+ (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+ (full-sharcs (fill-error sorted-sharcs))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op full-sharcs))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right))))))))))
+ (lambda (tables IS)
+ (let ((counters (vector-ref tables 0))
+ (<<EOF>>-action (vector-ref tables 1))
+ (<<ERROR>>-action (vector-ref tables 2))
+ (rules-actions (vector-ref tables 3))
+ (nl-start (vector-ref tables 5))
+ (no-nl-start (vector-ref tables 6))
+ (charcs-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8)))
+ (let* ((len (vector-length charcs-v))
+ (v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+ (loop (- i 1)))
+ (lexer-make-tree-lexer
+ (vector counters
+ <<EOF>>-action
+ <<ERROR>>-action
+ rules-actions
+ 'decision-trees
+ nl-start
+ no-nl-start
+ v
+ acc-v)
+ IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+ (lambda (tables IS)
+ (let ((<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-action (vector-ref tables 3))
+ (code (vector-ref tables 5)))
+ (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+ (lambda (tables IS)
+ (let ((automaton-type (vector-ref tables 4)))
+ (cond ((eq? automaton-type 'decision-trees)
+ (lexer-make-tree-lexer tables IS))
+ ((eq? automaton-type 'tagged-chars-lists)
+ (lexer-make-char-lexer tables IS))
+ ((eq? automaton-type 'code)
+ (lexer-make-code-lexer tables IS))))))
+
+;
+; Table generated from the file lisp-lex.l by SILex 1.0
+;
+
+(define lexer-default-table
+ (vector
+ 'line
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ 'eof
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (skribe-error 'lisp-fontifier "Parse error" yytext)
+
+
+; LocalWords: fontify
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Skribe text (i.e. [....])
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (if (*bracket-highlight*)
+ (new markup
+ (markup '&source-bracket)
+ (body yytext))
+ yytext)
+;; Spaces & parenthesis
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (begin
+ yytext)
+
+;; Identifier (real syntax is slightly more complicated but we are
+;; interested here in the identifiers that we will fontify)
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (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)))))
+ )))
+ 'decision-trees
+ 0
+ 0
+ '#((40 (32 (9 1 (11 2 1)) (34 (33 2 1) (35 5 1))) (91 (59 (42 2 1) (60 4
+ 1)) (93 (92 3 1) (94 3 1)))) (40 (32 (9 1 (11 err 1)) (34 (33 err 1)
+ (35 err 1))) (91 (59 (42 err 1) (60 err 1)) (93 (92 err 1) (94 err
+ 1)))) (32 (9 err (11 2 err)) (40 (33 2 err) (42 2 err))) err (= 10 err
+ 4) (= 34 6 5) err)
+ '#((#f . #f) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (#f . #f) (0 . 0))))
+
+;
+; User functions
+;
+
+(define lexer #f)
+
+(define lexer-get-line #f)
+(define lexer-getc #f)
+(define lexer-ungetc #f)
+
+(define lexer-init
+ (lambda (input-type input)
+ (let ((IS (lexer-make-IS input-type input 'line)))
+ (set! lexer (lexer-make-lexer lexer-default-table IS))
+ (set! lexer-get-line (lexer-get-func-line IS))
+ (set! lexer-getc (lexer-get-func-getc IS))
+ (set! lexer-ungetc (lexer-get-func-ungetc IS)))))
diff --git a/src/stklos/lisp.stk b/src/guile/skribilo/coloring/lisp.scm
index 9bfe75a..13bb6db 100644
--- a/src/stklos/lisp.stk
+++ b/src/guile/skribilo/coloring/lisp.scm
@@ -1,103 +1,106 @@
+;;;; lisp.scm -- Lisp Family Fontification
+;;;;
+;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;;
;;;;
-;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; 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 SKRIBE-LISP-MODULE
- (export skribe scheme stklos bigloo lisp)
- (import SKRIBE-SOURCE-MODULE)
+(define-module (skribilo coloring lisp)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo source)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils strings)
+ :use-module (srfi srfi-39)
+ :use-module (ice-9 match)
+ :autoload (ice-9 regex) (make-regexp)
+ :autoload (skribilo reader) (make-reader)
+ :export (skribe scheme stklos bigloo lisp))
+
-(include "lisp-lex.stk") ;; SILex generated
-
-(define *bracket-highlight* #f)
-(define *class-highlight* #f)
-(define *the-keys* #f)
+(define *bracket-highlight* (make-parameter #t))
+(define *class-highlight* (make-parameter #t))
+(define *the-keys* (make-parameter '()))
-(define *lisp-keys* #f)
-(define *scheme-keys* #f)
-(define *skribe-keys* #f)
-(define *stklos-keys* #f)
-(define *lisp-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)))
+(define (definition-search inp read tab def?)
+ (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))))))
+ (if (def? exp)
+ (let ((start (and (pair? exp) (source-property exp 'line)))
+ (stop (port-line inp)))
+ (source-read-lines (port-filename inp) start stop tab))
+ (Loop (read inp))))))
+;; Load the SILex-generated lexer.
+(load-from-path "skribilo/coloring/lisp-lex.l.scm")
(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))))))
-
+ (lexer-init 'port (open-input-string s))
+ (let loop ((token (lexer))
+ (res '()))
+ (if (eq? token 'eof)
+ (reverse! res)
+ (loop (lexer)
+ (cons token res)))))
+
+
;;;; ======================================================================
;;;;
-;;;; LISP
+;;;; LISP
;;;;
;;;; ======================================================================
(define (lisp-extractor iport def tab)
(definition-search
iport
+ read
tab
(lambda (exp)
- (match-case exp
- (((or defun defmacro) ?fun ?- . ?-)
- (and (eq? def fun) exp))
- ((defvar ?var . ?-)
- (and (eq? var def) exp))
- (else
- #f)))))
+ (match 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*
+ (unless %lisp-keys
+ (set! %lisp-keys
(append ;; key
- (map (lambda (x) (cons x '&source-keyword))
+ (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*)
+ %lisp-keys)
(define (lisp-fontifier s)
- (fluid-let ((*the-keys* (init-lisp-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
+ (parameterize ((*the-keys* (init-lisp-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
(lisp-family-fontifier s)))
@@ -107,43 +110,44 @@
(fontifier lisp-fontifier)
(extractor lisp-extractor)))
+
;;;; ======================================================================
;;;;
-;;;; SCHEME
+;;;; SCHEME
;;;;
;;;; ======================================================================
(define (scheme-extractor iport def tab)
(definition-search
iport
+ %skribilo-module-reader
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)))))
+ (match exp
+ (((or 'define 'define-macro) (fun . _) . _)
+ (and (eq? def fun) exp))
+ (('define (? symbol? var) . _)
+ (and (eq? var def) exp))
+ (else #f)))))
(define (init-scheme-keys)
- (unless *scheme-keys*
- (set! *scheme-keys*
+ (unless %scheme-keys
+ (set! %scheme-keys
(append ;; key
- (map (lambda (x) (cons x '&source-keyword))
+ (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*)
+ %scheme-keys)
(define (scheme-fontifier s)
- (fluid-let ((*the-keys* (init-scheme-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
+ (parameterize ((*the-keys* (init-scheme-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
(lisp-family-fontifier s)))
-
+
(define scheme
(new language
@@ -151,30 +155,32 @@
(fontifier scheme-fontifier)
(extractor scheme-extractor)))
+
;;;; ======================================================================
;;;;
-;;;; STKLOS
+;;;; STKLOS
;;;;
;;;; ======================================================================
(define (stklos-extractor iport def tab)
(definition-search
iport
+ %skribilo-module-reader
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))
+ (match exp
+ (((or 'define 'define-generic 'define-method 'define-macro)
+ (fun . _) . _)
+ (and (eq? def fun) exp))
+ (((or 'define 'define-module) (? symbol? var) . _)
+ (and (eq? var def) exp))
(else
- #f)))))
+ #f)))))
(define (init-stklos-keys)
- (unless *stklos-keys*
+ (unless %stklos-keys
(init-scheme-keys)
- (set! *stklos-keys* (append *scheme-keys*
+ (set! %stklos-keys (append %scheme-keys
;; Markups
(map (lambda (x) (cons x '&source-key))
'(select-module import export))
@@ -188,13 +194,13 @@
;; error
(map (lambda (x) (cons x '&source-error))
'(error call/cc)))))
- *stklos-keys*)
+ %stklos-keys)
(define (stklos-fontifier s)
- (fluid-let ((*the-keys* (init-stklos-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
+ (parameterize ((*the-keys* (init-stklos-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
(lisp-family-fontifier s)))
@@ -204,31 +210,33 @@
(fontifier stklos-fontifier)
(extractor stklos-extractor)))
+
;;;; ======================================================================
;;;;
-;;;; SKRIBE
+;;;; SKRIBE
;;;;
;;;; ======================================================================
(define (skribe-extractor iport def tab)
(definition-search
iport
+ (make-reader 'skribe)
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)))))
+ (match exp
+ (((or 'define 'define-macro 'define-markup 'define-public)
+ (fun . _) . _)
+ (and (eq? def fun) exp))
+ (('define (? 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*
+ (unless %skribe-keys
(init-stklos-keys)
- (set! *skribe-keys* (append *stklos-keys*
+ (set! %skribe-keys (append %stklos-keys
;; Markups
(map (lambda (x) (cons x '&source-markup))
'(bold it emph tt color ref index underline
@@ -249,13 +257,13 @@
;; Define
(map (lambda (x) (cons x '&source-define))
'(define-markup)))))
- *skribe-keys*)
-
+ %skribe-keys)
+
(define (skribe-fontifier s)
- (fluid-let ((*the-keys* (init-skribe-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
+ (parameterize ((*the-keys* (init-skribe-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
(lisp-family-fontifier s)))
@@ -265,30 +273,30 @@
(fontifier skribe-fontifier)
(extractor skribe-extractor)))
+
;;;; ======================================================================
;;;;
-;;;; BIGLOO
+;;;; BIGLOO
;;;;
;;;; ======================================================================
(define (bigloo-extractor iport def tab)
(definition-search
iport
+ %skribilo-module-reader
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)))))
+ (match 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)
+ (? 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/stklos/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l
index 5d9a8d9..aa7d312 100644
--- a/src/stklos/xml-lex.l
+++ b/src/guile/skribilo/coloring/xml-lex.l
@@ -17,7 +17,7 @@
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm
new file mode 100644
index 0000000..d58e42b
--- /dev/null
+++ b/src/guile/skribilo/coloring/xml-lex.l.scm
@@ -0,0 +1,1221 @@
+; *** This file starts with a copy of the file multilex.scm ***
+; SILex - Scheme Implementation of Lex
+; Copyright (C) 2001 Danny Dube'
+;
+; This program is free software; you can redistribute it and/or
+; modify it under the terms of the GNU General Public License
+; as published by the Free Software Foundation; either version 2
+; of the License, or (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful,
+; but WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+; GNU General Public License for more details.
+;
+; You should have received a copy of the GNU General Public License
+; along with this program; if not, write to the Free Software
+; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+;
+; Gestion des Input Systems
+; Fonctions a utiliser par l'usager:
+; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+;
+
+; Taille initiale par defaut du buffer d'entree
+(define lexer-init-buffer-len 1024)
+
+; Numero du caractere newline
+(define lexer-integer-newline (char->integer #\newline))
+
+; Constructeur d'IS brut
+(define lexer-raw-IS-maker
+ (lambda (buffer read-ptr input-f counters)
+ (let ((input-f input-f) ; Entree reelle
+ (buffer buffer) ; Buffer
+ (buflen (string-length buffer))
+ (read-ptr read-ptr)
+ (start-ptr 1) ; Marque de debut de lexeme
+ (start-line 1)
+ (start-column 1)
+ (start-offset 0)
+ (end-ptr 1) ; Marque de fin de lexeme
+ (point-ptr 1) ; Le point
+ (user-ptr 1) ; Marque de l'usager
+ (user-line 1)
+ (user-column 1)
+ (user-offset 0)
+ (user-up-to-date? #t)) ; Concerne la colonne seul.
+ (letrec
+ ((start-go-to-end-none ; Fonctions de depl. des marques
+ (lambda ()
+ (set! start-ptr end-ptr)))
+ (start-go-to-end-line
+ (lambda ()
+ (let loop ((ptr start-ptr) (line start-line))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1))
+ (loop (+ ptr 1) line))))))
+ (start-go-to-end-all
+ (lambda ()
+ (set! start-offset (+ start-offset (- end-ptr start-ptr)))
+ (let loop ((ptr start-ptr)
+ (line start-line)
+ (column start-column))
+ (if (= ptr end-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-line line)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) (+ line 1) 1)
+ (loop (+ ptr 1) line (+ column 1)))))))
+ (start-go-to-user-none
+ (lambda ()
+ (set! start-ptr user-ptr)))
+ (start-go-to-user-line
+ (lambda ()
+ (set! start-ptr user-ptr)
+ (set! start-line user-line)))
+ (start-go-to-user-all
+ (lambda ()
+ (set! start-line user-line)
+ (set! start-offset user-offset)
+ (if user-up-to-date?
+ (begin
+ (set! start-ptr user-ptr)
+ (set! start-column user-column))
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! start-ptr ptr)
+ (set! start-column column))
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1))))))))
+ (end-go-to-point
+ (lambda ()
+ (set! end-ptr point-ptr)))
+ (point-go-to-start
+ (lambda ()
+ (set! point-ptr start-ptr)))
+ (user-go-to-start-none
+ (lambda ()
+ (set! user-ptr start-ptr)))
+ (user-go-to-start-line
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)))
+ (user-go-to-start-all
+ (lambda ()
+ (set! user-ptr start-ptr)
+ (set! user-line start-line)
+ (set! user-column start-column)
+ (set! user-offset start-offset)
+ (set! user-up-to-date? #t)))
+ (init-lexeme-none ; Debute un nouveau lexeme
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-none))
+ (point-go-to-start)))
+ (init-lexeme-line
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-line))
+ (point-go-to-start)))
+ (init-lexeme-all
+ (lambda ()
+ (if (< start-ptr user-ptr)
+ (start-go-to-user-all))
+ (point-go-to-start)))
+ (get-start-line ; Obtention des stats du debut du lxm
+ (lambda ()
+ start-line))
+ (get-start-column
+ (lambda ()
+ start-column))
+ (get-start-offset
+ (lambda ()
+ start-offset))
+ (peek-left-context ; Obtention de caracteres (#f si EOF)
+ (lambda ()
+ (char->integer (string-ref buffer (- start-ptr 1)))))
+ (peek-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (char->integer (string-ref buffer point-ptr))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (read-char
+ (lambda ()
+ (if (< point-ptr read-ptr)
+ (let ((c (string-ref buffer point-ptr)))
+ (set! point-ptr (+ point-ptr 1))
+ (char->integer c))
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer point-ptr c)
+ (set! read-ptr (+ point-ptr 1))
+ (set! point-ptr read-ptr)
+ (char->integer c))
+ (begin
+ (set! input-f (lambda () 'eof))
+ #f))))))
+ (get-start-end-text ; Obtention du lexeme
+ (lambda ()
+ (substring buffer start-ptr end-ptr)))
+ (get-user-line-line ; Fonctions pour l'usager
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ user-line))
+ (get-user-line-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-line))
+ (get-user-column-all
+ (lambda ()
+ (cond ((< user-ptr start-ptr)
+ (user-go-to-start-all)
+ user-column)
+ (user-up-to-date?
+ user-column)
+ (else
+ (let loop ((ptr start-ptr) (column start-column))
+ (if (= ptr user-ptr)
+ (begin
+ (set! user-column column)
+ (set! user-up-to-date? #t)
+ column)
+ (if (char=? (string-ref buffer ptr) #\newline)
+ (loop (+ ptr 1) 1)
+ (loop (+ ptr 1) (+ column 1)))))))))
+ (get-user-offset-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ user-offset))
+ (user-getc-none
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-none))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-line
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-line))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (set! user-line (+ user-line 1)))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-getc-all
+ (lambda ()
+ (if (< user-ptr start-ptr)
+ (user-go-to-start-all))
+ (if (< user-ptr read-ptr)
+ (let ((c (string-ref buffer user-ptr)))
+ (set! user-ptr (+ user-ptr 1))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (let ((c (input-f)))
+ (if (char? c)
+ (begin
+ (if (= read-ptr buflen)
+ (reorganize-buffer))
+ (string-set! buffer user-ptr c)
+ (set! read-ptr (+ read-ptr 1))
+ (set! user-ptr read-ptr)
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (+ user-line 1))
+ (set! user-column 1))
+ (set! user-column (+ user-column 1)))
+ (set! user-offset (+ user-offset 1))
+ c)
+ (begin
+ (set! input-f (lambda () 'eof))
+ 'eof))))))
+ (user-ungetc-none
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (set! user-ptr (- user-ptr 1)))))
+ (user-ungetc-line
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (set! user-line (- user-line 1))))))))
+ (user-ungetc-all
+ (lambda ()
+ (if (> user-ptr start-ptr)
+ (begin
+ (set! user-ptr (- user-ptr 1))
+ (let ((c (string-ref buffer user-ptr)))
+ (if (char=? c #\newline)
+ (begin
+ (set! user-line (- user-line 1))
+ (set! user-up-to-date? #f))
+ (set! user-column (- user-column 1)))
+ (set! user-offset (- user-offset 1)))))))
+ (reorganize-buffer ; Decaler ou agrandir le buffer
+ (lambda ()
+ (if (< (* 2 start-ptr) buflen)
+ (let* ((newlen (* 2 buflen))
+ (newbuf (make-string newlen))
+ (delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! newbuf
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! buffer newbuf)
+ (set! buflen newlen)
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))
+ (let ((delta (- start-ptr 1)))
+ (let loop ((from (- start-ptr 1)))
+ (if (< from buflen)
+ (begin
+ (string-set! buffer
+ (- from delta)
+ (string-ref buffer from))
+ (loop (+ from 1)))))
+ (set! read-ptr (- read-ptr delta))
+ (set! start-ptr (- start-ptr delta))
+ (set! end-ptr (- end-ptr delta))
+ (set! point-ptr (- point-ptr delta))
+ (set! user-ptr (- user-ptr delta)))))))
+ (list (cons 'start-go-to-end
+ (cond ((eq? counters 'none) start-go-to-end-none)
+ ((eq? counters 'line) start-go-to-end-line)
+ ((eq? counters 'all ) start-go-to-end-all)))
+ (cons 'end-go-to-point
+ end-go-to-point)
+ (cons 'init-lexeme
+ (cond ((eq? counters 'none) init-lexeme-none)
+ ((eq? counters 'line) init-lexeme-line)
+ ((eq? counters 'all ) init-lexeme-all)))
+ (cons 'get-start-line
+ get-start-line)
+ (cons 'get-start-column
+ get-start-column)
+ (cons 'get-start-offset
+ get-start-offset)
+ (cons 'peek-left-context
+ peek-left-context)
+ (cons 'peek-char
+ peek-char)
+ (cons 'read-char
+ read-char)
+ (cons 'get-start-end-text
+ get-start-end-text)
+ (cons 'get-user-line
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) get-user-line-line)
+ ((eq? counters 'all ) get-user-line-all)))
+ (cons 'get-user-column
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-column-all)))
+ (cons 'get-user-offset
+ (cond ((eq? counters 'none) #f)
+ ((eq? counters 'line) #f)
+ ((eq? counters 'all ) get-user-offset-all)))
+ (cons 'user-getc
+ (cond ((eq? counters 'none) user-getc-none)
+ ((eq? counters 'line) user-getc-line)
+ ((eq? counters 'all ) user-getc-all)))
+ (cons 'user-ungetc
+ (cond ((eq? counters 'none) user-ungetc-none)
+ ((eq? counters 'line) user-ungetc-line)
+ ((eq? counters 'all ) user-ungetc-all))))))))
+
+; Construit un Input System
+; Le premier parametre doit etre parmi "port", "procedure" ou "string"
+; Prend un parametre facultatif qui doit etre parmi
+; "none", "line" ou "all"
+(define lexer-make-IS
+ (lambda (input-type input . largs)
+ (let ((counters-type (cond ((null? largs)
+ 'line)
+ ((memq (car largs) '(none line all))
+ (car largs))
+ (else
+ 'line))))
+ (cond ((and (eq? input-type 'port) (input-port? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f (lambda () (read-char input))))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'procedure) (procedure? input))
+ (let* ((buffer (make-string lexer-init-buffer-len #\newline))
+ (read-ptr 1)
+ (input-f input))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ ((and (eq? input-type 'string) (string? input))
+ (let* ((buffer (string-append (string #\newline) input))
+ (read-ptr (string-length buffer))
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
+ (else
+ (let* ((buffer (string #\newline))
+ (read-ptr 1)
+ (input-f (lambda () 'eof)))
+ (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
+
+; Les fonctions:
+; lexer-get-func-getc, lexer-get-func-ungetc,
+; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
+(define lexer-get-func-getc
+ (lambda (IS) (cdr (assq 'user-getc IS))))
+(define lexer-get-func-ungetc
+ (lambda (IS) (cdr (assq 'user-ungetc IS))))
+(define lexer-get-func-line
+ (lambda (IS) (cdr (assq 'get-user-line IS))))
+(define lexer-get-func-column
+ (lambda (IS) (cdr (assq 'get-user-column IS))))
+(define lexer-get-func-offset
+ (lambda (IS) (cdr (assq 'get-user-offset IS))))
+
+;
+; Gestion des lexers
+;
+
+; Fabrication de lexer a partir d'arbres de decision
+(define lexer-make-tree-lexer
+ (lambda (tables IS)
+ (letrec
+ (; Contenu de la table
+ (counters-type (vector-ref tables 0))
+ (<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-actions (vector-ref tables 3))
+ (table-nl-start (vector-ref tables 5))
+ (table-no-nl-start (vector-ref tables 6))
+ (trees-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8))
+
+ ; Contenu du IS
+ (IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
+ (IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
+ (IS-init-lexeme (cdr (assq 'init-lexeme IS)))
+ (IS-get-start-line (cdr (assq 'get-start-line IS)))
+ (IS-get-start-column (cdr (assq 'get-start-column IS)))
+ (IS-get-start-offset (cdr (assq 'get-start-offset IS)))
+ (IS-peek-left-context (cdr (assq 'peek-left-context IS)))
+ (IS-peek-char (cdr (assq 'peek-char IS)))
+ (IS-read-char (cdr (assq 'read-char IS)))
+ (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
+ (IS-get-user-line (cdr (assq 'get-user-line IS)))
+ (IS-get-user-column (cdr (assq 'get-user-column IS)))
+ (IS-get-user-offset (cdr (assq 'get-user-offset IS)))
+ (IS-user-getc (cdr (assq 'user-getc IS)))
+ (IS-user-ungetc (cdr (assq 'user-ungetc IS)))
+
+ ; Resultats
+ (<<EOF>>-action #f)
+ (<<ERROR>>-action #f)
+ (rules-actions #f)
+ (states #f)
+ (final-lexer #f)
+
+ ; Gestion des hooks
+ (hook-list '())
+ (add-hook
+ (lambda (thunk)
+ (set! hook-list (cons thunk hook-list))))
+ (apply-hooks
+ (lambda ()
+ (let loop ((l hook-list))
+ (if (pair? l)
+ (begin
+ ((car l))
+ (loop (cdr l)))))))
+
+ ; Preparation des actions
+ (set-action-statics
+ (lambda (pre-action)
+ (pre-action final-lexer IS-user-getc IS-user-ungetc)))
+ (prepare-special-action-none
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda ()
+ (action "")))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-line
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline)
+ (action "" yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action-all
+ (lambda (pre-action)
+ (let ((action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (action "" yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-special-action
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-special-action-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-special-action-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-special-action-all pre-action)))))
+ (prepare-action-yytext-none
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-line
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext-all
+ (lambda (pre-action)
+ (let ((get-start-end-text IS-get-start-end-text)
+ (start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (let ((yytext (get-start-end-text)))
+ (start-go-to-end)
+ (action yytext yyline yycolumn yyoffset))))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-yytext-all pre-action)))))
+ (prepare-action-no-yytext-none
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda ()
+ (start-go-to-end)
+ (action)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-line
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline)
+ (start-go-to-end)
+ (action yyline)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext-all
+ (lambda (pre-action)
+ (let ((start-go-to-end IS-start-go-to-end)
+ (action #f))
+ (let ((result
+ (lambda (yyline yycolumn yyoffset)
+ (start-go-to-end)
+ (action yyline yycolumn yyoffset)))
+ (hook
+ (lambda ()
+ (set! action (set-action-statics pre-action)))))
+ (add-hook hook)
+ result))))
+ (prepare-action-no-yytext
+ (lambda (pre-action)
+ (cond ((eq? counters-type 'none)
+ (prepare-action-no-yytext-none pre-action))
+ ((eq? counters-type 'line)
+ (prepare-action-no-yytext-line pre-action))
+ ((eq? counters-type 'all)
+ (prepare-action-no-yytext-all pre-action)))))
+
+ ; Fabrique les fonctions de dispatch
+ (prepare-dispatch-err
+ (lambda (leaf)
+ (lambda (c)
+ #f)))
+ (prepare-dispatch-number
+ (lambda (leaf)
+ (let ((state-function #f))
+ (let ((result
+ (lambda (c)
+ state-function))
+ (hook
+ (lambda ()
+ (set! state-function (vector-ref states leaf)))))
+ (add-hook hook)
+ result))))
+ (prepare-dispatch-leaf
+ (lambda (leaf)
+ (if (eq? leaf 'err)
+ (prepare-dispatch-err leaf)
+ (prepare-dispatch-number leaf))))
+ (prepare-dispatch-<
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 1))
+ (right-tree (list-ref tree 2)))
+ (let ((bound (list-ref tree 0))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (< c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-=
+ (lambda (tree)
+ (let ((left-tree (list-ref tree 2))
+ (right-tree (list-ref tree 3)))
+ (let ((bound (list-ref tree 1))
+ (left-func (prepare-dispatch-tree left-tree))
+ (right-func (prepare-dispatch-tree right-tree)))
+ (lambda (c)
+ (if (= c bound)
+ (left-func c)
+ (right-func c)))))))
+ (prepare-dispatch-tree
+ (lambda (tree)
+ (cond ((not (pair? tree))
+ (prepare-dispatch-leaf tree))
+ ((eq? (car tree) '=)
+ (prepare-dispatch-= tree))
+ (else
+ (prepare-dispatch-< tree)))))
+ (prepare-dispatch
+ (lambda (tree)
+ (let ((dicho-func (prepare-dispatch-tree tree)))
+ (lambda (c)
+ (and c (dicho-func c))))))
+
+ ; Fabrique les fonctions de transition (read & go) et (abort)
+ (prepare-read-n-go
+ (lambda (tree)
+ (let ((dispatch-func (prepare-dispatch tree))
+ (read-char IS-read-char))
+ (lambda ()
+ (dispatch-func (read-char))))))
+ (prepare-abort
+ (lambda (tree)
+ (lambda ()
+ #f)))
+ (prepare-transition
+ (lambda (tree)
+ (if (eq? tree 'err)
+ (prepare-abort tree)
+ (prepare-read-n-go tree))))
+
+ ; Fabrique les fonctions d'etats ([set-end] & trans)
+ (prepare-state-no-acc
+ (lambda (s r1 r2)
+ (let ((trans-func (prepare-transition (vector-ref trees-v s))))
+ (lambda (action)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state action)
+ action))))))
+ (prepare-state-yes-no
+ (lambda (s r1 r2)
+ (let ((peek-char IS-peek-char)
+ (end-go-to-point IS-end-go-to-point)
+ (new-action1 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ (begin
+ (end-go-to-point)
+ new-action1)
+ action))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-diff-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (peek-char IS-peek-char)
+ (new-action1 #f)
+ (new-action2 #f)
+ (trans-func (prepare-transition (vector-ref trees-v s))))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let* ((c (peek-char))
+ (new-action
+ (if (or (not c) (= c lexer-integer-newline))
+ new-action1
+ new-action2))
+ (next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action1 (vector-ref rules-actions r1))
+ (set! new-action2 (vector-ref rules-actions r2)))))
+ (add-hook hook)
+ result))))
+ (prepare-state-same-acc
+ (lambda (s r1 r2)
+ (let ((end-go-to-point IS-end-go-to-point)
+ (trans-func (prepare-transition (vector-ref trees-v s)))
+ (new-action #f))
+ (let ((result
+ (lambda (action)
+ (end-go-to-point)
+ (let ((next-state (trans-func)))
+ (if next-state
+ (next-state new-action)
+ new-action))))
+ (hook
+ (lambda ()
+ (set! new-action (vector-ref rules-actions r1)))))
+ (add-hook hook)
+ result))))
+ (prepare-state
+ (lambda (s)
+ (let* ((acc (vector-ref acc-v s))
+ (r1 (car acc))
+ (r2 (cdr acc)))
+ (cond ((not r1) (prepare-state-no-acc s r1 r2))
+ ((not r2) (prepare-state-yes-no s r1 r2))
+ ((< r1 r2) (prepare-state-diff-acc s r1 r2))
+ (else (prepare-state-same-acc s r1 r2))))))
+
+ ; Fabrique la fonction de lancement du lexage a l'etat de depart
+ (prepare-start-same
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (start-state #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (if (not (peek-char))
+ eof-action
+ (start-state error-action))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state (vector-ref states s1))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start-diff
+ (lambda (s1 s2)
+ (let ((peek-char IS-peek-char)
+ (eof-action #f)
+ (peek-left-context IS-peek-left-context)
+ (start-state1 #f)
+ (start-state2 #f)
+ (error-action #f))
+ (let ((result
+ (lambda ()
+ (cond ((not (peek-char))
+ eof-action)
+ ((= (peek-left-context) lexer-integer-newline)
+ (start-state1 error-action))
+ (else
+ (start-state2 error-action)))))
+ (hook
+ (lambda ()
+ (set! eof-action <<EOF>>-action)
+ (set! start-state1 (vector-ref states s1))
+ (set! start-state2 (vector-ref states s2))
+ (set! error-action <<ERROR>>-action))))
+ (add-hook hook)
+ result))))
+ (prepare-start
+ (lambda ()
+ (let ((s1 table-nl-start)
+ (s2 table-no-nl-start))
+ (if (= s1 s2)
+ (prepare-start-same s1 s2)
+ (prepare-start-diff s1 s2)))))
+
+ ; Fabrique la fonction principale
+ (prepare-lexer-none
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ ((start-func))))))
+ (prepare-lexer-line
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line)))
+ ((start-func) yyline))))))
+ (prepare-lexer-all
+ (lambda ()
+ (let ((init-lexeme IS-init-lexeme)
+ (get-start-line IS-get-start-line)
+ (get-start-column IS-get-start-column)
+ (get-start-offset IS-get-start-offset)
+ (start-func (prepare-start)))
+ (lambda ()
+ (init-lexeme)
+ (let ((yyline (get-start-line))
+ (yycolumn (get-start-column))
+ (yyoffset (get-start-offset)))
+ ((start-func) yyline yycolumn yyoffset))))))
+ (prepare-lexer
+ (lambda ()
+ (cond ((eq? counters-type 'none) (prepare-lexer-none))
+ ((eq? counters-type 'line) (prepare-lexer-line))
+ ((eq? counters-type 'all) (prepare-lexer-all))))))
+
+ ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
+ (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
+ (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
+
+ ; Calculer la valeur de rules-actions
+ (let* ((len (quotient (vector-length rules-pre-actions) 2))
+ (v (make-vector len)))
+ (let loop ((r (- len 1)))
+ (if (< r 0)
+ (set! rules-actions v)
+ (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
+ (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
+ (action (if yytext?
+ (prepare-action-yytext pre-action)
+ (prepare-action-no-yytext pre-action))))
+ (vector-set! v r action)
+ (loop (- r 1))))))
+
+ ; Calculer la valeur de states
+ (let* ((len (vector-length trees-v))
+ (v (make-vector len)))
+ (let loop ((s (- len 1)))
+ (if (< s 0)
+ (set! states v)
+ (begin
+ (vector-set! v s (prepare-state s))
+ (loop (- s 1))))))
+
+ ; Calculer la valeur de final-lexer
+ (set! final-lexer (prepare-lexer))
+
+ ; Executer les hooks
+ (apply-hooks)
+
+ ; Resultat
+ final-lexer)))
+
+; Fabrication de lexer a partir de listes de caracteres taggees
+(define lexer-make-char-lexer
+ (let* ((char->class
+ (lambda (c)
+ (let ((n (char->integer c)))
+ (list (cons n n)))))
+ (merge-sort
+ (lambda (l combine zero-elt)
+ (if (null? l)
+ zero-elt
+ (let loop1 ((l l))
+ (if (null? (cdr l))
+ (car l)
+ (loop1
+ (let loop2 ((l l))
+ (cond ((null? l)
+ l)
+ ((null? (cdr l))
+ l)
+ (else
+ (cons (combine (car l) (cadr l))
+ (loop2 (cddr l))))))))))))
+ (finite-class-union
+ (lambda (c1 c2)
+ (let loop ((c1 c1) (c2 c2) (u '()))
+ (if (null? c1)
+ (if (null? c2)
+ (reverse u)
+ (loop c1 (cdr c2) (cons (car c2) u)))
+ (if (null? c2)
+ (loop (cdr c1) c2 (cons (car c1) u))
+ (let* ((r1 (car c1))
+ (r2 (car c2))
+ (r1start (car r1))
+ (r1end (cdr r1))
+ (r2start (car r2))
+ (r2end (cdr r2)))
+ (if (<= r1start r2start)
+ (cond ((< (+ r1end 1) r2start)
+ (loop (cdr c1) c2 (cons r1 u)))
+ ((<= r1end r2end)
+ (loop (cdr c1)
+ (cons (cons r1start r2end) (cdr c2))
+ u))
+ (else
+ (loop c1 (cdr c2) u)))
+ (cond ((> r1start (+ r2end 1))
+ (loop c1 (cdr c2) (cons r2 u)))
+ ((>= r1end r2end)
+ (loop (cons (cons r2start r1end) (cdr c1))
+ (cdr c2)
+ u))
+ (else
+ (loop (cdr c1) c2 u))))))))))
+ (char-list->class
+ (lambda (cl)
+ (let ((classes (map char->class cl)))
+ (merge-sort classes finite-class-union '()))))
+ (class-<
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ (else (< b1 b2)))))
+ (finite-class-compl
+ (lambda (c)
+ (let loop ((c c) (start 'inf-))
+ (if (null? c)
+ (list (cons start 'inf+))
+ (let* ((r (car c))
+ (rstart (car r))
+ (rend (cdr r)))
+ (if (class-< start rstart)
+ (cons (cons start (- rstart 1))
+ (loop c rstart))
+ (loop (cdr c) (+ rend 1))))))))
+ (tagged-chars->class
+ (lambda (tcl)
+ (let* ((inverse? (car tcl))
+ (cl (cdr tcl))
+ (class-tmp (char-list->class cl)))
+ (if inverse? (finite-class-compl class-tmp) class-tmp))))
+ (charc->arc
+ (lambda (charc)
+ (let* ((tcl (car charc))
+ (dest (cdr charc))
+ (class (tagged-chars->class tcl)))
+ (cons class dest))))
+ (arc->sharcs
+ (lambda (arc)
+ (let* ((range-l (car arc))
+ (dest (cdr arc))
+ (op (lambda (range) (cons range dest))))
+ (map op range-l))))
+ (class-<=
+ (lambda (b1 b2)
+ (cond ((eq? b1 'inf-) #t)
+ ((eq? b2 'inf+) #t)
+ ((eq? b1 'inf+) #f)
+ ((eq? b2 'inf-) #f)
+ (else (<= b1 b2)))))
+ (sharc-<=
+ (lambda (sharc1 sharc2)
+ (class-<= (caar sharc1) (caar sharc2))))
+ (merge-sharcs
+ (lambda (l1 l2)
+ (let loop ((l1 l1) (l2 l2))
+ (cond ((null? l1)
+ l2)
+ ((null? l2)
+ l1)
+ (else
+ (let ((sharc1 (car l1))
+ (sharc2 (car l2)))
+ (if (sharc-<= sharc1 sharc2)
+ (cons sharc1 (loop (cdr l1) l2))
+ (cons sharc2 (loop l1 (cdr l2))))))))))
+ (class-= eqv?)
+ (fill-error
+ (lambda (sharcs)
+ (let loop ((sharcs sharcs) (start 'inf-))
+ (cond ((class-= start 'inf+)
+ '())
+ ((null? sharcs)
+ (cons (cons (cons start 'inf+) 'err)
+ (loop sharcs 'inf+)))
+ (else
+ (let* ((sharc (car sharcs))
+ (h (caar sharc))
+ (t (cdar sharc)))
+ (if (class-< start h)
+ (cons (cons (cons start (- h 1)) 'err)
+ (loop sharcs h))
+ (cons sharc (loop (cdr sharcs)
+ (if (class-= t 'inf+)
+ 'inf+
+ (+ t 1)))))))))))
+ (charcs->tree
+ (lambda (charcs)
+ (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
+ (sharcs-l (map op charcs))
+ (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
+ (full-sharcs (fill-error sorted-sharcs))
+ (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
+ (table (list->vector (map op full-sharcs))))
+ (let loop ((left 0) (right (- (vector-length table) 1)))
+ (if (= left right)
+ (cdr (vector-ref table left))
+ (let ((mid (quotient (+ left right 1) 2)))
+ (if (and (= (+ left 2) right)
+ (= (+ (car (vector-ref table mid)) 1)
+ (car (vector-ref table right)))
+ (eqv? (cdr (vector-ref table left))
+ (cdr (vector-ref table right))))
+ (list '=
+ (car (vector-ref table mid))
+ (cdr (vector-ref table mid))
+ (cdr (vector-ref table left)))
+ (list (car (vector-ref table mid))
+ (loop left (- mid 1))
+ (loop mid right))))))))))
+ (lambda (tables IS)
+ (let ((counters (vector-ref tables 0))
+ (<<EOF>>-action (vector-ref tables 1))
+ (<<ERROR>>-action (vector-ref tables 2))
+ (rules-actions (vector-ref tables 3))
+ (nl-start (vector-ref tables 5))
+ (no-nl-start (vector-ref tables 6))
+ (charcs-v (vector-ref tables 7))
+ (acc-v (vector-ref tables 8)))
+ (let* ((len (vector-length charcs-v))
+ (v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
+ (loop (- i 1)))
+ (lexer-make-tree-lexer
+ (vector counters
+ <<EOF>>-action
+ <<ERROR>>-action
+ rules-actions
+ 'decision-trees
+ nl-start
+ no-nl-start
+ v
+ acc-v)
+ IS))))))))
+
+; Fabrication d'un lexer a partir de code pre-genere
+(define lexer-make-code-lexer
+ (lambda (tables IS)
+ (let ((<<EOF>>-pre-action (vector-ref tables 1))
+ (<<ERROR>>-pre-action (vector-ref tables 2))
+ (rules-pre-action (vector-ref tables 3))
+ (code (vector-ref tables 5)))
+ (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
+
+(define lexer-make-lexer
+ (lambda (tables IS)
+ (let ((automaton-type (vector-ref tables 4)))
+ (cond ((eq? automaton-type 'decision-trees)
+ (lexer-make-tree-lexer tables IS))
+ ((eq? automaton-type 'tagged-chars-lists)
+ (lexer-make-char-lexer tables IS))
+ ((eq? automaton-type 'code)
+ (lexer-make-code-lexer tables IS))))))
+
+;
+; Table generated from the file xml-lex.l by SILex 1.0
+;
+
+(define lexer-default-table
+ (vector
+ 'line
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ 'eof
+ ))
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (skribe-error 'xml-fontifier "Parse error" yytext)
+ ))
+ (vector
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-string)
+ (body yytext))
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-comment)
+ (body yytext))
+
+;; Markup
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+
+;; Regular text
+ ))
+ #t
+ (lambda (yycontinue yygetc yyungetc)
+ (lambda (yytext yyline)
+ (begin yytext)
+ )))
+ 'decision-trees
+ 0
+ 0
+ '#((40 (35 (34 1 5) (39 1 4)) (61 (60 1 3) (= 62 2 1))) (40 (35 (34 1
+ err) (39 1 err)) (61 (60 1 err) (= 62 err 1))) err (33 (11 (10 6 err)
+ (32 6 err)) (62 (34 7 6) (63 err 6))) (= 39 8 4) (= 34 9 5) (32 (= 10
+ err 6) (62 (33 err 6) (63 err 6))) (33 (11 (10 6 err) (32 6 err)) (46
+ (45 6 10) (= 62 err 6))) err err (33 (11 (10 6 err) (32 6 err)) (46 (45
+ 6 11) (= 62 err 6))) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 13) (=
+ 62 12 11))) (= 45 14 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 15)
+ (= 62 12 11))) (= 45 16 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11
+ 15) (= 62 17 11))) (46 (45 12 16) (= 62 17 12)) (= 45 14 12))
+ '#((#f . #f) (4 . 4) (3 . 3) (#f . #f) (#f . #f) (#f . #f) (3 . 3) (3 .
+ 3) (1 . 1) (0 . 0) (3 . 3) (3 . 3) (#f . #f) (3 . 3) (#f . #f) (3 . 3)
+ (#f . #f) (2 . 2))))
+
+;
+; User functions
+;
+
+(define lexer #f)
+
+(define lexer-get-line #f)
+(define lexer-getc #f)
+(define lexer-ungetc #f)
+
+(define lexer-init
+ (lambda (input-type input)
+ (let ((IS (lexer-make-IS input-type input 'line)))
+ (set! lexer (lexer-make-lexer lexer-default-table IS))
+ (set! lexer-get-line (lexer-get-func-line IS))
+ (set! lexer-getc (lexer-get-func-getc IS))
+ (set! lexer-ungetc (lexer-get-func-ungetc IS)))))
diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm
new file mode 100644
index 0000000..e3db36f
--- /dev/null
+++ b/src/guile/skribilo/coloring/xml.scm
@@ -0,0 +1,82 @@
+;;; xml.scm -- XML syntax highlighting.
+;;;
+;;; 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(define-module (skribilo coloring xml)
+ :export (xml)
+ :use-module (skribilo source)
+ :use-module (skribilo lib)
+ :use-module (ice-9 rdelim)
+ :use-module (ice-9 regex))
+
+
+(define %comment-rx (make-regexp "<!--(.|\\n)*-->" regexp/extended))
+
+(define (xml-fontifier str)
+ (let loop ((start 0)
+ (result '()))
+ (if (>= start (string-length str))
+ (reverse! result)
+ (case (string-ref str start)
+ ((#\")
+ (let ((end (string-index str start #\")))
+ (if (not end)
+ (skribe-error 'xml-fontifier
+ "unterminated XML string"
+ (string-drop str start))
+ (loop end
+ (cons (new markup
+ (markup '&source-string)
+ (body (substring str start end)))
+ result)))))
+ ((#\<)
+ (let ((end (string-index str #\> start)))
+ (if (not end)
+ (skribe-error 'xml-fontifier
+ "unterminated XML tag"
+ (string-drop str start))
+ (let ((comment? (regexp-exec %comment-rx
+ (substring str start end))))
+ (loop end
+ (cons (if comment?
+ (new markup
+ (markup '&source-comment)
+ (body (substring str start end)))
+ (new markup
+ (markup '&source-module)
+ (body (substring str start end))))
+ result))))))
+
+ (else
+ (loop (+ 1 start)
+ (if (or (null? result)
+ (not (string? (car result))))
+ (cons (string (string-ref str start)) result)
+ (cons (string-append (car result)
+ (string (string-ref str start)))
+ (cdr result)))))))))
+
+
+(define xml
+ (new language
+ (name "xml")
+ (fontifier xml-fontifier)
+ (extractor #f)))
+
+;;; xml.scm ends here
diff --git a/src/guile/skribilo/condition.scm b/src/guile/skribilo/condition.scm
new file mode 100644
index 0000000..4d61efb
--- /dev/null
+++ b/src/guile/skribilo/condition.scm
@@ -0,0 +1,171 @@
+;;; condition.scm -- Skribilo SRFI-35 error condition hierarchy.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo condition)
+ :autoload (srfi srfi-1) (find)
+ :autoload (srfi srfi-34) (guard)
+ :use-module (srfi srfi-35)
+ :use-module (srfi srfi-39)
+ :export (&skribilo-error skribilo-error?
+ &invalid-argument-error invalid-argument-error?
+ &too-few-arguments-error too-few-arguments-error?
+
+ &file-error file-error?
+ &file-search-error file-search-error?
+ &file-open-error file-open-error?
+ &file-write-error file-write-error?
+
+ register-error-condition-handler!
+ lookup-error-condition-handler
+
+ %call-with-skribilo-error-catch
+ call-with-skribilo-error-catch))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; Top-level of Skribilo's SRFI-35 error conditions.
+;;;
+;;; Code:
+
+
+;;;
+;;; Standard error conditions.
+;;;
+
+(define-condition-type &skribilo-error &error
+ skribilo-error?)
+
+
+;;;
+;;; Generic errors.
+;;;
+
+(define-condition-type &invalid-argument-error &skribilo-error
+ invalid-argument-error?
+ (proc-name invalid-argument-error:proc-name)
+ (argument invalid-argument-error:argument))
+
+(define-condition-type &too-few-arguments-error &skribilo-error
+ too-few-arguments-error?
+ (proc-name too-few-arguments-error:proc-name)
+ (arguments too-few-arguments-error:arguments))
+
+
+;;;
+;;; File errors.
+;;;
+
+(define-condition-type &file-error &skribilo-error
+ file-error?
+ (file-name file-error:file-name))
+
+(define-condition-type &file-search-error &file-error
+ file-search-error?
+ (path file-search-error:path))
+
+(define-condition-type &file-open-error &file-error
+ file-open-error?)
+
+(define-condition-type &file-write-error &file-error
+ file-write-error?)
+
+
+
+;;;
+;;; Adding new error conditions from other modules.
+;;;
+
+(define %external-error-condition-alist '())
+
+(define (register-error-condition-handler! pred handler)
+ (set! %external-error-condition-alist
+ (cons (cons pred handler)
+ %external-error-condition-alist)))
+
+(define (lookup-error-condition-handler c)
+ (let ((pair (find (lambda (pair)
+ (let ((pred (car pair)))
+ (pred c)))
+ %external-error-condition-alist)))
+ (if (pair? pair)
+ (cdr pair)
+ #f)))
+
+
+
+;;;
+;;; Convenience functions.
+;;;
+
+(define (%call-with-skribilo-error-catch thunk exit exit-val)
+ (guard (c ((invalid-argument-error? c)
+ (format (current-error-port) "in `~a': invalid argument: ~S~%"
+ (invalid-argument-error:proc-name c)
+ (invalid-argument-error:argument c))
+ (exit exit-val))
+
+ ((too-few-arguments-error? c)
+ (format (current-error-port) "in `~a': too few arguments: ~S~%"
+ (too-few-arguments-error:proc-name c)
+ (too-few-arguments-error:arguments c)))
+
+ ((file-search-error? c)
+ (format (current-error-port) "~a: not found in path `~S'~%"
+ (file-error:file-name c)
+ (file-search-error:path c))
+ (exit exit-val))
+
+ ((file-open-error? c)
+ (format (current-error-port) "~a: cannot open file~%"
+ (file-error:file-name c))
+ (exit exit-val))
+
+ ((file-write-error? c)
+ (format (current-error-port) "~a: cannot write to file~%"
+ (file-error:file-name c))
+ (exit exit-val))
+
+ ((file-error? c)
+ (format (current-error-port) "file error: ~a~%"
+ (file-error:file-name c))
+ (exit exit-val))
+
+ (;;(skribilo-error? c)
+ #t ;; XXX: The SRFI-35 currently in `guile-lib' doesn't work
+ ;; properly with non-direct super-types.
+ (let ((handler (lookup-error-condition-handler c)))
+ (if (procedure? handler)
+ (handler c)
+ (format (current-error-port)
+ "undefined skribilo error: ~S~%"
+ c)))
+ (exit exit-val)))
+
+ (thunk)))
+
+(define-macro (call-with-skribilo-error-catch thunk)
+ `(call/cc (lambda (cont)
+ (%call-with-skribilo-error-catch ,thunk cont #f))))
+
+;;; arch-tag: 285010f9-06ea-4c39-82c2-6c3604f668b3
+
+;;; conditions.scm ends here
diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in
new file mode 100644
index 0000000..545612c
--- /dev/null
+++ b/src/guile/skribilo/config.scm.in
@@ -0,0 +1,20 @@
+;;; -*- Scheme -*-
+;;;
+
+(define-module (skribilo config))
+
+(define-public (skribilo-release) "1.2")
+(define-public (skribilo-url) "http://www.nongnu.org/skribilo/")
+(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..f7709a0
--- /dev/null
+++ b/src/guile/skribilo/debug.scm
@@ -0,0 +1,168 @@
+;;; debug.scm -- Debugging facilities.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo debug)
+ :use-module (skribilo utils syntax)
+ :use-module (srfi srfi-17)
+ :use-module (srfi srfi-39)
+ :export-syntax (debug-item with-debug))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; Parameters.
+;;;
+
+;; Current debugging level.
+(define-public *debug*
+ (make-parameter 0 (lambda (val)
+ (cond ((number? val) val)
+ ((string? val)
+ (string->number val))
+ (else
+ (error "*debug*: wrong argument type"
+ val))))))
+
+;; Whether to use colors.
+(define-public *debug-use-colors?* (make-parameter #t))
+
+;; Where to spit debugging output.
+(define-public *debug-port* (make-parameter (current-output-port)))
+
+;; Whether to debug individual items.
+(define-public *debug-item?* (make-parameter #f))
+
+;; Watched (debugged) symbols (procedure names).
+(define-public *watched-symbols* (make-parameter '()))
+
+
+
+;;;
+;;; Implementation.
+;;;
+
+(define *debug-depth* (make-parameter 0))
+(define *debug-margin* (make-parameter ""))
+(define *margin-level* (make-parameter 0))
+
+
+
+;;
+;; 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 (*debug-use-colors?*)
+ (equal? (getenv "TERM") "xterm"))
+ (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-macro (debug-item . args)
+ `(if (*debug-item?*) (%do-debug-item ,@args)))
+
+(define-public (%do-debug-item . args)
+ (begin
+ (display (*debug-margin*) (*debug-port*))
+ (display (debug-color (- (*debug-depth*) 1) "- ") (*debug-port*))
+ (for-each (lambda (a) (display a (*debug-port*))) args)
+ (newline (*debug-port*))))
+
+;;(define-macro (debug-item . args)
+;; `())
+
+
+;;;
+;;; %with-debug-margin
+;;;
+(define (%with-debug-margin margin thunk)
+ (parameterize ((*debug-depth* (+ (*debug-depth*) 1))
+ (*debug-margin* (string-append (*debug-margin*) margin)))
+ (thunk)))
+
+;;;
+;;; %with-debug
+;;;
+(define-public (%do-with-debug lvl lbl thunk)
+ (parameterize ((*margin-level* lvl)
+ (*debug-item?* #t))
+ (display (*debug-margin*) (*debug-port*))
+ (display (if (= (*debug-depth*) 0)
+ (debug-color (*debug-depth*) "+ " lbl)
+ (debug-color (*debug-depth*) "--+ " lbl))
+ (*debug-port*))
+ (newline (*debug-port*))
+ (%with-debug-margin (debug-color (*debug-depth*) " |")
+ thunk)))
+
+(define-macro (with-debug level label . body)
+ ;; We have this as a macro in order to avoid procedure calls in the
+ ;; non-debugging case. Unfortunately, the macro below duplicates BODY,
+ ;; which has a negative impact on memory usage and startup time (XXX).
+ (if (number? level)
+ `(if (or (>= (*debug*) ,level)
+ (memq ,label (*watched-symbols*)))
+ (%do-with-debug ,level ,label (lambda () ,@body))
+ (begin ,@body))
+ (error "with-debug: syntax error")))
+
+
+; Example:
+
+; (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))
+
+;;; debug.scm ends here
diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm
new file mode 100644
index 0000000..06667ad
--- /dev/null
+++ b/src/guile/skribilo/engine.scm
@@ -0,0 +1,390 @@
+;;; engine.scm -- Skribilo engines.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo engine)
+ :use-module (skribilo debug)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo lib)
+
+ ;; `(skribilo writer)' depends on this module so it needs to be loaded
+ ;; after we defined `<engine>' and the likes.
+ :autoload (skribilo writer) (<writer>)
+
+ :use-module (oop goops)
+ :use-module (ice-9 optargs)
+ :autoload (srfi srfi-39) (make-parameter)
+
+ :export (<engine> engine? engine-ident engine-format
+ engine-customs engine-filter engine-symbol-table
+
+ *current-engine*
+ default-engine default-engine-set!
+ make-engine copy-engine find-engine lookup-engine
+ engine-custom engine-custom-set! engine-custom-add!
+ engine-format? engine-add-writer!
+ processor-get-engine
+ push-default-engine pop-default-engine
+
+ engine-loaded? when-engine-is-loaded))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; Class definition.
+;;;
+
+;; Note on writers
+;; ---------------
+;;
+;; `writers' here is an `eq?' hash table where keys are markup names
+;; (symbols) and values are lists of markup writers (most of the time, the
+;; list will only contain one writer). Each of these writer may define a
+;; predicate or class that may further restrict its applicability.
+;;
+;; `free-writers' is a list of writers that may apply to *any* kind of
+;; markup. These are typically define by passing `#t' to `markup-writer'
+;; instead of a symbol:
+;;
+;; (markup-writer #f (find-engine 'xml)
+;; :before ...
+;; ...)
+;;
+;; The XML engine contains an example of such free writers. Again, these
+;; writers may define a predicate or a class restricting their applicability.
+;;
+;; The distinction between these two kinds of writers is mostly performance:
+;; "free writers" are rarely used and markup-specific are the most common
+;; case which we want to be fast. Therefore, for the latter case, we can't
+;; afford traversing a list of markups, evaluating each and every markup
+;; predicate.
+;;
+;; For more details, see `markup-writer-get' and `lookup-markup-writer' in
+;; `(skribilo writer)'.
+
+(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-thunk make-hash-table)
+ (free-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)
+ (slot-ref obj 'ident))
+
+(define (engine-format obj)
+ (slot-ref obj 'format))
+
+(define (engine-customs obj)
+ (slot-ref obj 'customs))
+
+(define (engine-filter obj)
+ (slot-ref obj 'filter))
+
+(define (engine-symbol-table obj)
+ (slot-ref obj 'symbol-table))
+
+
+
+;;;
+;;; Default engines.
+;;;
+
+(define *default-engine* #f)
+(define *default-engines* '())
+
+
+(define (default-engine)
+ *default-engine*)
+
+
+(define (default-engine-set! e)
+ (with-debug 5 'default-engine-set!
+ (debug-item "engine=" 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))
+ (else (*current-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)))
+ 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)))
+
+ ;; XXX: We don't use `list-copy' here because writer lists are only
+ ;; consed, never mutated.
+
+ ;(slot-set! new 'free-writers (list-copy (slot-ref e 'free-writers)))
+
+ (let ((new-writers (make-hash-table)))
+ (hash-for-each (lambda (m w*)
+ (hashq-set! new-writers m w*))
+ (slot-ref e 'writers))
+ (slot-set! new 'writers new-writers))
+
+ new))
+
+
+
+;;;
+;;; Engine loading.
+;;;
+
+;; Each engine is to be stored in its own module with the `(skribilo engine)'
+;; hierarchy. The `engine-id->module-name' procedure returns this module
+;; name based on the engine name.
+
+(define (engine-id->module-name id)
+ `(skribilo engine ,id))
+
+(define (engine-loaded? id)
+ "Check whether engine @var{id} is already loaded."
+ ;; Trick taken from `resolve-module' in `boot-9.scm'.
+ (nested-ref the-root-module
+ `(%app modules ,@(engine-id->module-name id))))
+
+;; A mapping of engine names to hooks.
+(define %engine-load-hook (make-hash-table))
+
+(define (consume-load-hook! id)
+ (with-debug 5 'consume-load-hook!
+ (let ((hook (hashq-ref %engine-load-hook id)))
+ (if hook
+ (begin
+ (debug-item "running hook " hook " for engine " id)
+ (hashq-remove! %engine-load-hook id)
+ (run-hook hook))))))
+
+(define (when-engine-is-loaded id thunk)
+ "Run @var{thunk} only when engine with identifier @var{id} is loaded."
+ (if (engine-loaded? id)
+ (begin
+ ;; Maybe the engine had already been loaded via `use-modules'.
+ (consume-load-hook! id)
+ (thunk))
+ (let ((hook (or (hashq-ref %engine-load-hook id)
+ (let ((hook (make-hook)))
+ (hashq-set! %engine-load-hook id hook)
+ hook))))
+ (add-hook! hook thunk))))
+
+
+(define* (lookup-engine id :key (version 'unspecified))
+ "Look for an engine named @var{name} (a symbol) in the @code{(skribilo
+engine)} module hierarchy. If no such engine was found, an error is raised,
+otherwise the requested engine is returned."
+ (with-debug 5 'lookup-engine
+ (debug-item "id=" id " version=" version)
+
+ (let* ((engine (symbol-append id '-engine))
+ (m (resolve-module (engine-id->module-name id))))
+ (if (module-bound? m engine)
+ (let ((e (module-ref m engine)))
+ (if e (consume-load-hook! id))
+ e)
+ (error "no such engine" id)))))
+
+(define* (find-engine id :key (version 'unspecified))
+ (false-if-exception (apply lookup-engine (list id version))))
+
+
+
+
+
+;;;
+;;; Engine methods.
+;;;
+
+(define (engine-custom e id)
+ (let* ((customs (slot-ref e 'customs))
+ (c (assq id customs)))
+ (if (pair? c)
+ (cadr c)
+ 'unspecified)))
+
+
+(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)))))
+
+(define (engine-custom-add! e id val)
+ (let ((old (engine-custom e id)))
+ (if (unspecified? old)
+ (engine-custom-set! e id (list val))
+ (engine-custom-set! e id (cons val old)))))
+
+(define (engine-add-writer! e ident pred upred opt before action
+ after class valid)
+ ;; Add a writer to engine E. If IDENT is a symbol, then it should denote
+ ;; a markup name and the writer being added is specific to that markup. If
+ ;; IDENT is `#t' (for instance), then it is assumed to be a ``free writer''
+ ;; that may apply to any kind of markup for which PRED returns true.
+
+ (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
+ (if pred
+ (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)))
+ (if (symbol? ident)
+ (let ((writers (slot-ref e 'writers)))
+ (hashq-set! writers ident
+ (cons n (hashq-ref writers ident '()))))
+ (slot-set! e 'free-writers
+ (cons n (slot-ref e 'free-writers))))
+ n))
+
+
+
+;;;
+;;; Current engine.
+;;;
+
+;;; `(skribilo module)' must be loaded before the first `find-engine' call.
+(use-modules (skribilo module))
+
+;; At this point, we're almost done with the bootstrap process.
+;(format #t "base engine: ~a~%" (lookup-engine 'base))
+
+(define *current-engine*
+ ;; By default, use the HTML engine.
+ (make-parameter (lookup-engine 'html)
+ (lambda (val)
+ (cond ((symbol? val) (lookup-engine val))
+ ((engine? val) val)
+ (else
+ (error "invalid value for `*current-engine*'"
+ val))))))
+
+
+;;; engine.scm ends here
diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am
new file mode 100644
index 0000000..7b6ec2c
--- /dev/null
+++ b/src/guile/skribilo/engine/Makefile.am
@@ -0,0 +1,5 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/engine
+dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \
+ latex-simple.scm latex.scm \
+ lout.scm \
+ xml.scm
diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm
new file mode 100644
index 0000000..8418e8b
--- /dev/null
+++ b/src/guile/skribilo/engine/base.scm
@@ -0,0 +1,479 @@
+;;; base.scm -- BASE Skribe engine
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo engine base))
+
+;*---------------------------------------------------------------------*/
+;* base-engine ... */
+;*---------------------------------------------------------------------*/
+(define base-engine
+ (default-engine-set!
+ (make-engine 'base
+ :version 'plain
+ :symbol-table '(("iexcl" "!")
+ ("cent" "c")
+ ("lguillemet" "\"")
+ ("not" "!")
+ ("registered" "(r)")
+ ("degree" "o")
+ ("plusminus" "+/-")
+ ("micro" "o")
+ ("paragraph" "p")
+ ("middot" ".")
+ ("rguillemet" "\"")
+ ("iquestion" "?")
+ ("Agrave" "À")
+ ("Aacute" "A")
+ ("Acircumflex" "Â")
+ ("Atilde" "A")
+ ("Amul" "A")
+ ("Aring" "A")
+ ("AEligature" "AE")
+ ("Oeligature" "OE")
+ ("Ccedilla" "Ç")
+ ("Egrave" "È")
+ ("Eacute" "É")
+ ("Ecircumflex" "Ê")
+ ("Euml" "E")
+ ("Igrave" "I")
+ ("Iacute" "I")
+ ("Icircumflex" "Î")
+ ("Iuml" "I")
+ ("ETH" "D")
+ ("Ntilde" "N")
+ ("Ograve" "O")
+ ("Oacute" "O")
+ ("Ocurcumflex" "O")
+ ("Otilde" "O")
+ ("Ouml" "O")
+ ("times" "x")
+ ("Oslash" "O")
+ ("Ugrave" "Ù")
+ ("Uacute" "U")
+ ("Ucircumflex" "Û")
+ ("Uuml" "Ü")
+ ("Yacute" "Y")
+ ("agrave" "à")
+ ("aacute" "a")
+ ("acircumflex" "â")
+ ("atilde" "a")
+ ("amul" "a")
+ ("aring" "a")
+ ("aeligature" "æ")
+ ("oeligature" "oe")
+ ("ccedilla" "ç")
+ ("egrave" "è")
+ ("eacute" "é")
+ ("ecircumflex" "ê")
+ ("euml" "e")
+ ("igrave" "i")
+ ("iacute" "i")
+ ("icircumflex" "î")
+ ("iuml" "i")
+ ("ntilde" "n")
+ ("ograve" "o")
+ ("oacute" "o")
+ ("ocurcumflex" "o")
+ ("otilde" "o")
+ ("ouml" "o")
+ ("divide" "/")
+ ("oslash" "o")
+ ("ugrave" "ù")
+ ("uacute" "u")
+ ("ucircumflex" "û")
+ ("uuml" "ü")
+ ("yacute" "y")
+ ("ymul" "y")
+ ;; punctuation
+ ("bullet" ".")
+ ("ellipsis" "...")
+ ("<-" "<-")
+ ("<--" "<--")
+ ("uparrow" "^;")
+ ("->" "->")
+ ("-->" "-->")
+ ("downarrow" "v")
+ ("<->" "<->")
+ ("<-->" "<-->")
+ ("<+" "<+")
+ ("<=" "<=;")
+ ("<==" "<==")
+ ("Uparrow" "^")
+ ("=>" "=>")
+ ("==>" "==>")
+ ("Downarrow" "v")
+ ("<=>" "<=>")
+ ("<==>" "<==>")
+ ;; Mathematical operators
+ ("asterisk" "*")
+ ("angle" "<")
+ ("and" "^;")
+ ("or" "v")
+ ("models" "|=")
+ ("vdash" "|-")
+ ("dashv" "-|")
+ ("sim" "~")
+ ("mid" "|")
+ ("langle" "<")
+ ("rangle" ">")
+ ;; LaTeX
+ ("circ" "o")
+ ("top" "T")
+ ("lhd" "<")
+ ("rhd" ">")
+ ("parallel" "||")))))
+
+;*---------------------------------------------------------------------*/
+;* mark ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'symbol
+ :action (lambda (n e)
+ (let* ((s (markup-body n))
+ (c (assoc s (engine-symbol-table e))))
+ (if (pair? c)
+ (display (cadr c))
+ (output s e)))))
+
+;*---------------------------------------------------------------------*/
+;* unref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'unref
+ :options 'all
+ :action (lambda (n e)
+ (let* ((s (markup-option n :skribe))
+ (k (markup-option n 'kind))
+ (f (cond
+ (s
+ (format #f "?~a@~a " k s))
+ (else
+ (format #f "?~a " k))))
+ (msg (list f (markup-body n)))
+ (n (list "[" (color :fg "red" (bold msg)) "]")))
+ (skribe-eval n e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ (let ((w (markup-writer-get 'table e)))
+ (and (writer? w) (invoke (writer-before w) n e))))
+ :action (lambda (n e)
+ (when (pair? (markup-body n))
+ (for-each (lambda (i) (output i e)) (markup-body n))))
+ :after (lambda (n e)
+ (let ((w (markup-writer-get 'table e)))
+ (and (writer? w) (invoke (writer-after w) n e)))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :before (lambda (n e)
+ (invoke (writer-before (markup-writer-get 'tr e)) n e))
+ :action (lambda (n e)
+ (let ((wtc (markup-writer-get 'tc e)))
+ ;; the label
+ (markup-option-add! n :valign 'top)
+ (markup-option-add! n :align 'right)
+ (invoke (writer-before wtc) n e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (invoke (writer-after wtc) n e)
+ ;; the body
+ (markup-option-add! n :valign 'top)
+ (markup-option-add! n :align 'left)
+ (invoke (writer-before wtc) n e)
+ (output n e (markup-writer-get '&bib-entry-body))
+ (invoke (writer-after wtc) n e)))
+ :after (lambda (n e)
+ (invoke (writer-after (markup-writer-get 'tr e)) n e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before "["
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-body ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-body
+ :action (lambda (n e)
+ (define (output-fields descr)
+ (let loop ((descr descr)
+ (pending #f)
+ (armed #f))
+ (cond
+ ((null? descr)
+ 'done)
+ ((pair? (car descr))
+ (if (eq? (caar descr) 'or)
+ (let ((o1 (cadr (car descr))))
+ (if (markup-option n o1)
+ (loop (cons o1 (cdr descr))
+ pending
+ #t)
+ (let ((o2 (caddr (car descr))))
+ (loop (cons o2 (cdr descr))
+ pending
+ armed))))
+ (let ((o (markup-option n (cadr (car descr)))))
+ (if o
+ (begin
+ (if (and pending armed)
+ (output pending e))
+ (output (caar descr) e)
+ (output o e)
+ (if (pair? (cddr (car descr)))
+ (output (caddr (car descr)) e))
+ (loop (cdr descr) #f #t))
+ (loop (cdr descr) pending armed)))))
+ ((symbol? (car descr))
+ (let ((o (markup-option n (car descr))))
+ (if o
+ (begin
+ (if (and armed pending)
+ (output pending e))
+ (output o e)
+ (loop (cdr descr) #f #t))
+ (loop (cdr descr) pending armed))))
+ ((null? (cdr descr))
+ (output (car descr) e))
+ ((string? (car descr))
+ (loop (cdr descr)
+ (if pending pending (car descr))
+ armed))
+ (else
+ (skribe-error 'output-bib-fields
+ "Illegal description"
+ (car descr))))))
+ (output-fields
+ (case (markup-option n 'kind)
+ ((techreport)
+ `(author " -- " (or title url documenturl) " -- "
+ number ", " institution ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((article)
+ `(author " -- " (or title url documenturl) " -- "
+ journal ", " volume "" ("(" number ")") ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((inproceedings)
+ `(author " -- " (or title url documenturl) " -- "
+ booktitle ", " series ", " ("(" number ")") ", "
+ address ", " month ", " year ", "
+ ("pp. " pages) "."))
+ ((book)
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year ", " ("pp. " pages) "."))
+ ((phdthesis)
+ '(author " -- " (or title url documenturl) " -- " type ", "
+ school ", " address
+ ", " month ", " year"."))
+ ((misc)
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year"."))
+ (else
+ '(author " -- " (or title url documenturl) " -- "
+ publisher ", " address
+ ", " month ", " year ", " ("pp. " pages) "."))))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-ident ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-ident
+ :action (lambda (n e)
+ (output (markup-option n 'number) e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-publisher ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-publisher
+ :action (lambda (n e)
+ (skribe-eval (it (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &the-index ... @label the-index@ */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index
+ :options '(:column)
+ :before (lambda (n e)
+ (output (markup-option n 'header) e))
+ :action (lambda (n e)
+ (define (make-mark-entry n fst)
+ (let ((l (tr :class 'index-mark-entry
+ (td :colspan 2 :align 'left
+ (bold (it (sf n)))))))
+ (if fst
+ (list l)
+ (list (tr (td :colspan 2)) l))))
+ (define (make-primary-entry n p)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (c (if note
+ (list b
+ (it (list " (" note ")")))
+ b)))
+ (when p
+ (markup-option-add! b :text
+ (list (markup-option b :text)
+ ", p."))
+ (markup-option-add! b :page #t))
+ (tr :class 'index-primary-entry
+ (td :colspan 2 :valign 'top :align 'left c))))
+ (define (make-secondary-entry n p)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (bb (markup-body b)))
+ (cond
+ ((not (or bb (is-markup? b 'url-ref)))
+ (skribe-error 'the-index
+ "Illegal entry"
+ b))
+ (note
+ (let ((r (if bb
+ (it (ref :class "the-index-secondary"
+ :handle bb
+ :page p
+ :text (if p
+ (list note ", p.")
+ note)))
+ (it (ref :class "the-index-secondary"
+ :url (markup-option b :url)
+ :page p
+ :text (if p
+ (list note ", p.")
+ note))))))
+ (tr :class 'index-secondary-entry
+ (td :valign 'top :align 'right :width 1. " ...")
+ (td :valign 'top :align 'left r))))
+ (else
+ (let ((r (if bb
+ (ref :class "the-index-secondary"
+ :handle bb
+ :page p
+ :text (if p " ..., p." " ..."))
+ (ref :class "the-index-secondary"
+ :url (markup-option b :url)
+ :page p
+ :text (if p " ..., p." " ...")))))
+ (tr :class 'index-secondary-entry
+ (td :valign 'top :align 'right :width 1.)
+ (td :valign 'top :align 'left r)))))))
+ (define (make-column ie p)
+ (let loop ((ie ie)
+ (f #t))
+ (cond
+ ((null? ie)
+ '())
+ ((not (pair? (car ie)))
+ (append (make-mark-entry (car ie) f)
+ (loop (cdr ie) #f)))
+ (else
+ (cons (make-primary-entry (caar ie) p)
+ (append (map (lambda (x)
+ (make-secondary-entry x p))
+ (cdar ie))
+ (loop (cdr ie) #f)))))))
+ (define (make-sub-tables ie nc p)
+ (let* ((l (length ie))
+ (w (/ 100. nc))
+ (iepc (let ((d (/ l nc)))
+ (if (integer? d)
+ (inexact->exact d)
+ (+ 1 (inexact->exact (truncate d))))))
+ (split (list-split ie iepc)))
+ (tr (map (lambda (ies)
+ (td :valign 'top :width w
+ (if (pair? ies)
+ (table :width 100. (make-column ies p))
+ "")))
+ split))))
+ (let* ((ie (markup-body n))
+ (nc (markup-option n :column))
+ (loc (ast-loc n))
+ (pref (eq? (engine-custom e 'index-page-ref) #t))
+ (t (cond
+ ((null? ie)
+ "")
+ ;; FIXME: Since we don't support
+ ;; `:&skribe-eval-location', we could set up a
+ ;; `parameterize' thing around `skribe-eval' to
+ ;; provide it with the right location information.
+ ((or (not (integer? nc)) (= nc 1))
+ (table :width 100.
+ ;;:&skribe-eval-location loc
+ :class "index-table"
+ (make-column ie pref)))
+ (else
+ (table :width 100.
+ ;;:&skribe-eval-location loc
+ :class "index-table"
+ (make-sub-tables ie nc pref))))))
+ (output (skribe-eval t e) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;* ------------------------------------------------------------- */
+;* The index header is only useful for targets that support */
+;* hyperlinks such as HTML. */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e) #f))
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (n (markup-ident (handle-body (markup-body n)))))
+ (skribe-eval (it (if (integer? o) (+ o n) n)) e))))
+
+
+
+;;;; A VIRER (mais handle-body n'est pas défini)
+(markup-writer 'line-ref
+ :options '(:offset)
+ :action #f)
diff --git a/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm
new file mode 100644
index 0000000..c9e0986
--- /dev/null
+++ b/src/guile/skribilo/engine/context.scm
@@ -0,0 +1,1382 @@
+;;;;
+;;;; context.skr -- ConTeXt mode 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 23-Sep-2004 17:21 (eg)
+;;;; Last file update: 3-Nov-2004 12:54 (eg)
+;;;;
+
+(define-skribe-module (skribilo engine context))
+
+;;;; ======================================================================
+;;;; context-customs ...
+;;;; ======================================================================
+(define context-customs
+ '((source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ (index-page-ref #t)
+ (image-format ("jpg"))
+ (font-size 11)
+ (font-type "roman")
+ (user-style #f)
+ (document-style "book")))
+
+;;;; ======================================================================
+;;;; context-encoding ...
+;;;; ======================================================================
+(define context-encoding
+ '((#\# "\\type{#}")
+ (#\| "\\type{|}")
+ (#\{ "$\\{$")
+ (#\} "$\\}$")
+ (#\~ "\\type{~}")
+ (#\& "\\type{&}")
+ (#\_ "\\type{_}")
+ (#\^ "\\type{^}")
+ (#\[ "\\type{[}")
+ (#\] "\\type{]}")
+ (#\< "\\type{<}")
+ (#\> "\\type{>}")
+ (#\$ "\\type{$}")
+ (#\% "\\%")
+ (#\\ "$\\backslash$")))
+
+;;;; ======================================================================
+;;;; context-pre-encoding ...
+;;;; ======================================================================
+(define context-pre-encoding
+ (append '((#\space "~")
+ (#\~ "\\type{~}"))
+ context-encoding))
+
+
+;;;; ======================================================================
+;;;; context-symbol-table ...
+;;;; ======================================================================
+(define (context-symbol-table math)
+ `(("iexcl" "!`")
+ ("cent" "c")
+ ("pound" "\\pounds")
+ ("yen" "Y")
+ ("section" "\\S")
+ ("mul" ,(math "^-"))
+ ("copyright" "\\copyright")
+ ("lguillemet" ,(math "\\ll"))
+ ("not" ,(math "\\neg"))
+ ("degree" ,(math "^{\\small{o}}"))
+ ("plusminus" ,(math "\\pm"))
+ ("micro" ,(math "\\mu"))
+ ("paragraph" "\\P")
+ ("middot" ,(math "\\cdot"))
+ ("rguillemet" ,(math "\\gg"))
+ ("1/4" ,(math "\\frac{1}{4}"))
+ ("1/2" ,(math "\\frac{1}{2}"))
+ ("3/4" ,(math "\\frac{3}{4}"))
+ ("iquestion" "?`")
+ ("Agrave" "\\`{A}")
+ ("Aacute" "\\'{A}")
+ ("Acircumflex" "\\^{A}")
+ ("Atilde" "\\~{A}")
+ ("Amul" "\\\"{A}")
+ ("Aring" "{\\AA}")
+ ("AEligature" "{\\AE}")
+ ("Oeligature" "{\\OE}")
+ ("Ccedilla" "{\\c{C}}")
+ ("Egrave" "{\\`{E}}")
+ ("Eacute" "{\\'{E}}")
+ ("Ecircumflex" "{\\^{E}}")
+ ("Euml" "\\\"{E}")
+ ("Igrave" "{\\`{I}}")
+ ("Iacute" "{\\'{I}}")
+ ("Icircumflex" "{\\^{I}}")
+ ("Iuml" "\\\"{I}")
+ ("ETH" "D")
+ ("Ntilde" "\\~{N}")
+ ("Ograve" "\\`{O}")
+ ("Oacute" "\\'{O}")
+ ("Ocurcumflex" "\\^{O}")
+ ("Otilde" "\\~{O}")
+ ("Ouml" "\\\"{O}")
+ ("times" ,(math "\\times"))
+ ("Oslash" "\\O")
+ ("Ugrave" "\\`{U}")
+ ("Uacute" "\\'{U}")
+ ("Ucircumflex" "\\^{U}")
+ ("Uuml" "\\\"{U}")
+ ("Yacute" "\\'{Y}")
+ ("szlig" "\\ss")
+ ("agrave" "\\`{a}")
+ ("aacute" "\\'{a}")
+ ("acircumflex" "\\^{a}")
+ ("atilde" "\\~{a}")
+ ("amul" "\\\"{a}")
+ ("aring" "\\aa")
+ ("aeligature" "\\ae")
+ ("oeligature" "{\\oe}")
+ ("ccedilla" "{\\c{c}}")
+ ("egrave" "{\\`{e}}")
+ ("eacute" "{\\'{e}}")
+ ("ecircumflex" "{\\^{e}}")
+ ("euml" "\\\"{e}")
+ ("igrave" "{\\`{\\i}}")
+ ("iacute" "{\\'{\\i}}")
+ ("icircumflex" "{\\^{\\i}}")
+ ("iuml" "\\\"{\\i}")
+ ("ntilde" "\\~{n}")
+ ("ograve" "\\`{o}")
+ ("oacute" "\\'{o}")
+ ("ocurcumflex" "\\^{o}")
+ ("otilde" "\\~{o}")
+ ("ouml" "\\\"{o}")
+ ("divide" ,(math "\\div"))
+ ("oslash" "\\o")
+ ("ugrave" "\\`{u}")
+ ("uacute" "\\'{u}")
+ ("ucircumflex" "\\^{u}")
+ ("uuml" "\\\"{u}")
+ ("yacute" "\\'{y}")
+ ("ymul" "\\\"{y}")
+ ;; Greek
+ ("Alpha" "A")
+ ("Beta" "B")
+ ("Gamma" ,(math "\\Gamma"))
+ ("Delta" ,(math "\\Delta"))
+ ("Epsilon" "E")
+ ("Zeta" "Z")
+ ("Eta" "H")
+ ("Theta" ,(math "\\Theta"))
+ ("Iota" "I")
+ ("Kappa" "K")
+ ("Lambda" ,(math "\\Lambda"))
+ ("Mu" "M")
+ ("Nu" "N")
+ ("Xi" ,(math "\\Xi"))
+ ("Omicron" "O")
+ ("Pi" ,(math "\\Pi"))
+ ("Rho" "P")
+ ("Sigma" ,(math "\\Sigma"))
+ ("Tau" "T")
+ ("Upsilon" ,(math "\\Upsilon"))
+ ("Phi" ,(math "\\Phi"))
+ ("Chi" "X")
+ ("Psi" ,(math "\\Psi"))
+ ("Omega" ,(math "\\Omega"))
+ ("alpha" ,(math "\\alpha"))
+ ("beta" ,(math "\\beta"))
+ ("gamma" ,(math "\\gamma"))
+ ("delta" ,(math "\\delta"))
+ ("epsilon" ,(math "\\varepsilon"))
+ ("zeta" ,(math "\\zeta"))
+ ("eta" ,(math "\\eta"))
+ ("theta" ,(math "\\theta"))
+ ("iota" ,(math "\\iota"))
+ ("kappa" ,(math "\\kappa"))
+ ("lambda" ,(math "\\lambda"))
+ ("mu" ,(math "\\mu"))
+ ("nu" ,(math "\\nu"))
+ ("xi" ,(math "\\xi"))
+ ("omicron" ,(math "\\o"))
+ ("pi" ,(math "\\pi"))
+ ("rho" ,(math "\\rho"))
+ ("sigmaf" ,(math "\\varsigma"))
+ ("sigma" ,(math "\\sigma"))
+ ("tau" ,(math "\\tau"))
+ ("upsilon" ,(math "\\upsilon"))
+ ("phi" ,(math "\\varphi"))
+ ("chi" ,(math "\\chi"))
+ ("psi" ,(math "\\psi"))
+ ("omega" ,(math "\\omega"))
+ ("thetasym" ,(math "\\vartheta"))
+ ("piv" ,(math "\\varpi"))
+ ;; punctuation
+ ("bullet" ,(math "\\bullet"))
+ ("ellipsis" ,(math "\\ldots"))
+ ("weierp" ,(math "\\wp"))
+ ("image" ,(math "\\Im"))
+ ("real" ,(math "\\Re"))
+ ("tm" ,(math "^{\\sc\\tiny{tm}}"))
+ ("alef" ,(math "\\aleph"))
+ ("<-" ,(math "\\leftarrow"))
+ ("<--" ,(math "\\longleftarrow"))
+ ("uparrow" ,(math "\\uparrow"))
+ ("->" ,(math "\\rightarrow"))
+ ("-->" ,(math "\\longrightarrow"))
+ ("downarrow" ,(math "\\downarrow"))
+ ("<->" ,(math "\\leftrightarrow"))
+ ("<-->" ,(math "\\longleftrightarrow"))
+ ("<+" ,(math "\\hookleftarrow"))
+ ("<=" ,(math "\\Leftarrow"))
+ ("<==" ,(math "\\Longleftarrow"))
+ ("Uparrow" ,(math "\\Uparrow"))
+ ("=>" ,(math "\\Rightarrow"))
+ ("==>" ,(math "\\Longrightarrow"))
+ ("Downarrow" ,(math "\\Downarrow"))
+ ("<=>" ,(math "\\Leftrightarrow"))
+ ("<==>" ,(math "\\Longleftrightarrow"))
+ ;; Mathematical operators
+ ("forall" ,(math "\\forall"))
+ ("partial" ,(math "\\partial"))
+ ("exists" ,(math "\\exists"))
+ ("emptyset" ,(math "\\emptyset"))
+ ("infinity" ,(math "\\infty"))
+ ("nabla" ,(math "\\nabla"))
+ ("in" ,(math "\\in"))
+ ("notin" ,(math "\\notin"))
+ ("ni" ,(math "\\ni"))
+ ("prod" ,(math "\\Pi"))
+ ("sum" ,(math "\\Sigma"))
+ ("asterisk" ,(math "\\ast"))
+ ("sqrt" ,(math "\\surd"))
+ ("propto" ,(math "\\propto"))
+ ("angle" ,(math "\\angle"))
+ ("and" ,(math "\\wedge"))
+ ("or" ,(math "\\vee"))
+ ("cap" ,(math "\\cap"))
+ ("cup" ,(math "\\cup"))
+ ("integral" ,(math "\\int"))
+ ("models" ,(math "\\models"))
+ ("vdash" ,(math "\\vdash"))
+ ("dashv" ,(math "\\dashv"))
+ ("sim" ,(math "\\sim"))
+ ("cong" ,(math "\\cong"))
+ ("approx" ,(math "\\approx"))
+ ("neq" ,(math "\\neq"))
+ ("equiv" ,(math "\\equiv"))
+ ("le" ,(math "\\leq"))
+ ("ge" ,(math "\\geq"))
+ ("subset" ,(math "\\subset"))
+ ("supset" ,(math "\\supset"))
+ ("subseteq" ,(math "\\subseteq"))
+ ("supseteq" ,(math "\\supseteq"))
+ ("oplus" ,(math "\\oplus"))
+ ("otimes" ,(math "\\otimes"))
+ ("perp" ,(math "\\perp"))
+ ("mid" ,(math "\\mid"))
+ ("lceil" ,(math "\\lceil"))
+ ("rceil" ,(math "\\rceil"))
+ ("lfloor" ,(math "\\lfloor"))
+ ("rfloor" ,(math "\\rfloor"))
+ ("langle" ,(math "\\langle"))
+ ("rangle" ,(math "\\rangle"))
+ ;; Misc
+ ("loz" ,(math "\\diamond"))
+ ("spades" ,(math "\\spadesuit"))
+ ("clubs" ,(math "\\clubsuit"))
+ ("hearts" ,(math "\\heartsuit"))
+ ("diams" ,(math "\\diamondsuit"))
+ ("euro" "\\euro{}")
+ ;; ConTeXt
+ ("dag" "\\dag")
+ ("ddag" "\\ddag")
+ ("circ" ,(math "\\circ"))
+ ("top" ,(math "\\top"))
+ ("bottom" ,(math "\\bot"))
+ ("lhd" ,(math "\\triangleleft"))
+ ("rhd" ,(math "\\triangleright"))
+ ("parallel" ,(math "\\parallel"))))
+
+;;;; ======================================================================
+;;;; context-width
+;;;; ======================================================================
+(define (context-width width)
+ (cond
+ ((string? width)
+ width)
+ ((and (number? width) (inexact? width))
+ (string-append (number->string (/ width 100.)) "\\textwidth"))
+ (else
+ (string-append (number->string width) "pt"))))
+
+;;;; ======================================================================
+;;;; context-dim
+;;;; ======================================================================
+(define (context-dim dimension)
+ (cond
+ ((string? dimension)
+ dimension)
+ ((number? dimension)
+ (string-append (number->string (inexact->exact (round dimension)))
+ "pt"))))
+
+;;;; ======================================================================
+;;;; context-url
+;;;; ======================================================================
+(define(context-url url text e)
+ (let ((name (gensym 'url))
+ (text (or text url)))
+ (printf "\\useURL[~A][~A][][" name url)
+ (output text e)
+ (printf "]\\from[~A]" name)))
+
+;;;; ======================================================================
+;;;; Color Management ...
+;;;; ======================================================================
+(define *skribe-context-color-table* (make-hashtable))
+
+(define (skribe-color->context-color spec)
+ (receive (r g b)
+ (skribe-color->rgb spec)
+ (let ((ff (exact->inexact #xff)))
+ (format "r=~a,g=~a,b=~a"
+ (number->string (/ r ff))
+ (number->string (/ g ff))
+ (number->string (/ b ff))))))
+
+
+(define (skribe-declare-used-colors)
+ (printf "\n%%Colors\n")
+ (for-each (lambda (spec)
+ (let ((c (hashtable-get *skribe-context-color-table* spec)))
+ (unless (string? c)
+ ;; Color was never used before
+ (let ((name (symbol->string (gensym 'col))))
+ (hashtable-put! *skribe-context-color-table* spec name)
+ (printf "\\definecolor[~A][~A]\n"
+ name
+ (skribe-color->context-color spec))))))
+ (skribe-get-used-colors))
+ (newline))
+
+(define (skribe-declare-standard-colors engine)
+ (for-each (lambda (x)
+ (skribe-use-color! (engine-custom engine x)))
+ '(source-comment-color source-define-color source-module-color
+ source-markup-color source-thread-color source-string-color
+ source-bracket-color source-type-color)))
+
+(define (skribe-get-color spec)
+ (let ((c (and (hashtable? *skribe-context-color-table*)
+ (hashtable-get *skribe-context-color-table* spec))))
+ (if (not (string? c))
+ (skribe-error 'context "Can't find color" spec)
+ c)))
+
+;;;; ======================================================================
+;;;; context-engine ...
+;;;; ======================================================================
+(define context-engine
+ (default-engine-set!
+ (make-engine 'context
+ :version 1.0
+ :format "context"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace context-encoding)
+ :symbol-table (context-symbol-table (lambda (m) (format #f "$~a$" m)))
+ :custom context-customs)))
+
+;;;; ======================================================================
+;;;; document ...
+;;;; ======================================================================
+(markup-writer 'document
+ :options '(:title :subtitle :author :ending :env)
+ :before (lambda (n e)
+ ;; Prelude
+ (printf "% interface=en output=pdftex\n")
+ (display "%%%% -*- TeX -*-\n")
+ (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n"
+ (skribe-release) (date))
+ ;; Make URLs active
+ (printf "\\setupinteraction[state=start]\n")
+ ;; Choose the document font
+ (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type)
+ (engine-custom e 'font-size))
+ ;; Color
+ (display "\\setupcolors[state=start]\n")
+ ;; Load Style
+ (printf "\\input skribe-context-~a.tex\n"
+ (engine-custom e 'document-style))
+ ;; Insert User customization
+ (let ((s (engine-custom e 'user-style)))
+ (when s (printf "\\input ~a\n" s)))
+ ;; Output used colors
+ (skribe-declare-standard-colors e)
+ (skribe-declare-used-colors)
+
+ (display "\\starttext\n\\StartTitlePage\n")
+ ;; title
+ (let ((t (markup-option n :title)))
+ (when t
+ (skribe-eval (new markup
+ (markup '&context-title)
+ (body t)
+ (options
+ `((subtitle ,(markup-option n :subtitle)))))
+ e
+ :env `((parent ,n)))))
+ ;; author(s)
+ (let ((a (markup-option n :author)))
+ (when a
+ (if (list? a)
+ ;; List of authors. Use multi-columns
+ (begin
+ (printf "\\defineparagraphs[Authors][n=~A]\n" (length a))
+ (display "\\startAuthors\n")
+ (let Loop ((l a))
+ (unless (null? l)
+ (output (car l) e)
+ (unless (null? (cdr l))
+ (display "\\nextAuthors\n")
+ (Loop (cdr l)))))
+ (display "\\stopAuthors\n\n"))
+ ;; One author, that's easy
+ (output a e))))
+ ;; End of the title
+ (display "\\StopTitlePage\n"))
+ :after (lambda (n e)
+ (display "\n\\stoptext\n")))
+
+
+
+;;;; ======================================================================
+;;;; &context-title ...
+;;;; ======================================================================
+(markup-writer '&context-title
+ :before "{\\DocumentTitle{"
+ :action (lambda (n e)
+ (output (markup-body n) e)
+ (let ((sub (markup-option n 'subtitle)))
+ (when sub
+ (display "\\\\\n\\switchtobodyfont[16pt]\\it{")
+ (output sub e)
+ (display "}\n"))))
+ :after "}}")
+
+;;;; ======================================================================
+;;;; author ...
+;;;; ======================================================================
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (out (lambda (n)
+ (output n e)
+ (display "\\\\\n"))))
+ (display "{\\midaligned{")
+ (when name (out name))
+ (when title (out title))
+ (when affiliation (out affiliation))
+ (when (pair? address) (for-each out address))
+ (when phone (out phone))
+ (when email (out email))
+ (when url (out url))
+ (display "}}\n"))))
+
+
+;;;; ======================================================================
+;;;; toc ...
+;;;; ======================================================================
+(markup-writer 'toc
+ :options '()
+ :action (lambda (n e) (display "\\placecontent\n")))
+
+;;;; ======================================================================
+;;;; context-block-before ...
+;;;; ======================================================================
+(define (context-block-before name name-unnum)
+ (lambda (n e)
+ (let ((num (markup-option n :number)))
+ (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n)))
+ (printf "\\~a[~a]{" (if num name name-unnum)
+ (string-canonicalize (markup-ident n)))
+ (output (markup-option n :title) e)
+ (display "}\n"))))
+
+
+;;;; ======================================================================
+;;;; chapter, section, ...
+;;;; ======================================================================
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'chapter 'title))
+
+
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'section 'subject))
+
+
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'subsection 'subsubject))
+
+
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :before (context-block-before 'subsubsection 'subsubsubject))
+
+;;;; ======================================================================
+;;;; paragraph ...
+;;;; ======================================================================
+(markup-writer 'paragraph
+ :options '(:title :number :toc :env)
+ :after "\\par\n")
+
+;;;; ======================================================================
+;;;; footnote ...
+;;;; ======================================================================
+(markup-writer 'footnote
+ :before "\\footnote{"
+ :after "}")
+
+;;;; ======================================================================
+;;;; linebreak ...
+;;;; ======================================================================
+(markup-writer 'linebreak
+ :action "\\crlf ")
+
+;;;; ======================================================================
+;;;; hrule ...
+;;;; ======================================================================
+(markup-writer 'hrule
+ :options '(:width :height)
+ :before (lambda (n e)
+ (printf "\\blackrule[width=~A,height=~A]\n"
+ (context-width (markup-option n :width))
+ (context-dim (markup-option n :height)))))
+
+;;;; ======================================================================
+;;;; color ...
+;;;; ======================================================================
+(markup-writer 'color
+ :options '(:bg :fg :width :margin :border)
+ :before (lambda (n e)
+ (let ((bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (w (markup-option n :width))
+ (m (markup-option n :margin))
+ (b (markup-option n :border))
+ (c (markup-option n :round-corner)))
+ (if (or bg w m b)
+ (begin
+ (printf "\\startframedtext[width=~a" (if w
+ (context-width w)
+ "fit"))
+ (printf ",rulethickness=~A" (if b (context-width b) "0pt"))
+ (when m
+ (printf ",offset=~A" (context-width m)))
+ (when bg
+ (printf ",background=color,backgroundcolor=~A"
+ (skribe-get-color bg)))
+ (when fg
+ (printf ",foregroundcolor=~A"
+ (skribe-get-color fg)))
+ (when c
+ (display ",framecorner=round"))
+ (printf "]\n"))
+ ;; Probably just a foreground was specified
+ (when fg
+ (printf "\\startcolor[~A] " (skribe-get-color fg))))))
+ :after (lambda (n e)
+ (let ((bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (w (markup-option n :width))
+ (m (markup-option n :margin))
+ (b (markup-option n :border)))
+ (if (or bg w m b)
+ (printf "\\stopframedtext ")
+ (when fg
+ (printf "\\stopcolor "))))))
+;;;; ======================================================================
+;;;; frame ...
+;;;; ======================================================================
+(markup-writer 'frame
+ :options '(:width :border :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (b (markup-option n :border))
+ (c (markup-option n :round-corner)))
+ (printf "\\startframedtext[width=~a" (if w
+ (context-width w)
+ "fit"))
+ (printf ",rulethickness=~A" (context-dim b))
+ (printf ",offset=~A" (context-width m))
+ (when c
+ (display ",framecorner=round"))
+ (printf "]\n")))
+ :after "\\stopframedtext ")
+
+;;;; ======================================================================
+;;;; font ...
+;;;; ======================================================================
+(markup-writer 'font
+ :options '(:size)
+ :action (lambda (n e)
+ (let* ((size (markup-option n :size))
+ (cs (engine-custom e 'font-size))
+ (ns (cond
+ ((and (integer? size) (exact? size))
+ (if (> size 0)
+ size
+ (+ cs size)))
+ ((and (number? size) (inexact? size))
+ (+ cs (inexact->exact size)))
+ ((string? size)
+ (let ((nb (string->number size)))
+ (if (not (number? nb))
+ (skribe-error
+ 'font
+ (format #f "Illegal font size ~s" size)
+ nb)
+ (+ cs nb))))))
+ (ne (make-engine (gensym 'context)
+ :delegate e
+ :filter (engine-filter e)
+ :symbol-table (engine-symbol-table e)
+ :custom `((font-size ,ns)
+ ,@(engine-customs e)))))
+ (printf "{\\switchtobodyfont[~apt]" ns)
+ (output (markup-body n) ne)
+ (display "}"))))
+
+
+;;;; ======================================================================
+;;;; flush ...
+;;;; ======================================================================
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\n\n\\midaligned{"))
+ ((left)
+ (display "\n\n\\leftaligned{"))
+ ((right)
+ (display "\n\n\\rightaligned{"))))
+ :after "}\n")
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before "\n\n\\midaligned{"
+ :after "}\n")
+
+;;;; ======================================================================
+;;;; pre ...
+;;;; ======================================================================
+(markup-writer 'pre
+ :before "{\\tt\n\\startlines\n\\fixedspaces\n"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'context)
+ :delegate e
+ :filter (make-string-replace context-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after "\n\\stoplines\n}")
+
+;;;; ======================================================================
+;;;; prog ...
+;;;; ======================================================================
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before "{\\tt\n\\startlines\n\\fixedspaces\n"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'context)
+ :delegate e
+ :filter (make-string-replace context-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after "\n\\stoplines\n}")
+
+
+;;;; ======================================================================
+;;;; itemize, enumerate ...
+;;;; ======================================================================
+(define (context-itemization-action n e descr?)
+ (let ((symbol (markup-option n :symbol)))
+ (for-each (lambda (item)
+ (if symbol
+ (begin
+ (display "\\sym{")
+ (output symbol e)
+ (display "}"))
+ ;; output a \item iff not a description
+ (unless descr?
+ (display " \\item ")))
+ (output item e)
+ (newline))
+ (markup-body n))))
+
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[serried]\n"
+ :action (lambda (n e) (context-itemization-action n e #f))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[n][standard]\n"
+ :action (lambda (n e) (context-itemization-action n e #f))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+;;;; ======================================================================
+;;;; description ...
+;;;; ======================================================================
+(markup-writer 'description
+ :options '(:symbol)
+ :before "\\startnarrower[left]\n\\startitemize[serried]\n"
+ :action (lambda (n e) (context-itemization-action n e #t))
+ :after "\\stopitemize\n\\stopnarrower\n")
+
+;;;; ======================================================================
+;;;; item ...
+;;;; ======================================================================
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (when k
+ ;; Output the key(s)
+ (let Loop ((l (if (pair? k) k (list k))))
+ (unless (null? l)
+ (output (bold (car l)) e)
+ (unless (null? (cdr l))
+ (display "\\crlf\n"))
+ (Loop (cdr l))))
+ (display "\\nowhitespace\\startnarrower[left]\n"))
+ ;; Output body
+ (output (markup-body n) e)
+ ;; Terminate
+ (when k
+ (display "\n\\stopnarrower\n")))))
+
+;;;; ======================================================================
+;;;; blockquote ...
+;;;; ======================================================================
+(markup-writer 'blockquote
+ :before "\n\\startnarrower[left,right]\n"
+ :after "\n\\stopnarrower\n")
+
+
+;;;; ======================================================================
+;;;; figure ...
+;;;; ======================================================================
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (unless number
+ (display "{\\setupcaptions[number=off]\n"))
+ (display "\\placefigure\n")
+ (printf " [~a]\n" (string-canonicalize ident))
+ (display " {") (output legend e) (display "}\n")
+ (display " {") (output (markup-body n) e) (display "}")
+ (unless number
+ (display "}\n")))))
+
+;;;; ======================================================================
+;;;; table ...
+;;;; ======================================================================
+ ;; width doesn't work
+(markup-writer 'table
+ :options '(:width :border :frame :rules :cellpadding)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (cp (markup-option n :cellpadding))
+ (cs (markup-option n :cellspacing)))
+ (printf "\n{\\bTABLE\n")
+ (printf "\\setupTABLE[")
+ (printf "width=~A" (if width (context-width width) "fit"))
+ (when border
+ (printf ",rulethickness=~A" (context-dim border)))
+ (when cp
+ (printf ",offset=~A" (context-width cp)))
+ (printf ",frame=off]\n")
+
+ (when rules
+ (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n")
+ (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n"))
+ (case rules
+ ((rows) (display hor))
+ ((cols) (display vert))
+ ((all) (display hor) (display vert)))))
+
+ (when frame
+ ;; hsides, vsides, lhs, rhs, box, border
+ (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n")
+ (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n")
+ (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n")
+ (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n"))
+ (case frame
+ ((above) (display top))
+ ((below) (display bot))
+ ((hsides) (display top) (display bot))
+ ((lhs) (display left))
+ ((rhs) (display right))
+ ((vsides) (display left) (diplay right))
+ ((box border) (display top) (display bot)
+ (display left) (display right)))))))
+
+ :after (lambda (n e)
+ (printf "\\eTABLE}\n")))
+
+
+;;;; ======================================================================
+;;;; tr ...
+;;;; ======================================================================
+(markup-writer 'tr
+ :options '(:bg)
+ :before (lambda (n e)
+ (display "\\bTR")
+ (let ((bg (markup-option n :bg)))
+ (when bg
+ (printf "[background=color,backgroundcolor=~A]"
+ (skribe-get-color bg)))))
+ :after "\\eTR\n")
+
+
+;;;; ======================================================================
+;;;; tc ...
+;;;; ======================================================================
+(markup-writer 'tc
+ :options '(:width :align :valign :colspan)
+ :before (lambda (n e)
+ (let ((th? (eq? 'th (markup-option n 'markup)))
+ (width (markup-option n :width))
+ (align (markup-option n :align))
+ (valign (markup-option n :valign))
+ (colspan (markup-option n :colspan))
+ (rowspan (markup-option n :rowspan))
+ (bg (markup-option n :bg)))
+ (printf "\\bTD[")
+ (printf "width=~a" (if width (context-width width) "fit"))
+ (when valign
+ ;; This is buggy. In fact valign an align can't be both
+ ;; specified in ConTeXt
+ (printf ",align=~a" (case valign
+ ((center) 'lohi)
+ ((bottom) 'low)
+ ((top) 'high))))
+ (when align
+ (printf ",align=~a" (case align
+ ((left) 'right) ; !!!!
+ ((right) 'left) ; !!!!
+ (else 'middle))))
+ (unless (equal? colspan 1)
+ (printf ",nx=~a" colspan))
+ (display "]")
+ (when th?
+ ;; This is a TH, output is bolded
+ (display "{\\bf{"))))
+
+ :after (lambda (n e)
+ (when (equal? (markup-option n 'markup) 'th)
+ ;; This is a TH, output is bolded
+ (display "}}"))
+ (display "\\eTD")))
+
+;;;; ======================================================================
+;;;; image ...
+;;;; ======================================================================
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("jpg"))))))
+ (if (not (string? img))
+ (skribe-error 'context "Illegal image" file)
+ (begin
+ (printf "\\externalfigure[~A][frame=off" (strip-ref-base img))
+ (if zoom (printf ",factor=~a" (inexact->exact zoom)))
+ (if width (printf ",width=~a" (context-width width)))
+ (if height (printf ",height=~apt" (context-dim height)))
+ (display "]"))))))
+
+
+;;;; ======================================================================
+;;;; Ornaments ...
+;;;; ======================================================================
+(markup-writer 'roman :before "{\\rm{" :after "}}")
+(markup-writer 'bold :before "{\\bf{" :after "}}")
+(markup-writer 'underline :before "{\\underbar{" :after "}}")
+(markup-writer 'emph :before "{\\em{" :after "}}")
+(markup-writer 'it :before "{\\it{" :after "}}")
+(markup-writer 'code :before "{\\tt{" :after "}}")
+(markup-writer 'var :before "{\\tt{" :after "}}")
+(markup-writer 'sc :before "{\\sc{" :after "}}")
+;;//(markup-writer 'sf :before "{\\sf{" :after "}}")
+(markup-writer 'sub :before "{\\low{" :after "}}")
+(markup-writer 'sup :before "{\\high{" :after "}}")
+
+
+;;//
+;;//(markup-writer 'tt
+;;// :before "{\\texttt{"
+;;// :action (lambda (n e)
+;;// (let ((ne (make-engine
+;;// (gensym 'latex)
+;;// :delegate e
+;;// :filter (make-string-replace latex-tt-encoding)
+;;// :custom (engine-customs e)
+;;// :symbol-table (engine-symbol-table e))))
+;;// (output (markup-body n) ne)))
+;;// :after "}}")
+
+;;;; ======================================================================
+;;;; q ...
+;;;; ======================================================================
+(markup-writer 'q
+ :before "\\quotation{"
+ :after "}")
+
+;;;; ======================================================================
+;;;; mailto ...
+;;;; ======================================================================
+(markup-writer 'mailto
+ :options '(:text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text))
+ (url (markup-body n)))
+ (when (pair? url)
+ (context-url (format #f "mailto:~A" (car url))
+ (or text
+ (car url))
+ e)))))
+;;;; ======================================================================
+;;;; mark ...
+;;;; ======================================================================
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "\\reference[~a]{}\n"
+ (string-canonicalize (markup-ident n)))))
+
+;;;; ======================================================================
+;;;; ref ...
+;;;; ======================================================================
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection
+ :figure :mark :handle :page)
+ :action (lambda (n e)
+ (let* ((text (markup-option n :text))
+ (page (markup-option n :page))
+ (c (handle-ast (markup-body n)))
+ (id (markup-ident c)))
+ (cond
+ (page ;; Output the page only (this is a hack)
+ (when text (output text e))
+ (printf "\\at[~a]"
+ (string-canonicalize id)))
+ ((or (markup-option n :chapter)
+ (markup-option n :section)
+ (markup-option n :subsection)
+ (markup-option n :subsubsection))
+ (if text
+ (printf "\\goto{~a}[~a]" (or text id)
+ (string-canonicalize id))
+ (printf "\\in[~a]" (string-canonicalize id))))
+ ((markup-option n :mark)
+ (printf "\\goto{~a}[~a]"
+ (or text id)
+ (string-canonicalize id)))
+ (else ;; Output a little image indicating the direction
+ (printf "\\in[~a]" (string-canonicalize id)))))))
+
+;;;; ======================================================================
+;;;; bib-ref ...
+;;;; ======================================================================
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e)
+ (let* ((obj (handle-ast (markup-body n)))
+ (title (markup-option obj :title))
+ (ref (markup-option title 'number))
+ (ident (markup-ident obj)))
+ (printf "\\goto{~a}[~a]" ref (string-canonicalize ident))))
+ :after (lambda (n e) (output "]" e)))
+
+;;;; ======================================================================
+;;;; bib-ref+ ...
+;;;; ======================================================================
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after (lambda (n e) (output "]" e)))
+
+;;;; ======================================================================
+;;;; url-ref ...
+;;;; ======================================================================
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (context-url (markup-option n :url) (markup-option n :text) e)))
+
+;;//;*---------------------------------------------------------------------*/
+;;//;* line-ref ... */
+;;//;*---------------------------------------------------------------------*/
+;;//(markup-writer 'line-ref
+;;// :options '(:offset)
+;;// :before "{\\textit{"
+;;// :action (lambda (n e)
+;;// (let ((o (markup-option n :offset))
+;;// (v (string->number (markup-option n :text))))
+;;// (cond
+;;// ((and (number? o) (number? v))
+;;// (display (+ o v)))
+;;// (else
+;;// (display v)))))
+;;// :after "}}")
+
+
+;;;; ======================================================================
+;;;; &the-bibliography ...
+;;;; ======================================================================
+(markup-writer '&the-bibliography
+ :before "\n% Bibliography\n\n")
+
+
+;;;; ======================================================================
+;;;; &bib-entry ...
+;;;; ======================================================================
+(markup-writer '&bib-entry
+ :options '(:title)
+ :action (lambda (n e)
+ (skribe-eval (mark (markup-ident n)) e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (output n e (markup-writer-get '&bib-entry-body e)))
+ :after "\n\n")
+
+;;;; ======================================================================
+;;;; &bib-entry-label ...
+;;;; ======================================================================
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before (lambda (n e) (output "[" e))
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after (lambda (n e) (output "] "e)))
+
+;;;; ======================================================================
+;;;; &bib-entry-title ...
+;;;; ======================================================================
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+
+;;//;*---------------------------------------------------------------------*/
+;;//;* &bib-entry-url ... */
+;;//;*---------------------------------------------------------------------*/
+;;//(markup-writer '&bib-entry-url
+;;// :action (lambda (n e)
+;;// (let* ((en (handle-ast (ast-parent n)))
+;;// (url (markup-option en 'url))
+;;// (t (bold (markup-body url))))
+;;// (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+
+;;;; ======================================================================
+;;;; &the-index ...
+;;;; ======================================================================
+(markup-writer '&the-index
+ :options '(:column)
+ :action
+ (lambda (n e)
+ (define (make-mark-entry n)
+ (display "\\blank[medium]\n{\\bf\\it\\tfc{")
+ (skribe-eval (bold n) e)
+ (display "}}\\crlf\n"))
+
+ (define (make-primary-entry n)
+ (let ((b (markup-body n)))
+ (markup-option-add! b :text (list (markup-option b :text) ", "))
+ (markup-option-add! b :page #t)
+ (output n e)))
+
+ (define (make-secondary-entry n)
+ (let* ((note (markup-option n :note))
+ (b (markup-body n))
+ (bb (markup-body b)))
+ (if note
+ (begin ;; This is another entry
+ (display "\\crlf\n ... ")
+ (markup-option-add! b :text (list note ", ")))
+ (begin ;; another line on an entry
+ (markup-option-add! b :text ", ")))
+ (markup-option-add! b :page #t)
+ (output n e)))
+
+ ;; Writer body starts here
+ (let ((col (markup-option n :column)))
+ (when col
+ (printf "\\startcolumns[n=~a]\n" col))
+ (for-each (lambda (item)
+ ;;(DEBUG "ITEM= ~S" item)
+ (if (pair? item)
+ (begin
+ (make-primary-entry (car item))
+ (for-each (lambda (x) (make-secondary-entry x))
+ (cdr item)))
+ (make-mark-entry item))
+ (display "\\crlf\n"))
+ (markup-body n))
+ (when col
+ (printf "\\stopcolumns\n")))))
+
+;;;; ======================================================================
+;;;; &source-comment ...
+;;;; ======================================================================
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-line-comment ...
+;;;; ======================================================================
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-keyword ...
+;;;; ======================================================================
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (it (markup-body n)) e)))
+
+;;;; ======================================================================
+;;;; &source-error ...
+;;;; ======================================================================
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'error-color) cc)
+ (color :fg cc (it n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-define ...
+;;;; ======================================================================
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-module ...
+;;;; ======================================================================
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-markup ...
+;;;; ======================================================================
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-thread ...
+;;;; ======================================================================
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-string ...
+;;;; ======================================================================
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-bracket ...
+;;;; ======================================================================
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-type ...
+;;;; ======================================================================
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-key ...
+;;;; ======================================================================
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;;;; ======================================================================
+;;;; &source-type ...
+;;;; ======================================================================
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+
+
+;;;; ======================================================================
+;;;; Context Only Markups
+;;;; ======================================================================
+
+;;;
+;;; Margin -- put text in the margin
+;;;
+(define-markup (margin #!rest opts #!key (ident #f) (class "margin")
+ (side 'right) text)
+ (new markup
+ (markup 'margin)
+ (ident (or ident (symbol->string (gensym 'ident))))
+ (class class)
+ (required-options '(:text))
+ (options (the-options opts :ident :class))
+ (body (the-body opts))))
+
+(markup-writer 'margin
+ :options '(:text)
+ :before (lambda (n e)
+ (display
+ "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n")
+ (display "\\inright{")
+ (output (markup-option n :text) e)
+ (display "}{"))
+ :after "}")
+
+;;;
+;;; ConTeXt and TeX
+;;;
+(define-markup (ConTeXt #!key (space #t))
+ (if (engine-format? "context")
+ (! (if space "\\CONTEXT\\ " "\\CONTEXT"))
+ "ConTeXt"))
+
+(define-markup (TeX #!key (space #t))
+ (if (engine-format? "context")
+ (! (if space "\\TEX\\ " "\\TEX"))
+ "ConTeXt"))
+
+;;;; ======================================================================
+;;;; Restore the base engine
+;;;; ======================================================================
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm
new file mode 100644
index 0000000..6232b96
--- /dev/null
+++ b/src/guile/skribilo/engine/html.scm
@@ -0,0 +1,2313 @@
+;;; html.scm -- HTML engine.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo engine html)
+ :autoload (skribilo parameters) (*destination-file*)
+ :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)))
+
+
+;; Keep a reference to the base engine.
+(define base-engine (find-engine 'base))
+
+(if (not (engine? base-engine))
+ (error "bootstrap problem: base engine broken" base-engine))
+
+;*---------------------------------------------------------------------*/
+;* html-file-default ... */
+;*---------------------------------------------------------------------*/
+(define html-file-default
+ ;; Default implementation of the `file-name-proc' custom.
+ (let ((table '())
+ (filename (tmpnam)))
+ (define (get-file-name base suf)
+ (let* ((c (assoc base table))
+ (n (if (pair? c)
+ (let ((n (+ 1 (cdr c))))
+ (set-cdr! c n)
+ n)
+ (begin
+ (set! table (cons (cons base 1) table))
+ 1))))
+ (format #f "~a-~a.~a" base n suf)))
+ (lambda (node e)
+ (let ((f (markup-option node filename))
+ (file (markup-option node :file)))
+ (cond
+ ((string? f)
+ f)
+ ((string? file)
+ file)
+ ((or file
+ (and (is-markup? node 'chapter)
+ (engine-custom e 'chapter-file))
+ (and (is-markup? node 'section)
+ (engine-custom e 'section-file))
+ (and (is-markup? node 'subsection)
+ (engine-custom e 'subsection-file))
+ (and (is-markup? node 'subsubsection)
+ (engine-custom e 'subsubsection-file)))
+ (let* ((b (or (and (string? (*destination-file*))
+ (prefix (*destination-file*)))
+ ""))
+ (s (or (and (string? (*destination-file*))
+ (suffix (*destination-file*)))
+ "html"))
+ (nm (get-file-name b s)))
+ (markup-option-add! node filename nm)
+ nm))
+ ((document? node)
+ (*destination-file*))
+ (else
+ (let ((p (ast-parent node)))
+ (if (container? p)
+ (let ((file (html-file p e)))
+ (if (string? file)
+ (begin
+ (markup-option-add! node filename file)
+ file)
+ #f))
+ #f))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-engine ... */
+;*---------------------------------------------------------------------*/
+(define-public html-engine
+ ;; setup the html engine
+ (default-engine-set!
+ (make-engine 'html
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")
+ (#\@ "&#x40;")))
+ :custom `(;; the icon associated with the URL
+ (favicon #f)
+ ;; charset used
+ (charset "ISO-8859-1")
+ ;; enable/disable Javascript
+ (javascript #f)
+ ;; user html head
+ (head #f)
+ ;; user CSS
+ (css ())
+ ;; user inlined CSS
+ (inline-css ())
+ ;; user JS
+ (js ())
+ ;; emit-sui
+ (emit-sui #f)
+ ;; the body
+ (background #f)
+ (foreground #f)
+ ;; the margins
+ (margin-padding 3)
+ (left-margin #f)
+ (chapter-left-margin #f)
+ (section-left-margin #f)
+ (left-margin-font #f)
+ (left-margin-size 17.)
+ (left-margin-background #f)
+ (left-margin-foreground #f)
+ (right-margin #f)
+ (chapter-right-margin #f)
+ (section-right-margin #f)
+ (right-margin-font #f)
+ (right-margin-size 17.)
+ (right-margin-background #f)
+ (right-margin-foreground #f)
+ ;; author configuration
+ (author-font #f)
+ ;; title configuration
+ (title-font #f)
+ (title-background #f)
+ (title-foreground #f)
+ (file-title-separator " -- ")
+ ;; html file naming
+ (file-name-proc ,html-file-default)
+ ;; index configuration
+ (index-header-font-size #f) ;; +2.
+ ;; chapter configuration
+ (chapter-number->string number->string)
+ (chapter-file #f)
+ ;; section configuration
+ (section-title-start "<h3>")
+ (section-title-stop "</h3>")
+ (section-title-background #f)
+ (section-title-foreground #f)
+ (section-title-number-separator " ")
+ (section-number->string number->string)
+ (section-file #f)
+ ;; subsection configuration
+ (subsection-title-start "<h3>")
+ (subsection-title-stop "</h3>")
+ (subsection-title-background #f)
+ (subsection-title-foreground #f)
+ (subsection-title-number-separator " ")
+ (subsection-number->string number->string)
+ (subsection-file #f)
+ ;; subsubsection configuration
+ (subsubsection-title-start "<h4>")
+ (subsubsection-title-stop "</h4>")
+ (subsubsection-title-background #f)
+ (subsubsection-title-foreground #f)
+ (subsubsection-title-number-separator " ")
+ (subsubsection-number->string number->string)
+ (subsubsection-file #f)
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ ;; image
+ (image-format ("png" "gif" "jpg" "jpeg")))
+ :symbol-table '(("iexcl" "&#161;")
+ ("cent" "&#162;")
+ ("pound" "&#163;")
+ ("currency" "&#164;")
+ ("yen" "&#165;")
+ ("section" "&#167;")
+ ("mul" "&#168;")
+ ("copyright" "&#169;")
+ ("female" "&#170;")
+ ("lguillemet" "&#171;")
+ ("not" "&#172;")
+ ("registered" "&#174;")
+ ("degree" "&#176;")
+ ("plusminus" "&#177;")
+ ("micro" "&#181;")
+ ("paragraph" "&#182;")
+ ("middot" "&#183;")
+ ("male" "&#184;")
+ ("rguillemet" "&#187;")
+ ("1/4" "&#188;")
+ ("1/2" "&#189;")
+ ("3/4" "&#190;")
+ ("iquestion" "&#191;")
+ ("Agrave" "&#192;")
+ ("Aacute" "&#193;")
+ ("Acircumflex" "&#194;")
+ ("Atilde" "&#195;")
+ ("Amul" "&#196;")
+ ("Aring" "&#197;")
+ ("AEligature" "&#198;")
+ ("Oeligature" "&#338;")
+ ("Ccedilla" "&#199;")
+ ("Egrave" "&#200;")
+ ("Eacute" "&#201;")
+ ("Ecircumflex" "&#202;")
+ ("Euml" "&#203;")
+ ("Igrave" "&#204;")
+ ("Iacute" "&#205;")
+ ("Icircumflex" "&#206;")
+ ("Iuml" "&#207;")
+ ("ETH" "&#208;")
+ ("Ntilde" "&#209;")
+ ("Ograve" "&#210;")
+ ("Oacute" "&#211;")
+ ("Ocurcumflex" "&#212;")
+ ("Otilde" "&#213;")
+ ("Ouml" "&#214;")
+ ("times" "&#215;")
+ ("Oslash" "&#216;")
+ ("Ugrave" "&#217;")
+ ("Uacute" "&#218;")
+ ("Ucircumflex" "&#219;")
+ ("Uuml" "&#220;")
+ ("Yacute" "&#221;")
+ ("THORN" "&#222;")
+ ("szlig" "&#223;")
+ ("agrave" "&#224;")
+ ("aacute" "&#225;")
+ ("acircumflex" "&#226;")
+ ("atilde" "&#227;")
+ ("amul" "&#228;")
+ ("aring" "&#229;")
+ ("aeligature" "&#230;")
+ ("oeligature" "&#339;")
+ ("ccedilla" "&#231;")
+ ("egrave" "&#232;")
+ ("eacute" "&#233;")
+ ("ecircumflex" "&#234;")
+ ("euml" "&#235;")
+ ("igrave" "&#236;")
+ ("iacute" "&#237;")
+ ("icircumflex" "&#238;")
+ ("iuml" "&#239;")
+ ("eth" "&#240;")
+ ("ntilde" "&#241;")
+ ("ograve" "&#242;")
+ ("oacute" "&#243;")
+ ("ocurcumflex" "&#244;")
+ ("otilde" "&#245;")
+ ("ouml" "&#246;")
+ ("divide" "&#247;")
+ ("oslash" "&#248;")
+ ("ugrave" "&#249;")
+ ("uacute" "&#250;")
+ ("ucircumflex" "&#251;")
+ ("uuml" "&#252;")
+ ("yacute" "&#253;")
+ ("thorn" "&#254;")
+ ("ymul" "&#255;")
+ ;; Greek
+ ("Alpha" "&#913;")
+ ("Beta" "&#914;")
+ ("Gamma" "&#915;")
+ ("Delta" "&#916;")
+ ("Epsilon" "&#917;")
+ ("Zeta" "&#918;")
+ ("Eta" "&#919;")
+ ("Theta" "&#920;")
+ ("Iota" "&#921;")
+ ("Kappa" "&#922;")
+ ("Lambda" "&#923;")
+ ("Mu" "&#924;")
+ ("Nu" "&#925;")
+ ("Xi" "&#926;")
+ ("Omicron" "&#927;")
+ ("Pi" "&#928;")
+ ("Rho" "&#929;")
+ ("Sigma" "&#931;")
+ ("Tau" "&#932;")
+ ("Upsilon" "&#933;")
+ ("Phi" "&#934;")
+ ("Chi" "&#935;")
+ ("Psi" "&#936;")
+ ("Omega" "&#937;")
+ ("alpha" "&#945;")
+ ("beta" "&#946;")
+ ("gamma" "&#947;")
+ ("delta" "&#948;")
+ ("epsilon" "&#949;")
+ ("zeta" "&#950;")
+ ("eta" "&#951;")
+ ("theta" "&#952;")
+ ("iota" "&#953;")
+ ("kappa" "&#954;")
+ ("lambda" "&#955;")
+ ("mu" "&#956;")
+ ("nu" "&#957;")
+ ("xi" "&#958;")
+ ("omicron" "&#959;")
+ ("pi" "&#960;")
+ ("rho" "&#961;")
+ ("sigmaf" "&#962;")
+ ("sigma" "&#963;")
+ ("tau" "&#964;")
+ ("upsilon" "&#965;")
+ ("phi" "&#966;")
+ ("chi" "&#967;")
+ ("psi" "&#968;")
+ ("omega" "&#969;")
+ ("thetasym" "&#977;")
+ ("piv" "&#982;")
+ ;; punctuation
+ ("bullet" "&#8226;")
+ ("ellipsis" "&#8230;")
+ ("weierp" "&#8472;")
+ ("image" "&#8465;")
+ ("real" "&#8476;")
+ ("tm" "&#8482;")
+ ("alef" "&#8501;")
+ ("<-" "&#8592;")
+ ("<--" "&#8592;")
+ ("uparrow" "&#8593;")
+ ("->" "&#8594;")
+ ("-->" "&#8594;")
+ ("downarrow" "&#8595;")
+ ("<->" "&#8596;")
+ ("<-->" "&#8596;")
+ ("<+" "&#8629;")
+ ("<=" "&#8656;")
+ ("<==" "&#8656;")
+ ("Uparrow" "&#8657;")
+ ("=>" "&#8658;")
+ ("==>" "&#8658;")
+ ("Downarrow" "&#8659;")
+ ("<=>" "&#8660;")
+ ("<==>" "&#8660;")
+ ;; Mathematical operators
+ ("forall" "&#8704;")
+ ("partial" "&#8706;")
+ ("exists" "&#8707;")
+ ("emptyset" "&#8709;")
+ ("infinity" "&#8734;")
+ ("nabla" "&#8711;")
+ ("in" "&#8712;")
+ ("notin" "&#8713;")
+ ("ni" "&#8715;")
+ ("prod" "&#8719;")
+ ("sum" "&#8721;")
+ ("asterisk" "&#8727;")
+ ("sqrt" "&#8730;")
+ ("propto" "&#8733;")
+ ("angle" "&#8736;")
+ ("and" "&#8743;")
+ ("or" "&#8744;")
+ ("cap" "&#8745;")
+ ("cup" "&#8746;")
+ ("integral" "&#8747;")
+ ("therefore" "&#8756;")
+ ("models" "|=")
+ ("vdash" "|-")
+ ("dashv" "-|")
+ ("sim" "&#8764;")
+ ("cong" "&#8773;")
+ ("approx" "&#8776;")
+ ("neq" "&#8800;")
+ ("equiv" "&#8801;")
+ ("le" "&#8804;")
+ ("ge" "&#8805;")
+ ("subset" "&#8834;")
+ ("supset" "&#8835;")
+ ("nsupset" "&#8835;")
+ ("subseteq" "&#8838;")
+ ("supseteq" "&#8839;")
+ ("oplus" "&#8853;")
+ ("otimes" "&#8855;")
+ ("perp" "&#8869;")
+ ("mid" "|")
+ ("lceil" "&#8968;")
+ ("rceil" "&#8969;")
+ ("lfloor" "&#8970;")
+ ("rfloor" "&#8971;")
+ ("langle" "&#9001;")
+ ("rangle" "&#9002;")
+ ;; Misc
+ ("loz" "&#9674;")
+ ("spades" "&#9824;")
+ ("clubs" "&#9827;")
+ ("hearts" "&#9829;")
+ ("diams" "&#9830;")
+ ("euro" "&#8464;")
+ ;; LaTeX
+ ("dag" "dag")
+ ("ddag" "ddag")
+ ("circ" "o")
+ ("top" "T")
+ ("bottom" "&#8869;")
+ ("lhd" "<")
+ ("rhd" ">")
+ ("parallel" "||")))))
+
+;*---------------------------------------------------------------------*/
+;* html-file ... */
+;*---------------------------------------------------------------------*/
+(define (html-file n e)
+ (let ((proc (or (engine-custom e 'file-name-proc) html-file-default)))
+ (proc n e)))
+
+;*---------------------------------------------------------------------*/
+;* html-title-engine ... */
+;*---------------------------------------------------------------------*/
+(define html-title-engine
+ (copy-engine 'html-title base-engine
+ :filter (make-string-replace '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")))))
+
+;*---------------------------------------------------------------------*/
+;* html-browser-title ... */
+;*---------------------------------------------------------------------*/
+(define (html-browser-title n)
+ (and (markup? n)
+ (or (markup-option n :html-title)
+ (if (document? n)
+ (markup-option n :title)
+ (html-browser-title (ast-parent n))))))
+
+
+;*---------------------------------------------------------------------*/
+;* html-container-number ... */
+;* ------------------------------------------------------------- */
+;* Returns a string representing the container number */
+;*---------------------------------------------------------------------*/
+(define (html-container-number c e)
+ (define (html-number n proc)
+ (cond
+ ((string? n)
+ n)
+ ((number? n)
+ (if (procedure? proc)
+ (proc n)
+ (number->string n)))
+ (else
+ "")))
+ (define (html-chapter-number c)
+ (html-number (markup-option c :number)
+ (engine-custom e 'chapter-number->string)))
+ (define (html-section-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'section-number->string))))
+ (cond
+ ((is-markup? p 'chapter)
+ (string-append (html-chapter-number p) "." s))
+ (else
+ (string-append s)))))
+ (define (html-subsection-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'subsection-number->string))))
+ (cond
+ ((is-markup? p 'section)
+ (string-append (html-section-number p) "." s))
+ (else
+ (string-append "." s)))))
+ (define (html-subsubsection-number c)
+ (let ((p (ast-parent c))
+ (s (html-number (markup-option c :number)
+ (engine-custom e 'subsubsection-number->string))))
+ (cond
+ ((is-markup? p 'subsection)
+ (string-append (html-subsection-number p) "." s))
+ (else
+ (string-append ".." s)))))
+ (define (inner-html-container-number c)
+ (html-number (markup-option c :number) #f))
+ (let ((n (markup-option c :number)))
+ (if (not n)
+ ""
+ (case (markup-markup c)
+ ((chapter)
+ (html-chapter-number c))
+ ((section)
+ (html-section-number c))
+ ((subsection)
+ (html-subsection-number c))
+ ((subsubsection)
+ (html-subsubsection-number c))
+ (else
+ (if (container? c)
+ (inner-html-container-number c)
+ (skribe-error 'html-container-number
+ "Not a container"
+ (markup-markup c))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-counter ... */
+;*---------------------------------------------------------------------*/
+(define (html-counter cnts)
+ (cond
+ ((not cnts)
+ "")
+ ((null? cnts)
+ "")
+ ((not (pair? cnts))
+ cnts)
+ ((null? (cdr cnts))
+ (format #f "~a." (car cnts)))
+ (else
+ (let loop ((cnts cnts))
+ (if (null? (cdr cnts))
+ (format #f "~a" (car cnts))
+ (format #f "~a.~a" (car cnts) (loop (cdr cnts))))))))
+
+;*---------------------------------------------------------------------*/
+;* html-width ... */
+;*---------------------------------------------------------------------*/
+(define-public (html-width width)
+ (cond
+ ((and (integer? width) (exact? width))
+ (format #f "~A" width))
+ ((real? width)
+ (format #f "~A%" (inexact->exact (round width))))
+ ((string? width)
+ width)
+ (else
+ (skribe-error 'html-width "bad width" width))))
+
+;*---------------------------------------------------------------------*/
+;* html-class ... */
+;*---------------------------------------------------------------------*/
+(define-public (html-class m)
+ (if (markup? m)
+ (let ((c (markup-class m)))
+ (if (or (string? c) (symbol? c) (number? c))
+ (printf " class=\"~a\"" c)))))
+
+;*---------------------------------------------------------------------*/
+;* html-markup-class ... */
+;*---------------------------------------------------------------------*/
+(define-public (html-markup-class m)
+ (lambda (n e)
+ (printf "<~a" m)
+ (html-class n)
+ (display ">")))
+
+;*---------------------------------------------------------------------*/
+;* html-color-spec? ... */
+;*---------------------------------------------------------------------*/
+(define (html-color-spec? v)
+ (and v
+ (not (unspecified? v))
+ (or (not (string? v)) (> (string-length v) 0))))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :html-title :env :keywords)
+ :action (lambda (n e)
+ (let* ((id (markup-ident n))
+ (title (new markup
+ (markup '&html-document-title)
+ (parent n)
+ (ident (string-append id "-title"))
+ (class (markup-class n))
+ (options `((author ,(markup-option n :author))))
+ (body (markup-option n :title)))))
+ (&html-generic-document n title e)))
+ :after (lambda (n e)
+ (if (engine-custom e 'emit-sui)
+ (document-sui n e))))
+
+;*---------------------------------------------------------------------*/
+;* &html-html ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-html
+ :before "<!-- 95% W3C COMPLIANT, 95% CSS FREE, RAW HTML -->
+<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+<html>\n"
+ :after "</html>")
+
+;*---------------------------------------------------------------------*/
+;* &html-head ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-head
+ :before (lambda (n e)
+ (printf "<head>\n")
+ (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;")
+ (printf "charset=~A\">\n" (engine-custom (find-engine 'html)
+ 'charset)))
+ :after "</head>\n\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-meta ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-meta
+ :before "<meta name=\"keywords\" content=\""
+ :action (lambda (n e)
+ (let ((kw* (map ast->string (or (markup-body n) '()))))
+ (output (keyword-list->comma-separated kw*) e)))
+ :after "\">\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-body ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-body
+ :before (lambda (n e)
+ (let ((bg (engine-custom e 'background)))
+ (display "<body")
+ (html-class n)
+ (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg))
+ (display ">\n")))
+ :after "</body>\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-page ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-page
+ :action (lambda (n e)
+ (define (html-margin m fn size bg fg cla)
+ (printf "<td align=\"left\" valign=\"top\" class=\"~a\"" cla)
+ (if size
+ (printf " width=\"~a\"" (html-width size)))
+ (if (html-color-spec? bg)
+ (printf " bgcolor=\"~a\">" bg)
+ (display ">"))
+ (printf "<div class=\"~a\">\n" cla)
+ (cond
+ ((and (string? fg) (string? fn))
+ (printf "<font color=\"~a\" \"~a\">" fg fn))
+ ((string? fg)
+ (printf "<font color=\"~a\">" fg))
+ ((string? fn)
+ (printf "<font \"~a\">" fn)))
+ (if (procedure? m)
+ (skribe-eval (m n e) e)
+ (output m e))
+ (if (or (string? fg) (string? fn))
+ (display "</font>"))
+ (display "</div></td>\n"))
+ (let ((body (markup-body n))
+ (lm (engine-custom e 'left-margin))
+ (lmfn (engine-custom e 'left-margin-font))
+ (lms (engine-custom e 'left-margin-size))
+ (lmbg (engine-custom e 'left-margin-background))
+ (lmfg (engine-custom e 'left-margin-foreground))
+ (rm (engine-custom e 'right-margin))
+ (rmfn (engine-custom e 'right-margin-font))
+ (rms (engine-custom e 'right-margin-size))
+ (rmbg (engine-custom e 'right-margin-background))
+ (rmfg (engine-custom e 'right-margin-foreground)))
+ (cond
+ ((and lm rm)
+ (let* ((ep (engine-custom e 'margin-padding))
+ (ac (if (number? ep) ep 0)))
+ (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n" ac))
+ (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin")
+ (html-margin body #f #f #f #f "skribilo-body")
+ (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin")
+ (display "</tr></table>"))
+ (lm
+ (let* ((ep (engine-custom e 'margin-padding))
+ (ac (if (number? ep) ep 0)))
+ (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n" ac))
+ (html-margin lm lmfn lms lmbg lmfg "skribilo-left-margin")
+ (html-margin body #f #f #f #f "skribilo-body")
+ (display "</tr></table>"))
+ (rm
+ (let* ((ep (engine-custom e 'margin-padding))
+ (ac (if (number? ep) ep 0)))
+ (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribilo-margins\"><tr>\n"))
+ (html-margin body #f #f #f #f "skribilo-body")
+ (html-margin rm rmfn rms rmbg rmfg "skribilo-right-margin")
+ (display "</tr></table>"))
+ (else
+ (display "<div class=\"skribilo-body\">\n")
+ (output body e)
+ (display "</div>\n"))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-header ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-header n e)
+ (let* ((ic (engine-custom e 'favicon))
+ (id (markup-ident n)))
+ (unless (string? id)
+ (skribe-error '&html-generic-header
+ (format #f "Illegal identifier `~a'" id)
+ n))
+ ;; title
+ (output (new markup
+ (markup '&html-header-title)
+ (parent n)
+ (ident (string-append id "-title"))
+ (class (markup-class n))
+ (body (markup-body n)))
+ e)
+ ;; favicon
+ (output (new markup
+ (markup '&html-header-favicon)
+ (parent n)
+ (ident (string-append id "-favicon"))
+ (body (cond
+ ((string? ic)
+ ic)
+ ((procedure? ic)
+ (ic d e))
+ (else #f))))
+ e)
+ ;; style
+ (output (new markup
+ (markup '&html-header-style)
+ (parent n)
+ (ident (string-append id "-style"))
+ (class (markup-class n)))
+ e)
+ ;; css
+ (output (new markup
+ (markup '&html-header-css)
+ (parent n)
+ (ident (string-append id "-css"))
+ (body (let ((c (engine-custom e 'css)))
+ (if (string? c)
+ (list c)
+ c))))
+ e)
+ ;; javascript
+ (output (new markup
+ (markup '&html-header-javascript)
+ (parent n)
+ (ident (string-append id "-javascript")))
+ e)))
+
+(markup-writer '&html-header-title
+ :before "<title>"
+ :action (lambda (n e)
+ (output (markup-body n) html-title-engine))
+ :after "</title>\n")
+
+(markup-writer '&html-header-favicon
+ :action (lambda (n e)
+ (let ((i (markup-body n)))
+ (when i
+ (printf " <link rel=\"shortcut icon\" href=~s>\n" i)))))
+
+(markup-writer '&html-header-css
+ :action (lambda (n e)
+ (let ((css (markup-body n)))
+ (when (pair? css)
+ (for-each (lambda (css)
+ (printf " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css))
+ css)))))
+
+(markup-writer '&html-header-style
+ :before " <style type=\"text/css\">\n <!--\n"
+ :action (lambda (n e)
+ (let ((hd (engine-custom e 'head))
+ (icss (let ((ic (engine-custom e 'inline-css)))
+ (if (string? ic)
+ (list ic)
+ ic))))
+ (display " pre { font-family: monospace }\n")
+ (display " tt { font-family: monospace }\n")
+ (display " code { font-family: monospace }\n")
+ (display " p.flushright { text-align: right }\n")
+ (display " p.flushleft { text-align: left }\n")
+ (display " span.sc { font-variant: small-caps }\n")
+ (display " span.sf { font-family: sans-serif }\n")
+ (display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n")
+ (when hd (display (format #f " ~a\n" hd)))
+ (when (pair? icss)
+ (for-each (lambda (css)
+ (let ((p (open-input-file css)))
+ (if (not (input-port? p))
+ (skribe-error
+ 'html-css
+ "Can't open CSS file for input"
+ css)
+ (begin
+ (let loop ((l (read-line p)))
+ (unless (eof-object? l)
+ (display l)
+ (newline)
+ (loop (read-line p))))
+ (close-input-port p)))))
+ icss))))
+ :after " -->\n </style>\n")
+
+(markup-writer '&html-header-javascript
+ :action (lambda (n e)
+ (when (engine-custom e 'javascript)
+ (display " <script language=\"JavaScript\" type=\"text/javascript\">\n")
+ (display " <!--\n")
+ (display " function skribenospam( n, d, f ) {\n")
+ (display " nn=n.replace( / /g , \".\" );\n" )
+ (display " dd=d.replace( / /g , \".\" );\n" )
+ (display " document.write( \"<a href=\\\"mailto:\" + nn + \"@\" + dd + \"\\\">\" );\n")
+ (display " if( f ) {\n")
+ (display " document.write( \"<tt>\" + nn + \"@\" + dd + \"</\" + \"tt><\" + \"/a>\" );\n")
+ (display " }\n")
+ (display " }\n")
+ (display " -->\n")
+ (display " </script>\n"))
+ (let* ((ejs (engine-custom e 'js))
+ (js (cond
+ ((string? ejs)
+ (list ejs))
+ ((list? ejs)
+ ejs)
+ (else
+ '()))))
+ (for-each (lambda (s)
+ (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s))
+ js))))
+
+
+;*---------------------------------------------------------------------*/
+;* &html-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-document-header :action &html-generic-header)
+(markup-writer '&html-chapter-header :action &html-generic-header)
+(markup-writer '&html-section-header :action &html-generic-header)
+(markup-writer '&html-subsection-header :action &html-generic-header)
+(markup-writer '&html-subsubsection-header :action &html-generic-header)
+
+;*---------------------------------------------------------------------*/
+;* &html-ending ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-ending
+ :before "<div class=\"skribilo-ending\">"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if body
+ (output body #t)
+ (skribe-eval
+ (list (hrule)
+ (p :class "ending"
+ (font :size -1
+ (list "This HTML page was "
+ "produced by "
+ (ref :text "Skribilo"
+ :url (skribilo-url))
+ "."
+ (linebreak)
+ "Last update: "
+ (s19:date->string
+ (s19:current-date))))))
+ e))))
+ :after "</div>\n")
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-title ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-title n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (tbg (engine-custom e 'title-background))
+ (tfg (engine-custom e 'title-foreground))
+ (tfont (engine-custom e 'title-font)))
+ (when title
+ (display "<table width=\"100%\" class=\"skribilo-title\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>")
+ (if (html-color-spec? tbg)
+ (printf "<td align=\"center\"~A>"
+ (if (html-color-spec? tbg)
+ (string-append "bgcolor=\"" tbg "\"")
+ ""))
+ (display "<td align=\"center\">"))
+ (if (string? tfg)
+ (printf "<font color=\"~a\">" tfg))
+ (when title
+ (if (string? tfont)
+ (begin
+ (printf "<font ~a><strong>" tfont)
+ (output title e)
+ (display "</strong></font>"))
+ (begin
+ (printf "<div class=\"skribilo-title\"><strong><big>")
+ (output title e)
+ (display "</big></strong></div>"))))
+ (if (not authors)
+ (display "\n")
+ (html-title-authors authors e))
+ (if (string? tfg)
+ (display "</font>"))
+ (display "</td></tr></tbody></table>\n"))))
+
+;*---------------------------------------------------------------------*/
+;* &html-document-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-document-title :action &html-generic-title)
+(markup-writer '&html-chapter-title :action &html-generic-title)
+(markup-writer '&html-section-title :action &html-generic-title)
+(markup-writer '&html-subsection-title :action &html-generic-title)
+(markup-writer '&html-subsubsection-title :action &html-generic-title)
+
+;*---------------------------------------------------------------------*/
+;* &html-footnotes */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-footnotes
+ :before (lambda (n e)
+ (let ((footnotes (markup-body n)))
+ (when (pair? footnotes)
+ (display "<div class=\"skribilo-footnote\">")
+ (display "<br><br>\n")
+ (display "<hr width='20%' size='2' align='left'>\n"))))
+ :action (lambda (n e)
+ (let ((footnotes (markup-body n)))
+ (when (pair? footnotes)
+ (let loop ((fns footnotes))
+ (if (pair? fns)
+ (let ((fn (car fns)))
+ (printf "<a name=\"footnote-~a\">"
+ (string-canonicalize
+ (container-ident fn)))
+ (printf "<sup><small>~a</small></sup></a>: "
+ (markup-option fn :number))
+ (output (markup-body fn) e)
+ (display "\n<br>\n")
+ (loop (cdr fns)))))
+ (display "<div>")))))
+
+;*---------------------------------------------------------------------*/
+;* html-title-authors ... */
+;*---------------------------------------------------------------------*/
+(define-public (html-title-authors authors e)
+ (define (html-authorsN authors cols first)
+ (define (make-row authors . opt)
+ (tr (map (lambda (v)
+ (apply td :align 'center :valign 'top v opt))
+ authors)))
+ (define (make-rows authors)
+ (let loop ((authors authors)
+ (rows '())
+ (row '())
+ (cnum 0))
+ (cond
+ ((null? authors)
+ (reverse! (cons (make-row (reverse! row)) rows)))
+ ((= cnum cols)
+ (loop authors
+ (cons (make-row (reverse! row)) rows)
+ '()
+ 0))
+ (else
+ (loop (cdr authors)
+ rows
+ (cons (car authors) row)
+ (+ cnum 1))))))
+ (output (table :cellpadding 10
+ (if first
+ (cons (make-row (list (car authors)) :colspan cols)
+ (make-rows (cdr authors)))
+ (make-rows authors)))
+ e))
+ (cond
+ ((pair? authors)
+ (display "<center>\n")
+ (let ((len (length authors)))
+ (case len
+ ((1)
+ (output (car authors) e))
+ ((2 3)
+ (html-authorsN authors len #f))
+ ((4)
+ (html-authorsN authors 2 #f))
+ (else
+ (html-authorsN authors 3 #t))))
+ (display "</center>\n"))
+ (else
+ (html-title-authors (list authors) e))))
+
+;*---------------------------------------------------------------------*/
+;* document-sui ... */
+;*---------------------------------------------------------------------*/
+(define (document-sui n e)
+ (define (sui)
+ (display "(sui \"")
+ (skribe-eval (markup-option n :title) html-title-engine)
+ (display "\"\n")
+ (printf " :file ~s\n" (sui-referenced-file n e))
+ (sui-marks n e)
+ (sui-blocks 'chapter n e)
+ (sui-blocks 'section n e)
+ (sui-blocks 'subsection n e)
+ (sui-blocks 'subsubsection n e)
+ (display " )\n"))
+ (if (string? (*destination-file*))
+ (let ((f (format #f "~a.sui" (prefix (*destination-file*)))))
+ (with-output-to-file f sui))
+ (sui)))
+
+;*---------------------------------------------------------------------*/
+;* sui-referenced-file ... */
+;*---------------------------------------------------------------------*/
+(define (sui-referenced-file n e)
+ (let ((file (html-file n e)))
+ (if (member (suffix file) '("skb" "sui" "skr" "html"))
+ (string-append (strip-ref-base (prefix file)) ".html")
+ file)))
+
+;*---------------------------------------------------------------------*/
+;* sui-marks ... */
+;*---------------------------------------------------------------------*/
+(define (sui-marks n e)
+ (printf " (marks")
+ (for-each (lambda (m)
+ (printf "\n (~s" (markup-ident m))
+ (printf " :file ~s" (sui-referenced-file m e))
+ (printf " :mark ~s" (markup-ident m))
+ (when (markup-class m)
+ (printf " :class ~s" (markup-class m)))
+ (display ")"))
+ (search-down (lambda (n) (is-markup? n 'mark)) n))
+ (display ")\n"))
+
+;*---------------------------------------------------------------------*/
+;* sui-blocks ... */
+;*---------------------------------------------------------------------*/
+(define (sui-blocks kind n e)
+ (printf " (~as" kind)
+ (for-each (lambda (chap)
+ (display "\n (\"")
+ (skribe-eval (markup-option chap :title) html-title-engine)
+ (printf "\" :file ~s" (sui-referenced-file chap e))
+ (printf " :mark ~s" (markup-ident chap))
+ (when (markup-class chap)
+ (printf " :class ~s" (markup-class chap)))
+ (display ")"))
+ (container-search-down (lambda (n) (is-markup? n kind)) n))
+ (display ")\n"))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (display "<table")
+ (html-class n)
+ (display "><tbody>\n"))
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (nfn (engine-custom e 'author-font))
+ (align (markup-option n :align)))
+ (define (row n)
+ (printf "<tr><td align=\"~a\">" align)
+ (output n e)
+ (display "</td></tr>"))
+ ;; name
+ (printf "<tr><td align=\"~a\">" align)
+ (if nfn (printf "<font ~a>\n" nfn))
+ (output name e)
+ (if nfn (printf "</font>\n"))
+ (display "</td></tr>")
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (if (pair? address)
+ (for-each row address))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url))))
+ :after "</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :predicate (lambda (n e) (markup-option n :photo))
+ :before (lambda (n e)
+ (display "<table")
+ (html-class n)
+ (display "><tbody>\n<tr>"))
+ :action (lambda (n e)
+ (let ((photo (markup-option n :photo)))
+ (display "<td>")
+ (output photo e)
+ (display "</td><td>")
+ (markup-option-add! n :photo #f)
+ (output n e)
+ (markup-option-add! n :photo photo)
+ (display "</td>")))
+ :after "</tr>\n</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options 'all
+ :action (lambda (n e)
+ (define (col n)
+ (let loop ((i 0))
+ (if (< i n)
+ (begin
+ (display "<td></td>")
+ (loop (+ i 1))))))
+ (define (toc-entry fe level)
+ (let* ((c (car fe))
+ (ch (cdr fe))
+ (t (markup-option c :title))
+ (id (markup-ident c))
+ (f (html-file c e)))
+ (unless (string? id)
+ (skribe-error 'toc
+ (format #f "illegal identifier `~a'" id)
+ c))
+ (display " <tr>")
+ ;; blank columns
+ (col level)
+ ;; number
+ (printf "<td valign=\"top\" align=\"left\">~a</td>"
+ (html-container-number c e))
+ ;; title
+ (printf "<td colspan=\"~a\" width=\"100%\">"
+ (- 4 level))
+ (printf "<a href=\"~a#~a\">"
+ (if (and (*destination-file*)
+ (string=? f (*destination-file*)))
+ ""
+ (strip-ref-base (or f (*destination-file*) "")))
+ (string-canonicalize id))
+ (output (markup-option c :title) e)
+ (display "</a></td>")
+ (display "</tr>\n")
+ ;; the children
+ (for-each (lambda (n) (toc-entry n (+ 1 level))) ch)))
+
+ (let* ((c (markup-option n :chapter))
+ (s (markup-option n :section))
+ (ss (markup-option n :subsection))
+ (sss (markup-option n :subsubsection))
+ (b (markup-body n))
+ (bb (if (handle? b)
+ (handle-ast b)
+ b)))
+ (if (not (container? bb))
+ (error 'toc
+ "Illegal body (container expected)"
+ (if (markup? bb)
+ (markup-markup bb)
+ "???"))
+ (let ((lst (find-down (lambda (x)
+ (and (markup? x)
+ (markup-option x :toc)
+ (or (and sss (is-markup? x 'subsubsection))
+ (and ss (is-markup? x 'subsection))
+ (and s (is-markup? x 'section))
+ (and c (is-markup? x 'chapter))
+ (markup-option n (symbol->keyword
+ (markup-markup x))))))
+ (container-body bb))))
+ ;; avoid to produce an empty table
+ (unless (null? lst)
+ (display "<table cellspacing=\"1\" cellpadding=\"1\" width=\"100%\"")
+ (html-class n)
+ (display ">\n<tbody>\n")
+
+ (for-each (lambda (n) (toc-entry n 0)) lst)
+
+ (display "</tbody>\n</table>\n")))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-document ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-document n title e)
+ (let* ((id (markup-ident n))
+ (header (new markup
+ (markup '&html-chapter-header)
+ (ident (string-append id "-header"))
+ (class (markup-class n))
+ (parent n)
+ (body (html-browser-title n))))
+ (meta (new markup
+ (markup '&html-meta)
+ (ident (string-append id "-meta"))
+ (class (markup-class n))
+ (parent n)
+ (body (markup-option (ast-document n) :keywords))))
+ (head (new markup
+ (markup '&html-head)
+ (ident (string-append id "-head"))
+ (class (markup-class n))
+ (parent n)
+ (body (list header meta))))
+ (ftnote (new markup
+ (markup '&html-footnotes)
+ (ident (string-append id "-footnote"))
+ (class (markup-class n))
+ (parent n)
+ (body (reverse!
+ (container-env-get n 'footnote-env)))))
+ (page (new markup
+ (markup '&html-page)
+ (ident (string-append id "-page"))
+ (class (markup-class n))
+ (parent n)
+ (body (list (markup-body n) ftnote))))
+ (ending (new markup
+ (markup '&html-ending)
+ (ident (string-append id "-ending"))
+ (class (markup-class n))
+ (parent n)
+ (body (or (markup-option n :ending)
+ (let ((p (ast-document n)))
+ (and p (markup-option p :ending)))))))
+ (body (new markup
+ (markup '&html-body)
+ (ident (string-append id "-body"))
+ (class (markup-class n))
+ (parent n)
+ (body (list title page ending))))
+ (html (new markup
+ (markup '&html-html)
+ (ident (string-append id "-html"))
+ (class (markup-class n))
+ (parent n)
+ (body (list head body)))))
+ ;; No file must be opened for documents. These files are
+ ;; directly opened by Skribe
+ (if (document? n)
+ (output html e)
+ (with-output-to-file (html-file n e)
+ (lambda ()
+ (output html e))))))
+
+;*---------------------------------------------------------------------*/
+;* &html-generic-subdocument ... */
+;*---------------------------------------------------------------------*/
+(define (&html-generic-subdocument n e)
+ (let* ((p (ast-document n))
+ (id (markup-ident n))
+ (ti (let* ((nb (html-container-number n e))
+ (tc (markup-option n :title))
+ (ti (if (document? p)
+ (list (markup-option p :title)
+ (engine-custom e 'file-title-separator)
+ tc)
+ tc))
+ (sep (engine-custom
+ e
+ (symbol-append (markup-markup n)
+ '-title-number-separator)))
+ (nti (and tc
+ (if (and nb (not (equal? nb "")))
+ (list nb
+ (if (unspecified? sep) ". " sep)
+ ti)
+ ti))))
+ (new markup
+ (markup (symbol-append '&html- (markup-markup n) '-title))
+ (ident (string-append id "-title"))
+ (parent n)
+ (options '((author ())))
+ (body nti)))))
+ (case (markup-markup n)
+ ((chapter)
+ (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id))
+ ((section)
+ (skribe-message " [~s section: ~a]\n" (engine-ident e) id)))
+ (&html-generic-document n ti e)))
+
+;*---------------------------------------------------------------------*/
+;* chapter ... @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :file :toc :html-title :env)
+ :before (lambda (n e)
+ (let ((title (markup-option n :title))
+ (ident (markup-ident n)))
+ (display "<!-- ")
+ (output title html-title-engine)
+ (display " -->\n")
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (display "<center><h1")
+ (html-class n)
+ (display ">")
+ (output (html-container-number n e) e)
+ (display " ")
+ (output (markup-option n :title) e)
+ (display "</h1></center>")))
+ :after "<br>")
+
+;; This writer is invoked only for chapters rendered inside separate files!
+(markup-writer 'chapter
+ :options '(:title :number :file :toc :html-title :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'chapter-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* html-section-title ... */
+;*---------------------------------------------------------------------*/
+(define (html-section-title n e)
+ (let* ((title (markup-option n :title))
+ (number (markup-option n :number))
+ (c (markup-class n))
+ (ident (markup-ident n))
+ (kind (markup-markup n))
+ (tbg (engine-custom e (symbol-append kind '-title-background)))
+ (tfg (engine-custom e (symbol-append kind '-title-foreground)))
+ (tstart (engine-custom e (symbol-append kind '-title-start)))
+ (tstop (engine-custom e (symbol-append kind '-title-stop)))
+ (nsep (engine-custom e (symbol-append kind '-title-number-separator))))
+ ;; the section header
+ (display "<!-- ")
+ (output title html-title-engine)
+ (display " -->\n")
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (if c
+ (printf "<div class=\"~a-title\">" c)
+ (printf "<div class=\"skribilo-~a-title\">" (markup-markup n)))
+ (when (html-color-spec? tbg)
+ (display "<table width=\"100%\">")
+ (printf "<tr><td bgcolor=\"~a\">" tbg))
+ (display tstart)
+ (if tfg (printf "<font color=\"~a\">" tfg))
+ (if number
+ (begin
+ (output (html-container-number n e) e)
+ (output nsep e)))
+ (output title e)
+ (if tfg (display "</font>\n"))
+ (display tstop)
+ (when (and (string? tbg) (> (string-length tbg) 0))
+ (display "</td></tr></table>\n"))
+ (display "</div>")
+ (display "<div")
+ (html-class n)
+ (display ">"))
+ (newline))
+
+;*---------------------------------------------------------------------*/
+;* section ... @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :before html-section-title
+ :after "</div><br>\n")
+
+;; on-file section writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'section-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :html-title :number :toc :env :file)
+ :before html-section-title
+ :after "</div>\n")
+
+;; on-file subsection writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'subsection-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :html-title :number :toc :env :file)
+ :before html-section-title
+ :after "</div>\n")
+
+;; on-file subsection writer
+(markup-writer 'section
+ :options '(:title :html-title :number :toc :file :env)
+ :predicate (lambda (n e)
+ (or (markup-option n :file)
+ (engine-custom e 'subsubsection-file)))
+ :action &html-generic-subdocument)
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :before (lambda (n e)
+ (when (and (>= (skribe-debug) 2) (location? (ast-loc n)))
+ (printf "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>"
+ (ast-location n)))
+ ((html-markup-class "p") n e))
+ :after "</p>")
+
+;*---------------------------------------------------------------------*/
+;* ~ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '~
+ :before "&nbsp;"
+ :after #f
+ :action #f)
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :options '(:label)
+ :action (lambda (n e)
+ (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>"
+ (string-canonicalize (container-ident n))
+ (markup-option n :label))))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :before (lambda (n e)
+ (display "<br")
+ (html-class n)
+ (display "/>")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '(:width :height)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (height (markup-option n :height)))
+ (display "<hr")
+ (html-class n)
+ (if (< width 100)
+ (printf " width=\"~a\"" (html-width width)))
+ (if (> height 1)
+ (printf " size=\"~a\"" height))
+ (display ">"))))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:bg :fg :width :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg)))
+ (when (html-color-spec? bg)
+ (display "<table cellspacing=\"0\"")
+ (html-class n)
+ (printf " cellpadding=\"~a\"" (if m m 0))
+ (if w (printf " width=\"~a\"" (html-width w)))
+ (display "><tbody>\n<tr>")
+ (display "<td bgcolor=\"")
+ (output bg e)
+ (display "\">"))
+ (when (html-color-spec? fg)
+ (display "<font color=\"")
+ (output fg e)
+ (display "\">"))))
+ :after (lambda (n e)
+ (when (html-color-spec? (markup-option n :fg))
+ (display "</font>"))
+ (when (html-color-spec? (markup-option n :bg))
+ (display "</td></tr>\n</tbody></table>"))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ :options '(:width :margin :border)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (b (markup-option n :border))
+ (w (markup-option n :width)))
+ (display "<table cellspacing=\"0\"")
+ (html-class n)
+ (printf " cellpadding=\"~a\"" (if m m 0))
+ (printf " border=\"~a\"" (if b b 0))
+ (if w (printf " width=\"~a\"" (html-width w)))
+ (display "><tbody>\n<tr><td>")))
+ :after "</td></tr>\n</tbody></table>")
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((size (markup-option n :size))
+ (face (markup-option n :face)))
+ (when (and (number? size) (inexact? size))
+ (let ((s (if (> size 0) "<big>" "<small>"))
+ (d (if (> size 0) 1 -1)))
+ (do ((i (inexact->exact size) (- i d)))
+ ((= i 0))
+ (display s))))
+ (when (or (and (number? size) (exact? size)) face)
+ (display "<font")
+ (html-class n)
+ (when (and (number? size) (exact? size) (not (= size 0)))
+ (printf " size=\"~a\"" size))
+ (when face (printf " face=\"~a\"" face))
+ (display ">"))))
+ :after (lambda (n e)
+ (let ((size (markup-option n :size))
+ (face (markup-option n :face)))
+ (when (or (and (number? size) (exact? size) (not (= size 0)))
+ face)
+ (display "</font>"))
+ (when (and (number? size) (inexact? size))
+ (let ((s (if (> size 0) "</big>" "</small>"))
+ (d (if (> size 0) 1 -1)))
+ (do ((i (inexact->exact size) (- i d)))
+ ((= i 0))
+ (display s)))))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "<center")
+ (html-class n)
+ (display ">\n"))
+ ((left)
+ (display "<p style=\"text-align:left;\"")
+ (html-class n)
+ (display ">\n"))
+ ((right)
+ (display "<table ")
+ (html-class n)
+ (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">"))
+ (else
+ (skribe-error 'flush
+ "Illegal side"
+ (markup-option n :side)))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "</center>\n"))
+ ((right)
+ (display "</td></tr></table>\n"))
+ ((left)
+ (display "</p>\n")))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before (html-markup-class "center")
+ :after "</center>\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre :before (html-markup-class "pre") :after "</pre>\n")
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before (html-markup-class "pre")
+ :after "</pre>\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before (html-markup-class "ul")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((ident (and (markup? item)
+ (markup-ident item))))
+ (display "<li")
+ (html-class item)
+ (display ">")
+ (if ident ;; produce an anchor
+ (printf "\n<a name=\"~a\"></a>\n"
+ (string-canonicalize ident)))
+ (output item e)
+ (display "</li>\n")))
+ (markup-body n)))
+ :after "</ul>")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before (html-markup-class "ol")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((ident (and (markup? item)
+ (markup-ident item))))
+ (display "<li")
+ (html-class item)
+ (display ">")
+ (if ident ;; produce an anchor
+ (printf "\n<a name=\"~a\"></a>\n" ident))
+ (output item e)
+ (display "</li>\n")))
+ (markup-body n)))
+ :after "</ol>")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol)
+ :before (html-markup-class "dl")
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (for-each (lambda (i)
+ (display " <dt")
+ (html-class i)
+ (display ">")
+ (output i e)
+ (display "</dt>"))
+ (if (pair? k) k (list k)))
+ (display "<dd")
+ (html-class item)
+ (display ">")
+ (output (markup-body item) e)
+ (display "</dd>\n")))
+ (markup-body n)))
+ :after "</dl>")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (if k
+ (begin
+ (display "<b")
+ (html-class n)
+ (display ">")
+ (output k e)
+ (display "</b> "))))
+ (output (markup-body n) e)))
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :options '()
+ :before (lambda (n e)
+ (display "<blockquote ")
+ (html-class n)
+ (display ">\n"))
+ :after "\n</blockquote>\n")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns :legend-width)
+ :before (html-markup-class "br")
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (display "<a name=\"")
+ (display (string-canonicalize ident))
+ (display "\"></a>\n")
+ (output (markup-body n) e)
+ (display "<br>\n")
+ (output (new markup
+ (markup '&html-figure-legend)
+ (parent n)
+ (ident (string-append ident "-legend"))
+ (class (markup-class n))
+ (options `((:number ,number)))
+ (body legend))
+ e)))
+ :after "<br>")
+
+;*---------------------------------------------------------------------*/
+;* &html-figure-legend ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-figure-legend
+ :options '(:number)
+ :before (lambda (n e)
+ (display "<center>")
+ (let ((number (markup-option n :number))
+ (legend (markup-option n :legend)))
+ (if number
+ (printf "<strong>Fig. ~a:</strong> " number)
+ (printf "<strong>Fig. :</strong> "))))
+ :after "</center>")
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (cp (markup-option n :cellpadding))
+ (cs (markup-option n :cellspacing)))
+ (display "<table")
+ (html-class n)
+ (if width (printf " width=\"~a\"" (html-width width)))
+ (if border (printf " border=\"~a\"" border))
+ (if (and (number? cp) (>= cp 0))
+ (printf " cellpadding=\"~a\"" cp))
+ (if (and (number? cs) (>= cs 0))
+ (printf " cellspacing=\"~a\"" cs))
+ (cond
+ ((symbol? cstyle)
+ (printf " style=\"border-collapse: ~a;\"" cstyle))
+ ((string? cstyle)
+ (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle))
+ ((number? cstyle)
+ (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle)))
+ (if frame
+ (printf " frame=\"~a\""
+ (if (eq? frame 'none) "void" frame)))
+ (if (and rules (not (eq? rules 'header)))
+ (printf " rules=\"~a\"" rules))
+ (display "><tbody>\n")))
+ :after "</tbody></table>\n")
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '(:bg)
+ :before (lambda (n e)
+ (let ((bg (markup-option n :bg)))
+ (display "<tr")
+ (html-class n)
+ (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg))
+ (display ">")))
+ :after "</tr>\n")
+
+;*---------------------------------------------------------------------*/
+;* tc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(markup :width :align :valign :colspan :rowspan :bg)
+ :before (lambda (n e)
+ (let ((markup (or (markup-option n 'markup) 'td))
+ (width (markup-option n :width))
+ (align (markup-option n :align))
+ (valign (let ((v (markup-option n :valign)))
+ (cond
+ ((or (eq? v 'center)
+ (equal? v "center"))
+ "middle")
+ (else
+ v))))
+ (colspan (markup-option n :colspan))
+ (rowspan (markup-option n :rowspan))
+ (bg (markup-option n :bg)))
+ (printf "<~a" markup)
+ (html-class n)
+ (if width (printf " width=\"~a\"" (html-width width)))
+ (if align (printf " align=\"~a\"" align))
+ (if valign (printf " valign=\"~a\"" valign))
+ (if colspan (printf " colspan=\"~a\"" colspan))
+ (if rowspan (printf " rowspan=\"~a\"" rowspan))
+ (when (html-color-spec? bg)
+ (printf " bgcolor=\"~a\"" bg))
+ (display ">")))
+ :after (lambda (n e)
+ (let ((markup (or (markup-option n 'markup) 'td)))
+ (printf "</~a>" markup))))
+
+;*---------------------------------------------------------------------*/
+;* image ... @label image@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("gif" "jpg" "png"))))))
+ (if (not (string? img))
+ (skribe-error 'html "Illegal image" file)
+ (begin
+ (printf "<img src=\"~a\" border=\"0\"" img)
+ (html-class n)
+ (if body
+ (begin
+ (display " alt=\"")
+ (output body e)
+ (display "\""))
+ (printf " alt=\"~a\"" file))
+ (if width (printf " width=\"~a\"" (html-width width)))
+ (if height (printf " height=\"~a\"" height))
+ (display ">"))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'roman :before "")
+(markup-writer 'bold :before (html-markup-class "strong") :after "</strong>")
+(markup-writer 'underline :before (html-markup-class "u") :after "</u>")
+(markup-writer 'strike :before (html-markup-class "strike") :after "</strike>")
+(markup-writer 'emph :before (html-markup-class "em") :after "</em>")
+(markup-writer 'kbd :before (html-markup-class "kbd") :after "</kbd>")
+(markup-writer 'it :before (html-markup-class "em") :after "</em>")
+(markup-writer 'tt :before (html-markup-class "tt") :after "</tt>")
+(markup-writer 'code :before (html-markup-class "code") :after "</code>")
+(markup-writer 'var :before (html-markup-class "var") :after "</var>")
+(markup-writer 'samp :before (html-markup-class "samp") :after "</samp>")
+(markup-writer 'sc :before "<span class=\"sc\">" :after "</span>")
+(markup-writer 'sf :before "<span class=\"sf\">" :after "</span>")
+(markup-writer 'sub :before (html-markup-class "sub") :after "</sub>")
+(markup-writer 'sup :before (html-markup-class "sup") :after "</sup>")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "\""
+ :after "\"")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (display "<a href=\"mailto:")
+ (output (markup-body n) e)
+ (display #\")
+ (html-class n)
+ (display #\>)
+ (if text
+ (output text e)
+ (skribe-eval (tt (markup-body n)) e))
+ (display "</a>"))))
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :predicate (lambda (n e)
+ (and (engine-custom e 'javascript)
+ (or (string? (markup-body n))
+ (and (pair? (markup-body n))
+ (null? (cdr (markup-body n)))
+ (string? (car (markup-body n)))))))
+ :action (lambda (n e)
+ (let* ((body (markup-body n))
+ (email (if (string? body) body (car body)))
+ (split (pregexp-split "@" email))
+ (na (car split))
+ (do (if (pair? (cdr split)) (cadr split) ""))
+ (nn (pregexp-replace* "[.]" na " "))
+ (dd (pregexp-replace* "[.]" do " "))
+ (text (markup-option n :text)))
+ (display "<script language=\"JavaScript\" type=\"text/javascript\"")
+ (if (not text)
+ (printf ">skribenospam( ~s, ~s, true )" nn dd)
+ (begin
+ (printf ">skribenospam( ~s, ~s, false )" nn dd)
+ (display "</script>")
+ (output text e)
+ (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")")))
+ (display "</script>\n"))))
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n)))
+ (html-class n)
+ (display ">"))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle)
+ :before (lambda (n e)
+ (let* ((c (handle-ast (markup-body n)))
+ (id (markup-ident c))
+ (f (html-file c e))
+ (class (if (markup-class n)
+ (markup-class n)
+ "skribilo-ref")))
+ (printf "<a href=\"~a#~a\" class=\"~a\""
+ (if (and (*destination-file*)
+ (string=? f (*destination-file*)))
+ ""
+ (strip-ref-base (or f (*destination-file*) "")))
+ (string-canonicalize id)
+ class)
+ (display ">")))
+ :action (lambda (n e)
+ (let ((t (markup-option n :text))
+ (m (markup-option n 'mark))
+ (f (markup-option n :figure))
+ (c (markup-option n :chapter))
+ (s (markup-option n :section))
+ (ss (markup-option n :subsection))
+ (sss (markup-option n :subsubsection)))
+ (cond
+ (t
+ (output t e))
+ (f
+ (output (new markup
+ (markup '&html-figure-ref)
+ (body (markup-body n)))
+ e))
+ ((or c s ss sss)
+ (output (new markup
+ (markup '&html-section-ref)
+ (body (markup-body n)))
+ e))
+
+ ((not m)
+ (output (new markup
+ (markup '&html-unmark-ref)
+ (body (markup-body n)))
+ e))
+ (else
+ (display m)))))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* &html-figure-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-figure-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (or (not (markup? c))
+ (not (is-markup? c 'figure)))
+ (display "???")
+ (output (markup-option c :number) e)))))
+
+;*---------------------------------------------------------------------*/
+;* &html-section-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-section-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (not (markup? c))
+ (display "???")
+ (output (markup-option c :title) e)))))
+
+;*---------------------------------------------------------------------*/
+;* &html-unmark-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&html-unmark-ref
+ :action (lambda (n e)
+ (let ((c (handle-ast (markup-body n))))
+ (if (not (markup? c))
+ (display "???")
+ (let ((t (markup-option c :title)))
+ (if t
+ (output t e)
+ (let ((l (markup-option c :legend)))
+ (if l
+ (output t e)
+ (display
+ (string-canonicalize
+ (markup-ident c)))))))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e) (output n e (markup-writer-get 'ref e)))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (output (car rs) e (markup-writer-get 'ref e))
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :before (lambda (n e)
+ (let* ((url (markup-option n :url))
+ (class (cond
+ ((markup-class n)
+ (markup-class n))
+ ((not (string? url))
+ #f)
+ (else
+ (let ((l (string-length url)))
+ (let loop ((i 0))
+ (cond
+ ((= i l)
+ #f)
+ ((char=? (string-ref url i) #\:)
+ (substring url 0 i))
+ (else
+ (loop (+ i 1))))))))))
+ (display "<a href=\"")
+ (output url html-title-engine)
+ (display "\"")
+ (when class (printf " class=\"~a\"" class))
+ (display ">")))
+ :action (lambda (n e)
+ (let ((v (markup-option n :text)))
+ (output (or v (markup-option n :url)) e)))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before (html-markup-class "i")
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (if (and (number? o) (number? v))
+ (markup-option-add! n :text (+ o v)))
+ (output n e (markup-writer-get 'ref e))
+ (if (and (number? o) (number? v))
+ (markup-option-add! n :text v))))
+ :after "</i>")
+
+;*---------------------------------------------------------------------*/
+;* page-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'page-ref
+ :options '(:mark :handle)
+ :action (lambda (n e)
+ (error 'page-ref:html "Not implemented yet" n)))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before (lambda (n e)
+ (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n)))
+ (html-class n)
+ (display ">"))
+ :action (lambda (n e)
+ (output n e (markup-writer-get '&bib-entry-label base-engine)))
+ :after "</a>")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (or (markup-option en 'url)
+ (markup-option en 'documenturl)))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e)
+ (display "<center")
+ (html-class n)
+ (display ">")
+ (for-each (lambda (h)
+ (let ((f (engine-custom e 'index-header-font-size)))
+ (if f
+ (skribe-eval (font :size f (bold (it h))) e)
+ (output h e))
+ (display " ")))
+ (markup-body n))
+ (display "</center>")
+ (skribe-eval (linebreak 2) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-error ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm
new file mode 100644
index 0000000..48550ef
--- /dev/null
+++ b/src/guile/skribilo/engine/html4.scm
@@ -0,0 +1,168 @@
+;;;;
+;;;; html4.skr -- HTML 4.01 Engine
+;;;;
+;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 18-Feb-2004 11:58 (eg)
+;;;; Last file update: 26-Feb-2004 21:09 (eg)
+;;;;
+
+(define-skribe-module (skribilo engine html4))
+
+(define (find-children node)
+ (define (flat l)
+ (cond
+ ((null? l) l)
+ ((pair? l) (append (flat (car l))
+ (flat (cdr l))))
+ (else (list l))))
+
+ (if (markup? node)
+ (flat (markup-body node))
+ node))
+
+;;; ======================================================================
+
+(let ((le (find-engine 'html)))
+ ;;----------------------------------------------------------------------
+ ;; Customizations
+ ;;----------------------------------------------------------------------
+ (engine-custom-set! le 'html-variant "html4")
+ (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401")
+ (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer")
+
+ ;;----------------------------------------------------------------------
+ ;; &html-html ...
+ ;;----------------------------------------------------------------------
+ (markup-writer '&html-html le
+ :before "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">
+<html>\n"
+ :after "</html>")
+
+ ;;----------------------------------------------------------------------
+ ;; &html-ending
+ ;;----------------------------------------------------------------------
+ (let* ((img (engine-custom le 'html4-logo))
+ (url (engine-custom le 'html4-validator))
+ (bottom (list (hrule)
+ (table :width 100.
+ (tr
+ (td :align 'left
+ (font :size -1 [
+ This ,(sc "Html") page has been produced by
+ ,(ref :url (skribe-url) :text "Skribe").
+ ,(linebreak)
+ Last update ,(it (date)).]))
+ (td :align 'right :valign 'top
+ (ref :url url
+ :text (image :url img :width 88 :height 31))))))))
+ (markup-writer '&html-ending le
+ :before "<div class=\"skribe-ending\">"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if body
+ (output body #t)
+ (skribe-eval bottom e))))
+ :after "</div>\n"))
+
+ ;;----------------------------------------------------------------------
+ ;; color ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'color le
+ :options '(:bg :fg :width :margin)
+ :before (lambda (n e)
+ (let ((m (markup-option n :margin))
+ (w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg)))
+ (when bg
+ (display "<table cellspacing=\"0\"")
+ (html-class n)
+ (printf " cellpadding=\"~a\"" (if m m 0))
+ (if w (printf " width=\"~a\"" (html-width w)))
+ (display "><tbody>\n<tr>")
+ (display "<td bgcolor=\"")
+ (output bg e)
+ (display "\">"))
+ (when fg
+ (display "<span style=\"color:")
+ (output fg e)
+ (display ";\">"))))
+ :after (lambda (n e)
+ (when (markup-option n :fg)
+ (display "</span>"))
+ (when (markup-option n :bg)
+ (display "</td></tr>\n</tbody></table>"))))
+
+ ;;----------------------------------------------------------------------
+ ;; font ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'font le
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((face (markup-option n :face))
+ (size (let ((sz (markup-option n :size)))
+ (cond
+ ((or (unspecified? sz) (not sz))
+ #f)
+ ((and (number? sz) (or (inexact? sz) (negative? sz)))
+ (format #f "~a%"
+ (+ 100
+ (* 20 (inexact->exact (truncate sz))))))
+ ((number? sz)
+ sz)
+ (else
+ (skribe-error 'font
+ (format #f
+ "illegal font size ~s" sz)
+ n))))))
+ (display "<span ")
+ (html-class n)
+ (display "style=\"")
+ (if size (printf "font-size: ~a; " size))
+ (if face (printf "font-family:'~a'; " face))
+ (display "\">")))
+ :after "</span>")
+
+ ;;----------------------------------------------------------------------
+ ;; paragraph ...
+ ;;----------------------------------------------------------------------
+ (copy-markup-writer 'paragraph le
+ :validate (lambda (n e)
+ (let ((pred (lambda (x)
+ (and (container? x)
+ (not (memq (markup-markup x) '(font color)))))))
+ (not (any pred (find-children n))))))
+
+ ;;----------------------------------------------------------------------
+ ;; roman ...
+ ;;----------------------------------------------------------------------
+ (markup-writer 'roman le
+ :before "<span style=\"font-family: serif\">"
+ :after "</span>")
+
+ ;;----------------------------------------------------------------------
+ ;; table ...
+ ;;----------------------------------------------------------------------
+ (let ((old-writer (markup-writer-get 'table le)))
+ (copy-markup-writer 'table le
+ :validate (lambda (n e)
+ (not (null? (markup-body n))))))
+)
diff --git a/src/guile/skribilo/engine/latex-simple.scm b/src/guile/skribilo/engine/latex-simple.scm
new file mode 100644
index 0000000..638c158
--- /dev/null
+++ b/src/guile/skribilo/engine/latex-simple.scm
@@ -0,0 +1,103 @@
+(define-skribe-module (skribilo engine latex-simple))
+
+;;;
+;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER
+;;; CE FICHIER (sion simplifie il ne rest plus grand chose)
+;;; Erick 27-10-04
+;;;
+
+
+;*=====================================================================*/
+;* scmws04/src/latex-style.skr */
+;* ------------------------------------------------------------- */
+;* Author : Damien Ciabrini */
+;* Creation : Tue Aug 24 19:17:04 2004 */
+;* Last change : Thu Oct 28 21:45:25 2004 (eg) */
+;* Copyright : 2004 Damien Ciabrini, see LICENCE file */
+;* ------------------------------------------------------------- */
+;* Custom style for Latex... */
+;*=====================================================================*/
+
+(let* ((le (find-engine 'latex))
+ (oa (markup-writer-get 'author le)))
+ ; latex class & package for the workshop
+ (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}")
+ (engine-custom-set! le 'usepackage
+ "\\usepackage{epsfig}
+\\usepackage{workshop}
+\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.}
+ {September 22, 2004, Snowbird, Utah, USA.}
+\\CopyrightYear{2004}
+\\CopyrightHolder{Damien Ciabrini}
+\\renewcommand{\\ttdefault}{cmtt}
+")
+ (engine-custom-set! le 'image-format '("eps"))
+ (engine-custom-set! le 'source-define-color "#000080")
+ (engine-custom-set! le 'source-thread-color "#8080f0")
+ (engine-custom-set! le 'source-string-color "#000000")
+
+ ; hyperref options
+ (engine-custom-set! le 'hyperref #t)
+ (engine-custom-set! le 'hyperref-usepackage
+ "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}")
+ ; nbsp with ~ char
+ (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding))
+
+ ; let latex process citations
+ (markup-writer 'bib-ref le
+ :options '(:text :bib)
+ :before "\\cite{"
+ :action (lambda (n e) (display (markup-option n :bib)))
+ :after "}")
+ (markup-writer 'bib-ref+ le
+ :options '(:text :bib)
+ :before "\\cite{"
+ :action (lambda (n e)
+ (let loop ((bibs (markup-option n :bib)))
+ (if (pair? bibs)
+ (begin
+ (display (car bibs))
+ (if (pair? (cdr bibs)) (display ", "))
+ (loop (cdr bibs))))))
+ :after "}")
+ (markup-writer '&the-bibliography le
+ :action (lambda (n e)
+ (print "\\bibliographystyle{abbrv}")
+ (display "\\bibliography{biblio}")))
+
+ ; ACM-style for authors
+ (markup-writer '&latex-author le
+ :before (lambda (n e)
+ (let ((body (markup-body n)))
+ (if (pair? body)
+ (print "\\numberofauthors{" (length body) "}"))
+ (print "\\author{")))
+ :after "}\n")
+ (markup-writer 'author le
+ :options (writer-options oa)
+ :before ""
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (affiliation (markup-option n :affiliation))
+ (address (markup-option n :address))
+ (email (markup-option n :email)))
+ (define (row pre n post)
+ (display pre)
+ (output n e)
+ (display post)
+ (display "\\\\\n"))
+ ;; name
+ (if name (row "\\alignauthor " name ""))
+ ;; affiliation
+ (if affiliation (row "\\affaddr{" affiliation "}"))
+ ;; address
+ (if (pair? address)
+ (for-each (lambda (x)
+ (row "\\affaddr{" x "}")) address))
+ ;; email
+ (if email (row "\\email{" email "}"))))
+ :after "")
+)
+
+(define (include-biblio)
+ (the-bibliography))
diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm
new file mode 100644
index 0000000..8d5b88f
--- /dev/null
+++ b/src/guile/skribilo/engine/latex.scm
@@ -0,0 +1,1784 @@
+;;; latex.scm -- LaTeX engine.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo engine latex))
+
+;*---------------------------------------------------------------------*/
+;* latex-verbatim-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-verbatim-encoding
+ '((#\\ "{\\char92}")
+ (#\^ "{\\char94}")
+ (#\{ "\\{")
+ (#\} "\\}")
+ (#\& "\\&")
+ (#\$ "\\$")
+ (#\# "\\#")
+ (#\_ "\\_")
+ (#\% "\\%")
+ (#\~ "$_{\\mbox{\\char126}}$")
+ (#\ç "\\c{c}")
+ (#\Ç "\\c{C}")
+ (#\â "\\^{a}")
+ (#\Â "\\^{A}")
+ (#\à "\\`{a}")
+ (#\À "\\`{A}")
+ (#\é "\\'{e}")
+ (#\É "\\'{E}")
+ (#\è "\\`{e}")
+ (#\È "\\`{E}")
+ (#\ê "\\^{e}")
+ (#\Ê "\\^{E}")
+ (#\ù "\\`{u}")
+ (#\Ù "\\`{U}")
+ (#\û "\\^{u}")
+ (#\Û "\\^{U}")
+ (#\ø "{\\o}")
+ (#\ô "\\^{o}")
+ (#\Ô "\\^{O}")
+ (#\ö "\\\"{o}")
+ (#\Ö "\\\"{O}")
+ (#\î "\\^{\\i}")
+ (#\Î "\\^{I}")
+ (#\ï "\\\"{\\i}")
+ (#\Ï "\\\"{I}")
+ (#\] "{\\char93}")
+ (#\[ "{\\char91}")
+ (#\» "\\,{\\tiny{$^{\\gg}$}}")
+ (#\« "{\\tiny{$^{\\ll}$}}\\,")))
+
+;*---------------------------------------------------------------------*/
+;* latex-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-encoding
+ (append '((#\| "$|$")
+ (#\< "$<$")
+ (#\> "$>$")
+ (#\: "{\\char58}")
+ (#\# "{\\char35}")
+ (#\Newline " %\n"))
+ latex-verbatim-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-tt-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-tt-encoding
+ (append '((#\. ".\\-")
+ (#\/ "/\\-"))
+ latex-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-pre-encoding ... */
+;*---------------------------------------------------------------------*/
+(define latex-pre-encoding
+ (append '((#\Space "\\ ")
+ (#\Newline "\\\\\n"))
+ latex-encoding))
+
+;*---------------------------------------------------------------------*/
+;* latex-symbol-table ... */
+;*---------------------------------------------------------------------*/
+(define (latex-symbol-table math)
+ `(("iexcl" "!`")
+ ("cent" "c")
+ ("pound" "\\pounds")
+ ("yen" "Y")
+ ("section" "\\S")
+ ("mul" ,(math "^-"))
+ ("copyright" "\\copyright")
+ ("lguillemet" ,(math "\\ll"))
+ ("not" ,(math "\\neg"))
+ ("degree" ,(math "^{\\small{o}}"))
+ ("plusminus" ,(math "\\pm"))
+ ("micro" ,(math "\\mu"))
+ ("paragraph" "\\P")
+ ("middot" ,(math "\\cdot"))
+ ("rguillemet" ,(math "\\gg"))
+ ("1/4" ,(math "\\frac{1}{4}"))
+ ("1/2" ,(math "\\frac{1}{2}"))
+ ("3/4" ,(math "\\frac{3}{4}"))
+ ("iquestion" "?`")
+ ("Agrave" "\\`{A}")
+ ("Aacute" "\\'{A}")
+ ("Acircumflex" "\\^{A}")
+ ("Atilde" "\\~{A}")
+ ("Amul" "\\\"{A}")
+ ("Aring" "{\\AA}")
+ ("AEligature" "{\\AE}")
+ ("Oeligature" "{\\OE}")
+ ("Ccedilla" "{\\c{C}}")
+ ("Egrave" "{\\`{E}}")
+ ("Eacute" "{\\'{E}}")
+ ("Ecircumflex" "{\\^{E}}")
+ ("Euml" "\\\"{E}")
+ ("Igrave" "{\\`{I}}")
+ ("Iacute" "{\\'{I}}")
+ ("Icircumflex" "{\\^{I}}")
+ ("Iuml" "\\\"{I}")
+ ("ETH" "D")
+ ("Ntilde" "\\~{N}")
+ ("Ograve" "\\`{O}")
+ ("Oacute" "\\'{O}")
+ ("Ocurcumflex" "\\^{O}")
+ ("Otilde" "\\~{O}")
+ ("Ouml" "\\\"{O}")
+ ("times" ,(math "\\times"))
+ ("Oslash" "\\O")
+ ("Ugrave" "\\`{U}")
+ ("Uacute" "\\'{U}")
+ ("Ucircumflex" "\\^{U}")
+ ("Uuml" "\\\"{U}")
+ ("Yacute" "\\'{Y}")
+ ("szlig" "\\ss")
+ ("agrave" "\\`{a}")
+ ("aacute" "\\'{a}")
+ ("acircumflex" "\\^{a}")
+ ("atilde" "\\~{a}")
+ ("amul" "\\\"{a}")
+ ("aring" "\\aa")
+ ("aeligature" "\\ae")
+ ("oeligature" "{\\oe}")
+ ("ccedilla" "{\\c{c}}")
+ ("egrave" "{\\`{e}}")
+ ("eacute" "{\\'{e}}")
+ ("ecircumflex" "{\\^{e}}")
+ ("euml" "\\\"{e}")
+ ("igrave" "{\\`{\\i}}")
+ ("iacute" "{\\'{\\i}}")
+ ("icircumflex" "{\\^{\\i}}")
+ ("iuml" "\\\"{\\i}")
+ ("ntilde" "\\~{n}")
+ ("ograve" "\\`{o}")
+ ("oacute" "\\'{o}")
+ ("ocurcumflex" "\\^{o}")
+ ("otilde" "\\~{o}")
+ ("ouml" "\\\"{o}")
+ ("divide" ,(math "\\div"))
+ ("oslash" "\\o")
+ ("ugrave" "\\`{u}")
+ ("uacute" "\\'{u}")
+ ("ucircumflex" "\\^{u}")
+ ("uuml" "\\\"{u}")
+ ("yacute" "\\'{y}")
+ ("ymul" "\\\"{y}")
+ ;; Greek
+ ("Alpha" "A")
+ ("Beta" "B")
+ ("Gamma" ,(math "\\Gamma"))
+ ("Delta" ,(math "\\Delta"))
+ ("Epsilon" "E")
+ ("Zeta" "Z")
+ ("Eta" "H")
+ ("Theta" ,(math "\\Theta"))
+ ("Iota" "I")
+ ("Kappa" "K")
+ ("Lambda" ,(math "\\Lambda"))
+ ("Mu" "M")
+ ("Nu" "N")
+ ("Xi" ,(math "\\Xi"))
+ ("Omicron" "O")
+ ("Pi" ,(math "\\Pi"))
+ ("Rho" "P")
+ ("Sigma" ,(math "\\Sigma"))
+ ("Tau" "T")
+ ("Upsilon" ,(math "\\Upsilon"))
+ ("Phi" ,(math "\\Phi"))
+ ("Chi" "X")
+ ("Psi" ,(math "\\Psi"))
+ ("Omega" ,(math "\\Omega"))
+ ("alpha" ,(math "\\alpha"))
+ ("beta" ,(math "\\beta"))
+ ("gamma" ,(math "\\gamma"))
+ ("delta" ,(math "\\delta"))
+ ("epsilon" ,(math "\\varepsilon"))
+ ("zeta" ,(math "\\zeta"))
+ ("eta" ,(math "\\eta"))
+ ("theta" ,(math "\\theta"))
+ ("iota" ,(math "\\iota"))
+ ("kappa" ,(math "\\kappa"))
+ ("lambda" ,(math "\\lambda"))
+ ("mu" ,(math "\\mu"))
+ ("nu" ,(math "\\nu"))
+ ("xi" ,(math "\\xi"))
+ ("omicron" ,(math "\\o"))
+ ("pi" ,(math "\\pi"))
+ ("rho" ,(math "\\rho"))
+ ("sigmaf" ,(math "\\varsigma"))
+ ("sigma" ,(math "\\sigma"))
+ ("tau" ,(math "\\tau"))
+ ("upsilon" ,(math "\\upsilon"))
+ ("phi" ,(math "\\varphi"))
+ ("chi" ,(math "\\chi"))
+ ("psi" ,(math "\\psi"))
+ ("omega" ,(math "\\omega"))
+ ("thetasym" ,(math "\\vartheta"))
+ ("piv" ,(math "\\varpi"))
+ ;; punctuation
+ ("bullet" ,(math "\\bullet"))
+ ("ellipsis" ,(math "\\ldots"))
+ ("weierp" ,(math "\\wp"))
+ ("image" ,(math "\\Im"))
+ ("real" ,(math "\\Re"))
+ ("tm" ,(math "^{\\sc\\tiny{tm}}"))
+ ("alef" ,(math "\\aleph"))
+ ("<-" ,(math "\\leftarrow"))
+ ("<--" ,(math "\\longleftarrow"))
+ ("uparrow" ,(math "\\uparrow"))
+ ("->" ,(math "\\rightarrow"))
+ ("-->" ,(math "\\longrightarrow"))
+ ("downarrow" ,(math "\\downarrow"))
+ ("<->" ,(math "\\leftrightarrow"))
+ ("<-->" ,(math "\\longleftrightarrow"))
+ ("<+" ,(math "\\hookleftarrow"))
+ ("<=" ,(math "\\Leftarrow"))
+ ("<==" ,(math "\\Longleftarrow"))
+ ("Uparrow" ,(math "\\Uparrow"))
+ ("=>" ,(math "\\Rightarrow"))
+ ("==>" ,(math "\\Longrightarrow"))
+ ("Downarrow" ,(math "\\Downarrow"))
+ ("<=>" ,(math "\\Leftrightarrow"))
+ ("<==>" ,(math "\\Longleftrightarrow"))
+ ;; Mathematical operators
+ ("forall" ,(math "\\forall"))
+ ("partial" ,(math "\\partial"))
+ ("exists" ,(math "\\exists"))
+ ("emptyset" ,(math "\\emptyset"))
+ ("infinity" ,(math "\\infty"))
+ ("nabla" ,(math "\\nabla"))
+ ("in" ,(math "\\in"))
+ ("notin" ,(math "\\notin"))
+ ("ni" ,(math "\\ni"))
+ ("prod" ,(math "\\Pi"))
+ ("sum" ,(math "\\Sigma"))
+ ("asterisk" ,(math "\\ast"))
+ ("sqrt" ,(math "\\surd"))
+ ("propto" ,(math "\\propto"))
+ ("angle" ,(math "\\angle"))
+ ("and" ,(math "\\wedge"))
+ ("or" ,(math "\\vee"))
+ ("cap" ,(math "\\cap"))
+ ("cup" ,(math "\\cup"))
+ ("integral" ,(math "\\int"))
+ ("models" ,(math "\\models"))
+ ("vdash" ,(math "\\vdash"))
+ ("dashv" ,(math "\\dashv"))
+ ("sim" ,(math "\\sim"))
+ ("cong" ,(math "\\cong"))
+ ("approx" ,(math "\\approx"))
+ ("neq" ,(math "\\neq"))
+ ("equiv" ,(math "\\equiv"))
+ ("le" ,(math "\\leq"))
+ ("ge" ,(math "\\geq"))
+ ("subset" ,(math "\\subset"))
+ ("supset" ,(math "\\supset"))
+ ("subseteq" ,(math "\\subseteq"))
+ ("supseteq" ,(math "\\supseteq"))
+ ("oplus" ,(math "\\oplus"))
+ ("otimes" ,(math "\\otimes"))
+ ("perp" ,(math "\\perp"))
+ ("mid" ,(math "\\mid"))
+ ("lceil" ,(math "\\lceil"))
+ ("rceil" ,(math "\\rceil"))
+ ("lfloor" ,(math "\\lfloor"))
+ ("rfloor" ,(math "\\rfloor"))
+ ("langle" ,(math "\\langle"))
+ ("rangle" ,(math "\\rangle"))
+ ;; Misc
+ ("loz" ,(math "\\diamond"))
+ ("spades" ,(math "\\spadesuit"))
+ ("clubs" ,(math "\\clubsuit"))
+ ("hearts" ,(math "\\heartsuit"))
+ ("diams" ,(math "\\diamondsuit"))
+ ("euro" "\\euro{}")
+ ;; LaTeX
+ ("dag" "\\dag")
+ ("ddag" "\\ddag")
+ ("circ" ,(math "\\circ"))
+ ("top" ,(math "\\top"))
+ ("bottom" ,(math "\\bot"))
+ ("lhd" ,(math "\\triangleleft"))
+ ("rhd" ,(math "\\triangleright"))
+ ("parallel" ,(math "\\parallel"))))
+
+;*---------------------------------------------------------------------*/
+;* latex-engine ... */
+;*---------------------------------------------------------------------*/
+(define latex-engine
+ (default-engine-set!
+ (make-engine 'latex
+ :version 1.0
+ :format "latex"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace latex-encoding)
+ :custom '((documentclass "\\documentclass{article}")
+ (usepackage "\\usepackage{epsfig}\n")
+ (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n")
+ (postdocument #f)
+ (maketitle "\\date{}\n\\maketitle")
+ (%font-size 0)
+ ;; color
+ (color #t)
+ (color-usepackage "\\usepackage{color}\n")
+ ;; hyperref
+ (hyperref #t)
+ (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n")
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-error-color "red")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00")
+ (image-format ("eps"))
+ (index-page-ref #t))
+ :symbol-table (latex-symbol-table
+ (lambda (m)
+ (format #f "\\begin{math}~a\\end{math}" m))))))
+
+;*---------------------------------------------------------------------*/
+;* latex-title-engine ... */
+;*---------------------------------------------------------------------*/
+(define latex-title-engine
+ (make-engine 'latex-title
+ :version 1.0
+ :format "latex-title"
+ :delegate latex-engine
+ :filter (make-string-replace latex-encoding)
+ :symbol-table (latex-symbol-table (lambda (m) (format #f "$~a$" m)))))
+
+;*---------------------------------------------------------------------*/
+;* latex-color? ... */
+;*---------------------------------------------------------------------*/
+(define (latex-color? e)
+ (engine-custom e 'color))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX ... */
+;*---------------------------------------------------------------------*/
+(define-markup (LaTeX #!key (space #t))
+ (if (engine-format? "latex")
+ (! (if space "\\LaTeX\\ " "\\LaTeX"))
+ "LaTeX"))
+
+;*---------------------------------------------------------------------*/
+;* TeX ... */
+;*---------------------------------------------------------------------*/
+(define-markup (TeX #!key (space #t))
+ (if (engine-format? "latex")
+ (! (if space "\\TeX\\ " "\\TeX"))
+ "TeX"))
+
+;*---------------------------------------------------------------------*/
+;* latex ... */
+;*---------------------------------------------------------------------*/
+(define-markup (!latex fmt #!rest opt)
+ (if (engine-format? "latex")
+ (apply ! fmt opt)
+ #f))
+
+;*---------------------------------------------------------------------*/
+;* latex-width ... */
+;*---------------------------------------------------------------------*/
+(define (latex-width width)
+ (if (and (number? width) (inexact? width))
+ (string-append (number->string (/ width 100.)) "\\linewidth")
+ (string-append (number->string width) "pt")))
+
+;*---------------------------------------------------------------------*/
+;* latex-font-size ... */
+;*---------------------------------------------------------------------*/
+(define (latex-font-size size)
+ (case size
+ ((4) "Huge")
+ ((3) "huge")
+ ((2) "Large")
+ ((1) "large")
+ ((0) "normalsize")
+ ((-1) "small")
+ ((-2) "footnotesize")
+ ((-3) "scriptsize")
+ ((-4) "tiny")
+ (else (if (number? size)
+ (if (< size 0) "tiny" "Huge")
+ "normalsize"))))
+
+;*---------------------------------------------------------------------*/
+;* *skribe-latex-color-table* ... */
+;*---------------------------------------------------------------------*/
+(define *skribe-latex-color-table* #f)
+
+;*---------------------------------------------------------------------*/
+;* latex-declare-color ... */
+;*---------------------------------------------------------------------*/
+(define (latex-declare-color name rgb)
+ (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb))
+
+;*---------------------------------------------------------------------*/
+;* skribe-get-latex-color ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-get-latex-color spec)
+ (let ((c (and (hashtable? *skribe-latex-color-table*)
+ (hashtable-get *skribe-latex-color-table* spec))))
+ (if (not (string? c))
+ (skribe-error 'latex "Can't find color" spec)
+ c)))
+
+;*---------------------------------------------------------------------*/
+;* skribe-color->latex-rgb ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-color->latex-rgb spec)
+ (receive (r g b)
+ (skribe-color->rgb spec)
+ (cond
+ ((and (= r 0) (= g 0) (= b 0))
+ "0.,0.,0.")
+ ((and (= r #xff) (= g #xff) (= b #xff))
+ "1.,1.,1.")
+ (else
+ (let ((ff (exact->inexact #xff)))
+ (format #f "~a,~a,~a"
+ (number->string (/ r ff))
+ (number->string (/ g ff))
+ (number->string (/ b ff))))))))
+
+;*---------------------------------------------------------------------*/
+;* skribe-latex-declare-colors ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-latex-declare-colors colors)
+ (set! *skribe-latex-color-table* (make-hashtable))
+ (for-each (lambda (spec)
+ (let ((old (hashtable-get *skribe-latex-color-table* spec)))
+ (if (not (string? old))
+ (let ((name (symbol->string (gensym 'c))))
+ ;; bind the color
+ (hashtable-put! *skribe-latex-color-table* spec name)
+ ;; and emit a latex declaration
+ (latex-declare-color
+ name
+ (skribe-color->latex-rgb spec))))))
+ colors))
+
+;*---------------------------------------------------------------------*/
+;* ~ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '~
+ :before "~"
+ :action #f)
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-start */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-start
+ :options '()
+ :action (lambda (n e)
+ (let ((width (markup-option n 'width)))
+ (if (number? width)
+ (printf "\\begin{tabular*}{~a}" (latex-width width))
+ (display "\\begin{tabular}")))))
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-stop */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-stop
+ :options '()
+ :action (lambda (n e)
+ (let ((width (markup-option n 'width)))
+ (if (number? width)
+ (display "\\end{tabular*}\n")
+ (display "\\end{tabular}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :env)
+ :before (lambda (n e)
+ ;; documentclass
+ (let ((dc (engine-custom e 'documentclass)))
+ (if dc
+ (begin (display dc) (newline))
+ (display "\\documentclass{article}\n")))
+ (if (latex-color? e)
+ (display (engine-custom e 'color-usepackage)))
+ (if (engine-custom e 'hyperref)
+ (display (engine-custom e 'hyperref-usepackage)))
+ ;; usepackage
+ (let ((pa (engine-custom e 'usepackage)))
+ (if pa (begin (display pa) (newline))))
+ ;; colors
+ (if (latex-color? e)
+ (begin
+ (skribe-use-color! (engine-custom e 'source-comment-color))
+ (skribe-use-color! (engine-custom e 'source-define-color))
+ (skribe-use-color! (engine-custom e 'source-module-color))
+ (skribe-use-color! (engine-custom e 'source-markup-color))
+ (skribe-use-color! (engine-custom e 'source-thread-color))
+ (skribe-use-color! (engine-custom e 'source-string-color))
+ (skribe-use-color! (engine-custom e 'source-bracket-color))
+ (skribe-use-color! (engine-custom e 'source-type-color))
+ (display "\n%% colors\n")
+ (skribe-latex-declare-colors (skribe-get-used-colors))
+ (display "\n\n")))
+ ;; predocument
+ (let ((pd (engine-custom e 'predocument)))
+ (when pd (display pd) (newline)))
+ ;; title
+ (let ((t (markup-option n :title)))
+ (when t
+ (skribe-eval (new markup
+ (markup '&latex-title)
+ (body t))
+ e
+ :env `((parent ,n)))))
+ ;; author
+ (let ((a (markup-option n :author)))
+ (when a
+ (skribe-eval (new markup
+ (markup '&latex-author)
+ (body a))
+ e
+ :env `((parent ,n)))))
+ ;; document
+ (display "\\begin{document}\n")
+ ;; postdocument
+ (let ((pd (engine-custom e 'postdocument)))
+ (if pd (begin (display pd) (newline))))
+ ;; maketitle
+ (let ((mt (engine-custom e 'maketitle)))
+ (if mt (begin (display mt) (newline)))))
+ :action (lambda (n e)
+ (output (markup-body n) e))
+ :after (lambda (n e)
+ (display "\n\\end{document}\n")))
+
+;*---------------------------------------------------------------------*/
+;* &latex-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-title
+ :before "\\title{"
+ :after "}\n")
+
+;*---------------------------------------------------------------------*/
+;* &latex-author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-author
+ :before "\\author{\\centerline{\n"
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (if (pair? body)
+ (begin
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "&latex-author-table"))
+ e)
+ (printf "{~a}\n" (make-string (length body) #\c))
+ (let loop ((as body))
+ (output (car as) e)
+ (if (pair? (cdr as))
+ (begin
+ (display " & ")
+ (loop (cdr as)))))
+ (display "\\\\\n")
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "&latex-author-table"))
+ e))
+ (output body e))))
+ :after "}}\n")
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "author"))
+ e)
+ (printf "{~a}\n"
+ (case (markup-option n :align)
+ ((left) "l")
+ ((right) "r")
+ (else "c"))))
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone)))
+ (define (row n)
+ (output n e)
+ (display "\\\\\n"))
+ ;; name
+ (if name (row name))
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (cond
+ ((pair? address)
+ (for-each row address))
+ ((string? address)
+ (row address)))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url))))
+ :after (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :predicate (lambda (n e) (markup-option n :photo))
+ :before (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "author"))
+ e)
+ (printf "{cc}\n"))
+ :action (lambda (n e)
+ (let ((photo (markup-option n :photo)))
+ (output photo e)
+ (display " & ")
+ (markup-option-add! n :photo #f)
+ (output n e)
+ (markup-option-add! n :photo photo)
+ (display "\\\\\n")))
+ :after (lambda (n e)
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options '()
+ :action (lambda (n e) (display "\\tableofcontents\n")))
+
+;*---------------------------------------------------------------------*/
+;* latex-block-before ... */
+;*---------------------------------------------------------------------*/
+(define (latex-block-before m)
+ (lambda (n e)
+ (let ((num (markup-option n :number)))
+ (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n)))
+ (printf "\\~a~a{" m (if (not num) "*" ""))
+ (output (markup-option n :title) latex-title-engine)
+ (display "}\n")
+ (when num
+ (printf "\\label{~a}\n" (string-canonicalize (markup-ident n)))))))
+
+;*---------------------------------------------------------------------*/
+;* section ... .. @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'chapter))
+
+;*---------------------------------------------------------------------*/
+;* section ... . @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'section))
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'subsection))
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :before (latex-block-before 'subsubsection))
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :options '(:title :number :toc :env)
+ :before (lambda (n e)
+ (when (and (>= (skribe-debug) 2) (location? (ast-loc n)))
+ (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n"
+ (ast-location n)))
+ (display "\\noindent "))
+ :after "\\par\n")
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :before "\\footnote{"
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :action (lambda (n e)
+ (display "\\makebox[\\linewidth]{}")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '()
+ :before "\\hrulefill"
+ :action #f)
+
+;*---------------------------------------------------------------------*/
+;* latex-color-counter */
+;*---------------------------------------------------------------------*/
+(define latex-color-counter 1)
+
+;*---------------------------------------------------------------------*/
+;* latex-color ... */
+;*---------------------------------------------------------------------*/
+(define latex-color
+ (lambda (bg fg n e)
+ (if (not (latex-color? e))
+ (output n e)
+ (begin
+ (if bg
+ (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter))
+ (set! latex-color-counter (+ latex-color-counter 1))
+ (if fg
+ (begin
+ (printf "\\textcolor{~a}{" (skribe-get-latex-color fg))
+ (output n e)
+ (display "}"))
+ (output n e))
+ (set! latex-color-counter (- latex-color-counter 1))
+ (if bg
+ (printf "\\egroup\\colorbox{~a}{\\box~a}%\n"
+ (skribe-get-latex-color bg) latex-color-counter))))))
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:bg :fg :width)
+ :action (lambda (n e)
+ (let* ((w (markup-option n :width))
+ (bg (markup-option n :bg))
+ (fg (markup-option n :fg))
+ (m (markup-option n :margin))
+ (tw (cond
+ ((not w)
+ #f)
+ ((and (integer? w) (exact? w))
+ w)
+ ((real? w)
+ (latex-width w)))))
+ (when bg
+ (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n")
+ (when m
+ (printf "\\addtolength{\\tabcolsep}{~a}"
+ (latex-width m)))
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "color"))
+ e)
+ (if tw
+ (printf "{p{~a}}\n" tw)
+ (printf "{l}\n")))
+ (latex-color bg fg (markup-body n) e)
+ (when bg
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "color"))
+ e)
+ (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ :options '(:width :border :margin)
+ :before (lambda (n e)
+ (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}")
+ (let ((m (markup-option n :margin)))
+ (when m
+ (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m))))
+ (newline))
+ :action (lambda (n e)
+ (let* ((b (markup-option n :border))
+ (w (markup-option n :width))
+ (tw (cond
+ ((not w)
+ ".96\\linewidth")
+ ((and (integer? w) (exact? w))
+ w)
+ ((real? w)
+ (latex-width w)))))
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "frame"))
+ e)
+ (if (and (integer? b) (> b 0))
+ (begin
+ (printf "{|p{~a}|}\\hline\n" tw)
+ (output (markup-body n) e)
+ (display "\\\\\\hline\n"))
+ (begin
+ (printf "{p{~a}}\n" tw)
+ (output (markup-body n) e)))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "author"))
+ e)))
+ :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n")
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size)
+ :action (lambda (n e)
+ (let* ((size (markup-option n :size))
+ (cs (let ((n (engine-custom e '%font-size)))
+ (if (number? n)
+ n
+ 0)))
+ (ns (cond
+ ((and (integer? size) (exact? size))
+ (if (> size 0)
+ size
+ (+ cs size)))
+ ((and (number? size) (inexact? size))
+ (+ cs (inexact->exact size)))
+ ((string? size)
+ (let ((nb (string->number size)))
+ (if (not (number? nb))
+ (skribe-error
+ 'font
+ (format #f "Illegal font size ~s" size)
+ nb)
+ (+ cs nb))))))
+ (ne (make-engine (gensym 'latex)
+ :delegate e
+ :filter (engine-filter e)
+ :symbol-table (engine-symbol-table e)
+ :custom `((%font-size ,ns)
+ ,@(engine-customs e)))))
+ (printf "{\\~a{" (latex-font-size ns))
+ (output (markup-body n) ne)
+ (display "}}"))))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\\begin{center}\n"))
+ ((left)
+ (display "\\begin{flushleft}"))
+ ((right)
+ (display "\\begin{flushright}"))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((center)
+ (display "\\end{center}\n"))
+ ((left)
+ (display "\\end{flushleft}\n"))
+ ((right)
+ (display "\\end{flushright}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ :before "\\begin{center}\n"
+ :after "\\end{center}\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre
+ :before (lambda (n e)
+ (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{"
+ latex-color-counter)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "pre"))
+ e)
+ (display "{l}\n")
+ (set! latex-color-counter (+ latex-color-counter 1)))
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after (lambda (n e)
+ (set! latex-color-counter (- latex-color-counter 1))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "pre"))
+ e)
+ (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter)))
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before (lambda (n e)
+ (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{"
+ latex-color-counter)
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "pre"))
+ e)
+ (display "{l}\n")
+ (set! latex-color-counter (+ latex-color-counter 1)))
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-pre-encoding)
+ :symbol-table (engine-symbol-table e)
+ :custom (engine-customs e))))
+ (output (markup-body n) ne)))
+ :after (lambda (n e)
+ (set! latex-color-counter (- latex-color-counter 1))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "prog"))
+ e)
+ (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter)))
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\\\\\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before "\\begin{itemize}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{itemize} ")
+
+(markup-writer 'itemize
+ :predicate (lambda (n e) (markup-option n :symbol))
+ :options '(:symbol)
+ :before (lambda (n e)
+ (display "\\begin{list}{")
+ (output (markup-option n :symbol) e)
+ (display "}{}")
+ (newline))
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{list}\n")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before "\\begin{enumerate}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (display " \\item ")
+ (output item e)
+ (newline))
+ (markup-body n)))
+ :after "\\end{enumerate}\n")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol)
+ :before "\\begin{description}\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (for-each (lambda (i)
+ (display " \\item[")
+ (output i e)
+ (display "]\n"))
+ (if (pair? k) k (list k)))
+ (output (markup-body item) e)))
+ (markup-body n)))
+ :after "\\end{description}\n")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :action (lambda (n e)
+ (let ((k (markup-option n :key)))
+ (if k
+ (begin
+ (display "[")
+ (output k e)
+ (display "] "))))
+ (output (markup-body n) e)))
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :before "\n\\begin{quote}\n"
+ :after "\n\\end{quote}")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend))
+ (mc (markup-option n :multicolumns)))
+ (display (if mc
+ "\\begin{figure*}[!th]\n"
+ "\\begin{figure}[ht]\n"))
+ (output (markup-body n) e)
+ (printf "\\caption{\\label{~a}" (string-canonicalize ident))
+ (output legend e)
+ (display (if mc
+ "}\\end{figure*}\n"
+ "}\\end{figure}\n")))))
+
+;*---------------------------------------------------------------------*/
+;* table-column-number ... */
+;* ------------------------------------------------------------- */
+;* Computes how many columns are contained in a table. */
+;*---------------------------------------------------------------------*/
+(define (table-column-number t)
+ (define (row-columns row)
+ (let luup ((cells (markup-body row))
+ (nbcols 0))
+ (cond
+ ((null? cells)
+ nbcols)
+ ((pair? cells)
+ (luup (cdr cells)
+ (+ nbcols (markup-option (car cells) :colspan))))
+ (else
+ (skribe-type-error 'tr "Illegal tr body, " row "pair")))))
+ (let loop ((rows (markup-body t))
+ (nbcols 0))
+ (if (null? rows)
+ nbcols
+ (loop (cdr rows)
+ (max (row-columns (car rows)) nbcols)))))
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:width :frame :rules :cellstyle)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (frame (markup-option n :frame))
+ (rules (markup-option n :rules))
+ (cstyle (markup-option n :cellstyle))
+ (nbcols (table-column-number n))
+ (id (markup-ident n))
+ (cla (markup-class n))
+ (rows (markup-body n)))
+ ;; the table header
+ (output (new markup
+ (markup '&latex-table-start)
+ (class "table")
+ (options `((width ,width))))
+ e)
+ ;; store the actual number of columns
+ (markup-option-add! n '&nbcols nbcols)
+ ;; compute the table header
+ (let ((cols (cond
+ ((= nbcols 0)
+ (skribe-error 'table
+ "Illegal empty table"
+ n))
+ ((or (not width) (= nbcols 1))
+ (make-string nbcols #\c))
+ (else
+ (let ((v (make-vector
+ (- nbcols 1)
+ "@{\\extracolsep{\\fill}}c")))
+ (apply string-append
+ (cons "c" (vector->list v))))))))
+ (case frame
+ ((none)
+ (printf "{~a}\n" cols))
+ ((border box)
+ (printf "{|~a|}" cols)
+ (markup-option-add! n '&lhs #t)
+ (markup-option-add! n '&rhs #t)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format #f "~a-above" id))
+ (class "table-line-above"))
+ e))
+ ((above hsides)
+ (printf "{~a}" cols)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format #f "~a-above" id))
+ (class "table-line-above"))
+ e))
+ ((vsides)
+ (markup-option-add! n '&lhs #t)
+ (markup-option-add! n '&rhs #t)
+ (printf "{|~a|}\n" cols))
+ ((lhs)
+ (markup-option-add! n '&lhs #t)
+ (printf "{|~a}\n" cols))
+ ((rhs)
+ (markup-option-add! n '&rhs #t)
+ (printf "{~a|}\n" cols))
+ (else
+ (printf "{~a}\n" cols)))
+ ;; mark each row with appropriate '&tl (top-line)
+ ;; and &bl (bottom-line) options
+ (when (pair? rows)
+ (if (and (memq rules '(rows all))
+ (or (not (eq? cstyle 'collapse))
+ (not (memq frame '(border box above hsides)))))
+ (let ((frow (car rows)))
+ (if (is-markup? frow 'tr)
+ (markup-option-add! frow '&tl #t))))
+ (if (eq? rules 'header)
+ (let ((frow (car rows)))
+ (if (is-markup? frow 'tr)
+ (markup-option-add! frow '&bl #t))))
+ (when (and (pair? (cdr rows))
+ (memq rules '(rows all)))
+ (for-each (lambda (row)
+ (if (is-markup? row 'tr)
+ (markup-option-add! row '&bl #t)))
+ rows)
+ (markup-option-add! (car (last-pair rows)) '&bl #f))
+ (if (and (memq rules '(rows all))
+ (or (not (eq? cstyle 'collapse))
+ (not (memq frame '(border box above hsides)))))
+ (let ((lrow (car (last-pair rows))))
+ (if (is-markup? lrow 'tr)
+ (markup-option-add! lrow '&bl #t))))))))
+ :after (lambda (n e)
+ (case (markup-option n :frame)
+ ((hsides below box border)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (format #f "~a-below" (markup-ident n)))
+ (class "table-hline-below"))
+ e)))
+ (output (new markup
+ (markup '&latex-table-stop)
+ (class "table")
+ (options `((width ,(markup-option n :width)))))
+ e)))
+
+;*---------------------------------------------------------------------*/
+;* &latex-table-hline */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-table-hline
+ :action "\\hline\n")
+
+;*---------------------------------------------------------------------*/
+;* tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '()
+ :action (lambda (n e)
+ (let* ((parent (ast-parent n))
+ (_ (if (not (is-markup? parent 'table))
+ (skribe-type-error 'tr "Illegal parent, " parent
+ "#<table>")))
+ (nbcols (markup-option parent '&nbcols))
+ (lhs (markup-option parent '&lhs))
+ (rhs (markup-option parent '&rhs))
+ (rules (markup-option parent :rules))
+ (collapse (eq? (markup-option parent :cellstyle)
+ 'collapse))
+ (vrules (memq rules '(cols all)))
+ (cells (markup-body n)))
+ (if (markup-option n '&tl)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (markup-ident n))
+ (class (markup-class n)))
+ e))
+ (if (> nbcols 0)
+ (let laap ((nbc nbcols)
+ (cs cells))
+ (if (null? cs)
+ (when (> nbc 1)
+ (display " & ")
+ (laap (- nbc 1) cs))
+ (let* ((c (car cs))
+ (nc (- nbc (markup-option c :colspan))))
+ (when (= nbcols nbc)
+ (cond
+ ((and lhs vrules (not collapse))
+ (markup-option-add! c '&lhs "||"))
+ ((or lhs vrules)
+ (markup-option-add! c '&lhs #\|))))
+ (when (= nc 0)
+ (cond
+ ((and rhs vrules (not collapse))
+ (markup-option-add! c '&rhs "||"))
+ ((or rhs vrules)
+ (markup-option-add! c '&rhs #\|))))
+ (when (and vrules (> nc 0) (< nc nbcols))
+ (markup-option-add! c '&rhs #\|))
+ (output c e)
+ (when (> nc 0)
+ (display " & ")
+ (laap nc (cdr cs)))))))))
+ :after (lambda (n e)
+ (display "\\\\")
+ (if (markup-option n '&bl)
+ (output (new markup
+ (markup '&latex-table-hline)
+ (parent n)
+ (ident (markup-ident n))
+ (class (markup-class n)))
+ e)
+ (newline))))
+
+;*---------------------------------------------------------------------*/
+;* tc */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(:width :align :valign :colspan)
+ :action (lambda (n e)
+ (let ((id (markup-ident n))
+ (cla (markup-class n)))
+ (let* ((o0 (markup-body n))
+ (o1 (if (eq? (markup-option n 'markup) 'th)
+ (new markup
+ (markup '&latex-th)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o0))
+ o0))
+ (o2 (if (markup-option n :width)
+ (new markup
+ (markup '&latex-tc-parbox)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o1))
+ o1))
+ (o3 (if (or (> (markup-option n :colspan) 1)
+ (not (eq? (markup-option n :align)
+ 'center))
+ (markup-option n '&lhs)
+ (markup-option n '&rhs))
+ (new markup
+ (markup '&latex-tc-multicolumn)
+ (parent n)
+ (ident id)
+ (class cla)
+ (options (markup-options n))
+ (body o2))
+ o2)))
+ (output o3 e)))))
+
+;*---------------------------------------------------------------------*/
+;* &latex-th ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-th
+ :before "\\textsf{"
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* &latex-tc-parbox ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-tc-parbox
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (valign (markup-option n :valign)))
+ (printf "\\parbox{~a}{" (latex-width width))))
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* &latex-tc-multicolumn ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&latex-tc-multicolumn
+ :before (lambda (n e)
+ (let ((colspan (markup-option n :colspan))
+ (lhs (or (markup-option n '&lhs) ""))
+ (rhs (or (markup-option n '&rhs) ""))
+ (align (case (markup-option n :align)
+ ((left) #\l)
+ ((center) #\c)
+ ((right) #\r)
+ (else #\c))))
+ (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs)))
+ :after "}")
+
+;*---------------------------------------------------------------------*/
+;* image ... @label image@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("eps"))))))
+ (if (not (string? img))
+ (skribe-error 'latex "Illegal image" file)
+ (begin
+ (printf "\\epsfig{file=~a" (strip-ref-base img))
+ (if width (printf ", width=~a" (latex-width width)))
+ (if height (printf ", height=~apt" height))
+ (if zoom (printf ", zoom=\"~a\"" zoom))
+ (display "}"))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'roman :before "{\\textrm{" :after "}}")
+(markup-writer 'bold :before "{\\textbf{" :after "}}")
+(markup-writer 'underline :before "{\\underline{" :after "}}")
+(markup-writer 'emph :before "{\\em{" :after "}}")
+(markup-writer 'it :before "{\\textit{" :after "}}")
+(markup-writer 'code :before "{\\texttt{" :after "}}")
+(markup-writer 'var :before "{\\texttt{" :after "}}")
+(markup-writer 'sc :before "{\\sc{" :after "}}")
+(markup-writer 'sf :before "{\\sf{" :after "}}")
+(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}")
+(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}")
+
+(markup-writer 'tt
+ :before "{\\texttt{"
+ :action (lambda (n e)
+ (let ((ne (make-engine
+ (gensym 'latex)
+ :delegate e
+ :filter (make-string-replace latex-tt-encoding)
+ :custom (engine-customs e)
+ :symbol-table (engine-symbol-table e))))
+ (output (markup-body n) ne)))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "``"
+ :after "''")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :before "{\\texttt{"
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (output (or text (markup-body n)) e)))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :before (lambda (n e)
+ (printf "\\label{~a}" (string-canonicalize (markup-ident n)))))
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page)
+ :action (lambda (n e)
+ (let ((t (markup-option n :text)))
+ (if t
+ (begin
+ (output t e)
+ (output "~" e (markup-writer-get '~ e))))))
+ :after (lambda (n e)
+ (let* ((c (handle-ast (markup-body n)))
+ (id (markup-ident c)))
+ (if (markup-option n :page)
+ (printf "\\begin{math}{\\pageref{~a}}\\end{math}"
+ (string-canonicalize id))
+ (printf "\\ref{~a}"
+ (string-canonicalize id))))))
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (output (markup-option (handle-ast (markup-body n)) :title) e))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let loop ((rs (markup-body n)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (let ((text (markup-option n :text))
+ (url (markup-option n :url)))
+ (if (not text)
+ (output url e)
+ (output text e)))))
+
+;*---------------------------------------------------------------------*/
+;* url-ref hyperref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :predicate (lambda (n e)
+ (engine-custom e 'hyperref))
+ :action (lambda (n e)
+ (let ((body (markup-option n :text))
+ (url (markup-option n :url)))
+ (if (and body (not (equal? body url)))
+ (begin
+ (display "\\href{")
+ (display url)
+ (display "}{")
+ (output body e)
+ (display "}"))
+ (begin
+ (display "\\href{")
+ (display url)
+ (printf "}{~a}" url))))))
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before "{\\textit{"
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (cond
+ ((and (number? o) (number? v))
+ (display (+ o v)))
+ (else
+ (display v)))))
+ :after "}}")
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ (display "{%
+\\sloppy
+\\sfcode`\\.=1000\\relax
+\\newdimen\\bibindent
+\\bibindent=0em
+\\begin{list}{}{%
+ \\settowidth\\labelwidth{[21]}%
+ \\leftmargin\\labelwidth
+ \\advance\\leftmargin\\labelsep
+ \\advance\\leftmargin\\bibindent
+ \\itemindent -\\bibindent
+ \\listparindent \\itemindent
+ \\itemsep 0pt
+ }%\n"))
+ :after (lambda (n e)
+ (display "\n\\end{list}}\n")))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :action (lambda (n e)
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (output n e (markup-writer-get '&bib-entry-body e)))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :predicate (lambda (n e)
+ (engine-custom e 'hyperref))
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before "\\item[{\\char91}"
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "{\\char93}] ")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (underline (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-error ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-error
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-error-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'error-color) cc)
+ (color :fg cc (underline n1))
+ (underline n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
new file mode 100644
index 0000000..893ab2e
--- /dev/null
+++ b/src/guile/skribilo/engine/lout.scm
@@ -0,0 +1,2891 @@
+;;; lout.scm -- A Lout engine.
+;;;
+;;; Copyright 2004, 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;;; Taken from `lcourtes@laas.fr--2004-libre',
+;;; `skribe-lout--main--0.2--patch-15'.
+;;; Based on `latex.skr', copyright 2003, 2004 Manuel Serrano.
+
+
+(define-skribe-module (skribilo engine lout)
+ :autoload (ice-9 popen) (open-output-pipe)
+ :autoload (ice-9 rdelim) (read-line))
+
+
+
+;*---------------------------------------------------------------------*/
+;* lout-verbatim-encoding ... */
+;*---------------------------------------------------------------------*/
+(define-public lout-verbatim-encoding
+ '((#\/ "\"/\"")
+ (#\\ "\"\\\\\"")
+ (#\| "\"|\"")
+ (#\& "\"&\"")
+ (#\@ "\"@\"")
+ (#\" "\"\\\"\"")
+ (#\{ "\"{\"")
+ (#\} "\"}\"")
+ (#\$ "\"$\"")
+ (#\# "\"#\"")
+ (#\_ "\"_\"")
+ (#\~ "\"~\"")))
+
+;*---------------------------------------------------------------------*/
+;* lout-encoding ... */
+;*---------------------------------------------------------------------*/
+(define-public lout-encoding
+ `(,@lout-verbatim-encoding
+ (#\ç "{ @Char ccedilla }")
+ (#\Ç "{ @Char Ccdeilla }")
+ (#\â "{ @Char acircumflex }")
+ (#\Â "{ @Char Acircumflex }")
+ (#\à "{ @Char agrave }")
+ (#\À "{ @Char Agrave }")
+ (#\é "{ @Char eacute }")
+ (#\É "{ @Char Eacute }")
+ (#\è "{ @Char egrave }")
+ (#\È "{ @Char Egrave }")
+ (#\ê "{ @Char ecircumflex }")
+ (#\Ê "{ @Char Ecircumflex }")
+ (#\ù "{ @Char ugrave }")
+ (#\Ù "{ @Char Ugrave }")
+ (#\û "{ @Char ucircumflex }")
+ (#\Û "{ @Char Ucircumflex }")
+ (#\ø "{ @Char oslash }")
+ (#\ô "{ @Char ocircumflex }")
+ (#\Ô "{ @Char Ocircumflex }")
+ (#\ö "{ @Char odieresis }")
+ (#\Ö "{ @Char Odieresis }")
+ (#\î "{ @Char icircumflex }")
+ (#\Î "{ @Char Icircumflex }")
+ (#\ï "{ @Char idieresis }")
+ (#\Ï "{ @Char Idieresis }")
+ (#\] "\"]\"")
+ (#\[ "\"[\"")
+ (#\» "{ @Char guillemotright }")
+ (#\« "{ @Char guillemotleft }")))
+
+
+;; XXX: This is just here for experimental purposes.
+(define lout-french-punctuation-encoding
+ (let ((space (lambda (before after thing)
+ (string-append "{ "
+ (if before
+ (string-append "{ " before " @Wide {} }")
+ "")
+ "\"" thing "\""
+ (if after
+ (string-append "{ " after " @Wide {} }")
+ "")
+ " }"))))
+ `((#\; ,(space "0.5s" #f ";"))
+ (#\? ,(space "0.5s" #f ";"))
+ (#\! ,(space "0.5s" #f ";")))))
+
+(define lout-french-encoding
+ (let ((punctuation (map car lout-french-punctuation-encoding)))
+ (append (let loop ((ch lout-encoding)
+ (purified '()))
+ (if (null? ch)
+ purified
+ (loop (cdr ch)
+ (if (member (car ch) punctuation)
+ purified
+ (cons (car ch) purified)))))
+ lout-french-punctuation-encoding)))
+
+;*---------------------------------------------------------------------*/
+;* lout-symbol-table ... */
+;*---------------------------------------------------------------------*/
+(define (lout-symbol-table sym math)
+ `(("iexcl" "{ @Char exclamdown }")
+ ("cent" "{ @Char cent }")
+ ("pound" "{ @Char sterling }")
+ ("yen" "{ @Char yen }")
+ ("section" "{ @Char section }")
+ ("mul" "{ @Char multiply }")
+ ("copyright" "{ @Char copyright }")
+ ("lguillemet" "{ @Char guillemotleft }")
+ ("not" "{ @Char logicalnot }")
+ ("degree" "{ @Char degree }")
+ ("plusminus" "{ @Char plusminus }")
+ ("micro" "{ @Char mu }")
+ ("paragraph" "{ @Char paragraph }")
+ ("middot" "{ @Char periodcentered }")
+ ("rguillemet" "{ @Char guillemotright }")
+ ("1/4" "{ @Char onequarter }")
+ ("1/2" "{ @Char onehalf }")
+ ("3/4" "{ @Char threequarters }")
+ ("iquestion" "{ @Char questiondown }")
+ ("Agrave" "{ @Char Agrave }")
+ ("Aacute" "{ @Char Aacute }")
+ ("Acircumflex" "{ @Char Acircumflex }")
+ ("Atilde" "{ @Char Atilde }")
+ ("Amul" "{ @Char Adieresis }") ;;; FIXME: Why `mul' and not `uml'?!
+ ("Aring" "{ @Char Aring }")
+ ("AEligature" "{ @Char oe }")
+ ("Oeligature" "{ @Char OE }") ;;; FIXME: Should be `OEligature'?!
+ ("Ccedilla" "{ @Char Ccedilla }")
+ ("Egrave" "{ @Char Egrave }")
+ ("Eacute" "{ @Char Eacute }")
+ ("Ecircumflex" "{ @Char Ecircumflex }")
+ ("Euml" "{ @Char Edieresis }")
+ ("Igrave" "{ @Char Igrave }")
+ ("Iacute" "{ @Char Iacute }")
+ ("Icircumflex" "{ @Char Icircumflex }")
+ ("Iuml" "{ @Char Idieresis }")
+ ("ETH" "{ @Char Eth }")
+ ("Ntilde" "{ @Char Ntilde }")
+ ("Ograve" "{ @Char Ograve }")
+ ("Oacute" "{ @Char Oacute }")
+ ("Ocircumflex" "{ @Char Ocircumflex }")
+ ("Otilde" "{ @Char Otilde }")
+ ("Ouml" "{ @Char Odieresis }")
+ ("times" ,(sym "multiply"))
+ ("Oslash" "{ @Char oslash }")
+ ("Ugrave" "{ @Char Ugrave }")
+ ("Uacute" "{ @Char Uacute }")
+ ("Ucircumflex" "{ @Char Ucircumflex }")
+ ("Uuml" "{ @Char Udieresis }")
+ ("Yacute" "{ @Char Yacute }")
+ ("szlig" "{ @Char germandbls }")
+ ("agrave" "{ @Char agrave }")
+ ("aacute" "{ @Char aacute }")
+ ("acircumflex" "{ @Char acircumflex }")
+ ("atilde" "{ @Char atilde }")
+ ("amul" "{ @Char adieresis }")
+ ("aring" "{ @Char aring }")
+ ("aeligature" "{ @Char ae }")
+ ("oeligature" "{ @Char oe }")
+ ("ccedilla" "{ @Char ccedilla }")
+ ("egrave" "{ @Char egrave }")
+ ("eacute" "{ @Char eacute }")
+ ("ecircumflex" "{ @Char ecircumflex }")
+ ("euml" "{ @Char edieresis }")
+ ("igrave" "{ @Char igrave }")
+ ("iacute" "{ @Char iacute }")
+ ("icircumflex" "{ @Char icircumflex }")
+ ("iuml" "{ @Char idieresis }")
+ ("ntilde" "{ @Char ntilde }")
+ ("ograve" "{ @Char ograve }")
+ ("oacute" "{ @Char oacute }")
+ ("ocurcumflex" "{ @Char ocircumflex }") ;; FIXME: `ocIrcumflex'
+ ("otilde" "{ @Char otilde }")
+ ("ouml" "{ @Char odieresis }")
+ ("divide" "{ @Char divide }")
+ ("oslash" "{ @Char oslash }")
+ ("ugrave" "{ @Char ugrave }")
+ ("uacute" "{ @Char uacute }")
+ ("ucircumflex" "{ @Char ucircumflex }")
+ ("uuml" "{ @Char udieresis }")
+ ("yacute" "{ @Char yacute }")
+ ("ymul" "{ @Char ydieresis }") ;; FIXME: `yUMl'
+ ;; Greek
+ ("Alpha" ,(sym "Alpha"))
+ ("Beta" ,(sym "Beta"))
+ ("Gamma" ,(sym "Gamma"))
+ ("Delta" ,(sym "Delta"))
+ ("Epsilon" ,(sym "Epsilon"))
+ ("Zeta" ,(sym "Zeta"))
+ ("Eta" ,(sym "Eta"))
+ ("Theta" ,(sym "Theta"))
+ ("Iota" ,(sym "Iota"))
+ ("Kappa" ,(sym "Kappa"))
+ ("Lambda" ,(sym "Lambda"))
+ ("Mu" ,(sym "Mu"))
+ ("Nu" ,(sym "Nu"))
+ ("Xi" ,(sym "Xi"))
+ ("Omicron" ,(sym "Omicron"))
+ ("Pi" ,(sym "Pi"))
+ ("Rho" ,(sym "Rho"))
+ ("Sigma" ,(sym "Sigma"))
+ ("Tau" ,(sym "Tau"))
+ ("Upsilon" ,(sym "Upsilon"))
+ ("Phi" ,(sym "Phi"))
+ ("Chi" ,(sym "Chi"))
+ ("Psi" ,(sym "Psi"))
+ ("Omega" ,(sym "Omega"))
+ ("alpha" ,(sym "alpha"))
+ ("beta" ,(sym "beta"))
+ ("gamma" ,(sym "gamma"))
+ ("delta" ,(sym "delta"))
+ ("epsilon" ,(sym "epsilon"))
+ ("zeta" ,(sym "zeta"))
+ ("eta" ,(sym "eta"))
+ ("theta" ,(sym "theta"))
+ ("iota" ,(sym "iota"))
+ ("kappa" ,(sym "kappa"))
+ ("lambda" ,(sym "lambda"))
+ ("mu" ,(sym "mu"))
+ ("nu" ,(sym "nu"))
+ ("xi" ,(sym "xi"))
+ ("omicron" ,(sym "omicron"))
+ ("pi" ,(sym "pi"))
+ ("rho" ,(sym "rho"))
+ ("sigmaf" ,(sym "sigmaf")) ;; FIXME!
+ ("sigma" ,(sym "sigma"))
+ ("tau" ,(sym "tau"))
+ ("upsilon" ,(sym "upsilon"))
+ ("phi" ,(sym "phi"))
+ ("chi" ,(sym "chi"))
+ ("psi" ,(sym "psi"))
+ ("omega" ,(sym "omega"))
+ ("thetasym" ,(sym "thetasym"))
+ ("piv" ,(sym "piv")) ;; FIXME!
+ ;; punctuation
+ ("bullet" ,(sym "bullet"))
+ ("ellipsis" ,(sym "ellipsis"))
+ ("weierp" "{ @Sym weierstrass }")
+ ("image" ,(sym "Ifraktur"))
+ ("real" ,(sym "Rfraktur"))
+ ("tm" ,(sym "trademarksans")) ;; alt: @Sym trademarkserif
+ ("alef" ,(sym "aleph"))
+ ("<-" ,(sym "arrowleft"))
+ ("<--" "{ { 1.6 1 } @Scale { @Sym arrowleft } }") ;; copied from `eqf'
+ ("uparrow" ,(sym "arrowup"))
+ ("->" ,(sym "arrowright"))
+ ("-->" "{ { 1.6 1 } @Scale { @Sym arrowright } }")
+ ("downarrow" ,(sym "arrowdown"))
+ ("<->" ,(sym "arrowboth"))
+ ("<-->" "{ { 1.6 1 } @Scale { @Sym arrowboth } }")
+ ("<+" ,(sym "carriagereturn"))
+ ("<=" ,(sym "arrowdblleft"))
+ ("<==" "{ { 1.6 1 } @Scale { @Sym arrowdblleft } }")
+ ("Uparrow" ,(sym "arrowdblup"))
+ ("=>" ,(sym "arrowdblright"))
+ ("==>" "{ { 1.6 1 } @Scale { @Sym arrowdblright } }")
+ ("Downarrow" ,(sym "arrowdbldown"))
+ ("<=>" ,(sym "arrowdblboth"))
+ ("<==>" "{ { 1.6 1 } @Scale { @Sym arrowdblboth } }")
+ ;; Mathematical operators (we try to avoid `@Eq' since it
+ ;; requires to `@SysInclude { eq }' -- one solution consists in copying
+ ;; the symbol definition from `eqf')
+ ("forall" "{ { Symbol Base } @Font \"\\042\" }")
+ ("partial" ,(sym "partialdiff"))
+ ("exists" "{ { Symbol Base } @Font \"\\044\" }")
+ ("emptyset" "{ { Symbol Base } @Font \"\\306\" }")
+ ("infinity" ,(sym "infinity"))
+ ("nabla" "{ { Symbol Base } @Font \"\\321\" }")
+ ("in" ,(sym "element"))
+ ("notin" ,(sym "notelement"))
+ ("ni" "{ 180d @Rotate @Sym element }")
+ ("prod" ,(sym "product"))
+ ("sum" ,(sym "summation"))
+ ("asterisk" ,(sym "asteriskmath"))
+ ("sqrt" ,(sym "radical"))
+ ("propto" ,(math "propto"))
+ ("angle" ,(sym "angle"))
+ ("and" ,(math "bwedge"))
+ ("or" ,(math "bvee"))
+ ("cap" ,(math "bcap"))
+ ("cup" ,(math "bcup"))
+ ("integral" ,(math "int"))
+ ("models" ,(math "models"))
+ ("vdash" ,(math "vdash"))
+ ("dashv" ,(math "dashv"))
+ ("sim" ,(sym "similar"))
+ ("cong" ,(sym "congruent"))
+ ("approx" ,(sym "approxequal"))
+ ("neq" ,(sym "notequal"))
+ ("equiv" ,(sym "equivalence"))
+ ("le" ,(sym "lessequal"))
+ ("ge" ,(sym "greaterequal"))
+ ("subset" ,(sym "propersubset"))
+ ("supset" ,(sym "propersuperset"))
+ ("subseteq" ,(sym "reflexsubset"))
+ ("supseteq" ,(sym "reflexsuperset"))
+ ("oplus" ,(sym "circleplus"))
+ ("otimes" ,(sym "circlemultiply"))
+ ("perp" ,(sym "perpendicular"))
+ ("mid" ,(sym "bar"))
+ ("lceil" ,(sym "bracketlefttp"))
+ ("rceil" ,(sym "bracketrighttp"))
+ ("lfloor" ,(sym "bracketleftbt"))
+ ("rfloor" ,(sym "bracketrightbt"))
+ ("langle" ,(sym "angleleft"))
+ ("rangle" ,(sym "angleright"))
+ ;; Misc
+ ("loz" "{ @Lozenge }")
+ ("spades" ,(sym "spade"))
+ ("clubs" ,(sym "club"))
+ ("hearts" ,(sym "heart"))
+ ("diams" ,(sym "diamond"))
+ ("euro" "{ @Euro }")
+ ;; Lout
+ ("dag" "{ @Dagger }")
+ ("ddag" "{ @DaggerDbl }")
+ ("circ" ,(math "circle"))
+ ("top" ,(math "top"))
+ ("bottom" ,(math "bot"))
+ ("lhd" ,(math "triangleleft"))
+ ("rhd" ,(math "triangleright"))
+ ("parallel" ,(math "dbar"))))
+
+
+;;; Debugging support
+
+(define *lout-debug?* #f)
+
+(define-macro (lout-debug fmt . args)
+ `(if *lout-debug?*
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (printf (string-append ,fmt "~%") ,@args
+ (current-error-port))))
+ #t))
+
+(define-public (lout-tagify ident)
+ ;; Return an "clean" identifier (a string) based on `ident' (a string),
+ ;; suitable for Lout as an `@Tag' value.
+ (let ((tag-encoding '((#\, "-")
+ (#\( "-")
+ (#\) "-")
+ (#\[ "-")
+ (#\] "-")
+ (#\/ "-")
+ (#\| "-")
+ (#\& "-")
+ (#\@ "-")
+ (#\! "-")
+ (#\? "-")
+ (#\: "-")
+ (#\; "-")))
+ (tag (string-canonicalize ident)))
+ ((make-string-replace tag-encoding) tag)))
+
+
+;; Default values of various customs (procedures)
+
+(define (lout-definitions engine)
+ ;; Return a string containing a set of useful Lout definitions that should
+ ;; be inserted at the beginning of the output document.
+ (let ((leader (engine-custom engine 'toc-leader))
+ (leader-space (engine-custom engine 'toc-leader-space)))
+ (apply string-append
+ `("# @SkribeMark implements Skribe's marks "
+ "(i.e. cross-references)\n"
+ "def @SkribeMark\n"
+ " right @Tag\n"
+ "{\n"
+ " @PageMark @Tag\n"
+ "}\n\n"
+
+ "# @SkribiloLeaders is used in `toc'\n"
+ "# (this is mostly copied from the expert's guide)\n"
+ "def @SkribiloLeaders { "
+ ,leader " |" ,leader-space " @SkribiloLeaders }\n\n"))))
+
+(define (lout-make-doc-cover-sheet doc engine)
+ ;; Create a cover sheet for node `doc' which is a doc-style Lout document.
+ ;; This is the default implementation, i.e. the default value of the
+ ;; `doc-cover-sheet-proc' custom.
+ (let ((title (markup-option doc :title))
+ (author (markup-option doc :author))
+ (date-line (engine-custom engine 'date-line))
+ (cover-sheet? (engine-custom engine 'cover-sheet?))
+ (multi-column? (> (engine-custom engine 'column-number) 1)))
+
+ (if multi-column?
+ ;; In single-column document, `@FullWidth' yields a blank page.
+ (display "\n@FullWidth {"))
+ (display "\n//3.0fx\n")
+ (display "\n@Center 1.4f @Font @B { cragged nohyphen 1.4fx } @Break { ")
+ (if title
+ (output title engine)
+ (display "The Lout Document"))
+ (display " }\n")
+ (display "//1.7fx\n")
+ (if date-line
+ (begin
+ (display "@Center { ")
+ (output date-line engine)
+ (display " }\n//1.4fx\n")))
+ (if author
+ (begin
+ (display "@Center { ")
+ (output author engine)
+ (display " }\n")
+ (display "//4fx\n")))
+ (if multi-column?
+ (display "\n} # @FullWidth\n"))))
+
+(define (lout-split-external-link markup)
+ ;; Shorten `markup', an URL `url-ref' markup, by splitting it into an URL
+ ;; `ref' followed by plain text. This is useful because Lout's
+ ;; @ExternalLink symbols are unbreakable to the embodied text should _not_
+ ;; be too large (otherwise it is scaled down).
+ (let* ((url (markup-option markup :url))
+ (text (or (markup-option markup :text) url)))
+ (lout-debug "lout-split-external-link: text=~a" text)
+ (cond ((pair? text)
+ ;; no need to go recursive here: we'll get called again later
+ `(,(ref :url url :text (car text)) ,@(cdr text)))
+
+ ((string? text)
+ (let ((len (string-length text)))
+ (if (> (- len 8) 2)
+ ;; don't split on a whitespace or it will vanish
+ (let ((split (let loop ((where 10))
+ (if (= 0 where)
+ 10
+ (if (char=? (string-ref text
+ (- where 1))
+ #\space)
+ (loop (- where 1))
+ where)))))
+ `(,(ref :url url :text (substring text 0 split))
+ ,(substring text split len)))
+ (list markup))))
+
+ ((markup? text)
+ (let ((kind (markup-markup text)))
+ (lout-debug "lout-split-external-link: kind=~a" kind)
+ (if (member kind '(bold it underline))
+ ;; get the ornament markup out of the `:text' argument
+ (list (apply (eval kind (interaction-environment))
+ (list (ref :url url
+ :text (markup-body text)))))
+ ;; otherwise, leave it as is
+ (list markup))))
+
+ (else (list markup)))))
+
+(define (lout-make-toc-entry node engine)
+ ;; Default implementation of the `toc-entry-proc' custom that produces the
+ ;; number and title of `node' for use in the table of contents.
+ (let ((num (markup-option node :number))
+ (title (markup-option node :title))
+ (lang (engine-custom engine 'initial-language)))
+ (if num
+ (begin
+ (if (is-markup? node 'chapter) (display "@B { "))
+ (printf "~a. |2s " (lout-structure-number-string node))
+ (output title engine)
+ (if (is-markup? node 'chapter) (display " }")))
+ (if (is-markup? node 'chapter)
+ (output (bold title) engine)
+ (output title engine)))))
+
+(define (lout-bib-refs-sort/number entry1 entry2)
+ ;; Default implementation of the `bib-refs-sort-proc' custom. Compare
+ ;; bibliography entries `entry1' and `entry2' (of type `&bib-entry') for
+ ;; use by `sort' in `bib-ref+'.
+ (let ((ident1 (markup-option entry1 :title))
+ (ident2 (markup-option entry2 :title)))
+ (if (and (markup? ident1) (markup? ident2))
+ (< (markup-option ident1 'number)
+ (markup-option ident2 'number))
+ (begin
+ (fprint (current-error-port) "i1: " ident1 ", " entry1)
+ (fprint (current-error-port) "i2: " ident2 ", " entry2)))))
+
+(define (lout-pdf-bookmark-title node engine)
+ ;; Default implementation of the `pdf-bookmark-title-proc' custom that
+ ;; returns a title (a string) for the PDF bookmark of `node'.
+ (let ((number (lout-structure-number-string node)))
+ (string-append (if (string=? number "") "" (string-append number ". "))
+ (ast->string (markup-option node :title)))))
+
+(define (lout-pdf-bookmark-node? node engine)
+ ;; Default implementation of the `pdf-bookmark-node-pred' custom that
+ ;; returns a boolean.
+ (or (is-markup? node 'chapter)
+ (is-markup? node 'section)
+ (is-markup? node 'subsection)
+ (is-markup? node 'slide)))
+
+
+
+
+;*---------------------------------------------------------------------*/
+;* lout-engine ... */
+;*---------------------------------------------------------------------*/
+(define lout-engine
+ (make-engine 'lout
+ :version 0.2
+ :format "lout"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace lout-encoding)
+ :custom `(;; The underlying Lout document type, i.e. one
+ ;; of `doc', `report', `book' or `slides'.
+ (document-type doc)
+
+ ;; Document style file include line (a string
+ ;; such as `@Include { doc-style.lout }') or
+ ;; `auto' (symbol) in which case the include
+ ;; file is deduced from `document-type'.
+ (document-include auto)
+
+ (includes "@SysInclude { tbl }\n")
+ (initial-font "Palatino Base 10p")
+ (initial-break
+ ,(string-append "unbreakablefirst "
+ "unbreakablelast "
+ "hyphen adjust 1.2fx"))
+
+ ;; The document's language, used for hyphenation
+ ;; and other things.
+ (initial-language "English")
+
+ ;; Number of columns.
+ (column-number 1)
+
+ ;; First page number.
+ (first-page-number 1)
+
+ ;; Page orientation, `portrait', `landscape',
+ ;; `reverse-portrait' or `reverse-landscape'.
+ (page-orientation portrait)
+
+ ;; For reports, whether to produce a cover
+ ;; sheet. The `doc-cover-sheet-proc' custom may
+ ;; also honor this custom for `doc' documents.
+ (cover-sheet? #t)
+
+ ;; For reports, the date line.
+ (date-line #t)
+
+ ;; For reports, an abstract.
+ (abstract #f)
+
+ ;; For reports, title/name of the abstract. If
+ ;; `#f', the no abstract title will be
+ ;; produced. If `#t', a default name in the
+ ;; current language is chosen.
+ (abstract-title #t)
+
+ ;; Whether to optimize pages.
+ (optimize-pages? #f)
+
+ ;; For docs, the procedure that produces the
+ ;; Lout code for the cover sheet or title.
+ (doc-cover-sheet-proc
+ ,lout-make-doc-cover-sheet)
+
+ ;; Procedure used to sort bibliography
+ ;; references when several are referred to at
+ ;; the same time, as in:
+ ;; (ref :bib '("smith03" "jones98")) .
+ ;; By default they are sorted by number. If
+ ;; `#f' is given, they are left as is.
+ (bib-refs-sort-proc
+ ,lout-bib-refs-sort/number)
+
+ ;; Lout code for paragraph gaps (similar to
+ ;; `@PP' with `@ParaGap' equal to `1.0vx' by
+ ;; default)
+ (paragraph-gap
+ "\n//1.0vx @ParaIndent @Wide &{0i}\n")
+
+ ;; For multi-page tables, it may be
+ ;; useful to set this to `#t'. However,
+ ;; this looks kind of buggy.
+ (use-header-rows? #f)
+
+ ;; Tells whether to use Skribe's footnote
+ ;; numbers or Lout's numbering scheme (the
+ ;; latter may be better, typography-wise).
+ (use-skribe-footnote-numbers? #t)
+
+ ;; A procedure that is passed the engine
+ ;; and produces Lout definitions.
+ (inline-definitions-proc ,lout-definitions)
+
+ ;; A procedure that takes a URL `ref' markup and
+ ;; returns a list containing (maybe) one such
+ ;; `ref' markup. This custom can be used to
+ ;; modified the way URLs are rendered. The
+ ;; default value is a procedure that limits the
+ ;; size of Lout's @ExternalLink symbols since
+ ;; they are unbreakable. In order to completely
+ ;; disable use of @ExternalLinks, just set it to
+ ;; `markup-body'.
+ (transform-url-ref-proc
+ ,lout-split-external-link)
+
+ ;; Leader used in the table of contents entries.
+ (toc-leader ".")
+
+ ;; Inter-leader spacing in the TOC entries.
+ (toc-leader-space "2.5s")
+
+ ;; Procedure that takes a large-scale structure
+ ;; (chapter, section, etc.) and the engine and
+ ;; produces the number and possibly title of
+ ;; this structure for use the TOC.
+ (toc-entry-proc ,lout-make-toc-entry)
+
+ ;; The Lout program name, only useful when using
+ ;; `lout-illustration' on other back-ends.
+ (lout-program-name "lout")
+
+ ;; Title and author information in the PDF
+ ;; document information. If `#t', the
+ ;; document's `:title' and `:author' are used.
+ (pdf-title #t)
+ (pdf-author #t)
+
+ ;; Keywords (a list of string) in the PDF
+ ;; document information. This custom is deprecated,
+ ;; use the `:keywords' option of `document' instead.
+ (pdf-keywords #f)
+
+ ;; Extra PDF information, an alist of key-value
+ ;; pairs (string pairs).
+ (pdf-extra-info (("SkribeVersion"
+ ,(skribe-release))))
+
+ ;; Tells whether to produce PDF "docinfo"
+ ;; (meta-information with title, author,
+ ;; keywords, etc.).
+ (make-pdf-docinfo? #t)
+
+ ;; Tells whether a PDF outline
+ ;; (aka. "bookmarks") should be produced.
+ (make-pdf-outline? #t)
+
+ ;; Procedure that takes a node and an engine and
+ ;; return a string representing the title of
+ ;; that node's PDF bookmark.
+ (pdf-bookmark-title-proc ,lout-pdf-bookmark-title)
+
+ ;; Procedure that takes a node and an engine and
+ ;; returns true if that node should have a PDF
+ ;; outline entry.
+ (pdf-bookmark-node-pred ,lout-pdf-bookmark-node?)
+
+ ;; Procedure that takes a node and an engine and
+ ;; returns true if the bookmark for that node
+ ;; should be closed ("folded") when the user
+ ;; opens the PDF document.
+ (pdf-bookmark-closed-pred
+ ,(lambda (n e)
+ (not (is-markup? n 'chapter))))
+
+ ;; color
+ (color? #t)
+
+ ;; source fontification
+ (source-color #t)
+ (source-comment-color "#ffa600")
+ (source-define-color "#6959cf")
+ (source-module-color "#1919af")
+ (source-markup-color "#1919af")
+ (source-thread-color "#ad4386")
+ (source-string-color "red")
+ (source-bracket-color "red")
+ (source-type-color "#00cf00"))
+
+ :symbol-table (lout-symbol-table
+ (lambda (m)
+ ;; We don't use `@Sym' because it doesn't
+ ;; work within `@Eq'.
+ (string-append "{ { Symbol Base } @Font "
+ "@Char \"" m "\" }"))
+ (lambda (m)
+ (format #f "{ @Eq { ~a } }" m)))))
+
+
+;; So that calls to `markup-writer' automatically use `lout-engine'...
+(push-default-engine lout-engine)
+
+
+
+;; User-level implementation of PDF bookmarks.
+;;
+;; Basically, Lout code is produced that produces (via `@Graphic') PostScript
+;; code. That PostScript code is a `pdfmark' command (see Adobe's "pdfmark
+;; Reference Manual") which, when converted to PDF (e.g. with `ps2pdf'),
+;; produces a PDF outline, aka. "bookmarks" (see "PDF Reference, Fifth
+;; Edition", section 8.2.2).
+
+(define (lout-internal-dest-name ident)
+ ;; Return the Lout-generated `pdfmark' named destination for `ident'. This
+ ;; function mimics Lout's `ConvertToPDFName ()', in `z49.c' (Lout's
+ ;; PostScript back-end). In Lout, `ConvertToPDFName ()' produces
+ ;; destination names for the `/Dest' function of the `pdfmark' operator.
+ ;; This implementation is valid as of Lout 3.31 and hopefully it won't
+ ;; change in the future.
+ (string-append "LOUT"
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list ident)))))
+
+(define (lout-pdf-bookmark node children closed? engine)
+ ;; Return the PostScript `pdfmark' operation (a string) that creates a PDF
+ ;; bookmark for node `node'. `children' is the number of children of
+ ;; `node' in the PDF outline. If `closed?' is true, then the bookmark will
+ ;; be close (i.e. its children are hidden).
+ ;;
+ ;; Note: Here, we use a `GoTo' action, while we could instead simply
+ ;; produce a `/Page' attribute without having to use the
+ ;; `lout-internal-dest-name' hack. The point for doing this is that Lout's
+ ;; `@PageOf' operator doesn't return an "actual" page number within the
+ ;; document, but rather a "typographically correct" page number (e.g. `i'
+ ;; for the cover sheet, `1' for the second page, etc.). See
+ ;; http://lists.planix.com/pipermail/lout-users/2005q1/003925.html for
+ ;; details.
+ (let* ((filter-title (make-string-replace `(,@lout-verbatim-encoding
+ (#\newline " "))))
+ (make-bookmark-title (lambda (n e)
+ (filter-title
+ ((engine-custom
+ engine 'pdf-bookmark-title-proc)
+ n e))))
+ (ident (markup-ident node)))
+ (string-append "["
+ (if (= 0 children)
+ ""
+ (string-append "\"/\"Count "
+ (if closed? "-" "")
+ (number->string children) " "))
+ "\"/\"Title \"(\"" (make-bookmark-title node engine)
+ "\")\" "
+ (if (not ident) ""
+ (string-append "\"/\"Action \"/\"GoTo \"/\"Dest \"/\""
+ (lout-internal-dest-name ident) " "))
+ "\"/\"OUT pdfmark\n")))
+
+(define (lout-pdf-outline node engine . children)
+ ;; Return the PDF outline string (in the form of a PostScript `pdfmark'
+ ;; command) for `node' whose child nodes are assumed to be `children',
+ ;; unless `node' is a document.
+ (let* ((choose-node? (lambda (n)
+ ((engine-custom engine 'pdf-bookmark-node-pred)
+ n engine)))
+ (nodes (if (document? node)
+ (filter choose-node? (markup-body node))
+ children)))
+ (apply string-append
+ (map (lambda (node)
+ (let* ((children (filter choose-node? (markup-body node)))
+ (closed? ((engine-custom engine
+ 'pdf-bookmark-closed-pred)
+ node engine))
+ (bm (lout-pdf-bookmark node (length children)
+ closed? engine)))
+ (string-append bm (apply lout-pdf-outline
+ `(,node ,engine ,@children)))))
+ nodes))))
+
+(define-public (lout-embedded-postscript-code postscript)
+ ;; Return a string embedding PostScript code `postscript' into Lout code.
+ (string-append "\n"
+ "{ @BackEnd @Case {\n"
+ " PostScript @Yield {\n"
+ postscript
+ " }\n"
+ "} } @Graphic { }\n"))
+
+(define-public (lout-pdf-docinfo doc engine)
+ ;; Produce PostScript code that will produce PDF document information once
+ ;; converted to PDF.
+ (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding
+ (#\newline " "))))
+ (docinfo-field (lambda (key value)
+ (string-append "\"/\"" key " \"(\""
+ (filter-string value)
+ "\")\"\n")))
+ (author (let ((a (engine-custom engine 'pdf-author)))
+ (if (or (string? a) (ast? a))
+ a
+ (markup-option doc :author))))
+ (title (let ((t (engine-custom engine 'pdf-title)))
+ (if (or (string? t) (ast? t))
+ t
+ (markup-option doc :title))))
+ (keywords (or (engine-custom engine 'pdf-keywords)
+ (map ast->string
+ (or (markup-option doc :keywords) '()))))
+ (extra-fields (engine-custom engine 'pdf-extra-info)))
+
+ (string-append "[ "
+ (if title
+ (docinfo-field "Title" (ast->string title))
+ "")
+ (if author
+ (docinfo-field "Author"
+ (or (cond ((markup? author)
+ (ast->string
+ (or (markup-option
+ author :name)
+ (markup-option
+ author :affiliation))))
+ ((string? author) author)
+ (else (ast->string author)))
+ ""))
+ "")
+ (if (pair? keywords)
+ (docinfo-field "Keywords"
+ (apply string-append
+ (keyword-list->comma-separated
+ keywords)))
+ "")
+ ;; arbitrary key-value pairs, see sect. 4.7, "Info
+ ;; dictionary" of the `pdfmark' reference.
+ (if (or (not extra-fields) (null? extra-fields))
+ ""
+ (apply string-append
+ (map (lambda (p)
+ (docinfo-field (car p) (cadr p)))
+ extra-fields)))
+ "\"/\"DOCINFO pdfmark\n")))
+
+(define-public (lout-output-pdf-meta-info doc engine)
+ ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as
+ ;; document meta-information (or "docinfo"). This function makes sure that
+ ;; both are only produced once, and only if the relevant customs ask for
+ ;; them.
+ (if (and doc (engine-custom engine 'make-pdf-outline?)
+ (not (markup-option doc '&pdf-outline-produced?)))
+ (begin
+ (display
+ (lout-embedded-postscript-code (lout-pdf-outline doc engine)))
+ (markup-option-add! doc '&pdf-outline-produced? #t)))
+ (if (and doc (engine-custom engine 'make-pdf-docinfo?)
+ (not (markup-option doc '&pdf-docinfo-produced?)))
+ (begin
+ (display
+ (lout-embedded-postscript-code (lout-pdf-docinfo doc engine)))
+ (markup-option-add! doc '&pdf-docinfo-produced? #t))))
+
+
+
+;*---------------------------------------------------------------------*/
+;* lout ... */
+;*---------------------------------------------------------------------*/
+(define-markup (!lout fmt #!rest opt)
+ (if (engine-format? "lout")
+ (apply ! fmt opt)
+ #f))
+
+;*---------------------------------------------------------------------*/
+;* lout-width ... */
+;*---------------------------------------------------------------------*/
+(define (lout-width width)
+ (cond ((inexact? width) ;; a relative size (XXX: was `flonum?')
+ ;; FIXME: Hack ahead: assuming A4 with a 2.5cm margin
+ ;; on both sides
+ (let* ((orientation (let ((lout (find-engine 'lout)))
+ (or (and lout
+ (engine-custom lout
+ 'page-orientation))
+ 'portrait)))
+ (margins 5)
+ (paper-width (case orientation
+ ((portrait reverse-portrait)
+ (- 21 margins))
+ (else (- 29.7 margins)))))
+ (string-append (number->string (* paper-width
+ (/ (abs width) 100.)))
+ "c")))
+ ((string? width) ;; an engine-dependent width
+ width)
+ (else ;; an absolute "pixel" size
+ (string-append (number->string width) "p"))))
+
+;*---------------------------------------------------------------------*/
+;* lout-font-size ... */
+;*---------------------------------------------------------------------*/
+(define (lout-font-size size)
+ (case size
+ ((4) "3.5f")
+ ((3) "2.0f")
+ ((2) "1.5f")
+ ((1) "1.2f")
+ ((0) "1.0f")
+ ((-1) "0.8f")
+ ((-2) "0.5f")
+ ((-3) "0.3f")
+ ((-4) "0.2f")
+ (else (if (number? size)
+ (if (< size 0) "0.3f" "1.5f")
+ "1.0f"))))
+
+(define-public (lout-color-specification skribe-color)
+ ;; Return a Lout color name, ie. a string which is either an English color
+ ;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string
+ ;; representing a Skribe color such as "black" or "#ffffff".
+ (let ((b&w? (let ((lout (find-engine 'lout)))
+ (and lout (not (engine-custom lout 'color?)))))
+ (actual-color
+ (if (and (string? skribe-color)
+ (char=? (string-ref skribe-color 0) #\#))
+ (string->number (substring skribe-color 1
+ (string-length skribe-color))
+ 16)
+ skribe-color)))
+ (receive (r g b)
+ (skribe-color->rgb actual-color)
+ (apply format #f
+ (cons "rgb ~a ~a ~a"
+ (map (if b&w?
+ (let ((avg (exact->inexact (/ (+ r g b)
+ (* 256 3)))))
+ (lambda (x) avg))
+ (lambda (x)
+ (exact->inexact (/ x 256))))
+ (list r g b)))))))
+
+;*---------------------------------------------------------------------*/
+;* ~ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '~ :before "~" :action #f)
+
+(define (lout-page-orientation orientation)
+ ;; Return a string representing the Lout page orientation name for symbol
+ ;; `orientation'.
+ (let* ((alist '((portrait . "Portrait")
+ (landscape . "Landscape")
+ (reverse-portrait . "ReversePortrait")
+ (reverse-landscape . "ReverseLandscape")))
+ (which (assoc orientation alist)))
+ (if (not which)
+ (skribe-error 'lout
+ "`page-orientation' should be either `portrait' or `landscape'"
+ orientation)
+ (cdr which))))
+
+
+;*---------------------------------------------------------------------*/
+;* document ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'document
+ :options '(:title :author :ending :keywords :env)
+ :before (lambda (n e) ;; `e' is the engine
+ (let* ((doc-type (let ((d (engine-custom e 'document-type)))
+ (if (string? d)
+ (begin
+ (engine-custom-set! e 'document-type
+ (string->symbol d))
+ (string->symbol d))
+ d)))
+ (doc-style? (eq? doc-type 'doc))
+ (slides? (eq? doc-type 'slides))
+ (doc-include (engine-custom e 'document-include))
+ (includes (engine-custom e 'includes))
+ (font (engine-custom e 'initial-font))
+ (lang (engine-custom e 'initial-language))
+ (break (engine-custom e 'initial-break))
+ (column-number (engine-custom e 'column-number))
+ (first-page-number (engine-custom e 'first-page-number))
+ (page-orientation (engine-custom e 'page-orientation))
+ (title (markup-option n :title)))
+
+ ;; Add this markup option, used by
+ ;; `lout-start-large-scale-structure' et al.
+ (markup-option-add! n '&substructs-started? #f)
+
+ (if (eq? doc-include 'auto)
+ (case doc-type
+ ((report) (display "@SysInclude { report }\n"))
+ ((book) (display "@SysInclude { book }\n"))
+ ((doc) (display "@SysInclude { doc }\n"))
+ ((slides) (display "@SysInclude { slides }\n"))
+ (else (skribe-error
+ 'lout
+ "`document-type' should be one of `book', `report', `doc' or `slides'"
+ doc-type)))
+ (printf "# Custom document includes\n~a\n" doc-include))
+
+ (if includes
+ (printf "# Additional user includes\n~a\n" includes)
+ (display "@SysInclude { tbl }\n"))
+
+ ;; Write additional Lout definitions
+ (display (lout-definitions e))
+
+ (case doc-type
+ ((report) (display "@Report\n"))
+ ((book) (display "@Book\n"))
+ ((doc) (display "@Document\n"))
+ ((slides) (display "@OverheadTransparencies\n")))
+
+ (display (string-append " @InitialSpace { tex } "
+ "# avoid having too many spaces\n"))
+
+ ;; The `doc' style doesn't have @Title, @Author and the likes
+ (if (not doc-style?)
+ (begin
+ (display " @Title { ")
+ (if title
+ (output title e)
+ (display "The Lout-Skribe Book"))
+ (display " }\n")
+
+ ;; The author
+ (let* ((author (markup-option n :author)))
+
+ (display " @Author { ")
+ (output author e)
+ (display " }\n")
+
+ ;; Lout reports support `@Institution' while books
+ ;; don't.
+ (if (and (eq? doc-type 'report)
+ (is-markup? author 'author))
+ (let ((institution (markup-option author
+ :affiliation)))
+ (if institution
+ (begin
+ (printf " @Institution { ")
+ (output institution e)
+ (printf " }\n"))))))))
+
+ ;; Lout reports make it possible to choose whether to prepend
+ ;; a cover sheet (books and docs don't). Same for a date
+ ;; line.
+ (if (eq? doc-type 'report)
+ (let ((cover-sheet? (engine-custom e 'cover-sheet?))
+ (date-line (engine-custom e 'date-line))
+ (abstract (engine-custom e 'abstract))
+ (abstract-title (engine-custom e 'abstract-title)))
+ (display (string-append " @CoverSheet { "
+ (if cover-sheet?
+ "Yes" "No")
+ " }\n"))
+ (display " @DateLine { ")
+ (if (string? date-line)
+ (output date-line e)
+ (display (if date-line "Yes" "No")))
+ (display " }\n")
+
+ (if abstract
+ (begin
+ (if (not (eq? abstract-title #t))
+ (begin
+ (display " @AbstractTitle { ")
+ (cond
+ ((not abstract-title) #t)
+ (else (output abstract-title e)))
+ (display " }\n")))
+
+ (display " @Abstract {\n")
+ (output abstract e)
+ (display "\n}\n")))))
+
+ (printf " @OptimizePages { ~a }\n"
+ (if (engine-custom e 'optimize-pages?)
+ "Yes" "No"))
+
+ (printf " @InitialFont { ~a }\n"
+ (cond ((string? font) font)
+ ((symbol? font)
+ (string-append (symbol->string font)
+ " Base 10p"))
+ ((number? font)
+ (string-append "Palatino Base "
+ (number->string font)
+ "p"))
+ (#t
+ (skribe-error
+ 'lout 'initial-font
+ "Should be a Lout font name, a symbol, or a number"))))
+ (printf " @InitialBreak { ~a }\n"
+ (if break break "adjust 1.2fx hyphen"))
+ (if (not slides?)
+ (printf " @ColumnNumber { ~a }\n"
+ (if (number? column-number)
+ column-number 1)))
+ (printf " @FirstPageNumber { ~a }\n"
+ (if (number? first-page-number)
+ first-page-number 1))
+ (printf " @PageOrientation { ~a }\n"
+ (lout-page-orientation page-orientation))
+ (printf " @InitialLanguage { ~a }\n"
+ (if lang lang "English"))
+
+ ;; FIXME: Insert a preface for text preceding the first ch.
+ ;; FIXME: Create an @Introduction for the first chapter
+ ;; if its title is "Introduction" (for books).
+
+ (display "//\n\n")
+
+ (if doc-style?
+ ;; `doc' documents don't have @Title and the likes so
+ ;; we need to implement them "by hand"
+ (let ((make-cover-sheet
+ (engine-custom e 'doc-cover-sheet-proc)))
+ (display "@Text @Begin\n")
+ (if make-cover-sheet
+ (make-cover-sheet n e)
+ (lout-make-doc-cover-sheet n e))))
+
+ (if doc-style?
+ ;; Putting it here will only work with `doc' documents.
+ (lout-output-pdf-meta-info n e))))
+
+ :after (lambda (n e)
+ (let ((doc-type (engine-custom e 'document-type)))
+ (if (eq? doc-type 'doc)
+ (begin
+ (if (markup-option n '&substructs-started?)
+ (display "\n@EndSections\n"))
+ (display "\n@End @Text\n")))
+ (display "\n\n# Lout document ends here.\n"))))
+
+
+;*---------------------------------------------------------------------*/
+;* author ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'author
+ :options '(:name :title :affiliation :email :url :address
+ :phone :photo :align)
+
+ :action (lambda (n e)
+ (let ((doc-type (engine-custom e 'document-type))
+ (name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (photo (markup-option n :photo)))
+
+ (define (row x)
+ (display "\n//1.5fx\n@Center { ")
+ (output x e)
+ (display " }\n"))
+
+ (if email
+ (row (list (if name name "")
+ (! " <@I{")
+ (cond ((string? email) email)
+ ((markup? email)
+ (markup-body email))
+ (#t ""))
+ (! "}> ")))
+ (if name (row name)))
+
+ (if title (row title))
+
+ ;; In reports, the affiliation is passed to `@Institution'.
+ ;; However, books do not have an `@Institution' parameter.
+ (if (and affiliation (not (eq? doc-type 'report)))
+ (row affiliation))
+
+ (if address (row address))
+ (if phone (row phone))
+ (if url (row (it url)))
+ (if photo (row photo)))))
+
+
+(define (lout-toc-entry node depth engine)
+ ;; Produce a TOC entry of depth `depth' (a integer greater than or equal to
+ ;; zero) for `node' using engine `engine'. The Lout code here is mostly
+ ;; copied from Lout's `dsf' (see definition of `@Item').
+ (let ((ident (markup-ident node))
+ (entry-proc (engine-custom engine 'toc-entry-proc)))
+ (if (markup-option node :toc)
+ (begin
+ (display "@LP\n")
+ (if ident
+ ;; create an internal for PDF navigation
+ (printf "{ ~a } @LinkSource { " (lout-tagify ident)))
+
+ (if (> depth 0)
+ (printf "|~as " (number->string (* 6 depth))))
+ (display " @HExpand { ")
+
+ ;; output the number and title of this node
+ (entry-proc node engine)
+
+ (display " &1rt @OneCol { ")
+ (printf " @SkribiloLeaders & @PageOf { ~a }"
+ (lout-tagify (markup-ident node)))
+ (display " &0io } }")
+
+ (if ident (display " }"))
+ (display "\n")))))
+
+;*---------------------------------------------------------------------*/
+;* toc ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'toc
+ :options '(:class :chapter :section :subsection)
+ :action (lambda (n e)
+ (display "\n# toc\n")
+ (if (markup-option n :chapter)
+ (let ((chapters (filter (lambda (n)
+ (or (is-markup? n 'chapter)
+ (is-markup? n 'slide)))
+ (markup-body (ast-document n)))))
+ (for-each (lambda (c)
+ (let ((sections
+ (search-down (lambda (n)
+ (is-markup? n 'section))
+ c)))
+ (lout-toc-entry c 0 e)
+ (if (markup-option n :section)
+ (for-each
+ (lambda (s)
+ (lout-toc-entry s 1 e)
+ (if (markup-option n :subsection)
+ (let ((subs
+ (search-down
+ (lambda (n)
+ (is-markup?
+ n 'subsection))
+ s)))
+ (for-each
+ (lambda (s)
+ (lout-toc-entry s 2 e))
+ subs))))
+ sections))))
+ chapters)))))
+
+(define lout-book-markup-alist
+ '((chapter . "Chapter")
+ (section . "Section")
+ (subsection . "SubSection")
+ (subsubsection . "SubSubSection")))
+
+(define lout-report-markup-alist
+ '((chapter . "Section")
+ (section . "SubSection")
+ (subsection . "SubSubSection")
+ (subsubsection . #f)))
+
+(define lout-slides-markup-alist
+ '((slide . "Overhead")))
+
+(define lout-doc-markup-alist lout-report-markup-alist)
+
+(define (lout-structure-markup skribe-markup engine)
+ ;; Return the Lout structure name for `skribe-markup' (eg. "Chapter" for
+ ;; `chapter' markups when `engine''s document type is `book').
+ (let ((doc-type (engine-custom engine 'document-type))
+ (assoc-ref (lambda (alist key)
+ (and-let* ((as (assoc key alist))) (cdr as)))))
+ (case doc-type
+ ((book) (assoc-ref lout-book-markup-alist skribe-markup))
+ ((report) (assoc-ref lout-report-markup-alist skribe-markup))
+ ((doc) (assoc-ref lout-doc-markup-alist skribe-markup))
+ ((slides) (assoc-ref lout-slides-markup-alist skribe-markup))
+ (else
+ (skribe-error 'lout
+ "`document-type' should be one of `book', `report', `doc' or `slides'"
+ doc-type)))))
+
+(define-public (lout-structure-number-string markup)
+ ;; Return a structure number string such as "1.2".
+ ;; FIXME: External code has started to rely on this. This should be
+ ;; generalized and moved elsewhere.
+ (let loop ((struct markup))
+ (if (document? struct)
+ ""
+ (let ((parent-num (loop (ast-parent struct)))
+ (num (markup-option struct :number)))
+ (string-append parent-num
+ (if (string=? "" parent-num) "" ".")
+ (if (number? num) (number->string num) ""))))))
+
+;*---------------------------------------------------------------------*/
+;* lout-block-before ... */
+;*---------------------------------------------------------------------*/
+(define (lout-block-before n e)
+ ;; Produce the Lout code that introduces node `n', a large-scale
+ ;; structure (chapter, section, etc.).
+ (let ((lout-markup (lout-structure-markup (markup-markup n) e))
+ (title (markup-option n :title))
+ (number (markup-option n :number))
+ (ident (markup-ident n)))
+
+ (if (not lout-markup)
+ (begin
+ ;; the fallback method (i.e. when there exists no equivalent
+ ;; Lout markup)
+ (display "\n//1.8vx\n@B { ")
+ (output title e)
+ (display " }\n@SkribeMark { ")
+ (display (lout-tagify ident))
+ (display " }\n//0.8vx\n\n"))
+ (begin
+ (printf "\n@~a\n @Title { " lout-markup)
+ (output title e)
+ (printf " }\n")
+
+ (if (number? number)
+ (printf " @BypassNumber { ~a }\n"
+ (lout-structure-number-string n))
+ (if (not number)
+ ;; this trick hides the section number
+ (printf " @BypassNumber { } # unnumbered\n")))
+
+ (cond ((string? ident)
+ (begin
+ (display " @Tag { ")
+ (display (lout-tagify ident))
+ (display " }\n")))
+ ((symbol? ident)
+ (begin
+ (display " @Tag { ")
+ (display (lout-tagify (symbol->string ident)))
+ (display " }\n")))
+ (#t
+ (skribe-error 'lout
+ "Node identifiers should be strings"
+ ident)))
+
+ (display "\n@Begin\n")))))
+
+(define (lout-block-after n e)
+ ;; Produce the Lout code that terminates node `n', a large-scale
+ ;; structure (chapter, section, etc.).
+ (let ((lout-markup (lout-structure-markup (markup-markup n) e)))
+ (if (not lout-markup)
+ (printf "\n\n//0.3vx\n\n") ;; fallback method
+ (printf "\n\n@End @~a\n\n" lout-markup))))
+
+
+(define (lout-markup-child-type skribe-markup)
+ ;; Return the child markup type of `skribe-markup' (e.g. for `chapter',
+ ;; return `section').
+ (let loop ((structs '(document chapter section subsection subsubsection)))
+ (if (null? structs)
+ #f
+ (if (eq? (car structs) skribe-markup)
+ (cadr structs)
+ (loop (cdr structs))))))
+
+(define (lout-start-large-scale-structure markup engine)
+ ;; Perform the necessary step and produce output as a result of starting
+ ;; large-scale structure `markup' (ie. a chapter, section, subsection,
+ ;; etc.).
+ (let* ((doc-type (engine-custom engine 'document-type))
+ (doc-style? (eq? doc-type 'doc))
+ (parent (ast-parent markup))
+ (markup-type (markup-markup markup))
+ (lout-markup-name (lout-structure-markup markup-type
+ engine)))
+ (lout-debug "start-struct: markup=~a parent=~a"
+ markup parent)
+
+ ;; add an `&substructs-started?' option to the markup
+ (markup-option-add! markup '&substructs-started? #f)
+
+ (if (and lout-markup-name
+ parent (or doc-style? (not (document? parent))))
+ (begin
+ (if (not (markup-option parent '&substructs-started?))
+ ;; produce an `@BeginSubSections' or equivalent; `doc'-style
+ ;; documents need to preprend an `@BeginSections' before the
+ ;; first section while other styles don't.
+ (printf "\n@Begin~as\n" lout-markup-name))
+
+ ;; FIXME: We need to make sure that PARENT is a large-scale
+ ;; structure, otherwise it won't have the `&substructs-started?'
+ ;; option (e.g., if PARENT is a `color' markup). I need to clarify
+ ;; this.
+ (if (memq (markup-markup parent)
+ '(document chapter section subsection subsubsection))
+ ;; update the `&substructs-started?' option of the parent
+ (markup-option-set! parent '&substructs-started? #t))
+
+ (lout-debug "start-struct: updated parent: ~a"
+ (markup-option parent '&substructs-started?))))
+
+ ;; output the `@Section @Title { ... } @Begin' thing
+ (lout-block-before markup engine)))
+
+(define (lout-end-large-scale-structure markup engine)
+ ;; Produce Lout code for ending structure `markup' (a chapter, section,
+ ;; subsection, etc.).
+ (let* ((doc-type (engine-custom engine 'document-type))
+ (doc-style? (eq? doc-type 'doc))
+ (markup-type (markup-markup markup))
+ (lout-markup-name (lout-structure-markup markup-type
+ engine)))
+
+ (if (and lout-markup-name
+ (markup-option markup '&substructs-started?)
+ (or doc-style? (not (document? markup))))
+ (begin
+ ;; produce an `@EndSubSections' or equivalent; `doc'-style
+ ;; documents need to issue an `@EndSections' after the last section
+ ;; while other types of documents don't.
+ (lout-debug "end-struct: closing substructs for ~a" markup)
+ (printf "\n@End~as\n"
+ (lout-structure-markup (lout-markup-child-type markup-type)
+ engine))
+ (markup-option-set! markup '&substructs-started? #f)))
+
+ (lout-block-after markup engine)))
+
+
+;*---------------------------------------------------------------------*/
+;* section ... .. @label chapter@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'chapter
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (document? (ast-parent n)))
+
+ :before (lambda (n e)
+ (lout-start-large-scale-structure n e)
+
+ ;; `doc' documents produce their PDF outline right after
+ ;; `@Text @Begin'; other types of documents must produce it
+ ;; as part of their first chapter.
+ (lout-output-pdf-meta-info (ast-document n) e))
+
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* section ... . @label section@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'section
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'chapter))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* subsection ... @label subsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsection
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'section))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+;*---------------------------------------------------------------------*/
+;* subsubsection ... @label subsubsection@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'subsubsection
+ :options '(:title :number :toc :file :env)
+ :validate (lambda (n e)
+ (is-markup? (ast-parent n) 'subsection))
+ :before lout-start-large-scale-structure
+ :after lout-end-large-scale-structure)
+
+
+;*---------------------------------------------------------------------*/
+;* paragraph ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'paragraph
+ :options '()
+ :validate (lambda (n e)
+ (or (eq? 'doc (engine-custom e 'document-type))
+ (memq (and (markup? (ast-parent n))
+ (markup-markup (ast-parent n)))
+ '(chapter section subsection subsubsection slide))))
+ :before (lambda (n e)
+ (let ((gap (engine-custom e 'paragraph-gap)))
+ (display (if (string? gap) gap "\n@PP\n")))))
+
+;*---------------------------------------------------------------------*/
+;* footnote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'footnote
+ :options '(:label)
+ :before (lambda (n e)
+ (let ((label (markup-option n :label))
+ (use-number?
+ (engine-custom e 'use-skribe-footnote-numbers?)))
+ (if (or (and (number? label) use-number?) label)
+ (printf "{ @FootNote @Label { ~a } { "
+ (if label label ""))
+ (printf "{ @FootNote ~a{ "
+ (if (not number) "@Label { } " "")))))
+ :after (lambda (n e)
+ (display " } }")))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'linebreak
+ :action (lambda (n e)
+ (display "\n@LP\n")))
+
+;*---------------------------------------------------------------------*/
+;* hrule ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'hrule
+ :options '()
+ :action "\n@LP\n@FullWidthRule\n@LP\n")
+
+;*---------------------------------------------------------------------*/
+;* color ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'color
+ :options '(:fg :bg :width)
+ ;; FIXME: `:bg' not supported
+ ;; FIXME: `:width' is not supported either. Rather use `frame' for that
+ ;; kind of options.
+ :before (lambda (n e)
+ (let* ((w (markup-option n :width))
+ (fg (markup-option n :fg)))
+ (printf "{ ~a } @Color { " (lout-color-specification fg))))
+
+ :after (lambda (n e)
+ (display " }")))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'frame
+ ;; @Box won't span over several pages so this may cause
+ ;; problems if large frames are used. The workaround here consists
+ ;; in using an @Tbl with one single cell.
+ :options '(:width :border :margin :bg)
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (margin (markup-option n :margin))
+ (border (markup-option n :border))
+ (bg (markup-option n :bg)))
+
+ ;; The user manual seems to expect `frame' to imply a
+ ;; linebreak. However, the LaTeX engine doesn't seem to
+ ;; agree.
+ ;(display "\n@LP")
+ (printf (string-append "\n@Tbl # frame\n"
+ " rule { yes }\n"))
+ (if border (printf " rulewidth { ~a }\n"
+ (lout-width border)))
+ (if width (printf " width { ~a }\n"
+ (lout-width width)))
+ (if margin (printf " margin { ~a }\n"
+ (lout-width margin)))
+ (if bg (printf " paint { ~a }\n"
+ (lout-color-specification bg)))
+ (display "{ @Row format { @Cell A } A { "))
+
+; (printf "\n@Box linewidth { ~a } margin { ~a } { "
+; (lout-width (markup-option n :width))
+; (lout-width (markup-option n :margin)))
+ )
+ :after (lambda (n e)
+ (display " } }\n")))
+
+;*---------------------------------------------------------------------*/
+;* font ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'font
+ :options '(:size :face)
+ :before (lambda (n e)
+ (let ((face (markup-option n :face))
+ (size (lout-font-size (markup-option n :size))))
+ (printf "\n~a @Font { " size)))
+ :after (lambda (n e)
+ (display " }\n")))
+
+;*---------------------------------------------------------------------*/
+;* flush ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'flush
+ :options '(:side)
+ :before (lambda (n e)
+ (display "\n@LP")
+ (case (markup-option n :side)
+ ((center)
+ (display "\n@Center { # flush-center\n"))
+ ((left)
+ (display "\n# flush-left\n"))
+ ((right)
+ (display (string-append "\n@Right "
+ "{ rragged hyphen } @Break "
+ "{ # flush-right\n")))))
+ :after (lambda (n e)
+ (case (markup-option n :side)
+ ((left)
+ (display ""))
+ (else
+ (display "\n}")))
+ (display " # flush\n")))
+
+;*---------------------------------------------------------------------*/
+;* center ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'center
+ ;; Note: We prepend and append a newline in order to make sure
+ ;; things work as expected.
+ :before "\n@LP\n@Center {"
+ :after "}\n@LP\n")
+
+;*---------------------------------------------------------------------*/
+;* pre ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'pre
+ :before "\n@LP lines @Break lout @Space { # pre\n"
+ :after "\n} # pre\n")
+
+;*---------------------------------------------------------------------*/
+;* prog ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'prog
+ :options '(:line :mark)
+ :before "\nlines @Break lout @Space {\n"
+ :after "\n} # @Break\n")
+
+;*---------------------------------------------------------------------*/
+;* &prog-line ... */
+;*---------------------------------------------------------------------*/
+;; Program lines appear within a `lines @Break' block.
+(markup-writer '&prog-line
+ :before (lambda (n e)
+ (let ((n (markup-ident n)))
+ (if n (skribe-eval (it (list n) ": ") e))))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* itemize ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'itemize
+ :options '(:symbol)
+ :before (lambda (n e)
+ (let ((symbol (markup-option n :symbol)))
+ (if symbol
+ (begin
+ (display "\n@List style { ")
+ (output symbol e)
+ (display " } # itemize\n"))
+ (display "\n@BulletList # itemize\n"))))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* enumerate ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'enumerate
+ :options '(:symbol)
+ :before (lambda (n e)
+ (let ((symbol (markup-option n :symbol)))
+ (if symbol
+ (printf "\n@List style { ~a } # enumerate\n"
+ symbol)
+ (display "\n@NumberedList # enumerate\n"))))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* description ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'description
+ :options '(:symbol) ;; `symbol' doesn't make sense here
+ :before "\n@TaggedList # description\n"
+ :action (lambda (n e)
+ (for-each (lambda (item)
+ (let ((k (markup-option item :key)))
+ (display "@DropTagItem { ")
+ (for-each (lambda (i)
+ (output i e)
+ (display " "))
+ (if (pair? k) k (list k)))
+ (display " } { ")
+ (output (markup-body item) e)
+ (display " }\n")))
+ (markup-body n)))
+ :after "\n@EndList\n")
+
+;*---------------------------------------------------------------------*/
+;* item ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'item
+ :options '(:key)
+ :before "\n@LI { "
+ :after " }")
+
+;*---------------------------------------------------------------------*/
+;* blockquote ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'blockquote
+ :before "\n@ID {"
+ :after "\n} # @ID\n")
+
+;*---------------------------------------------------------------------*/
+;* figure ... @label figure@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'figure
+ :options '(:legend :number :multicolumns)
+ :action (lambda (n e)
+ (let ((ident (markup-ident n))
+ (number (markup-option n :number))
+ (legend (markup-option n :legend))
+ (mc? (markup-option n :multicolumns)))
+ (display "\n@Figure\n")
+ (display " @Tag { ")
+ (display (lout-tagify ident))
+ (display " }\n")
+ (printf " @BypassNumber { ~a }\n"
+ (cond ((number? number) number)
+ ((not number) "")
+ (else number)))
+ (display " @InitialLanguage { ")
+ (display (engine-custom e 'initial-language))
+ (display " }\n")
+
+ (if legend
+ (begin
+ (lout-debug "figure: ~a, \"~a\"" ident legend)
+ (printf " @Caption { ")
+ (output legend e)
+ (printf " }\n")))
+ (printf " @Location { ~a }\n"
+ (if mc? "PageTop" "ColTop"))
+ (printf "{\n")
+ (output (markup-body n) e)))
+ :after (lambda (n e)
+ (display "}\n")))
+
+
+;*---------------------------------------------------------------------*/
+;* lout-table-column-number ... */
+;* ------------------------------------------------------------- */
+;* This function computes how columns are contained by the table. */
+;*---------------------------------------------------------------------*/
+(define (lout-table-column-number t)
+ (define (row-columns row)
+ (let loop ((cells (markup-body row))
+ (nbcols 0))
+ (if (null? cells)
+ nbcols
+ (loop (cdr cells)
+ (+ nbcols (markup-option (car cells) :colspan))))))
+ (let loop ((rows (markup-body t))
+ (nbcols 0))
+ (if (null? rows)
+ nbcols
+ (loop (cdr rows)
+ (max (row-columns (car rows)) nbcols)))))
+
+(define (lout-table-cell-indent align)
+ ;; Return the Lout name (a string) for cell alignment `align' (a symbol).
+ (case align
+ ((center #f #t) "ctr")
+ ((right) "right")
+ ((left) "left")
+ (else (skribe-error 'td align
+ "Unknown alignment type"))))
+
+(define (lout-table-cell-vindent align)
+ ;; Return the Lout name (a string) for cell alignment `align' (a symbol).
+ (case align
+ ((center #f #t) "ctr")
+ ((top) "top")
+ ((bottom) "foot")
+ (else (skribe-error 'td align
+ "Unknown alignment type"))))
+
+(define (lout-table-cell-vspan cell-letter row-vspan)
+ ;; Return the vspan information (an alist) for the cell whose
+ ;; letter is `cell-letter', within the row whose vspan information
+ ;; is given by `row-vspan'. If the given cell doesn't span over
+ ;; rows, then #f is returned.
+ (and-let* ((as (assoc cell-letter row-vspan)))
+ (cdr as)))
+
+(define (lout-table-cell-vspan-start? vspan-alist)
+ ;; For the cell whose vspan information is given by `vspan-alist',
+ ;; return #t if that cell starts spanning vertically.
+ (and vspan-alist
+ (cdr (assoc 'start? vspan-alist))))
+
+(define-macro (char+int c i)
+ `(integer->char (+ ,i (char->integer ,c))))
+
+(define-macro (-- i)
+ `(- ,i 1))
+
+
+(define (lout-table-cell-option-string cell)
+ ;; Return the Lout cell option string for `cell'.
+ (let ((align (markup-option cell :align))
+ (valign (markup-option cell :valign))
+ (width (markup-option cell :width))
+ (bg (markup-option cell :bg)))
+ (string-append (lout-table-cell-rules cell) " "
+ (string-append
+ "indent { "
+ (lout-table-cell-indent align)
+ " } ")
+ (string-append
+ "indentvertical { "
+ (lout-table-cell-vindent valign)
+ " } ")
+ (if (not width) ""
+ (string-append "width { "
+ (lout-width width)
+ " } "))
+ (if (not bg) ""
+ (string-append "paint { "
+ (lout-color-specification bg)
+ " } ")))))
+
+(define (lout-table-cell-format-string cell vspan-alist)
+ ;; Return a Lout cell format string for `cell'. It uses the `&cell-name'
+ ;; markup option of its cell as its Lout cell name and `vspan-alist' as the
+ ;; source of information regarding its vertical spanning (#f means that
+ ;; `cell' is not vertically spanned).
+ (let ((cell-letter (markup-option cell '&cell-name))
+ (cell-options (lout-table-cell-option-string cell))
+ (colspan (if vspan-alist
+ (cdr (assoc 'hspan vspan-alist))
+ (markup-option cell :colspan)))
+ (vspan-start? (and vspan-alist
+ (cdr (assoc 'start? vspan-alist)))))
+ (if (and (not vspan-start?) vspan-alist)
+ "@VSpan"
+ (let* ((cell-fmt (string-append "@Cell " cell-options
+ (string cell-letter))))
+ (string-append
+ (if (> colspan 1)
+ (string-append (if (and vspan-start? vspan-alist)
+ "@StartHVSpan " "@StartHSpan ")
+ cell-fmt
+ (let pool ((cnt (- colspan 1))
+ (span-cells ""))
+ (if (= cnt 0)
+ span-cells
+ (pool (- cnt 1)
+ (string-append span-cells
+ " | @HSpan")))))
+ (string-append (if (and vspan-alist vspan-start?)
+ "@StartVSpan " "")
+ cell-fmt)))))))
+
+
+(define (lout-table-row-format-string row)
+ ;; Return a Lout row format string for row `row'. It uses the `&cell-name'
+ ;; markup option of its cell as its Lout cell name.
+
+ ;; FIXME: This function has become quite ugly
+ (let ((cells (markup-body row))
+ (row-vspan (markup-option row '&vspan-alist)))
+
+ (let loop ((cells cells)
+ (cell-letter #\A)
+ (delim "")
+ (fmt ""))
+ (lout-debug "looping on cell ~a" cell-letter)
+
+ (if (null? cells)
+
+ ;; The final `|' prevents the rightmost column to be
+ ;; expanded to full page width (see sect. 6.11, p. 133).
+ (if row-vspan
+ ;; In the end, there can be vspan columns left so we need to
+ ;; mark them
+ (let final-loop ((cell-letter cell-letter)
+ (fmt fmt))
+ (let* ((cell-vspan (lout-table-cell-vspan cell-letter
+ row-vspan))
+ (hspan (if cell-vspan
+ (cdr (assoc 'hspan cell-vspan))
+ 1)))
+ (lout-debug "final-loop: ~a ~a" cell-letter cell-vspan)
+ (if (not cell-vspan)
+ (string-append fmt " |")
+ (final-loop (integer->char
+ (+ hspan (char->integer cell-letter)))
+ (string-append fmt " | @VSpan |")))))
+
+ (string-append fmt " |"))
+
+ (let* ((cell (car cells))
+ (vspan-alist (lout-table-cell-vspan cell-letter row-vspan))
+ (vspan-start? (lout-table-cell-vspan-start? vspan-alist))
+ (colspan (if vspan-alist
+ (cdr (assoc 'hspan vspan-alist))
+ (markup-option cell :colspan)))
+ (cell-format
+ (lout-table-cell-format-string cell vspan-alist)))
+
+ (loop (if (or (not vspan-alist) vspan-start?)
+ (cdr cells)
+ cells) ;; don't skip pure vspan cells
+
+ ;; next cell name
+ (char+int cell-letter colspan)
+
+ " | " ;; the cell delimiter
+ (string-append fmt delim cell-format)))))))
+
+
+
+;; A row vspan alist describes the cells of a row that span vertically
+;; and it looks like this:
+;;
+;; ((#\A . ((start? . #t) (hspan . 1) (vspan . 3)))
+;; (#\C . ((start? . #f) (hspan . 2) (vspan . 1))))
+;;
+;; which means that cell `A' start spanning vertically over three rows
+;; including this one, while cell `C' is an "empty" cell that continues
+;; the vertical spanning of a cell appearing on some previous row.
+;;
+;; The running "global" (or "table-wide") vspan alist looks the same
+;; except that it doesn't have the `start?' tags.
+
+(define (lout-table-compute-row-vspan-alist row global-vspan-alist)
+ ;; Compute the vspan alist of row `row' based on the current table vspan
+ ;; alist `global-vspan-alist'. As a side effect, this function stores the
+ ;; Lout cell name (a character between #\A and #\Z) as the value of markup
+ ;; option `&cell-name' of each cell.
+ (if (pair? (markup-body row))
+ ;; Mark the first cell as such.
+ (markup-option-add! (car (markup-body row)) '&first-cell? #t))
+
+ (let cell-loop ((cells (markup-body row))
+ (cell-letter #\A)
+ (row-vspan-alist '()))
+ (lout-debug "cell: ~a ~a" cell-letter
+ (if (null? cells) '() (car cells)))
+
+ (if (null? cells)
+
+ ;; In the end, we must retain any vspan cell that occurs after the
+ ;; current cell name (note: we must add a `start?' tag at this point
+ ;; since the global table vspan alist doesn't have that).
+ (let ((additional-cells (filter (lambda (c)
+ (char>=? (car c) cell-letter))
+ global-vspan-alist)))
+ (lout-debug "compute-row-vspan-alist returning: ~a + ~a (~a)"
+ row-vspan-alist additional-cells
+ (length global-vspan-alist))
+ (append row-vspan-alist
+ (map (lambda (c)
+ `(,(car c) . ,(cons '(start? . #f) (cdr c))))
+ additional-cells)))
+
+ (let* ((current-cell-vspan (assoc cell-letter global-vspan-alist))
+ (hspan (if current-cell-vspan
+ (cdr (assoc 'hspan (cdr current-cell-vspan)))
+ (markup-option (car cells) :colspan))))
+
+ (if (null? (cdr cells))
+ ;; Mark the last cell as such
+ (markup-option-add! (car cells) '&last-cell? #t))
+
+ (cell-loop (if current-cell-vspan
+ cells ;; this cell is vspanned, so don't skip it
+ (cdr cells))
+
+ ;; next cell name
+ (char+int cell-letter (or hspan 1))
+
+ (begin ;; updating the row vspan alist
+ (lout-debug "cells: ~a" (length cells))
+ (lout-debug "current-cell-vspan for ~a: ~a"
+ cell-letter current-cell-vspan)
+
+ (if current-cell-vspan
+
+ ;; this cell is currently vspanned, ie. a previous
+ ;; row defined a vspan for it and that it is still
+ ;; spanning on this row
+ (cons `(,cell-letter
+ . ((start? . #f)
+ (hspan . ,(cdr
+ (assoc
+ 'hspan
+ (cdr current-cell-vspan))))))
+ row-vspan-alist)
+
+ ;; this cell is not currently vspanned
+ (let ((vspan (markup-option (car cells) :rowspan)))
+ (lout-debug "vspan-option for ~a: ~a"
+ cell-letter vspan)
+
+ (markup-option-add! (car cells)
+ '&cell-name cell-letter)
+ (if (and vspan (> vspan 1))
+ (cons `(,cell-letter . ((start? . #t)
+ (hspan . ,hspan)
+ (vspan . ,vspan)))
+ row-vspan-alist)
+ row-vspan-alist)))))))))
+
+(define (lout-table-update-table-vspan-alist table-vspan-alist
+ row-vspan-alist)
+ ;; Update `table-vspan-alist' based on `row-vspan-alist', the alist
+ ;; representing vspan cells for the last row that has been read."
+ (lout-debug "update-table-vspan: ~a and ~a"
+ table-vspan-alist row-vspan-alist)
+
+ (let ((new-vspan-cells (filter (lambda (cell)
+ (cdr (assoc 'start? (cdr cell))))
+ row-vspan-alist)))
+
+ ;; Append the list of new vspan cells described in `row-vspan-alist'
+ (let loop ((cells (append table-vspan-alist new-vspan-cells))
+ (result '()))
+ (if (null? cells)
+ (begin
+ (lout-debug "update-table-vspan returning: ~a" result)
+ result)
+ (let* ((cell (car cells))
+ (cell-letter (car cell))
+ (cell-hspan (cdr (assoc 'hspan (cdr cell))))
+ (cell-vspan (-- (cdr (assoc 'vspan (cdr cell))))))
+ (loop (cdr cells)
+ (if (> cell-vspan 0)
+
+ ;; Keep information about this vspanned cell
+ (cons `(,cell-letter . ((hspan . ,cell-hspan)
+ (vspan . ,cell-vspan)))
+ result)
+
+ ;; Vspan for this cell has been done so we can remove
+ ;; it from the running table vspan alist
+ result)))))))
+
+(define (lout-table-mark-vspan! tab)
+ ;; Traverse the rows of table `tab' and add them an `&vspan-alist' option
+ ;; that describes which of its cells are to be vertically spanned.
+ (let loop ((rows (markup-body tab))
+ (global-vspan-alist '()))
+ (if (null? rows)
+
+ ;; At this point, each row holds its own vspan information alist (the
+ ;; `&vspan-alist' option) so we don't care anymore about the running
+ ;; table vspan alist
+ #t
+
+ (let* ((row (car rows))
+ (row-vspan-alist (lout-table-compute-row-vspan-alist
+ row global-vspan-alist)))
+
+ ;; Bind the row-specific vspan information to the row object
+ (markup-option-add! row '&vspan-alist row-vspan-alist)
+
+ (if (null? (cdr rows))
+ ;; Mark the last row as such
+ (markup-option-add! row '&last-row? #t))
+
+ (loop (cdr rows)
+ (lout-table-update-table-vspan-alist global-vspan-alist
+ row-vspan-alist))))))
+
+(define (lout-table-first-row? row)
+ (markup-option row '&first-row?))
+
+(define (lout-table-last-row? row)
+ (markup-option row '&last-row?))
+
+(define (lout-table-first-cell? cell)
+ (markup-option cell '&first-cell?))
+
+(define (lout-table-last-cell? cell)
+ (markup-option cell '&last-cell?))
+
+(define (lout-table-row-rules row)
+ ;; Return a string representing the Lout option string for
+ ;; displaying rules of `row'.
+ (let* ((table (ast-parent row))
+ (frames (markup-option table :frame))
+ (rules (markup-option table :rules))
+ (first? (lout-table-first-row? row))
+ (last? (lout-table-last-row? row)))
+ (string-append (if (and first?
+ (member frames '(above hsides box border)))
+ "ruleabove { yes } " "")
+ (if (and last?
+ (member frames '(below hsides box border)))
+ "rulebelow { yes } " "")
+ ;; rules
+ (case rules
+ ((header)
+ ;; We consider the first row to be a header row.
+ (if first? "rulebelow { yes }" ""))
+ ((rows all)
+ ;; We use redundant rules because coloring
+ ;; might make them disappear otherwise.
+ (string-append (if first? "" "ruleabove { yes } ")
+ (if last? "" "rulebelow { yes }")))
+ (else "")))))
+
+(define (lout-table-cell-rules cell)
+ ;; Return a string representing the Lout option string for
+ ;; displaying rules of `cell'.
+ (let* ((row (ast-parent cell))
+ (table (ast-parent row))
+ (frames (markup-option table :frame))
+ (rules (markup-option table :rules))
+ (first? (lout-table-first-cell? cell))
+ (last? (lout-table-last-cell? cell)))
+ (string-append (if (and first?
+ (member frames '(vsides lhs box border)))
+ "ruleleft { yes } " "")
+ (if (and last?
+ (member frames '(vsides rhs box border)))
+ "ruleright { yes } " "")
+ ;; rules
+ (case rules
+ ((cols all)
+ ;; We use redundant rules because coloring
+ ;; might make them disappear otherwise.
+ (string-append (if last? "" "ruleright { yes } ")
+ (if first? "" "ruleleft { yes }")))
+ (else "")))))
+
+;*---------------------------------------------------------------------*/
+;* table ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'table
+ :options '(:frame :rules :border :width :cellpadding)
+ ;; XXX: `:cellstyle' `separate' and `:cellspacing' not supported
+ ;; by Lout's @Tbl.
+ :before (lambda (n e)
+ (let ((width (markup-option n :width))
+ (border (markup-option n :border))
+ (cp (markup-option n :cellpadding))
+ (rows (markup-body n)))
+
+ (define (cell-width row col)
+ (let ((cells (markup-body row))
+ (bg (markup-option row :bg)))
+ (let loop ((cells cells)
+ (c 0))
+ (if (pair? cells)
+ (let* ((ce (car cells))
+ (width (markup-option ce :width))
+ (colspan (markup-option ce :colspan)))
+ (if (= col c)
+ (if (number? width) width 0)
+ (loop (cdr cells) (+ c colspan))))
+ 0))))
+
+ (define (col-width col)
+ (let loop ((rows rows)
+ (width 0))
+ (if (null? rows)
+ (if (= width 0)
+ 0
+ width)
+ (loop (cdr rows)
+ (max width (cell-width (car rows) col))))))
+
+ (if (pair? (markup-body n))
+ ;; Mark the first row as such
+ (markup-option-add! (car (markup-body n))
+ '&first-row? #t))
+
+ ;; Mark each row with vertical spanning information
+ (lout-table-mark-vspan! n)
+
+ (display "\n@Tbl # table\n")
+
+ (if (number? border)
+ (printf " rulewidth { ~a }\n"
+ (lout-width (markup-option n :border))))
+ (if (number? cp)
+ (printf " margin { ~ap }\n"
+ (number->string cp)))
+
+ (display "{\n")))
+
+ :after (lambda (n e)
+ (let ((header-rows (or (markup-option n '&header-rows) 0)))
+ ;; Issue an `@EndHeaderRow' symbol for each `@HeaderRow' symbol
+ ;; previously produced.
+ (let ((cnt header-rows))
+ (if (> cnt 0)
+ (display "\n@EndHeaderRow"))))
+
+ (display "\n} # @Tbl\n")))
+
+;*---------------------------------------------------------------------*/
+;* 'tr ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tr
+ :options '(:bg)
+ :action (lambda (row e)
+ (let* ((bg (markup-option row :bg))
+ (bg-color (if (not bg) ""
+ (string-append
+ "paint { "
+ (lout-color-specification bg) " } ")))
+ (first-row? (markup-option row '&first-row?))
+ (header-row? (any (lambda (n)
+ (eq? (markup-option n 'markup)
+ 'th))
+ (markup-body row)))
+ (fmt (lout-table-row-format-string row))
+ (rules (lout-table-row-rules row)))
+
+ ;; Use `@FirstRow' and `@HeaderFirstRow' for the first
+ ;; row. `@HeaderFirstRow' seems to be buggy though.
+ ;; (see section 6.1, p.119 of the User's Guide).
+
+ (printf "\n@~aRow ~aformat { ~a }"
+ (if first-row? "First" "")
+ bg-color fmt)
+ (display (string-append " " rules))
+ (output (markup-body row) e)
+
+ (if (and header-row? (engine-custom e 'use-header-rows?))
+ ;; `@HeaderRow' symbols are not actually printed
+ ;; (see section 6.11, p. 134 of the User's Guide)
+ ;; FIXME: This all seems buggy on the Lout side.
+ (let* ((tab (ast-parent row))
+ (hrows (and (markup? tab)
+ (or (markup-option tab '&header-rows)
+ 0))))
+ (if (not (is-markup? tab 'table))
+ (skribe-error 'lout
+ "tr's parent not a table!" tab))
+ (markup-option-add! tab '&header-rows (+ hrows 1))
+ (printf "\n@Header~aRow ~aformat { ~a }"
+ "" ; (if first-row? "First" "")
+ bg-color fmt)
+ (display (string-append " " rules))
+
+ ;; the cells must be produced once here
+ (output (markup-body row) e))))))
+
+;*---------------------------------------------------------------------*/
+;* tc */
+;*---------------------------------------------------------------------*/
+(markup-writer 'tc
+ :options '(markup :width :align :valign :colspan :rowspan :bg)
+ :before (lambda (cell e)
+ (printf "\n ~a { " (markup-option cell '&cell-name)))
+ :after (lambda (cell e)
+ (display " }")))
+
+
+;*---------------------------------------------------------------------*/
+;* image ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'image
+ :options '(:file :url :width :height :zoom)
+ :action (lambda (n e)
+ (let* ((file (markup-option n :file))
+ (url (markup-option n :url))
+ (width (markup-option n :width))
+ (height (markup-option n :height))
+ (zoom (markup-option n :zoom))
+ (body (markup-body n))
+ (efmt (engine-custom e 'image-format))
+ (img (or url (convert-image file
+ (if (list? efmt)
+ efmt
+ '("eps"))))))
+ (if url ;; maybe we should run `wget' then? :-)
+ (skribe-error 'lout "Image URLs not supported" url))
+ (if (not (string? img))
+ (skribe-error 'lout "Illegal image" file)
+ (begin
+ (if width
+ (printf "\n~a @Wide" (lout-width width)))
+ (if height
+ (printf "\n~a @High" (lout-width height)))
+ (if zoom
+ (printf "\n~a @Scale" zoom))
+ (printf "\n@IncludeGraphic { \"~a\" }\n" img))))))
+
+;*---------------------------------------------------------------------*/
+;* Ornaments ... */
+;*---------------------------------------------------------------------*/
+;; Each ornament is enclosed in braces to allow such things as
+;; "he,(bold "ll")o" to work without adding an extra space.
+(markup-writer 'roman :before "{ @R { " :after " } }")
+(markup-writer 'underline :before "{ @Underline { " :after " } }")
+(markup-writer 'code :before "{ @F { " :after " } }")
+(markup-writer 'var :before "{ @F { " :after " } }")
+(markup-writer 'sc :before "{ @S {" :after " } }")
+(markup-writer 'sf :before "{ { Helvetica Base } @Font { " :after " } }")
+(markup-writer 'sub :before "{ @Sub { " :after " } }")
+(markup-writer 'sup :before "{ @Sup { " :after " } }")
+(markup-writer 'tt :before "{ @F { " :after " } }")
+
+
+;; `(bold (it ...))' and `(it (bold ...))' should both lead to `@BI { ... }'
+;; instead of `@B { @I { ... } }' (which is different).
+;; Unfortunately, it is not possible to use `ast-parent' and
+;; `find1-up' to check whether `it' (resp. `bold') was invoked within
+;; a `bold' (resp. `it') markup, hence the `&italics' and `&bold'
+;; option trick. FIXME: This would be much more efficient if
+;; `ast-parent' would work as expected.
+
+;; FIXME: See whether `@II' can be useful. Use SRFI-39 parameters.
+
+(markup-writer 'it
+ :before (lambda (node engine)
+ (let ((bold-children (search-down (lambda (n)
+ (is-markup? n 'bold))
+ node)))
+ (map (lambda (b)
+ (markup-option-add! b '&italics #t))
+ bold-children)
+ (printf "{ ~a { "
+ (if (markup-option node '&bold)
+ "@BI" "@I"))))
+ :after " } }")
+
+(markup-writer 'emph
+ :before (lambda (n e)
+ (invoke (writer-before (markup-writer-get 'it e))
+ n e))
+ :after (lambda (n e)
+ (invoke (writer-after (markup-writer-get 'it e))
+ n e)))
+
+(markup-writer 'bold
+ :before (lambda (node engine)
+ (let ((it-children (search-down (lambda (n)
+ (or (is-markup? n 'it)
+ (is-markup? n 'emph)))
+ node)))
+ (map (lambda (i)
+ (markup-option-add! i '&bold #t))
+ it-children)
+ (printf "{ ~a { "
+ (if (markup-option node '&italics)
+ "@BI" "@B"))))
+ :after " } }")
+
+;*---------------------------------------------------------------------*/
+;* q ... @label q@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'q
+ :before "{ @Char guillemotleft }\" \""
+ :after "\" \"{ @Char guillemotright }")
+
+;*---------------------------------------------------------------------*/
+;* mailto ... @label mailto@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mailto
+ :options '(:text)
+ :before " @I { "
+ :action (lambda (n e)
+ (let ((text (markup-option n :text)))
+ (output (or text (markup-body n)) e)))
+ :after " }")
+
+;*---------------------------------------------------------------------*/
+;* mark ... @label mark@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'mark
+ :action (lambda (n e)
+ (if (markup-ident n)
+ (begin
+ (display "{ @SkribeMark { ")
+ (display (lout-tagify (markup-ident n)))
+ (display " } }"))
+ (skribe-error 'lout "mark: Node has no identifier" n))))
+
+(define (lout-page-of ident)
+ ;; Return a string for the `@PageOf' statement for `ident'.
+ (let ((tag (lout-tagify ident)))
+ (string-append ", { " tag " } @CrossLink { "
+ "p. @PageOf { " tag " } }")))
+
+
+;*---------------------------------------------------------------------*/
+;* ref ... @label ref@ */
+;*---------------------------------------------------------------------*/
+(markup-writer 'ref
+ :options '(:text :chapter :section :subsection :subsubsection
+ :figure :mark :handle :ident :page)
+ :action (lambda (n e)
+ (let ((url (markup-option n :url))
+ (text (markup-option n :text))
+ (mark (markup-option n :mark))
+ (handle (markup-option n :handle))
+ (chapter (markup-option n :chapter))
+ (section (markup-option n :section))
+ (subsection (markup-option n :subsection))
+ (subsubsection (markup-option n :subsubsection))
+ (show-page-num? (markup-option n :page)))
+
+ ;; A handle to the target is automagically passed
+ ;; as the body of each `ref' instance (see `api.scm').
+ (let* ((target (handle-ast (markup-body n)))
+ (ident (markup-ident target))
+ (title (markup-option target :title))
+ (number (markup-option target :number)))
+ (lout-debug "ref: target=~a ident=~a" target ident)
+ (if text (output text e))
+
+ ;; Marks don't have a number
+ (if (eq? (markup-markup target) 'mark)
+ (printf (lout-page-of ident))
+ (begin
+ ;; Don't output a section/whatever number
+ ;; when text is provided in order to be
+ ;; consistent with the HTML back-end.
+ ;; Sometimes (eg. for user-defined markups),
+ ;; we don't even know how to reference them
+ ;; anyway.
+ (if (not text)
+ (printf " @NumberOf { ~a }"
+ (lout-tagify ident)))
+ (if show-page-num?
+ (printf (lout-page-of ident)))))))))
+
+
+;*---------------------------------------------------------------------*/
+;* bib-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let ((entry (handle-ast (markup-body n))))
+ (output (markup-option entry :title) e)))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* bib-ref+ ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'bib-ref+
+ ;; When several references are passed. Strangely enough, the list of
+ ;; entries passed to this writer (as its body) contains both `bib-ref' and
+ ;; `bib-entry' objects, hence the `canonicalize-entry' function below.
+ :options '(:text :bib)
+ :before "["
+ :action (lambda (n e)
+ (let* ((entries (markup-body n))
+ (canonicalize-entry (lambda (x)
+ (cond
+ ((is-markup? x 'bib-entry) x)
+ ((is-markup? x 'bib-ref)
+ (handle-ast (markup-body x)))
+ (else
+ (skribe-error
+ 'lout
+ "bib-ref+: invalid entry type"
+ x)))))
+ (help-proc (lambda (proc)
+ (lambda (e1 e2)
+ (proc (canonicalize-entry e1)
+ (canonicalize-entry e2)))))
+ (sort-proc (engine-custom e 'bib-refs-sort-proc)))
+ (let loop ((rs (if sort-proc
+ (sort entries (help-proc sort-proc))
+ entries)))
+ (cond
+ ((null? rs)
+ #f)
+ (else
+ (if (is-markup? (car rs) 'bib-ref)
+ (invoke (writer-action (markup-writer-get 'bib-ref e))
+ (car rs)
+ e)
+ (output (car rs) e))
+ (if (pair? (cdr rs))
+ (begin
+ (display ",")
+ (loop (cdr rs)))))))))
+ :after "]")
+
+;*---------------------------------------------------------------------*/
+;* url-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'url-ref
+ :options '(:url :text)
+ :action (lambda (n e)
+ (let ((url (markup-option n :url))
+ (text (markup-option n :text))
+ (transform (engine-custom e 'transform-url-ref-proc)))
+ (if (or (not transform)
+ (markup-option n '&transformed))
+ (begin
+ (printf "{ \"~a\" @ExternalLink { " url)
+ (if text ;; FIXME: Should be (not (string-index text #\space))
+ (output text e)
+ (let ((filter-url (make-string-replace
+ `((#\/ "\"/\"&-")
+ (#\. ".&-")
+ (#\- "&-")
+ (#\_ "_&-")
+ ,@lout-verbatim-encoding
+ (#\newline "")))))
+ ;; Filter the URL in a way to give Lout hints on
+ ;; where hyphenation should take place.
+ (fprint (current-error-port) "Here!!!" filter-url)
+ (display (filter-url url) e)))
+ (printf " } }"))
+ (begin
+ (markup-option-add! n '&transformed #t)
+ (output (transform n) e))))))
+
+;*---------------------------------------------------------------------*/
+;* line-ref ... */
+;*---------------------------------------------------------------------*/
+(markup-writer 'line-ref
+ :options '(:offset)
+ :before "{ @I {" ;; FIXME: Not tested
+ :action (lambda (n e)
+ (let ((o (markup-option n :offset))
+ (v (string->number (markup-option n :text))))
+ (cond
+ ((and (number? o) (number? v))
+ (display (+ o v)))
+ (else
+ (display v)))))
+ :after "} }")
+
+;*---------------------------------------------------------------------*/
+;* &the-bibliography ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-bibliography
+ :before (lambda (n e)
+ ;; Compute the length (in characters) of the longest entry label
+ ;; so that the label width of the list is adjusted.
+ (let loop ((entries (markup-body n))
+ (label-width 0))
+ (if (null? entries)
+ (begin
+ (display "\n# the-bibliography\n@LP\n")
+ ;; usually, the tag with be something like "[7]", hence
+ ;; the `+ 1' below (`[]' is narrower than 2f)
+ (printf "@TaggedList labelwidth { ~af }\n"
+ (+ 1 label-width)))
+ (loop (cdr entries)
+ (let ((entry-length
+ (let liip ((e (car entries)))
+ (cond
+ ((markup? e)
+ (cond ((is-markup? e '&bib-entry)
+ (liip (markup-option e :title)))
+ ((is-markup? e '&bib-entry-ident)
+ (liip (markup-option e 'number)))
+ (else
+ (liip (markup-body e)))))
+ ((string? e)
+ (string-length e))
+ ((number? e)
+ (liip (number->string e)))
+ ((list? e)
+ (apply + (map liip e)))
+ (else 0)))))
+; (fprint (current-error-port)
+; "node=" (car entries)
+; " body=" (markup-body (car entries))
+; " title=" (markup-option (car entries)
+; :title)
+; " len=" entry-length)
+ (if (> label-width entry-length)
+ label-width
+ entry-length))))))
+ :after (lambda (n e)
+ (display "\n@EndList # the-bibliography (end)\n")))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry
+ :options '(:title)
+ :before "@TagItem "
+ :action (lambda (n e)
+ (display " { ")
+ (output n e (markup-writer-get '&bib-entry-label e))
+ (display " } { ")
+ (output n e (markup-writer-get '&bib-entry-body e))
+ (display " }"))
+ :after "\n")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-title ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-title
+ :action (lambda (n e)
+ (let* ((t (bold (markup-body n)))
+ (en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (ht (if url (ref :url (markup-body url) :text t) t)))
+ (skribe-eval ht e))))
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-label ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-label
+ :options '(:title)
+ :before " \"[\""
+ :action (lambda (n e) (output (markup-option n :title) e))
+ :after "\"]\" ")
+
+;*---------------------------------------------------------------------*/
+;* &bib-entry-url ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&bib-entry-url
+ :action (lambda (n e)
+ (let* ((en (handle-ast (ast-parent n)))
+ (url (markup-option en 'url))
+ (t (bold (markup-body url))))
+ (skribe-eval (ref :url (markup-body url) :text t) e))))
+
+;*---------------------------------------------------------------------*/
+;* &the-index-header ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&the-index-header
+ :action (lambda (n e)
+ (display "@Center { ") ;; FIXME: Needs to be rewritten.
+ (for-each (lambda (h)
+ (let ((f (engine-custom e 'index-header-font-size)))
+ (if f
+ (skribe-eval (font :size f (bold (it h))) e)
+ (output h e))
+ (display " ")))
+ (markup-body n))
+ (display " }")
+ (skribe-eval (linebreak 2) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (it (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-line-comment ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-line-comment
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-comment-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-keyword ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-keyword
+ :action (lambda (n e)
+ (skribe-eval (bold (markup-body n)) e)))
+
+;*---------------------------------------------------------------------*/
+;* &source-define ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-define
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-define-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-module ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-module
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-module-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-markup ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-markup
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-markup-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-thread ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-thread
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-thread-color))
+ (n1 (bold (markup-body n)))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-string ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-string
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-string-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ n1)))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-bracket-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-type ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-type
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc n1)
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-key ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-key
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg cc (bold n1))
+ (it n1))))
+ (skribe-eval n2 e))))
+
+;*---------------------------------------------------------------------*/
+;* &source-bracket ... */
+;*---------------------------------------------------------------------*/
+(markup-writer '&source-bracket
+ :action (lambda (n e)
+ (let* ((cc (engine-custom e 'source-type-color))
+ (n1 (markup-body n))
+ (n2 (if (and (engine-custom e 'source-color) cc)
+ (color :fg "red" (bold n1))
+ (bold n1))))
+ (skribe-eval n2 e))))
+
+
+;*---------------------------------------------------------------------*/
+;* Illustrations */
+;*---------------------------------------------------------------------*/
+(define-public (lout-illustration . args)
+ ;; FIXME: This should be a markup.
+
+ ;; Introduce a Lout illustration (such as a diagram) whose code is either
+ ;; the body of `lout-illustration' or the contents of `file'. For engines
+ ;; other than Lout, an EPS file is produced and then converted if needed.
+ ;; The `:alt' option is equivalent to HTML's `alt' attribute for the `img'
+ ;; markup, i.e. it is passed as the body of the `image' markup for
+ ;; non-Lout back-ends.
+
+ (define (file-contents file)
+ ;; Return the contents (a string) of file `file'.
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((contents "")
+ (line (read-line)))
+ (if (eof-object? line)
+ contents
+ (loop (string-append contents line "\n")
+ (read-line)))))))
+
+ (define (illustration-header)
+ ;; Return a string denoting the header of a Lout illustration.
+ (let ((lout (find-engine 'lout)))
+ (string-append "@SysInclude { picture }\n"
+ (engine-custom lout 'includes)
+ "\n\n@Illustration\n"
+ " @InitialFont { "
+ (engine-custom lout 'initial-font)
+ " }\n"
+ " @InitialBreak { "
+ (engine-custom lout 'initial-break)
+ " }\n"
+ " @InitialLanguage { "
+ (engine-custom lout 'initial-language)
+ " }\n"
+ " @InitialSpace { tex }\n"
+ "{\n")))
+
+ (define (illustration-ending)
+ ;; Return a string denoting the end of a Lout illustration.
+ "\n}\n")
+
+ (let* ((opts (the-options args '(file ident alt)))
+ (file* (assoc ':file opts))
+ (ident* (assoc ':ident opts))
+ (alt* (assoc ':alt opts))
+ (file (and file* (cadr file*)))
+ (ident (and ident* (cadr ident*)))
+ (alt (or (and alt* (cadr alt*)) "An illustration")))
+
+ (let ((contents (if (not file)
+ (car (the-body args))
+ (file-contents file))))
+ (if (engine-format? "lout")
+ (! contents) ;; simply inline the illustration
+ (let* ((lout (find-engine 'lout))
+ (output (string-append (or ident
+ (symbol->string
+ (gensym 'lout-illustration)))
+ ".eps"))
+ (port (open-output-pipe
+ (string-append (or (engine-custom lout
+ 'lout-program-name)
+ "lout")
+ " -o " output
+ " -EPS"))))
+
+ ;; send the illustration to Lout's standard input
+ (display (illustration-header) port)
+ (display contents port)
+ (display (illustration-ending) port)
+
+ (let ((exit-val (status:exit-val (close-pipe port))))
+ (if (not (eqv? 0 exit-val))
+ (skribe-error 'lout-illustration
+ "lout exited with error code" exit-val)))
+
+ (if (not (file-exists? output))
+ (skribe-error 'lout-illustration "file not created"
+ output))
+
+ (let ((file-info (false-if-exception (stat output))))
+ (if (or (not file-info)
+ (= 0 (stat:size file-info)))
+ (skribe-error 'lout-illustration
+ "empty output file" output)))
+
+ ;; the image (FIXME: Should set its location)
+ (image :file output alt))))))
+
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(pop-default-engine)
+
+
+;; Local Variables: --
+;; mode: Scheme --
+;; coding: latin-1 --
+;; scheme-program-name: "guile" --
+;; End: --
diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm
new file mode 100644
index 0000000..81e9f27
--- /dev/null
+++ b/src/guile/skribilo/engine/xml.scm
@@ -0,0 +1,115 @@
+;;; xml.scm -- Generic XML engine.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo engine xml))
+
+;*---------------------------------------------------------------------*/
+;* xml-engine ... */
+;*---------------------------------------------------------------------*/
+(define xml-engine
+ ;; setup the xml engine
+ (default-engine-set!
+ (make-engine 'xml
+ :version 1.0
+ :format "html"
+ :delegate (find-engine 'base)
+ :filter (make-string-replace '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")
+ (#\@ "&#x40;"))))))
+
+;*---------------------------------------------------------------------*/
+;* markup ... */
+;*---------------------------------------------------------------------*/
+(let ((xml-margin 0))
+ (define (make-margin)
+ (make-string xml-margin #\space))
+ (define (xml-attribute? val)
+ (cond
+ ((or (string? val) (number? val) (boolean? val))
+ #t)
+ ((list? val)
+ (every? xml-attribute? val))
+ (else
+ #f)))
+ (define (xml-attribute att val)
+ (let ((s (keyword->string att)))
+ (printf " ~a=\"" (substring s 1 (string-length s)))
+ (let loop ((val val))
+ (cond
+ ((or (string? val) (number? val))
+ (display val))
+ ((boolean? val)
+ (display (if val "true" "false")))
+ ((pair? val)
+ (for-each loop val))
+ (else
+ #f)))
+ (display #\")))
+ (define (xml-option opt val e)
+ (let* ((m (make-margin))
+ (ks (keyword->string opt))
+ (s (substring ks 1 (string-length ks))))
+ (printf "~a<~a>\n" m s)
+ (output val e)
+ (printf "~a</~a>\n" m s)))
+ (define (xml-options n e)
+ ;; display the true options
+ (let ((opts (filter (lambda (o)
+ (and (keyword? (car o))
+ (not (xml-attribute? (cadr o)))))
+ (markup-options n))))
+ (if (pair? opts)
+ (let ((m (make-margin)))
+ (display m)
+ (display "<options>\n")
+ (set! xml-margin (+ xml-margin 1))
+ (for-each (lambda (o)
+ (xml-option (car o) (cadr o) e))
+ opts)
+ (set! xml-margin (- xml-margin 1))
+ (display m)
+ (display "</options>\n")))))
+ (markup-writer #t
+ :options 'all
+ :before (lambda (n e)
+ (printf "~a<~a" (make-margin) (markup-markup n))
+ ;; display the xml attributes
+ (for-each (lambda (o)
+ (if (and (keyword? (car o))
+ (xml-attribute? (cadr o)))
+ (xml-attribute (car o) (cadr o))))
+ (markup-options n))
+ (set! xml-margin (+ xml-margin 1))
+ (display ">\n"))
+ :action (lambda (n e)
+ ;; options
+ (xml-options n e)
+ ;; body
+ (output (markup-body n) e))
+ :after (lambda (n e)
+ (printf "~a</~a>\n" (make-margin) (markup-markup n))
+ (set! xml-margin (- xml-margin 1)))))
+
+;*---------------------------------------------------------------------*/
+;* Restore the base engine */
+;*---------------------------------------------------------------------*/
+(default-engine-set! (find-engine 'base))
diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm
new file mode 100644
index 0000000..8502d51
--- /dev/null
+++ b/src/guile/skribilo/evaluator.scm
@@ -0,0 +1,203 @@
+;;; eval.scm -- Skribilo evaluator.
+;;;
+;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2005,2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo evaluator)
+ :export (evaluate-document evaluate-document-from-port
+ load-document include-document *load-options*)
+ :autoload (skribilo parameters) (*verbose* *document-path*)
+ :autoload (skribilo location) (<location>)
+ :autoload (skribilo ast) (ast? markup?)
+ :autoload (skribilo engine) (*current-engine*
+ engine? find-engine engine-ident)
+ :autoload (skribilo reader) (*document-reader*)
+
+ :autoload (skribilo verify) (verify)
+ :autoload (skribilo resolve) (resolve!)
+
+ :autoload (skribilo module) (*skribilo-user-module*))
+
+
+(use-modules (skribilo utils syntax)
+ (skribilo condition)
+ (skribilo debug)
+ (skribilo output)
+ (skribilo lib)
+
+ (ice-9 optargs)
+ (oop goops)
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (srfi srfi-34)
+ (srfi srfi-35)
+ (srfi srfi-39))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; %EVALUATE
+;;;
+(define (%evaluate expr)
+ ;; Evaluate EXPR, an arbitrary S-expression that may contain calls to the
+ ;; markup functions defined in a markup package such as
+ ;; `(skribilo package base)', e.g., `(bold "hello")'.
+ (let ((result (eval expr (*skribilo-user-module*))))
+
+ (if (ast? result)
+ (let ((file (source-property expr 'filename))
+ (line (source-property expr 'line))
+ (column (source-property expr 'column)))
+ (slot-set! result 'loc
+ (make <location>
+ :file file :line line :pos column))))
+
+ result))
+
+
+
+;;;
+;;; EVALUATE-DOCUMENT
+;;;
+(define* (evaluate-document a e :key (env '()))
+ ;; Argument A must denote an AST of something like that, not just an
+ ;; S-exp.
+ (with-debug 2 'evaluate-document
+ (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)))))
+
+;;;
+;;; EVALUATE-DOCUMENT-FROM-PORT
+;;;
+(define* (evaluate-document-from-port port engine
+ :key (env '())
+ (reader (*document-reader*)))
+ (with-debug 2 'evaluate-document-from-port
+ (debug-item "engine=" engine)
+ (debug-item "reader=" reader)
+
+ (let ((e (if (symbol? engine) (find-engine engine) engine)))
+ (debug-item "e=" e)
+ (if (not (engine? e))
+ (skribe-error 'evaluate-document-from-port "cannot find engine" engine)
+ (let loop ((exp (reader port)))
+ (with-debug 10 'evaluate-document-from-port
+ (debug-item "exp=" exp))
+ (unless (eof-object? exp)
+ (evaluate-document (%evaluate exp) e :env env)
+ (loop (reader port))))))))
+
+
+;;;
+;;; LOAD-DOCUMENT
+;;;
+
+;; Options that may make sense to a specific back-end or package.
+(define-public *load-options* (make-parameter '()))
+
+;; List of the names of files already loaded.
+(define *loaded-files* (make-parameter '()))
+
+(define* (load-document file :key (engine #f) (path #f) :allow-other-keys
+ :rest opt)
+ (with-debug 4 'skribe-load
+ (debug-item " engine=" engine)
+ (debug-item " path=" path)
+ (debug-item " opt=" opt)
+
+ (let* ((ei (*current-engine*))
+ (path (append (cond
+ ((not path) (*document-path*))
+ ((string? path) (list path))
+ ((not (and (list? path) (every? string? path)))
+ (raise (condition (&invalid-argument-error
+ (proc-name 'load-document)
+ (argument path)))))
+ (else path))
+ %load-path))
+ (filep (or (search-path path file)
+ (search-path (append path %load-path) file)
+ (search-path (append path %load-path)
+ (let ((dot (string-rindex file #\.)))
+ (if dot
+ (string-append
+ (string-take file dot)
+ ".scm")
+ file))))))
+
+ (unless (and (string? filep) (file-exists? filep))
+ (raise (condition (&file-search-error
+ (file-name file)
+ (path path)))))
+
+ ;; Pass the additional options to the back-end and/or packages being
+ ;; used.
+ (parameterize ((*load-options* opt))
+
+ ;; Load this file if not already done
+ ;; FIXME: Shouldn't we remove this logic? -- Ludo'.
+ (unless (member filep (*loaded-files*))
+ (cond
+ ((> (*verbose*) 1)
+ (format (current-error-port) " [loading file: ~S ~S]\n" filep opt))
+ ((> (*verbose*) 0)
+ (format (current-error-port) " [loading file: ~S]\n" filep)))
+
+ ;; Load it
+ (with-input-from-file filep
+ (lambda ()
+ (evaluate-document-from-port (current-input-port) ei)))
+
+ (*loaded-files* (cons filep (*loaded-files*))))))))
+
+;;;
+;;; INCLUDE-DOCUMENT
+;;;
+(define* (include-document file :key (path (*document-path*))
+ (reader (*document-reader*)))
+ (unless (every string? path)
+ (raise (condition (&invalid-argument-error (proc-name 'include-document)
+ (argument path)))))
+
+ (let ((full-path (search-path path file)))
+ (unless (and (string? full-path) (file-exists? full-path))
+ (raise (condition (&file-search-error
+ (file-name file)
+ (path path)))))
+
+ (when (> (*verbose*) 0)
+ (format (current-error-port) " [including file: ~S]\n" full-path))
+
+ (with-input-from-file full-path
+ (lambda ()
+ (let Loop ((exp (reader (current-input-port)))
+ (res '()))
+ (if (eof-object? exp)
+ (if (and (pair? res) (null? (cdr res)))
+ (car res)
+ (reverse! res))
+ (Loop (reader (current-input-port))
+ (cons (%evaluate exp) res))))))))
diff --git a/src/common/index.scm b/src/guile/skribilo/index.scm
index 65c271f..33f8d15 100644
--- a/src/common/index.scm
+++ b/src/guile/skribilo/index.scm
@@ -1,41 +1,80 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/index.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Sun Aug 24 08:01:45 2003 */
-;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe indexes */
-;* ------------------------------------------------------------- */
-;* Implementation: @label index@ */
-;* bigloo: @path ../bigloo/index.bgl@ */
-;*=====================================================================*/
+;;; index.scm
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo index)
+ :use-syntax (skribilo utils syntax)
+ :use-syntax (skribilo lib)
+
+ :use-module (skribilo lib)
+ :use-module (skribilo ast)
+ :use-module (srfi srfi-39)
+
+ ;; XXX: The use of `mark' here introduces a cross-dependency between
+ ;; `index' and `package base'. Thus, we require that each of these two
+ ;; modules autoloads the other one.
+ :autoload (skribilo package base) (mark)
+
+ :export (index? make-index-table *index-table*
+ default-index resolve-the-index))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; A library of functions dealing with the creation of indices in
+;;; documents.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `index.scm' file found in the `common' directory.
+
;*---------------------------------------------------------------------*/
;* index? ... */
;*---------------------------------------------------------------------*/
(define (index? obj)
- (hashtable? obj))
+ (hash-table? obj))
;*---------------------------------------------------------------------*/
;* *index-table* ... */
;*---------------------------------------------------------------------*/
-(define *index-table* #f)
+(define *index-table* (make-parameter #f))
;*---------------------------------------------------------------------*/
;* make-index-table ... */
;*---------------------------------------------------------------------*/
(define (make-index-table ident)
- (make-hashtable))
+ (make-hash-table))
;*---------------------------------------------------------------------*/
;* default-index ... */
;*---------------------------------------------------------------------*/
(define (default-index)
- (if (not *index-table*)
- (set! *index-table* (make-index-table "default-index")))
- *index-table*)
+ (if (not (*index-table*))
+ (*index-table* (make-index-table "default-index")))
+ (*index-table*))
;*---------------------------------------------------------------------*/
;* resolve-the-index ... */
@@ -49,7 +88,7 @@
(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
+ (sort ie
(lambda (i1 i2)
(or (not (markup-option i1 :note))
(markup-option i2 :note)))))
@@ -80,7 +119,10 @@
(else
(loop (cdr buckets)
(cons (car buckets) res)))))))
- (let* ((entries (apply append (map hashtable->list indexes)))
+ (let* ((entries (apply append (map (lambda (t)
+ (hash-map->list
+ (lambda (key val) val) t))
+ indexes)))
(sorted (map sort-entries-bucket
(merge-buckets
(sort entries
@@ -124,3 +166,5 @@
(cons r lrefs)
(append lr (cons m body)))))))))))
+
+;;; index.scm ends here
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
new file mode 100644
index 0000000..21b2a4d
--- /dev/null
+++ b/src/guile/skribilo/lib.scm
@@ -0,0 +1,239 @@
+;;;
+;;; lib.scm -- Utilities
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :export (skribe-eval-location skribe-ast-error skribe-error
+ skribe-type-error
+ skribe-warning skribe-warning/ast
+ skribe-message
+
+ type-name %procedure-arity)
+
+ :export-syntax (new define-markup define-simple-markup
+ define-simple-container define-processor-markup)
+
+ :use-module (skribilo config)
+ :use-module (skribilo ast)
+
+ ;; useful for `new' to work well with <language>
+ :autoload (skribilo source) (<language>)
+
+ :use-module (skribilo reader)
+ :use-module (skribilo parameters)
+ :use-module (skribilo location)
+
+ :use-module (srfi srfi-1)
+ :use-module (oop goops)
+ :use-module (ice-9 optargs))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; NEW
+;;;
+
+(define %types-module (current-module))
+
+(define-macro (new class . parameters)
+ ;; Thanks to the trick below, modules don't need to import `(oop goops)'
+ ;; and `(skribilo ast)' in order to make use of `new'.
+ (let* ((class-name (symbol-append '< class '>))
+ (actual-class (module-ref %types-module class-name)))
+ `(let ((make ,make)
+ (,class-name ,actual-class))
+ (make ,class-name
+ ,@(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 is not what Skribe/DSSSL
+ ;; expect, hence `fix-rest-arg'.
+ (define (fix-rest-arg args)
+ (let loop ((args args)
+ (result '())
+ (rest-arg #f))
+ (cond ((null? args)
+ (if rest-arg
+ (append (reverse result) rest-arg)
+ (reverse result)))
+
+ ((list? args)
+ (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))))
+
+ ((pair? args)
+ (loop '()
+ (cons (car args) result)
+ (list #:rest (cdr args)))))))
+
+ (let ((name (car bindings))
+ (opts (cdr bindings)))
+ `(define*-public ,(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 ',(symbol->string 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 ',(symbol->string 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)))))
+
+
+
+;;;
+;;; TYPE-NAME
+;;;
+(define (type-name obj)
+ (cond ((string? obj) "string")
+ ((ast? obj) "ast")
+ ((list? obj) "list")
+ ((pair? obj) "pair")
+ ((number? obj) "number")
+ ((char? obj) "character")
+ ((keyword? obj) "keyword")
+ (else (with-output-to-string
+ (lambda () (write obj))))))
+
+;;;
+;;; SKRIBE-EVAL-LOCATION ...
+;;;
+(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 (format #f "~a:~a: ~a: ~a ~s" (location-file l)
+ (location-line l) proc msg shape))
+ (error (format #f "~a: ~a ~s " proc msg shape)))))
+
+(define (skribe-error proc msg obj)
+ (if (ast? obj)
+ (skribe-ast-error proc msg obj)
+ (error (format #f "~a: ~a ~s" 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))
+
+
+;;;
+;;; SKRIBE-WARNING & SKRIBE-WARNING/AST
+;;;
+(define (%skribe-warn level file line lst)
+ (let ((port (current-error-port)))
+ (if (or (not file) (not line))
+ (begin
+ ;; XXX: This is a bit hackish, but it proves to be quite useful.
+ (set! file (port-filename (current-input-port)))
+ (set! line (port-line (current-input-port)))))
+ (when (and file line)
+ (format port "~a:~a: " file line))
+ (format port "warning: ")
+ (for-each (lambda (x) (format port "~a " x)) lst)
+ (newline port)))
+
+
+(define (skribe-warning level . obj)
+ (if (>= (*warning*) level)
+ (%skribe-warn level #f #f obj)))
+
+
+(define (skribe-warning/ast level ast . obj)
+ (if (>= (*warning*) level)
+ (let ((l (ast-loc ast)))
+ (if (location? l)
+ (%skribe-warn level (location-file l) (location-line l) obj)
+ (%skribe-warn level #f #f obj)))))
+
+;;;
+;;; SKRIBE-MESSAGE
+;;;
+(define (skribe-message fmt . obj)
+ (when (> (*verbose*) 0)
+ (apply format (current-error-port) fmt obj)))
+
+
+;;;
+;;; %PROCEDURE-ARITY
+;;;
+(define (%procedure-arity proc)
+ (car (procedure-property proc 'arity)))
+
+;;; lib.scm ends here
diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm
new file mode 100644
index 0000000..7c870fa
--- /dev/null
+++ b/src/guile/skribilo/location.scm
@@ -0,0 +1,69 @@
+;;; location.scm -- Skribilo source location.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo location)
+ :use-module (oop goops)
+ :use-module ((skribilo utils syntax) :select (%skribilo-module-reader))
+ :export (<location> location? ast-location
+ location-file location-line location-pos))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; An abstract data type to keep track of source locations.
+;;;
+;;; Code:
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; Class definition.
+;;;
+
+(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 #f "~a, line ~a" file line))
+ "no source location")))
+
+
+;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83
+
+;;; location.scm ends here.
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
new file mode 100644
index 0000000..ac8eee0
--- /dev/null
+++ b/src/guile/skribilo/module.scm
@@ -0,0 +1,153 @@
+;;; module.scm -- Integration of Skribe code as Guile modules.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo module)
+ :autoload (skribilo reader) (make-reader)
+ :use-module (skribilo debug)
+ :use-module (srfi srfi-1)
+ :use-module (ice-9 optargs)
+ :use-module (srfi srfi-39)
+ :use-module (skribilo utils syntax)
+ :export (make-run-time-module *skribilo-user-module*))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; 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 %skribilo-user-imports
+ ;; List of modules that should be imported by any good Skribilo module.
+ '((srfi srfi-1) ;; lists
+ (srfi srfi-13) ;; strings
+ (ice-9 optargs) ;; `define*'
+
+ (skribilo package base) ;; the core markups
+ (skribilo utils syntax) ;; `unless', `when', etc.
+ (skribilo utils compat) ;; `skribe-load-path', etc.
+ (skribilo utils keywords) ;; `the-body', `the-options'
+ (skribilo utils strings) ;; `make-string-replace', etc.
+ (skribilo module)
+ (skribilo ast) ;; `<document>', `document?', etc.
+ (skribilo config)
+ (skribilo biblio)
+ (skribilo lib) ;; `define-markup', `unwind-protect', etc.
+ (skribilo resolve)
+ (skribilo engine)
+ (skribilo writer)
+ (skribilo output)
+ (skribilo evaluator)
+ (skribilo debug)
+ (skribilo location)
+ ))
+
+(define %skribilo-user-autoloads
+ ;; List of auxiliary modules that may be lazily autoloaded.
+ '(((skribilo engine lout) . (!lout
+ lout-illustration
+ ;; FIXME: The following should eventually be
+ ;; removed from here.
+ lout-structure-number-string))
+ ((skribilo engine latex) . (!latex LaTeX TeX))
+ ((skribilo engine html) . (html-markup-class html-class
+ html-width))
+ ((skribilo utils images) . (convert-image))
+ ((skribilo index) . (index? make-index-table default-index
+ resolve-the-index))
+ ((skribilo source) . (source-read-lines source-fontify
+ language? language-extractor
+ language-fontifier source-fontify))
+ ((skribilo coloring lisp) . (skribe scheme lisp))
+ ((skribilo coloring xml) . (xml))
+ ((skribilo prog) . (make-prog-body resolve-line))
+ ((skribilo color) .
+ (skribe-color->rgb skribe-get-used-colors skribe-use-color!))
+ ((skribilo sui) . (load-sui))
+
+ ((ice-9 and-let-star) . (and-let*))
+ ((ice-9 receive) . (receive))))
+
+
+
+;; The very macro to turn a legacy Skribe file (which uses Skribe's syntax)
+;; into a Guile module.
+
+(define-macro (define-skribe-module name . options)
+ `(begin
+ (define-module ,name
+ :use-module ((skribilo reader) :select (%default-reader))
+ :use-module (srfi srfi-1)
+ ,@(append-map (lambda (mod)
+ (list :autoload (car mod) (cdr mod)))
+ %skribilo-user-autoloads)
+ ,@options)
+
+ ;; Pull all the bindings that Skribe code may expect, plus those needed
+ ;; to actually create and read the module.
+ ;; TODO: These should be auto-loaded.
+ ,(cons 'use-modules %skribilo-user-imports)
+
+ ;; Change the current reader to a Skribe-compatible reader. If this
+ ;; primitive is not provided by Guile (i.e., version <= 1.7.2), then it
+ ;; should be provided by `guile-reader' (version >= 0.3) as a core
+ ;; binding and installed by `(skribilo utils syntax)'.
+ (fluid-set! current-reader %default-reader)))
+
+
+;; Make it available to the top-level module.
+(module-define! the-root-module
+ 'define-skribe-module define-skribe-module)
+
+
+
+
+;;;
+;;; 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))
+ (autoloads (map (lambda (name+bindings)
+ (make-autoload-interface the-module
+ (car name+bindings)
+ (cdr name+bindings)))
+ %skribilo-user-autoloads)))
+ (set-module-name! the-module '(skribilo-user))
+ (module-use-interfaces! the-module
+ (cons the-root-module
+ (append (map resolve-interface
+ %skribilo-user-imports)
+ autoloads)))
+ the-module))
+
+;; The current module in which the document is evaluated.
+(define *skribilo-user-module* (make-parameter (make-run-time-module)))
+
+
+;;; module.scm ends here
diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm
new file mode 100644
index 0000000..a33c040
--- /dev/null
+++ b/src/guile/skribilo/output.scm
@@ -0,0 +1,228 @@
+;;; output.scm -- Skribilo output stage.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo output)
+ :autoload (skribilo engine) (engine-ident processor-get-engine)
+ :autoload (skribilo writer) (writer? writer-ident lookup-markup-writer)
+ :autoload (skribilo location) (location?)
+ :use-module (skribilo ast)
+ :use-module (skribilo debug)
+ :use-module (skribilo utils syntax)
+ :use-module (oop goops)
+
+ :use-module (skribilo condition)
+ :use-module (srfi srfi-35)
+ :use-module (srfi srfi-34)
+ :use-module (srfi srfi-39)
+
+ :export (output
+ *document-being-output*
+ &output-error &output-unresolved-error &output-writer-error
+ output-error? output-unresolved-error? output-writer-error?))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &output-error &skribilo-error
+ output-error?)
+
+(define-condition-type &output-unresolved-error &output-error
+ output-unresolved-error?
+ (ast output-unresolved-error:ast))
+
+(define-condition-type &output-writer-error &output-error
+ output-writer-error?
+ (writer output-writer-error:writer))
+
+
+(define (handle-output-error c)
+ ;; Issue a user-friendly error message for error condition C.
+ (cond ((output-unresolved-error? c)
+ (let* ((node (output-unresolved-error:ast c))
+ (location (and (ast? node) (ast-loc node))))
+ (format (current-error-port) "unresolved node: ~a~a~%"
+ node
+ (if (location? location)
+ (string-append " "
+ (location-file location) ":"
+ (location-line location))
+ ""))))
+ ((output-writer-error? c)
+ (format (current-error-port) "invalid writer: ~a~%"
+ (output-writer-error:writer c)))
+ (else
+ (format (current-error-port) "undefined output error: ~a~%"
+ c))))
+
+(register-error-condition-handler! output-error?
+ handle-output-error)
+
+
+
+;;;
+;;; Output method.
+;;;
+
+;; The document being output. Note: This is only meant to be used by the
+;; compatibility layer in order to implement things like `find-markups'!
+(define *document-being-output* (make-parameter #f))
+
+(define-generic out)
+
+(define (%out/writer n e w)
+ (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))
+ (raise (condition (&output-writer-error (writer writer)))))
+ (else
+ (raise (condition (&output-writer-error (writer writer)))))))))
+
+
+
+;;;
+;;; OUT implementations
+;;;
+(define-method (out node e)
+ #f)
+
+(define-method (out (node <document>) e)
+ ;; Only needed by the compatibility layer.
+ (parameterize ((*document-being-output* node))
+ (next-method)))
+
+(define-method (out (node <pair>) e)
+ (let loop ((n* node))
+ (cond
+ ((pair? n*)
+ (out (car n*) e)
+ (loop (cdr n*)))
+ ((not (null? n*))
+ (raise (condition (&invalid-argument-error
+ (proc-name output)
+ (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)
+ (raise (condition (&too-few-arguments-error
+ (proc-name "output<command>")
+ (arguments 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
+ (raise (condition (&too-few-arguments-error
+ (proc-name "output<command>")
+ (arguments 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)
+ (raise (condition (&output-unresolved-error (ast 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/package/Makefile.am b/src/guile/skribilo/package/Makefile.am
new file mode 100644
index 0000000..693f088
--- /dev/null
+++ b/src/guile/skribilo/package/Makefile.am
@@ -0,0 +1,7 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package
+dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \
+ lncs.scm scribe.scm sigplan.scm skribe.scm \
+ slide.scm web-article.scm web-book.scm \
+ eq.scm pie.scm base.scm
+
+SUBDIRS = slide eq pie
diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm
new file mode 100644
index 0000000..61eafd5
--- /dev/null
+++ b/src/guile/skribilo/package/acmproc.scm
@@ -0,0 +1,164 @@
+;;; acmproc.scm -- The Skribe style for ACMPROC articles.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;*---------------------------------------------------------------------*/
+;* LaTeX global customizations */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le
+ 'documentclass
+ "\\documentclass[letterpaper]{acmproc}")
+ ;; &latex-author
+ (markup-writer '&latex-author le
+ :before (lambda (n e)
+ (let ((body (markup-body n)))
+ (printf "\\numberofauthors{~a}\n\\author{\n"
+ (if (pair? body) (length body) 1))))
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (for-each (lambda (a)
+ (display "\\alignauthor\n")
+ (output a e))
+ (if (pair? body) body (list body)))))
+ :after "}\n")
+ ;; author
+ (let ((old-author (markup-writer-get 'author le)))
+ (markup-writer 'author le
+ :options (writer-options old-author)
+ :action (writer-action old-author)))
+ ;; ACM category, terms, and keywords
+ (markup-writer '&acm-category le
+ :options '(:index :section :subsection)
+ :before (lambda (n e)
+ (display "\\category{")
+ (display (markup-option n :index))
+ (display "}")
+ (display "{")
+ (display (markup-option n :section))
+ (display "}")
+ (display "{")
+ (display (markup-option n :subsection))
+ (display "}\n["))
+ :after "]\n")
+ (markup-writer '&acm-terms le
+ :before "\\terms{"
+ :after "}")
+ (markup-writer '&acm-keywords le
+ :before "\\keywords{"
+ :after "}")
+ (markup-writer '&acm-copyright le
+ :action (lambda (n e)
+ (display "\\conferenceinfo{")
+ (output (markup-option n :conference) e)
+ (display ",} {")
+ (output (markup-option n :location) e)
+ (display "}\n")
+ (display "\\CopyrightYear{")
+ (output (markup-option n :year) e)
+ (display "}\n")
+ (display "\\crdata{")
+ (output (markup-option n :crdata) e)
+ (display "}\n"))))
+
+;*---------------------------------------------------------------------*/
+;* HTML global customizations */
+;*---------------------------------------------------------------------*/
+(let ((he (find-engine 'html)))
+ (markup-writer '&html-acmproc-abstract he
+ :action (lambda (n e)
+ (let* ((ebg (engine-custom e 'abstract-background))
+ (bg (or (and (string? ebg)
+ (> (string-length ebg) 0))
+ ebg
+ "#cccccc"))
+ (exp (p (center (color :bg bg :width 90.
+ (markup-body n))))))
+ (skribe-eval exp e))))
+ ;; ACM category, terms, and keywords
+ (markup-writer '&acm-category :action #f)
+ (markup-writer '&acm-terms :action #f)
+ (markup-writer '&acm-keywords :action #f)
+ (markup-writer '&acm-copyright :action #f))
+
+;*---------------------------------------------------------------------*/
+;* abstract ... */
+;*---------------------------------------------------------------------*/
+(define-markup (abstract #!rest opt #!key (class "abstract") postscript)
+ (if (engine-format? "latex")
+ (section :number #f :title "ABSTRACT" (p (the-body opt)))
+ (let ((a (new markup
+ (markup '&html-acmproc-abstract)
+ (body (the-body opt)))))
+ (list (if postscript
+ (section :number #f :toc #f :title "Postscript download"
+ postscript))
+ (section :number #f :toc #f :class class :title "Abstract" a)
+ (section :number #f :toc #f :title "Table of contents"
+ (toc :subsection #t))))))
+
+;*---------------------------------------------------------------------*/
+;* acm-category ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-category #!rest opt #!key index section subsection)
+ (new markup
+ (markup '&acm-category)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-terms ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-terms #!rest opt)
+ (new markup
+ (markup '&acm-terms)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-keywords ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-keywords #!rest opt)
+ (new markup
+ (markup '&acm-keywords)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-copyright ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-copyright #!rest opt #!key conference location year crdata)
+ (let* ((le (find-engine 'latex))
+ (cop (format "\\conferenceinfo{~a,} {~a}
+\\CopyrightYear{~a}
+\\crdata{~a}\n" conference location year crdata))
+ (old (engine-custom le 'predocument)))
+ (if (string? old)
+ (engine-custom-set! le 'predocument (string-append cop old))
+ (engine-custom-set! le 'predocument cop))))
+
+;*---------------------------------------------------------------------*/
+;* references ... */
+;*---------------------------------------------------------------------*/
+(define (references)
+ (list "\n\n"
+ (if (engine-format? "latex")
+ (font :size -1 (flush :side 'left (the-bibliography)))
+ (section :title "References"
+ (font :size -1 (the-bibliography))))))
diff --git a/src/common/api.scm b/src/guile/skribilo/package/base.scm
index 397ba09..bbb2a62 100644
--- a/src/common/api.scm
+++ b/src/guile/skribilo/package/base.scm
@@ -1,56 +1,84 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/api.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Mon Jul 21 18:11:56 2003 */
-;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* The Scribe API */
-;* ------------------------------------------------------------- */
-;* Implementation: @label api@ */
-;* bigloo: @path ../bigloo/api.bgl@ */
-;* Documentation: */
-;* @path ../../doc/user/markup.skb@ */
-;* @path ../../doc/user/document.skb@ */
-;* @path ../../doc/user/sectioning.skb@ */
-;* @path ../../doc/user/toc.skb@ */
-;* @path ../../doc/user/ornament.skb@ */
-;* @path ../../doc/user/line.skb@ */
-;* @path ../../doc/user/font.skb@ */
-;* @path ../../doc/user/justify.skb@ */
-;* @path ../../doc/user/enumeration.skb@ */
-;* @path ../../doc/user/colframe.skb@ */
-;* @path ../../doc/user/figure.skb@ */
-;* @path ../../doc/user/image.skb@ */
-;* @path ../../doc/user/table.skb@ */
-;* @path ../../doc/user/footnote.skb@ */
-;* @path ../../doc/user/char.skb@ */
-;* @path ../../doc/user/links.skb@ */
-;*=====================================================================*/
+;;; base.scm -- The base markup package of Skribe/Skribilo.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package base)
+ :use-syntax (skribilo lib)
+ :use-syntax (skribilo reader)
+ :use-syntax (skribilo utils syntax)
+ :use-syntax (ice-9 optargs)
+
+ :use-module (skribilo ast)
+ :use-module (skribilo resolve)
+ :use-module (skribilo utils keywords)
+ :autoload (srfi srfi-1) (every any filter)
+ :autoload (skribilo evaluator) (include-document)
+ :autoload (skribilo engine) (engine?)
+
+ ;; optional ``sub-packages''
+ :autoload (skribilo biblio) (default-bib-table resolve-bib
+ bib-load! bib-add!)
+ :autoload (skribilo color) (skribe-use-color!)
+ :autoload (skribilo source) (language? source-read-lines source-fontify)
+ :autoload (skribilo prog) (make-prog-body resolve-line)
+ :autoload (skribilo index) (make-index-table)
+
+ :replace (symbol))
+
+(fluid-set! current-reader (make-reader 'skribe))
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; This module contains all the core markups of Skribe/Skribilo.
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `api.scm' file found in the `common' directory.
+
+
+
;*---------------------------------------------------------------------*/
;* include ... */
;*---------------------------------------------------------------------*/
(define-markup (include file)
(if (not (string? file))
(skribe-error 'include "Illegal file (string expected)" file)
- (skribe-include file)))
-
+ (include-document file)))
+
;*---------------------------------------------------------------------*/
;* document ... */
;*---------------------------------------------------------------------*/
(define-markup (document #!rest
opts
- #!key
+ #!key
(ident #f) (class "document")
(title #f) (html-title #f) (author #f)
- (ending #f) (env '()))
+ (ending #f) (keywords '()) (env '()))
(new document
(markup 'document)
(ident (or ident
(ast->string title)
- (symbol->string (gensym 'document))))
+ (symbol->string (gensym "document"))))
(class class)
(required-options '(:title :author :ending))
(options (the-options opts :ident :class :env))
@@ -62,6 +90,20 @@
(list 'figure-counter 0) (list 'figure-env '()))))))
;*---------------------------------------------------------------------*/
+;* keyword-list->comma-separated ... */
+;*---------------------------------------------------------------------*/
+(define-public (keyword-list->comma-separated kw*)
+ ;; Turn the the list of keywords (which may be strings or other markups)
+ ;; KW* into a markup where the elements of KW* are comma-separated. This
+ ;; may commonly be used in handling the `:keywords' option of `document'.
+ (let loop ((kw* kw*) (result '()))
+ (if (null? kw*)
+ (reverse! result)
+ (loop (cdr kw*)
+ (cons* (if (pair? (cdr kw*)) ", " "")
+ (car kw*) result)))))
+
+;*---------------------------------------------------------------------*/
;* author ... */
;*---------------------------------------------------------------------*/
(define-markup (author #!rest
@@ -81,7 +123,7 @@
(skribe-error 'author "Illegal align value" align)
(new container
(markup 'author)
- (ident (or ident (symbol->string (gensym 'author))))
+ (ident (or ident (symbol->string (gensym "author"))))
(class class)
(required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
(options `((:name ,name)
@@ -96,16 +138,18 @@
opts
#!key
(ident #f) (class "toc")
- (chapter #t) (section #t) (subsection #f))
+ (chapter #t) (section #t) (subsection #f)
+ (subsubsection #f))
(let ((body (the-body opts)))
(new container
(markup 'toc)
- (ident (or ident (symbol->string (gensym 'toc))))
+ (ident (or ident (symbol->string (gensym "toc"))))
(class class)
(required-options '())
(options `((:chapter ,chapter)
(:section ,section)
(:subsection ,subsection)
+ (:subsubsection ,subsubsection)
,@(the-options opts :ident :class)))
(body (cond
((null? body)
@@ -139,7 +183,7 @@
title (html-title #f) (file #f) (toc #t) (number #t))
(new container
(markup 'chapter)
- (ident (or ident (ast->string title)))
+ (ident (or ident (symbol->string (gensym "chapter"))))
(class class)
(required-options '(:title :file :toc :number))
(options `((:toc ,toc)
@@ -179,7 +223,7 @@
title (file #f) (toc #t) (number #t))
(new container
(markup 'section)
- (ident (or ident (ast->string title)))
+ (ident (or ident (symbol->string (gensym "section"))))
(class class)
(required-options '(:title :toc :file :toc :number))
(options `((:number ,(section-number number 'section))
@@ -206,7 +250,7 @@
title (file #f) (toc #t) (number #t))
(new container
(markup 'subsection)
- (ident (or ident (ast->string title)))
+ (ident (or ident (symbol->string (gensym "subsection"))))
(class class)
(required-options '(:title :toc :file :number))
(options `((:number ,(section-number number 'subsection))
@@ -230,7 +274,7 @@
title (file #f) (toc #f) (number #t))
(new container
(markup 'subsubsection)
- (ident (or ident (ast->string title)))
+ (ident (or ident (symbol->string (gensym "subsubsection"))))
(class class)
(required-options '(:title :toc :number :file))
(options `((:number ,(section-number number 'subsubsection))
@@ -243,21 +287,40 @@
;*---------------------------------------------------------------------*/
(define-simple-markup paragraph)
+
+;*---------------------------------------------------------------------*/
+;* ~ (unbreakable space) ... */
+;*---------------------------------------------------------------------*/
+(define-markup (~ #!rest opts #!key (class #f))
+ (new markup
+ (markup '~)
+ (ident (symbol->string (gensym "~")))
+ (class class)
+ (required-options '())
+ (options (the-options opts :class))
+ (body (the-body opts))))
+
;*---------------------------------------------------------------------*/
;* footnote ... */
;*---------------------------------------------------------------------*/
(define-markup (footnote #!rest opts
- #!key (ident #f) (class "footnote") (number #f))
+ #!key (ident #f) (class "footnote") (label #t))
+ ;; The `:label' option used to be called `:number'.
(new container
(markup 'footnote)
- (ident (symbol->string (gensym 'footnote)))
+ (ident (symbol->string (gensym "footnote")))
(class class)
(required-options '())
- (options `((:number
- ,(new unresolved
- (proc (lambda (n e env)
- (resolve-counter n env 'footnote #t)))))
- ,@(the-options opts :ident :class)))
+ (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))))
;*---------------------------------------------------------------------*/
@@ -265,7 +328,7 @@
;*---------------------------------------------------------------------*/
(define-markup (linebreak #!rest opts #!key (ident #f) (class #f))
(let ((ln (new markup
- (ident (or ident (symbol->string (gensym 'linebreak))))
+ (ident (or ident (symbol->string (gensym "linebreak"))))
(class class)
(markup 'linebreak)))
(num (the-body opts)))
@@ -289,7 +352,7 @@
(width 100.) (height 1))
(new markup
(markup 'hrule)
- (ident (or ident (symbol->string (gensym 'hrule))))
+ (ident (or ident (symbol->string (gensym "hrule"))))
(class class)
(required-options '())
(options `((:width ,width)
@@ -307,14 +370,14 @@
(bg #f) (fg #f) (width #f) (margin #f))
(new container
(markup 'color)
- (ident (or ident (symbol->string (gensym 'color))))
+ (ident (or ident (symbol->string (gensym "color"))))
(class class)
(required-options '(:bg :fg :width))
(options `((:bg ,(if bg (skribe-use-color! bg) bg))
(:fg ,(if fg (skribe-use-color! fg) fg))
,@(the-options opts :ident :class :bg :fg)))
(body (the-body opts))))
-
+
;*---------------------------------------------------------------------*/
;* frame ... */
;*---------------------------------------------------------------------*/
@@ -325,7 +388,7 @@
(width #f) (margin 2) (border 1))
(new container
(markup 'frame)
- (ident (or ident (symbol->string (gensym 'frame))))
+ (ident (or ident (symbol->string (gensym "frame"))))
(class class)
(required-options '(:width :border :margin))
(options `((:margin ,margin)
@@ -346,12 +409,12 @@
(size #f) (face #f))
(new container
(markup 'font)
- (ident (or ident (symbol->string (gensym 'font))))
+ (ident (or ident (symbol->string (gensym "font"))))
(class class)
(required-options '(:size))
(options (the-options opts :ident :class))
(body (the-body opts))))
-
+
;*---------------------------------------------------------------------*/
;* flush ... */
;*---------------------------------------------------------------------*/
@@ -364,7 +427,7 @@
((center left right)
(new container
(markup 'flush)
- (ident (or ident (symbol->string (gensym 'flush))))
+ (ident (or ident (symbol->string (gensym "flush"))))
(class class)
(required-options '(:side))
(options (the-options opts :ident :class))
@@ -399,7 +462,7 @@
(skribe-error 'prog "Illegal mark" mark)
(new container
(markup 'prog)
- (ident (or ident (symbol->string (gensym 'prog))))
+ (ident (or ident (symbol->string (gensym "prog"))))
(class class)
(required-options '(:line :mark))
(options (the-options opts :ident :class :linedigit))
@@ -446,11 +509,11 @@
((and (integer? start) (integer? stop) (> start stop))
(skribe-error 'source
"start line > stop line"
- (format "~a/~a" start stop)))
+ (format #f "~a/~a" start stop)))
((and language (not (language? language)))
- (skribe-error 'source "Illegal language" language))
+ (skribe-error 'source "illegal language" language))
((and tab (not (integer? tab)))
- (skribe-error 'source "Illegal tab" tab))
+ (skribe-error 'source "illegal tab" tab))
(file
(let ((s (if (not definition)
(source-read-lines file start stop tab)
@@ -462,7 +525,7 @@
(source-fontify body language))
(else
body))))
-
+
;*---------------------------------------------------------------------*/
;* language ... */
;* ------------------------------------------------------------- */
@@ -471,12 +534,12 @@
;*---------------------------------------------------------------------*/
(define-markup (language #!key name (fontifier #f) (extractor #f))
(if (not (string? name))
- (skribe-type-error 'language "Illegal name, " name "string")
+ (skribe-type-error 'language "illegal name" name "string")
(new language
(name name)
(fontifier fontifier)
(extractor extractor))))
-
+
;*---------------------------------------------------------------------*/
;* figure ... */
;* ------------------------------------------------------------- */
@@ -496,7 +559,7 @@
(let ((s (ast->string legend)))
(if (not (string=? s ""))
s
- (symbol->string (gensym 'figure))))))
+ (symbol->string (gensym "figure"))))))
(class class)
(required-options '(:legend :number :multicolumns))
(options `((:number
@@ -505,7 +568,7 @@
(resolve-counter n env 'figure number)))))
,@(the-options opts :ident :class)))
(body (the-body opts))))
-
+
;*---------------------------------------------------------------------*/
;* parse-list-of ... */
;* ------------------------------------------------------------- */
@@ -524,23 +587,24 @@
(null? (cdr lst)))
(parse-list-of for markup (car lst)))
(else
- (let loop ((lst lst))
+ (let loop ((lst lst)
+ (result '()))
(cond
((null? lst)
- '())
+ (reverse! result))
((pair? (car lst))
- (loop (car lst)))
+ (loop (car lst) result))
(else
(let ((r (car lst)))
(if (not (is-markup? r markup))
(skribe-warning 2
for
- (format "Illegal `~a' element, `~a' expected"
+ (format #f "illegal `~a' element, `~a' expected"
(if (markup? r)
(markup-markup r)
- (find-runtime-type r))
+ (type-name r))
markup)))
- (cons r (loop (cdr lst))))))))))
+ (loop (cdr lst) (cons r result)))))))))
;*---------------------------------------------------------------------*/
;* itemize ... */
@@ -548,7 +612,7 @@
(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol)
(new container
(markup 'itemize)
- (ident (or ident (symbol->string (gensym 'itemize))))
+ (ident (or ident (symbol->string (gensym "itemize"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -560,7 +624,7 @@
(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol)
(new container
(markup 'enumerate)
- (ident (or ident (symbol->string (gensym 'enumerate))))
+ (ident (or ident (symbol->string (gensym "enumerate"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -572,7 +636,7 @@
(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol)
(new container
(markup 'description)
- (ident (or ident (symbol->string (gensym 'description))))
+ (ident (or ident (symbol->string (gensym "description"))))
(class class)
(required-options '(:symbol))
(options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
@@ -589,7 +653,7 @@
(skribe-type-error 'item "Illegal key:" key "node")
(new container
(markup 'item)
- (ident (or ident (symbol->string (gensym 'item))))
+ (ident (or ident (symbol->string (gensym "item"))))
(class class)
(required-options '(:key))
(options `((:key ,key) ,@(the-options opts :ident :class :key)))
@@ -625,22 +689,22 @@
(cond
((and frame (not (memq frame frame-vals)))
(skribe-error 'table
- (format "frame should be one of \"~a\"" frame-vals)
+ (format #f "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)
+ (format #f "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)
+ (format #f "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))))
+ (ident (or ident (symbol->string (gensym "table"))))
(class class)
(required-options '(:width :frame :rules))
(options `((:frame ,frame)
@@ -655,7 +719,7 @@
(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f))
(new container
(markup 'tr)
- (ident (or ident (symbol->string (gensym 'tr))))
+ (ident (or ident (symbol->string (gensym "tr"))))
(class class)
(required-options '())
(options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
@@ -671,7 +735,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(let ((align (if (string? align)
(string->symbol align)
align))
@@ -696,7 +760,7 @@
(else
(new container
(markup 'tc)
- (ident (or ident (symbol->string (gensym 'tc))))
+ (ident (or ident (symbol->string (gensym "tc"))))
(class class)
(required-options '(:width :align :valign :colspan))
(options `((markup ,m)
@@ -717,7 +781,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(apply tc 'th opts))
;*---------------------------------------------------------------------*/
@@ -728,7 +792,7 @@
#!key
(ident #f) (class #f)
(width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
+ (colspan 1) (rowspan 1) (bg #f))
(apply tc 'td opts))
;*---------------------------------------------------------------------*/
@@ -753,7 +817,7 @@
(else
(new markup
(markup 'image)
- (ident (or ident (symbol->string (gensym 'image))))
+ (ident (or ident (symbol->string (gensym "image"))))
(class class)
(required-options '(:file :url :width :height))
(options (the-options opts :ident :class))
@@ -801,16 +865,16 @@
;* 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
+ (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))))
@@ -823,7 +887,7 @@
(new command
(fmt format)
(body node))))
-
+
;*---------------------------------------------------------------------*/
;* processor ... */
;*---------------------------------------------------------------------*/
@@ -836,11 +900,17 @@
(skribe-error 'processor "Illegal engine" engine))
((and procedure
(or (not (procedure? procedure))
- (not (correct-arity? procedure 2))))
+ (not (let ((a (procedure-property procedure 'arity)))
+ (and (pair? a)
+ (let ((compulsory (car a))
+ (optional (cadr a))
+ (rest? (caddr a)))
+ (or rest?
+ (>= (+ compulsory optional) 2))))))))
(skribe-error 'processor "Illegal procedure" procedure))
(else
(new processor
- (combinator combinator)
+ (combinator combinator)
(engine engine)
(procedure (or procedure (lambda (n e) n)))
(body (the-body opts))))))
@@ -884,7 +954,7 @@
(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text)
(new markup
(markup 'mailto)
- (ident (or ident (symbol->string (gensym 'ident))))
+ (ident (or ident (symbol->string (gensym "ident"))))
(class class)
(required-options '(:text))
(options (the-options opts :ident :class))
@@ -893,7 +963,7 @@
;*---------------------------------------------------------------------*/
;* *mark-table* ... */
;*---------------------------------------------------------------------*/
-(define *mark-table* (make-hashtable))
+(define *mark-table* (make-hash-table))
;*---------------------------------------------------------------------*/
;* mark ... */
@@ -918,11 +988,11 @@
(let* ((bs (ast->string bd))
(n (new markup
(markup 'mark)
- (ident bs)
+ (ident (symbol->string (gensym bs)))
(class class)
(options (the-options opts :ident :class :text))
(body text))))
- (hashtable-put! *mark-table* bs n)
+ (hash-set! *mark-table* bs n)
n)))))
;*---------------------------------------------------------------------*/
@@ -954,13 +1024,13 @@
(skribe #f)
(page #f))
(define (unref ast text kind)
- (let ((msg (format "Can't find `~a': " kind)))
+ (let ((msg (format #f "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))
+ (ident (symbol->string (gensym "unref")))
(class class)
(required-options '(:text))
(options `((kind ,kind) ,@(the-options opts :ident :class)))
@@ -969,7 +1039,7 @@
(skribe-warning 1 'ref msg text)
(new markup
(markup 'unref)
- (ident (symbol->string 'unref))
+ (ident (symbol->string (gensym "unref")))
(class class)
(required-options '(:text))
(options `((kind ,kind) ,@(the-options opts :ident :class)))
@@ -987,12 +1057,36 @@
(define (handle-ref text)
(new markup
(markup 'ref)
- (ident (symbol->string 'ref))
+ (ident (symbol->string (gensym "handle-ref")))
(class class)
(required-options '(:text))
(options `((kind handle) ,@(the-options opts :ident :class)))
(body text)))
- (define (doref text kind)
+ (define (do-title-ref title kind)
+ (if (not (string? title))
+ (skribe-type-error 'ref "illegal reference" title "string")
+ (new unresolved
+ (proc (lambda (n e env)
+ (let* ((doc (ast-document n))
+ (s (find1-down
+ (lambda (n)
+ (and (is-markup? n kind)
+ (equal? (markup-option n :title)
+ title)))
+ doc)))
+ (if s
+ (new markup
+ (markup 'ref)
+ (ident (symbol->string (gensym "title-ref")))
+ (class class)
+ (required-options '(:text))
+ (options `((kind ,kind)
+ (mark ,title)
+ ,@(the-options opts :ident :class)))
+ (body (new handle
+ (ast s))))
+ (unref n title (or kind 'title)))))))))
+ (define (do-ident-ref text kind)
(if (not (string? text))
(skribe-type-error 'ref "Illegal reference" text "string")
(new unresolved
@@ -1001,7 +1095,7 @@
(if s
(new markup
(markup 'ref)
- (ident (symbol->string 'ref))
+ (ident (symbol->string (gensym "ident-ref")))
(class class)
(required-options '(:text))
(options `((kind ,kind)
@@ -1015,11 +1109,11 @@
(skribe-type-error 'mark "Illegal mark, " mark "string")
(new unresolved
(proc (lambda (n e env)
- (let ((s (hashtable-get *mark-table* mark)))
+ (let ((s (hash-ref *mark-table* mark)))
(if s
(new markup
(markup 'ref)
- (ident (symbol->string 'ref))
+ (ident (symbol->string (gensym "mark-ref")))
(class class)
(required-options '(:text))
(options `((kind mark)
@@ -1033,7 +1127,7 @@
(if s
(let* ((n (new markup
(markup 'bib-ref)
- (ident (symbol->string 'bib-ref))
+ (ident (symbol->string (gensym "bib-ref")))
(class class)
(required-options '(:text))
(options (the-options opts :ident :class))
@@ -1043,12 +1137,13 @@
(o (markup-option s 'used)))
(markup-option-add! s 'used (if (pair? o) (cons h o) (list h)))
n)
- (unref #f v 'bib))))
+ (unref #f v 'bib)))) ; FIXME: This prevents source location
+ ; info to be provided in the warning msg
(define (bib-ref text)
(if (pair? text)
(new markup
(markup 'bib-ref+)
- (ident (symbol->string 'bib-ref+))
+ (ident (symbol->string (gensym "bib-ref+")))
(class class)
(options (the-options opts :ident :class))
(body (map make-bib-ref text)))
@@ -1056,7 +1151,7 @@
(define (url-ref)
(new markup
(markup 'url-ref)
- (ident (symbol->string 'url-ref))
+ (ident (symbol->string (gensym "url-ref")))
(class class)
(required-options '(:url :text))
(options (the-options opts :ident :class))))
@@ -1067,7 +1162,7 @@
(if (pair? l)
(new markup
(markup 'line-ref)
- (ident (symbol->string 'line-ref))
+ (ident (symbol->string (gensym "line-ref")))
(class class)
(options `((:text ,(markup-ident (car l)))
,@(the-options opts :ident :class)))
@@ -1080,17 +1175,17 @@
(cond
(skribe (skribe-ref skribe))
(handle (handle-ref handle))
- (ident (doref ident #f))
- (chapter (doref chapter 'chapter))
- (section (doref section 'section))
- (subsection (doref subsection 'subsection))
- (subsubsection (doref subsubsection 'subsubsection))
- (figure (doref figure 'figure))
+ (ident (do-ident-ref ident #f))
+ (chapter (do-title-ref chapter 'chapter))
+ (section (do-title-ref section 'section))
+ (subsection (do-title-ref subsection 'subsection))
+ (subsubsection (do-title-ref subsubsection 'subsubsection))
+ (figure (do-ident-ref figure 'figure))
(mark (mark-ref mark))
(bib (bib-ref bib))
(url (url-ref))
(line (line-ref line))
- (else (skribe-error 'ref "Illegal reference" opts)))))
+ (else (skribe-error 'ref "illegal reference" opts)))))
;*---------------------------------------------------------------------*/
;* resolve ... */
@@ -1153,7 +1248,7 @@
;*---------------------------------------------------------------------*/
(define-markup (make-index ident)
(make-index-table ident))
-
+
;*---------------------------------------------------------------------*/
;* index ... */
;* ------------------------------------------------------------- */
@@ -1184,11 +1279,11 @@
"Illegal index table, "
index
"index"))))
- (m (mark (symbol->string (gensym))))
+ (m (mark (symbol->string (gensym "mark"))))
(h (new handle (ast m)))
(new (new markup
(markup '&index-entry)
- (ident (or ident (symbol->string (gensym 'index))))
+ (ident (or ident (symbol->string (gensym "index"))))
(class class)
(options `((name ,ename) ,@(the-options opts :ident :class)))
(body (if url
@@ -1197,10 +1292,12 @@
;; New is bound to a dummy option of the mark in order
;; to make new options verified.
(markup-option-add! m 'to-verify new)
- (hashtable-update! table
- ename
- (lambda (cur) (cons new cur))
- (list new))
+
+ (let ((handle (hash-get-handle table ename)))
+ (if (not handle)
+ (hash-set! table ename (list new))
+ (set-cdr! handle (cons new (cdr handle)))))
+
m))
;*---------------------------------------------------------------------*/
@@ -1227,7 +1324,7 @@
(skribe-error 'the-index "Illegal char offset" char-offset))
((not (integer? column))
(skribe-error 'the-index "Illegal column number" column))
- ((not (every? index? bd))
+ ((not (every index? bd))
(skribe-error 'the-index
"Illegal indexes"
(filter (lambda (o) (not (index? o))) bd)))
@@ -1241,3 +1338,73 @@
char-offset
header-limit
column))))))))
+
+
+;;; This part comes from the file `skribe.skr' in the original Skribe
+;;; distribution.
+
+;*---------------------------------------------------------------------*/
+;* p ... */
+;*---------------------------------------------------------------------*/
+(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location)
+ (paragraph :ident ident :class class :loc &skribe-eval-location
+ (the-body opt)))
+
+;*---------------------------------------------------------------------*/
+;* fg ... */
+;*---------------------------------------------------------------------*/
+(define-public (fg c . body)
+ (color :fg c body))
+
+;*---------------------------------------------------------------------*/
+;* bg ... */
+;*---------------------------------------------------------------------*/
+(define-public (bg c . body)
+ (color :bg c body))
+
+;*---------------------------------------------------------------------*/
+;* counter ... */
+;* ------------------------------------------------------------- */
+;* This produces a kind of "local enumeration" that is: */
+;* (counting "toto," "tutu," "titi.") */
+;* produces: */
+;* i) toto, ii) tutu, iii) titi. */
+;*---------------------------------------------------------------------*/
+(define-markup (counter #!rest opts #!key (numbering 'roman))
+ (define items (if (eq? (car opts) :numbering) (cddr opts) opts))
+ (define vroman #(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x"))
+ (define (the-roman-number num)
+ (if (< num (vector-length vroman))
+ (list (list "(" (it (vector-ref vroman num)) ") "))
+ (skribe-error 'counter
+ "too many items for roman numbering"
+ (length items))))
+ (define (the-arabic-number num)
+ (list (list "(" (it (integer->string num)) ") ")))
+ (define (the-alpha-number num)
+ (list (list "(" (it (+ (integer->char #\a) num -1)) ") ")))
+ (let ((the-number (case numbering
+ ((roman) the-roman-number)
+ ((arabic) the-arabic-number)
+ ((alpha) the-alpha-number)
+ (else (skribe-error 'counter
+ "Illegal numbering"
+ numbering)))))
+ (let loop ((num 1)
+ (items items)
+ (res '()))
+ (if (null? items)
+ (reverse! res)
+ (loop (+ num 1)
+ (cdr items)
+ (cons (list (the-number num) (car items)) res))))))
+
+;*---------------------------------------------------------------------*/
+;* q */
+;*---------------------------------------------------------------------*/
+(define-markup (q #!rest opt)
+ (new markup
+ (markup 'q)
+ (options (the-options opt))
+ (body (the-body opt))))
+
diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm
new file mode 100644
index 0000000..4f5020e
--- /dev/null
+++ b/src/guile/skribilo/package/eq.scm
@@ -0,0 +1,439 @@
+;;; eq.scm -- An equation formatting package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package eq)
+ :autoload (skribilo ast) (markup?)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo module)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :autoload (skribilo package base) (it symbol sub sup)
+ :autoload (skribilo engine lout) (lout-illustration)
+ :use-module (ice-9 optargs))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This package defines a set of markups for formatting equations. The user
+;;; may either use the standard Scheme prefix notation to represent
+;;; equations, or directly use the specific markups (which looks more
+;;; verbose).
+;;;
+;;; FIXME: This is incomplete.
+;;;
+;;; Code:
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Utilities.
+;;;
+
+(define %operators
+ '(/ * + - = != ~= < > <= >= sqrt expt sum product script
+ in notin apply))
+
+(define %symbols
+ ;; A set of symbols that are automatically recognized within an `eq' quoted
+ ;; list.
+ '(;; lower-case Greek
+ alpha beta gamma delta epsilon zeta eta theta iota kappa
+ lambda mu nu xi omicron pi rho sigma tau upsilon phi chi omega
+
+ ;; upper-case Greek
+ Alpha Beta Gamma Delta Epsilon Zeta Eta Theta Iota Kappa
+ Lambda Mu Nu Xi Omicron Pi Rho Sigma Tau Upsilon Phi Chi Omega
+
+ ;; Hebrew
+ alef
+
+ ;; mathematics
+ ellipsis weierp image real forall partial exists
+ emptyset infinity in notin nabla nipropto angle and or cap cup
+ sim cong approx neq equiv le ge subset supset subseteq supseteq
+ oplus otimes perp mid lceil rceil lfloor rfloor langle rangle))
+
+
+(define (make-fast-member-predicate lst)
+ (let ((h (make-hash-table)))
+ ;; initialize a hash table equivalent to LST
+ (for-each (lambda (s) (hashq-set! h s #t)) lst)
+
+ ;; the run-time, fast, definition
+ (lambda (sym)
+ (hashq-ref h sym #f))))
+
+(define-public known-operator? (make-fast-member-predicate %operators))
+(define-public known-symbol? (make-fast-member-predicate %symbols))
+
+(define-public equation-markup-name?
+ (make-fast-member-predicate (map (lambda (s)
+ (symbol-append 'eq: s))
+ %operators)))
+
+(define-public (equation-markup? m)
+ "Return true if @var{m} is an instance of one of the equation sub-markups."
+ (and (markup? m)
+ (equation-markup-name? (markup-markup m))))
+
+(define-public (equation-markup-name->operator m)
+ "Given symbol @var{m} (an equation markup name, e.g., @code{eq:+}), return
+a symbol representing the mathematical operator denoted by @var{m} (e.g.,
+@code{+})."
+ (if (equation-markup-name? m)
+ (string->symbol (let ((str (symbol->string m)))
+ (substring str
+ (+ 1 (string-index str #\:))
+ (string-length str))))
+ #f))
+
+
+;;;
+;;; Operator precedence.
+;;;
+
+(define %operator-precedence
+ ;; FIXME: This needs to be augmented.
+ '((+ . 1)
+ (- . 1)
+ (* . 2)
+ (/ . 2)
+ (sum . 3)
+ (product . 3)
+ (= . 0)
+ (< . 0)
+ (> . 0)
+ (<= . 0)
+ (>= . 0)))
+
+(define-public (operator-precedence op)
+ (let ((p (assq op %operator-precedence)))
+ (if (pair? p) (cdr p) 0)))
+
+
+
+;;;
+;;; Turning an S-exp into an `eq' markup.
+;;;
+
+(define %rebindings
+ (map (lambda (sym)
+ (list sym (symbol-append 'eq: sym)))
+ %operators))
+
+(define (eq:symbols->strings equation)
+ "Turn symbols located in non-@code{car} positions into strings."
+ (cond ((list? equation)
+ (if (or (null? equation) (null? (cdr equation)))
+ equation
+ (cons (car equation) ;; XXX: not tail-recursive
+ (map eq:symbols->strings (cdr equation)))))
+ ((symbol? equation)
+ (if (known-symbol? equation)
+ `(symbol ,(symbol->string equation))
+ (symbol->string equation)))
+ (else equation)))
+
+(define-public (eq-evaluate equation)
+ "Evaluate @var{equation}, an sexp (list) representing an equation, e.g.
+@code{'(+ a (/ b 3))}."
+ (eval `(let ,%rebindings ,(eq:symbols->strings equation))
+ (current-module)))
+
+
+
+;;;
+;;; Markup.
+;;;
+
+(define-markup (eq :rest opts :key (ident #f) (inline? #f)
+ (renderer #f) (class "eq"))
+ (new markup
+ (markup 'eq)
+ (ident (or ident (symbol->string (gensym "eq"))))
+ (options (the-options opts))
+ (body (let loop ((body (the-body opts))
+ (result '()))
+ (if (null? body)
+ result
+ (loop (cdr body)
+ (if (markup? (car body))
+ (car body) ;; the `eq:*' markups were used
+ ;; directly
+ (eq-evaluate (car body))) ;; a quoted list was
+ ;; passed
+ ))))))
+
+(define-simple-markup eq:/)
+(define-simple-markup eq:*)
+(define-simple-markup eq:+)
+(define-simple-markup eq:-)
+
+(define-simple-markup eq:=)
+(define-simple-markup eq:!=)
+(define-simple-markup eq:~=)
+(define-simple-markup eq:<)
+(define-simple-markup eq:>)
+(define-simple-markup eq:>=)
+(define-simple-markup eq:<=)
+
+(define-simple-markup eq:sqrt)
+(define-simple-markup eq:expt)
+
+(define-markup (eq:sum :rest opts :key (ident #f) (class "eq:sum")
+ (from #f) (to #f))
+ (new markup
+ (markup 'eq:sum)
+ (ident (or ident (symbol->string (gensym "eq:sum"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (eq:product :rest opts :key (ident #f) (class "eq:product")
+ (from #f) (to #f))
+ (new markup
+ (markup 'eq:product)
+ (ident (or ident (symbol->string (gensym "eq:product"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (eq:script :rest opts :key (ident #f) (class "eq:script")
+ (sub #f) (sup #f))
+ (new markup
+ (markup 'eq:script)
+ (ident (or ident (symbol->string (gensym "eq:script"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-simple-markup eq:in)
+(define-simple-markup eq:notin)
+
+(define-markup (eq:apply :rest opts :key (ident #f) (class "eq:apply"))
+ ;; This markup may receive either a list of arguments or arguments
+ ;; compatible with the real `apply'. Note: the real `apply' can take N
+ ;; non-list arguments but the last one has to be a list.
+ (new markup
+ (markup 'eq:apply)
+ (ident (or ident (symbol->string (gensym "eq:apply"))))
+ (options (the-options opts))
+ (body (let loop ((body (the-body opts))
+ (result '()))
+ (if (null? body)
+ (reverse! result)
+ (let ((first (car body)))
+ (if (list? first)
+ (if (null? (cdr body))
+ (append (reverse! result) first)
+ (skribe-error 'eq:apply
+ "wrong argument type"
+ body))
+ (loop (cdr body) (cons first result)))))))))
+
+
+
+;;;
+;;; Text-based rendering.
+;;;
+
+
+(markup-writer 'eq (find-engine 'base)
+ :action (lambda (node engine)
+ ;; The `:renderer' option should be a symbol (naming an engine
+ ;; class) or an engine or engine class. This allows the use of
+ ;; another engine to render equations. For instance, equations
+ ;; may be rendered using the Lout engine within an HTML
+ ;; document.
+ (let ((renderer (markup-option node :renderer)))
+ (cond ((not renderer) ;; default: use the current engine
+ (output (it (markup-body node)) engine))
+ ((symbol? renderer)
+ (case renderer
+ ;; FIXME: We should have an `embed' slot for each
+ ;; engine class similar to `lout-illustration'.
+ ((lout)
+ (let ((lout-code
+ (with-output-to-string
+ (lambda ()
+ (output node (find-engine 'lout))))))
+ (output (lout-illustration
+ :ident (markup-ident node)
+ lout-code)
+ engine)))
+ (else
+ (skribe-error 'eq "invalid renderer" renderer))))
+ ;; FIXME: `engine?' and `engine-class?'
+ (else
+ (skribe-error 'eq "`:renderer' -- wrong argument type"
+ renderer))))))
+
+(define-macro (simple-markup-writer op . obj)
+ ;; Note: The text-only rendering is less ambiguous if we parenthesize
+ ;; without taking operator precedence into account.
+ (let ((precedence (operator-precedence op)))
+ `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base)
+ :action (lambda (node engine)
+ (let loop ((operands (markup-body node)))
+ (if (null? operands)
+ #t
+ (let* ((o (car operands))
+ (nested-eq? (equation-markup? o))
+ (need-paren?
+ (and nested-eq?
+; (< (operator-precedence
+; (equation-markup-name->operator
+; (markup-markup o)))
+; ,precedence)
+ )
+ ))
+
+ (display (if need-paren? "(" ""))
+ (output o engine)
+ (display (if need-paren? ")" ""))
+ (if (pair? (cdr operands))
+ (begin
+ (display " ")
+ (output ,(if (null? obj)
+ (symbol->string op)
+ (car obj))
+ engine)
+ (display " ")))
+ (loop (cdr operands)))))))))
+
+(simple-markup-writer +)
+(simple-markup-writer -)
+(simple-markup-writer /)
+(simple-markup-writer * (symbol "times"))
+
+(simple-markup-writer =)
+(simple-markup-writer != (symbol "neq"))
+(simple-markup-writer ~= (symbol "approx"))
+(simple-markup-writer <)
+(simple-markup-writer >)
+(simple-markup-writer >= (symbol "ge"))
+(simple-markup-writer <= (symbol "le"))
+
+(markup-writer 'eq:sqrt (find-engine 'base)
+ :action (lambda (node engine)
+ (display "sqrt(")
+ (output (markup-body node) engine)
+ (display ")")))
+
+(define-macro (simple-binary-markup-writer op obj)
+ `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((body (markup-body node)))
+ (if (= (length body) 2)
+ (let ((first (car body))
+ (second (cadr body)))
+ (display (if (equation-markup? first) "(" " "))
+ (output first engine)
+ (display (if (equation-markup? first) ")" " "))
+ (output ,obj engine)
+ (display (if (equation-markup? second) "(" ""))
+ (output second engine)
+ (display (if (equation-markup? second) ")" "")))
+ (skribe-error ',(symbol-append 'eq: op)
+ "wrong argument type"
+ body))))))
+
+(markup-writer 'eq:expt (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((body (markup-body node)))
+ (if (= (length body) 2)
+ (let ((first (car body))
+ (second (cadr body)))
+ (display (if (equation-markup? first) "(" ""))
+ (output first engine)
+ (display (if (equation-markup? first) ")" ""))
+ (output (sup second) engine))))))
+
+(simple-binary-markup-writer in (symbol "in"))
+(simple-binary-markup-writer notin (symbol "notin"))
+
+(markup-writer 'eq:apply (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((func (car (markup-body node))))
+ (output func engine)
+ (display "(")
+ (let loop ((operands (cdr (markup-body node))))
+ (if (null? operands)
+ #t
+ (begin
+ (output (car operands) engine)
+ (if (not (null? (cdr operands)))
+ (display ", "))
+ (loop (cdr operands)))))
+ (display ")"))))
+
+(markup-writer 'eq:sum (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((from (markup-option node :from))
+ (to (markup-option node :to)))
+ (output (symbol "Sigma") engine)
+ (display "(")
+ (output from engine)
+ (display ", ")
+ (output to engine)
+ (display ", ")
+ (output (markup-body node) engine)
+ (display ")"))))
+
+(markup-writer 'eq:prod (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((from (markup-option node :from))
+ (to (markup-option node :to)))
+ (output (symbol "Pi") engine)
+ (display "(")
+ (output from engine)
+ (display ", ")
+ (output to engine)
+ (display ", ")
+ (output (markup-body node) engine)
+ (display ")"))))
+
+(markup-writer 'eq:script (find-engine 'base)
+ :action (lambda (node engine)
+ (let ((body (markup-body node))
+ (sup* (markup-option node :sup))
+ (sub* (markup-option node :sub)))
+ (output body engine)
+ (output (sup sup*) engine)
+ (output (sub sub*) engine))))
+
+
+
+
+;;;
+;;; Initialization.
+;;;
+
+(when-engine-is-loaded 'lout
+ (lambda ()
+ (resolve-module '(skribilo package eq lout))))
+
+
+;;; arch-tag: 58764650-2684-47a6-8cc7-6288f2b474da
+
+;;; eq.scm ends here
diff --git a/src/guile/skribilo/package/eq/Makefile.am b/src/guile/skribilo/package/eq/Makefile.am
new file mode 100644
index 0000000..c7b4f93
--- /dev/null
+++ b/src/guile/skribilo/package/eq/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package/eq
+dist_guilemodule_DATA = lout.scm
+
+## arch-tag: 3e816c9a-7989-4baa-b38b-a095a5428ba1
diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm
new file mode 100644
index 0000000..c487b85
--- /dev/null
+++ b/src/guile/skribilo/package/eq/lout.scm
@@ -0,0 +1,217 @@
+;;; lout.scm -- Lout implementation of the `eq' package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package eq lout)
+ :use-module (skribilo package eq)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (ice-9 optargs))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Initialization.
+;;;
+
+(let ((lout (find-engine 'lout)))
+ (if (not lout)
+ (skribe-error 'eq "Lout engine not found" lout)
+ (let ((includes (engine-custom lout 'includes)))
+ ;; Append the `eq' include file
+ (engine-custom-set! lout 'includes
+ (string-append includes "\n"
+ "@SysInclude { eq }\n")))))
+
+
+;;;
+;;; Simple markup writers.
+;;;
+
+
+(markup-writer 'eq (find-engine 'lout)
+ :options '(:inline?)
+ :before "{ "
+ :action (lambda (node engine)
+ (display (if (markup-option node :inline?)
+ "@E { "
+ "@Eq { "))
+ (let ((eq (markup-body node)))
+ ;;(fprint (current-error-port) "eq=" eq)
+ (output eq engine)))
+ :after " } }")
+
+
+
+(define-macro (simple-lout-markup-writer sym . args)
+ (let* ((lout-name (if (null? args)
+ (symbol->string sym)
+ (car args)))
+ (parentheses? (if (or (null? args) (null? (cdr args)))
+ #t
+ (cadr args)))
+ (precedence (operator-precedence sym))
+
+ ;; Note: We could use `pmatrix' here but it precludes line-breaking
+ ;; within equations.
+ (open-par `(if need-paren? "{ @VScale ( }" ""))
+ (close-par `(if need-paren? "{ @VScale ) }" "")))
+
+ `(markup-writer ',(symbol-append 'eq: sym)
+ (find-engine 'lout)
+ :action (lambda (node engine)
+ (let loop ((operands (markup-body node)))
+ (if (null? operands)
+ #t
+ (let* ((op (car operands))
+ (eq-op? (equation-markup? op))
+ (need-paren?
+ (and eq-op?
+ (< (operator-precedence
+ (equation-markup-name->operator
+ (markup-markup op)))
+ ,precedence)))
+ (column (port-column
+ (current-output-port))))
+
+ ;; Work around Lout's limitations...
+ (if (> column 1000) (display "\n"))
+
+ (display (string-append " { "
+ ,(if parentheses?
+ open-par
+ "")))
+ (output op engine)
+ (display (string-append ,(if parentheses?
+ close-par
+ "")
+ " }"))
+ (if (pair? (cdr operands))
+ (display ,(string-append " "
+ lout-name
+ " ")))
+ (loop (cdr operands)))))))))
+
+
+;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their
+;; operands do not need to be enclosed in parentheses. OTOH, since we use a
+;; horizontal bar of `/', we don't need to parenthesize its arguments.
+
+
+(simple-lout-markup-writer +)
+(simple-lout-markup-writer * "times")
+(simple-lout-markup-writer - "-")
+(simple-lout-markup-writer / "over" #f)
+(simple-lout-markup-writer =)
+(simple-lout-markup-writer <)
+(simple-lout-markup-writer >)
+(simple-lout-markup-writer <=)
+(simple-lout-markup-writer >=)
+
+(define-macro (binary-lout-markup-writer sym lout-name)
+ `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((body (markup-body node)))
+ (if (= (length body) 2)
+ (let* ((first (car body))
+ (second (cadr body))
+ (parentheses? (equation-markup? first)))
+ (display " { { ")
+ (if parentheses? (display "("))
+ (output first engine)
+ (if parentheses? (display ")"))
+ (display ,(string-append " } " lout-name " { "))
+ (output second engine)
+ (display " } } "))
+ (skribe-error ,(symbol-append 'eq: sym)
+ "wrong number of arguments"
+ body))))))
+
+(binary-lout-markup-writer expt "sup")
+(binary-lout-markup-writer in "element")
+(binary-lout-markup-writer notin "notelement")
+
+(markup-writer 'eq:apply (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((func (car (markup-body node))))
+ (output func engine)
+ (display "(")
+ (let loop ((operands (cdr (markup-body node))))
+ (if (null? operands)
+ #t
+ (begin
+ (output (car operands) engine)
+ (if (not (null? (cdr operands)))
+ (display ", "))
+ (loop (cdr operands)))))
+ (display ")"))))
+
+
+
+;;;
+;;; Sums, products, integrals, etc.
+;;;
+
+(define-macro (range-lout-markup-writer sym lout-name)
+ `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((from (markup-option node :from))
+ (to (markup-option node :to))
+ (body (markup-body node)))
+ (display ,(string-append " { big " lout-name
+ " from { "))
+ (output from engine)
+ (display " } to { ")
+ (output to engine)
+ (display " } { ")
+ (output body engine)
+ (display " } } ")))))
+
+(range-lout-markup-writer sum "sum")
+(range-lout-markup-writer product "prod")
+
+(markup-writer 'eq:script (find-engine 'lout)
+ :action (lambda (node engine)
+ (let ((body (markup-body node))
+ (sup (markup-option node :sup))
+ (sub (markup-option node :sub)))
+ (display " { { ")
+ (output body engine)
+ (display " } ")
+ (if sup
+ (begin
+ (display (if sub " supp { " " sup { "))
+ (output sup engine)
+ (display " } ")))
+ (if sub
+ (begin
+ (display " on { ")
+ (output sub engine)
+ (display " } ")))
+ (display " } "))))
+
+
+;;; arch-tag: 2a1410e5-977e-4600-b781-3d57f4409b35
diff --git a/src/guile/skribilo/package/french.scm b/src/guile/skribilo/package/french.scm
new file mode 100644
index 0000000..a23d1da
--- /dev/null
+++ b/src/guile/skribilo/package/french.scm
@@ -0,0 +1,30 @@
+;;; french.scm -- French Skribe style
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package french))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX configuration */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le 'usepackage
+ (string-append (engine-custom le 'usepackage)
+ "\\usepackage[french]{babel}
+\\usepackage{a4}")))
diff --git a/src/guile/skribilo/package/jfp.scm b/src/guile/skribilo/package/jfp.scm
new file mode 100644
index 0000000..913b3e3
--- /dev/null
+++ b/src/guile/skribilo/package/jfp.scm
@@ -0,0 +1,328 @@
+;;; jfp.scm -- The Skribe style for JFP articles.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package jfp))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX global customizations */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le 'documentclass "\\documentclass{jfp}")
+ (engine-custom-set! le 'hyperref #f)
+ ;; &latex-author
+ (markup-writer '&latex-author le
+ :action (lambda (n e)
+ (define (&latex-subauthor)
+ (let* ((d (ast-document n))
+ (sa (and (is-markup? d 'document)
+ (markup-option d :head-author))))
+ (if sa
+ (begin
+ (display "[")
+ (output sa e)
+ (display "]")))))
+ (define (&latex-author-1 n)
+ (display "\\author")
+ (&latex-subauthor)
+ (display "{\n")
+ (output n e)
+ (display "}\n"))
+ (define (&latex-author-n n)
+ (display "\\author")
+ (&latex-subauthor)
+ (display "{\n")
+ (output (car n) e)
+ (for-each (lambda (a)
+ (display "\\and ")
+ (output a e))
+ (cdr n))
+ (display "}\n"))
+ (let ((body (markup-body n)))
+ (cond
+ ((is-markup? body 'author)
+ (&latex-author-1 body))
+ ((and (list? body)
+ (every? (lambda (b) (is-markup? b 'author))
+ body))
+ (&latex-author-n body))
+ (else
+ (skribe-error 'author
+ "Illegal `jfp' author"
+ body))))))
+ ;; title
+ (markup-writer '&latex-title le
+ :before (lambda (n e)
+ (let* ((d (ast-document n))
+ (st (and (is-markup? d 'document)
+ (markup-option d :head-title))))
+ (if st
+ (begin
+ (display "\\title[")
+ (output st e)
+ (display "]{"))
+ (display "\\title{"))))
+ :after "}\n")
+ ;; author
+ (let ((old-author (markup-writer-get 'author le)))
+ (markup-writer 'author le
+ :options (writer-options old-author)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (aff (markup-option n :affiliation))
+ (addr (markup-option n :address))
+ (email (markup-option n :email)))
+ (if name
+ (begin
+ (output name e)
+ (display "\\\\\n")))
+ (if aff
+ (begin
+ (output aff e)
+ (display "\\\\\n")))
+ (if addr
+ (begin
+ (if (pair? addr)
+ (for-each (lambda (a)
+ (output a e)
+ (display "\\\\\n"))
+ addr)
+ (begin
+ (output addr e)
+ (display "\\\\\n")))))
+ (if email
+ (begin
+ (display "\\email{")
+ (output email e)
+ (display "}\\\\\n")))))))
+ ;; bib-ref
+ (markup-writer 'bib-ref le
+ :options '(:bib :text :key)
+ :before "("
+ :action (lambda (n e)
+ (let ((be (handle-ast (markup-body n))))
+ (if (is-markup? be '&bib-entry)
+ (let ((a (markup-option be 'author))
+ (y (markup-option be 'year)))
+ (cond
+ ((and (is-markup? a '&bib-entry-author)
+ (is-markup? y '&bib-entry-year))
+ (let ((ba (markup-body a)))
+ (if (not (string? ba))
+ (output ba e)
+ (let* ((s1 (pregexp-replace* " and "
+ ba
+ " \\& "))
+ (s2 (pregexp-replace* ", [^ ]+"
+ s1
+ "")))
+ (output s2 e)
+ (display ", ")
+ (output y e)))))
+ ((is-markup? y '&bib-entry-year)
+ (skribe-error 'bib-ref
+ "Missing `name' entry"
+ (markup-ident be)))
+ (else
+ (let ((ba (markup-body a)))
+ (if (not (string? ba))
+ (output ba e)
+ (let* ((s1 (pregexp-replace* " and "
+ ba
+ " \\& "))
+ (s2 (pregexp-replace* ", [^ ]+"
+ s1
+ "")))
+ (output s2 e)))))))
+ (skribe-error 'bib-ref
+ "Illegal bib-ref"
+ (markup-ident be)))))
+ :after ")")
+ ;; bib-ref/text
+ (markup-writer 'bib-ref le
+ :options '(:bib :text :key)
+ :predicate (lambda (n e)
+ (markup-option n :key))
+ :action (lambda (n e)
+ (output (markup-option n :key) e)))
+ ;; &the-bibliography
+ (markup-writer '&the-bibliography le
+ :before (lambda (n e)
+ (display "{%
+\\sloppy
+\\sfcode`\\.=1000\\relax
+\\newdimen\\bibindent
+\\bibindent=0em
+\\begin{list}{}{%
+ \\settowidth\\labelwidth{[]}%
+ \\leftmargin\\labelwidth
+ \\advance\\leftmargin\\labelsep
+ \\advance\\leftmargin\\bibindent
+ \\itemindent -\\bibindent
+ \\listparindent \\itemindent
+ }%\n"))
+ :after (lambda (n e)
+ (display "\n\\end{list}}\n")))
+ ;; bib-entry
+ (markup-writer '&bib-entry le
+ :options '(:title)
+ :action (lambda (n e)
+ (output n e (markup-writer-get '&bib-entry-body e)))
+ :after "\n")
+ ;; %bib-entry-title
+ (markup-writer '&bib-entry-title le
+ :action (lambda (n e)
+ (output (markup-body n) e)))
+ ;; %bib-entry-body
+ (markup-writer '&bib-entry-body le
+ :action (lambda (n e)
+ (define (output-fields descr)
+ (display "\\item[")
+ (let loop ((descr descr)
+ (pending #f)
+ (armed #f)
+ (first #t))
+ (cond
+ ((null? descr)
+ 'done)
+ ((pair? (car descr))
+ (if (eq? (caar descr) 'or)
+ (let ((o1 (cadr (car descr))))
+ (if (markup-option n o1)
+ (loop (cons o1 (cdr descr))
+ pending
+ #t
+ #f)
+ (let ((o2 (caddr (car descr))))
+ (loop (cons o2 (cdr descr))
+ pending
+ armed
+ #f))))
+ (let ((o (markup-option n (cadr (car descr)))))
+ (if o
+ (begin
+ (if (and pending armed)
+ (output pending e))
+ (output (caar descr) e)
+ (output o e)
+ (if (pair? (cddr (car descr)))
+ (output (caddr (car descr)) e))
+ (loop (cdr descr) #f #t #f))
+ (loop (cdr descr) pending armed #f)))))
+ ((symbol? (car descr))
+ (let ((o (markup-option n (car descr))))
+ (if o
+ (begin
+ (if (and armed pending)
+ (output pending e))
+ (output o e)
+ (if first
+ (display "]"))
+ (loop (cdr descr) #f #t #f))
+ (loop (cdr descr) pending armed #f))))
+ ((null? (cdr descr))
+ (output (car descr) e))
+ ((string? (car descr))
+ (loop (cdr descr)
+ (if pending pending (car descr))
+ armed
+ #f))
+ (else
+ (skribe-error 'output-bib-fields
+ "Illegal description"
+ (car descr))))))
+ (output-fields
+ (case (markup-option n 'kind)
+ ((techreport)
+ `(author (" (" year ")") " " (or title url) ". "
+ number ", " institution ", "
+ address ", " month ", "
+ ("pp. " pages) "."))
+ ((article)
+ `(author (" (" year ")") " " (or title url) ". "
+ journal ", " volume ", " ("(" number ")") ", "
+ address ", " month ", "
+ ("pp. " pages) "."))
+ ((inproceedings)
+ `(author (" (" year ")") " " (or title url) ". "
+ book(or title url) ", " series ", " ("(" number ")") ", "
+ address ", " month ", "
+ ("pp. " pages) "."))
+ ((book)
+ '(author (" (" year ")") " " (or title url) ". "
+ publisher ", " address
+ ", " month ", " ("pp. " pages) "."))
+ ((phdthesis)
+ '(author (" (" year ")") " " (or title url) ". " type ", "
+ school ", " address
+ ", " month "."))
+ ((misc)
+ '(author (" (" year ")") " " (or title url) ". "
+ publisher ", " address
+ ", " month "."))
+ (else
+ '(author (" (" year ")") " " (or title url) ". "
+ publisher ", " address
+ ", " month ", " ("pp. " pages) "."))))))
+ ;; abstract
+ (markup-writer 'jfp-abstract le
+ :options '(postscript)
+ :before "\\begin{abstract}\n"
+ :after "\\end{abstract}\n"))
+
+;*---------------------------------------------------------------------*/
+;* HTML global customizations */
+;*---------------------------------------------------------------------*/
+(let ((he (find-engine 'html)))
+ (markup-writer '&html-jfp-abstract he
+ :action (lambda (n e)
+ (let* ((bg (engine-custom e 'abstract-background))
+ (exp (p (if bg
+ (center (color :bg bg :width 90.
+ (it (markup-body n))))
+ (it (markup-body n))))))
+ (skribe-eval exp e)))))
+
+;*---------------------------------------------------------------------*/
+;* abstract ... */
+;*---------------------------------------------------------------------*/
+(define-markup (abstract #!rest opt #!key postscript)
+ (if (engine-format? "latex")
+ (new markup
+ (markup 'jfp-abstract)
+ (body (p (the-body opt))))
+ (let ((a (new markup
+ (markup '&html-jfp-abstract)
+ (body (the-body opt)))))
+ (list (if postscript
+ (section :number #f :toc #f :title "Postscript download"
+ postscript))
+ (section :number #f :toc #f :title "Abstract" a)
+ (section :number #f :toc #f :title "Table of contents"
+ (toc :subsection #t))))))
+
+;*---------------------------------------------------------------------*/
+;* references ... */
+;*---------------------------------------------------------------------*/
+(define (references)
+ (list "\n\n"
+ (section :title "References" :class "references"
+ :number (not (engine-format? "latex"))
+ (font :size -1 (the-bibliography)))))
+
diff --git a/src/guile/skribilo/package/letter.scm b/src/guile/skribilo/package/letter.scm
new file mode 100644
index 0000000..91d45be
--- /dev/null
+++ b/src/guile/skribilo/package/letter.scm
@@ -0,0 +1,157 @@
+;;; letter.scm -- Skribe style for letters
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package letter))
+
+;*---------------------------------------------------------------------*/
+;* document */
+;*---------------------------------------------------------------------*/
+(define %letter-document document)
+
+(define-markup (document #!rest opt
+ #!key (ident #f) (class "letter")
+ where date author
+ &skribe-eval-location)
+ (let* ((ubody (the-body opt))
+ (body (list (new markup
+ (markup '&letter-where)
+ (loc &skribe-eval-location)
+ (options `((:where ,where)
+ (:date ,date)
+ (:author ,author))))
+ ubody)))
+ (apply %letter-document
+ :author #f :title #f
+ (append (apply append
+ (the-options opt :where :date :author :title))
+ body))))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX configuration */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n")
+ (engine-custom-set! le 'maketitle #f)
+ ;; &letter-where
+ (markup-writer '&letter-where le
+ :before "\\begin{raggedright}\n"
+ :action (lambda (n e)
+ (let* ((w (markup-option n :where))
+ (d (markup-option n :date))
+ (a (markup-option n :author))
+ (hd (if (and w d)
+ (list w ", " d)
+ (or w d)))
+ (ne (copy-engine 'author e)))
+ ;; author
+ (markup-writer 'author ne
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align :header)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone)))
+ (define (row n)
+ (output n e)
+ (when hd
+ (display "\\hfill ")
+ (output hd e)
+ (set! hd #f))
+ (display "\\\\\n"))
+ ;; name
+ (if name (row name))
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (if (pair? address)
+ (for-each row address))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url)))))
+ ;; emit the author
+ (if a
+ (output a ne)
+ (output hd e))))
+ :after "\\end{raggedright}\n\\vspace{1cm}\n\n"))
+
+;*---------------------------------------------------------------------*/
+;* HTML configuration */
+;*---------------------------------------------------------------------*/
+(let ((he (find-engine 'html)))
+ ;; &letter-where
+ (markup-writer '&letter-where he
+ :before "<table width=\"100%\">\n"
+ :action (lambda (n e)
+ (let* ((w (markup-option n :where))
+ (d (markup-option n :date))
+ (a (markup-option n :author))
+ (hd (if (and w d)
+ (list w ", " d)
+ (or w d)))
+ (ne (copy-engine 'author e)))
+ ;; author
+ (markup-writer 'author ne
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align :header)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone)))
+ (define (row n)
+ (display "<tr><td align='left'>")
+ (output n e)
+ (when hd
+ (display "</td><td align='right'>")
+ (output hd e)
+ (set! hd #f))
+ (display "</td></tr>\n"))
+ ;; name
+ (if name (row name))
+ ;; title
+ (if title (row title))
+ ;; affiliation
+ (if affiliation (row affiliation))
+ ;; address
+ (if (pair? address)
+ (for-each row address))
+ ;; telephone
+ (if phone (row phone))
+ ;; email
+ (if email (row email))
+ ;; url
+ (if url (row url)))))
+ ;; emit the author
+ (if a
+ (output a ne)
+ (output hd e))))
+ :after "</table>\n<hr>\n\n"))
+
+
diff --git a/src/guile/skribilo/package/lncs.scm b/src/guile/skribilo/package/lncs.scm
new file mode 100644
index 0000000..8ffa7da
--- /dev/null
+++ b/src/guile/skribilo/package/lncs.scm
@@ -0,0 +1,158 @@
+;;; lncs.scm -- The Skribe style for LNCS articles.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package lncs))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX global customizations */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le 'documentclass "\\documentclass{llncs}")
+ ;; &latex-author
+ (markup-writer '&latex-author le
+ :action (lambda (n e)
+ (define (&latex-inst-body n)
+ (let ((affiliation (markup-option n :affiliation))
+ (address (markup-option n :address)))
+ (when affiliation (output affiliation e) (display ", "))
+ (when address
+ (for-each (lambda (a) (output a e) (display " "))
+ address)
+ (newline))))
+ (define (&latex-inst-n i)
+ (display "\\institute{\n")
+ (&latex-inst-body (car i))
+ (for-each (lambda (n)
+ (display "\\and\n")
+ (&latex-inst-body n))
+ (cdr i))
+ (display "}\n"))
+ (define (&latex-author-1 n)
+ (display "\\author{\n")
+ (output n e)
+ (display "}\n"))
+ (define (&latex-author-n n)
+ (display "\\author{\n")
+ (output (car n) e)
+ (for-each (lambda (a)
+ (display " and ")
+ (output a e))
+ (cdr n))
+ (display "}\n"))
+ (let ((body (markup-body n)))
+ (cond
+ ((is-markup? body 'author)
+ (markup-option-add! n 'inst 1)
+ (&latex-author-1 body)
+ (&latex-inst-n (list body)))
+ ((and (list? body)
+ (every? (lambda (b) (is-markup? b 'author))
+ body))
+ (define (institute=? n1 n2)
+ (let ((aff1 (markup-option n1 :affiliation))
+ (add1 (markup-option n1 :address))
+ (aff2 (markup-option n2 :affiliation))
+ (add2 (markup-option n2 :address)))
+ (and (equal? aff1 aff2) (equal? add1 add2))))
+ (define (search-institute n i j)
+ (cond
+ ((null? i)
+ #f)
+ ((institute=? n (car i))
+ j)
+ (else
+ (search-institute n (cdr i) (- j 1)))))
+ (if (null? (cdr body))
+ (begin
+ (markup-option-add! (car body) 'inst 1)
+ (&latex-author-1 (car body))
+ (&latex-inst-n body))
+ ;; collect the institutes
+ (let loop ((ns body)
+ (is '())
+ (j 1))
+ (if (null? ns)
+ (begin
+ (&latex-author-n body)
+ (&latex-inst-n (reverse! is)))
+ (let* ((n (car ns))
+ (si (search-institute n is (- j 1))))
+ (if (integer? si)
+ (begin
+ (markup-option-add! n 'inst si)
+ (loop (cdr ns) is j))
+ (begin
+ (markup-option-add! n 'inst j)
+ (loop (cdr ns)
+ (cons n is)
+ (+ 1 j)))))))))
+ (else
+ (skribe-error 'author
+ "Illegal `lncs' author"
+ body))))))
+ ;; author
+ (let ((old-author (markup-writer-get 'author le)))
+ (markup-writer 'author le
+ :options (writer-options old-author)
+ :action (lambda (n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (inst (markup-option n 'inst)))
+ (if name (output name e))
+ (if title (output title e))
+ (if inst (printf "\\inst{~a}\n" inst)))))))
+
+;*---------------------------------------------------------------------*/
+;* HTML global customizations */
+;*---------------------------------------------------------------------*/
+(let ((he (find-engine 'html)))
+ (markup-writer '&html-lncs-abstract he
+ :action (lambda (n e)
+ (let* ((bg (or (engine-custom e 'abstract-background)
+ "#cccccc"))
+ (exp (p (center (color :bg bg :width 90.
+ (markup-body n))))))
+ (skribe-eval exp e)))))
+
+;*---------------------------------------------------------------------*/
+;* abstract ... */
+;*---------------------------------------------------------------------*/
+(define-markup (abstract #!rest opt #!key postscript)
+ (if (engine-format? "latex")
+ (section :number #f :title "ABSTRACT" (p (the-body opt)))
+ (let ((a (new markup
+ (markup '&html-lncs-abstract)
+ (body (the-body opt)))))
+ (list (if postscript
+ (section :number #f :toc #f :title "Postscript download"
+ postscript))
+ (section :number #f :toc #f :title "Abstract" a)
+ (section :number #f :toc #f :title "Table of contents"
+ (toc :subsection #t))))))
+
+;*---------------------------------------------------------------------*/
+;* references ... */
+;*---------------------------------------------------------------------*/
+(define (references)
+ (list "\n\n"
+ (if (engine-format? "latex")
+ (font :size -1 (flush :side 'left (the-bibliography)))
+ (section :title "References"
+ (font :size -1 (the-bibliography))))))
diff --git a/src/guile/skribilo/package/pie.scm b/src/guile/skribilo/package/pie.scm
new file mode 100644
index 0000000..8ccf858
--- /dev/null
+++ b/src/guile/skribilo/package/pie.scm
@@ -0,0 +1,314 @@
+;;; pie.scm -- An pie-chart formatting package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package pie)
+ :autoload (skribilo ast) (markup? markup-ident ast-parent)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib) ;; `skribe-error' et al.
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (skribilo utils strings) ;; `make-string-replace'
+ :use-module (skribilo module)
+ :autoload (skribilo color) (skribe-color->rgb)
+ :autoload (skribilo package base) (bold)
+ :autoload (skribilo engine lout) (lout-illustration)
+ :autoload (ice-9 popen) (open-output-pipe)
+ :use-module (ice-9 optargs)
+ :export (%ploticus-program %ploticus-debug?
+ pie-sliceweight-value pie-remove-markup))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Markup.
+;;;
+
+(define-markup (pie :rest opts
+ :key (ident #f) (title "Pie Chart")
+ (initial-angle 0) (total #f) (radius 3)
+ (fingers? #t) (labels 'outside)
+ (class "pie"))
+ (new container
+ (markup 'pie)
+ (ident (or ident (symbol->string (gensym "pie"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (slice :rest opts
+ :key (ident #f) (weight 1) (color "white") (detach? #f))
+ (new container
+ (markup 'slice)
+ (ident (or ident (symbol->string (gensym "slice"))))
+ (weight weight)
+ (color color)
+ (detach? detach?)
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (sliceweight :rest opts
+ :key (ident #f) (percentage? #f))
+ (new markup
+ (markup 'sliceweight)
+ (ident (or ident (symbol->string (gensym "sliceweight"))))
+ (percentage? percentage?)
+ (options (the-options opts))
+ (body '())))
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (make-rounder pow10)
+ ;; Return a procedure that round to 10 to the -POW10.
+ (let ((times (expt 10.0 pow10)))
+ (lambda (x)
+ (/ (round (* x times)) times))))
+
+(define (pie-sliceweight-value sw-node pct?)
+ "Return the value that should be displayed by `sw-node', a
+ `sliceweight' markup node. If `pct?' is true, then this value
+ should be a percentage."
+ (let* ((the-slice (ast-parent sw-node))
+ (weight (and the-slice (markup-option the-slice :weight))))
+ (if (not the-slice)
+ (skribe-error 'lout
+ "`sliceweight' node not within a `slice' body"
+ sw-node)
+ (if pct?
+ (let* ((the-pie (ast-parent the-slice))
+ (total (and the-pie
+ (markup-option the-pie
+ '&total-weight))))
+ (if (not the-pie)
+ (skribe-error 'lout
+ "`slice' not within a `pie' body"
+ the-slice)
+ (* 100.0 (/ weight total)))) ;; flonum (FIXME: precision)
+
+ weight))))
+
+(define (pie-remove-markup node)
+ "Remove markup from `node', ie. turn something like `(it \"hello\")' into
+the string \"hello\". Implement `sliceweight' markups too."
+ (define percentage-round (make-rounder 2))
+
+ (if (markup? node)
+ (if (and node (is-markup? node 'sliceweight))
+ (let* ((pct? (markup-option node :percentage?))
+ (value (pie-sliceweight-value node pct?)))
+ (number->string (percentage-round value)))
+ (pie-remove-markup (markup-body node)))
+ (if (list? node)
+ (apply string-append (map pie-remove-markup node))
+ node)))
+
+(define strip-newlines (make-string-replace '((#\newline " "))))
+
+(define (select-output-format engine)
+ ;; Choose an ouptut format suitable for ENGINE.
+ (define %supported-formats '("png" "ps" "eps" "svg" "svgz"))
+ (define %default-format "png")
+
+ (let ((fmt (engine-custom engine 'image-format)))
+ (cond ((string? fmt) fmt)
+ ((and (list? fmt) (not (null? fmt)))
+ (let ((f (car fmt)))
+ (if (member f %supported-formats)
+ f
+ %default-format)))
+ (else %default-format))))
+
+
+;;;
+;;; Default implementation (`base' engine).
+;;;
+
+;; Ploticus-based implementation of pie charts, suitable for most engines.
+;; See http://ploticus.sf.net for info about Ploticus.
+
+(define %ploticus-program "ploticus")
+(define %ploticus-debug? #f)
+
+(define (color-spec->ploticus color-spec)
+ (define round (make-rounder 2))
+
+ (call-with-values (lambda () (skribe-color->rgb color-spec))
+ (lambda (r g b)
+ (format #f "rgb(~a,~a,~a)"
+ (round (/ r 255.0))
+ (round (/ g 255.0))
+ (round (/ b 255.0))))))
+
+(define (ploticus-script pie)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body pie)))
+ (colors (map (lambda (slice)
+ (let ((c (markup-option slice :color)))
+ (string-append (color-spec->ploticus c)
+ " ")))
+ (markup-body pie)))
+ (total-weight (or (if (number? (markup-option pie
+ :total))
+ (markup-option pie :total)
+ #f)
+ (apply + weights)))
+
+ ;; Attach useful information to the pie and its slices
+ (-/- (markup-option-add! pie '&total-weight total-weight))
+
+ ;; One slice label per line -- so we need to remove
+ ;; newlines from labels.
+ (labels (map (lambda (b)
+ (strip-newlines (pie-remove-markup b)))
+ (markup-body pie)))
+
+; (flat-title (map pie-remove-markup
+; (markup-option pie :title)))
+ (detached (map (lambda (slice)
+ (let ((d (markup-option slice
+ :detach?)))
+ (cond ((number? d) d)
+ (d 0.5) ;; default
+ (#t 0))))
+ (markup-body pie)))
+
+ (initial-angle (or (markup-option pie :initial-angle)
+ 0))
+ (radius (or ;;FIXME
+ (markup-option pie :radius) 3))
+ (max-radius (+ radius (apply max detached)))
+
+ ;; center coordinates must take into account (i) the
+ ;; maxium radius when detached slices are considered and
+ ;; (ii) the fact that labels may get displayed to the
+ ;; left of the pie.
+ ;; FIXME: labels to the left (ii) end up being truncated
+ ;; when the radius is e.g. < 2.
+ (center `(,(+ max-radius
+ (* max-radius max-radius)) .
+ ,(* max-radius max-radius))))
+
+ (apply string-append
+ (append (list "#proc getdata\n" "data: ")
+ (map (lambda (weight)
+ (string-append (number->string weight)
+ "\n"))
+ weights)
+ `("\n"
+; "#proc page\n"
+; "title " ,@flat-title
+; "\n"
+ "#proc pie\n"
+ "total: "
+ ,(number->string total-weight)
+ "\n"
+ "datafield: " "1" "\n")
+ `("firstslice: " ,(number->string initial-angle) "\n")
+ `("radius: " ,(number->string radius) "\n")
+ `("center: " ,(number->string (car center))
+ " " ,(number->string (cdr center)) "\n")
+ `("labelmode: "
+ ,(case (markup-option
+ pie :labels)
+ ((outside) "line+label")
+ ((inside) "labelonly")
+ ((legend) "legend")
+ (else "legend"))
+ "\n"
+ "labels: " ,@(map (lambda (label)
+ (string-append label "\n"))
+ labels)
+ "\n")
+ `("explode: "
+ ,@(map (lambda (number)
+ (string-append (number->string number)
+ " "))
+ detached)
+ "\n")
+ `("colors: " ,@colors "\n")))))
+
+(markup-writer 'pie (find-engine 'base)
+ :action (lambda (node engine)
+ (let* ((fmt (select-output-format engine))
+ (pie-file (string-append (markup-ident node) "."
+ fmt))
+ (port (open-output-pipe
+ (string-append %ploticus-program
+ " -o " pie-file
+ " -cm -" fmt " -stdin")))
+ (script (ploticus-script node)))
+
+
+ (if %ploticus-debug?
+ (format (current-error-port) "** Ploticus script: ~a"
+ script))
+
+ (display script port)
+
+ (let ((exit-val (status:exit-val (close-pipe port))))
+ (if (not (eqv? 0 exit-val))
+ (skribe-error 'pie/ploticus
+ "ploticus exited with error code"
+ exit-val)))
+
+ (if (not (file-exists? pie-file))
+ (skribe-error 'ploticus
+ "Ploticus did not create the image file"
+ script))
+
+ (if (markup-option node :title)
+ (output (list (bold (markup-option node :title))
+ (linebreak))
+ engine))
+
+ (output (image :file pie-file
+ :class (markup-option node :class)
+ (or (markup-option node :title)
+ "A Pie Chart"))
+ engine))))
+
+(markup-writer 'slice (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here
+ (error "slice: this writer should never be invoked")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here.
+ (error "sliceweight: this writer should never be invoked")))
+
+
+;;;
+;;; Initialization.
+;;;
+
+(when-engine-is-loaded 'lout
+ (lambda ()
+ (resolve-module '(skribilo package pie lout))))
+
+
+;;; arch-tag: 8095d8f6-b810-4619-9fdb-23fb94a77ee3
diff --git a/src/guile/skribilo/package/pie/Makefile.am b/src/guile/skribilo/package/pie/Makefile.am
new file mode 100644
index 0000000..3b4fafd
--- /dev/null
+++ b/src/guile/skribilo/package/pie/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package/pie
+dist_guilemodule_DATA = lout.scm
+
+## arch-tag: e6a03451-14c9-4331-8b96-71bde92ac142
diff --git a/src/guile/skribilo/package/pie/lout.scm b/src/guile/skribilo/package/pie/lout.scm
new file mode 100644
index 0000000..61dbcb7
--- /dev/null
+++ b/src/guile/skribilo/package/pie/lout.scm
@@ -0,0 +1,132 @@
+;;; lout.scm -- Lout implementation of the `pie' package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package pie lout)
+ :use-module (skribilo package pie)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :autoload (skribilo engine lout) (lout-color-specification)
+ :use-module (ice-9 optargs))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(let ((lout (find-engine 'lout)))
+ (if lout
+ (engine-custom-set! lout 'includes
+ (string-append (engine-custom lout 'includes)
+ "\n@SysInclude { pie } # Pie Charts\n"))))
+
+
+
+;;;
+;;; Writers.
+;;;
+
+(markup-writer 'pie (find-engine 'lout)
+ :before (lambda (node engine)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body node)))
+ (total-weight (or (if (number? (markup-option node
+ :total))
+ (markup-option node :total)
+ #f)
+ (apply + weights))))
+
+ (if (= 0 total-weight)
+ (skribe-error 'lout
+ "Slices weight sum should not be zero"
+ total-weight))
+
+ ;; Attach useful information to the pie and its slices
+ (markup-option-add! node '&total-weight total-weight)
+
+ (display "\n@Pie\n")
+ (display " abovecaption { ")
+ (if (markup-option node :title)
+ (output (markup-option node :title) engine))
+ (display " }\n")
+ (format #t " totalweight { ~a }\n" total-weight)
+ (format #t " initialangle { ~a }\n"
+ (or (markup-option node :initial-angle) 0))
+ (format #t " finger { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside) (if (markup-option node :fingers?)
+ "yes" "no"))
+ (else "no")))
+
+ ;; We assume `:radius' to be centimeters
+ (if (markup-option node :radius)
+ (format #t " radius { ~ac }\n"
+ (markup-option node :radius)))
+
+ (format #t " labelradius { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside #f) "external") ; FIXME: options are
+ ; not availble within
+ ; :before? (hence the #f)
+
+ ((inside) "internal")
+ (else
+ (skribe-error 'lout
+ "`:labels' should be one of 'inside or 'outside."
+ (markup-option node :labels)))))
+ (display "{\n")))
+ :after "\n} # @Pie\n")
+
+(markup-writer 'slice (find-engine 'lout)
+ :options '(:weight :detach? :color)
+ :action (lambda (node engine)
+ (display " @Slice\n")
+ (format #t " detach { ~a }\n"
+ (if (markup-option node :detach?)
+ "yes"
+ "no"))
+ (format #t " paint { ~a }\n"
+ (lout-color-specification (markup-option node
+ :color)))
+ (format #t " weight { ~a }\n"
+ (markup-option node :weight))
+
+ (display " label { ")
+ (output (markup-body node) engine)
+ (display " }\n")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ ;; This writer should work for every engine, provided the `pie' markup has
+ ;; a proper `&total-weight' option.
+ :action (lambda (node engine)
+ (let ((pct? (markup-option node :percentage?)))
+ (output (number->string
+ (pie-sliceweight-value node pct?))
+ engine))))
+
+;;; arch-tag: b5221e30-f80e-4b72-a281-83ce19ddb755
diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm
new file mode 100644
index 0000000..902cdb5
--- /dev/null
+++ b/src/guile/skribilo/package/scribe.scm
@@ -0,0 +1,240 @@
+;;; scribe.scm -- Scribe Compatibility kit
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package scribe))
+
+;*---------------------------------------------------------------------*/
+;* style ... */
+;*---------------------------------------------------------------------*/
+(define (style . styles)
+ (define (load-style style)
+ (let ((name (cond
+ ((string? style)
+ style)
+ ((symbol? style)
+ (string-append (symbol->string style) ".scr")))))
+ (skribe-load name :engine *skribe-engine*)))
+ (for-each load-style styles))
+
+;*---------------------------------------------------------------------*/
+;* chapter ... */
+;*---------------------------------------------------------------------*/
+(define skribe-chapter chapter)
+
+(define-markup (chapter #!rest opt #!key title subtitle split number toc file)
+ (apply skribe-chapter
+ :title (or title subtitle)
+ :number number
+ :toc toc
+ :file file
+ (the-body opt)))
+
+;*---------------------------------------------------------------------*/
+;* table-of-contents ... */
+;*---------------------------------------------------------------------*/
+(define-markup (table-of-contents #!rest opts #!key chapter section subsection)
+ (apply toc opts))
+
+;*---------------------------------------------------------------------*/
+;* frame ... */
+;*---------------------------------------------------------------------*/
+(define skribe-frame frame)
+
+(define-markup (frame #!rest opt #!key width margin)
+ (apply skribe-frame
+ :width (if (real? width) (* 100 width) width)
+ :margin margin
+ (the-body opt)))
+
+;*---------------------------------------------------------------------*/
+;* copyright ... */
+;*---------------------------------------------------------------------*/
+(define (copyright)
+ (symbol 'copyright))
+
+;*---------------------------------------------------------------------*/
+;* sect ... */
+;*---------------------------------------------------------------------*/
+(define (sect)
+ (symbol 'section))
+
+;*---------------------------------------------------------------------*/
+;* euro ... */
+;*---------------------------------------------------------------------*/
+(define (euro)
+ (symbol 'euro))
+
+;*---------------------------------------------------------------------*/
+;* tab ... */
+;*---------------------------------------------------------------------*/
+(define (tab)
+ (char #\tab))
+
+;*---------------------------------------------------------------------*/
+;* space ... */
+;*---------------------------------------------------------------------*/
+(define (space)
+ (char #\space))
+
+;*---------------------------------------------------------------------*/
+;* print-bibliography ... */
+;*---------------------------------------------------------------------*/
+(define-markup (print-bibliography #!rest opts
+ #!key all (sort bib-sort/authors))
+ (the-bibliography all sort))
+
+;*---------------------------------------------------------------------*/
+;* linebreak ... */
+;*---------------------------------------------------------------------*/
+(define skribe-linebreak linebreak)
+
+(define-markup (linebreak . lnum)
+ (cond
+ ((null? lnum)
+ (skribe-linebreak))
+ ((string? (car lnum))
+ (skribe-linebreak (string->number (car lnum))))
+ (else
+ (skribe-linebreak (car lnum)))))
+
+;*---------------------------------------------------------------------*/
+;* ref ... */
+;*---------------------------------------------------------------------*/
+(define skribe-ref ref)
+
+(define-markup (ref #!rest opts
+ #!key scribe url id page figure mark
+ chapter section subsection subsubsection subsubsection
+ bib bib+ number)
+ (let ((bd (the-body opts))
+ (args (apply append (the-options opts :id))))
+ (if id (set! args (cons* :mark id args)))
+ (if (pair? bd) (set! args (cons* :text bd args)))
+ (apply skribe-ref args)))
+
+;*---------------------------------------------------------------------*/
+;* indexes ... */
+;*---------------------------------------------------------------------*/
+(define *scribe-indexes*
+ (list (cons "theindex" (make-index "theindex"))))
+
+(define skribe-index index)
+(define skribe-make-index make-index)
+
+(define-markup (make-index index)
+ (let ((i (skribe-make-index index)))
+ (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*))
+ i))
+
+(define-markup (index #!rest opts #!key note index shape)
+ (let ((i (if (not index)
+ "theindex"
+ (let ((i (assoc index *scribe-indexes*)))
+ (if (pair? i)
+ (cdr i)
+ (make-index index))))))
+ (apply skribe-index :note note :index i :shape shape (the-body opts))))
+
+(define-markup (print-index #!rest opts
+ #!key split (char-offset 0) (header-limit 100))
+ (apply the-index
+ :split split
+ :char-offset char-offset
+ :header-limit header-limit
+ (map (lambda (i)
+ (let ((c (assoc i *scribe-indexes*)))
+ (if (pair? c)
+ (cdr c)
+ (skribe-error 'the-index "Unknown index" i))))
+ (the-body opts))))
+
+;*---------------------------------------------------------------------*/
+;* format? */
+;*---------------------------------------------------------------------*/
+(define (scribe-format? fmt) #f)
+
+;*---------------------------------------------------------------------*/
+;* scribe-url ... */
+;*---------------------------------------------------------------------*/
+(define (scribe-url) (skribe-url))
+
+;*---------------------------------------------------------------------*/
+;* Various configurations */
+;*---------------------------------------------------------------------*/
+(define *scribe-background* #f)
+(define *scribe-foreground* #f)
+(define *scribe-tbackground* #f)
+(define *scribe-tforeground* #f)
+(define *scribe-title-font* #f)
+(define *scribe-author-font* #f)
+(define *scribe-chapter-numbering* #f)
+(define *scribe-footer* #f)
+(define *scribe-prgm-color* #f)
+
+;*---------------------------------------------------------------------*/
+;* prgm ... */
+;*---------------------------------------------------------------------*/
+(define-markup (prgm #!rest opts
+ #!key lnum lnumwidth language bg frame (width 1.)
+ colors (monospace #t))
+ (let* ((w (cond
+ ((real? width) (* width 100.))
+ ((number? width) width)
+ (else 100.)))
+ (body (if language
+ (source :language language (the-body opts))
+ (the-body opts)))
+ (body (if monospace
+ (prog :line lnum body)
+ body))
+ (body (if bg
+ (color :width 100. :bg bg body)
+ body)))
+ (skribe-frame :width w
+ :border (if frame 1 #f)
+ body)))
+
+;*---------------------------------------------------------------------*/
+;* latex configuration */
+;*---------------------------------------------------------------------*/
+(define *scribe-tex-predocument* #f)
+
+;*---------------------------------------------------------------------*/
+;* latex-prelude ... */
+;*---------------------------------------------------------------------*/
+(define (latex-prelude e)
+ (if (engine-format? "latex" e)
+ (begin
+ (if *scribe-tex-predocument*
+ (engine-custom-set! e 'predocument *scribe-tex-predocument*)))))
+
+;*---------------------------------------------------------------------*/
+;* html-prelude ... */
+;*---------------------------------------------------------------------*/
+(define (html-prelude e)
+ (if (engine-format? "html" e)
+ (begin
+ #f)))
+
+;*---------------------------------------------------------------------*/
+;* prelude */
+;*---------------------------------------------------------------------*/
+(let ((p (user-prelude)))
+ (user-prelude-set! (lambda (e) (p e) (latex-prelude e))))
diff --git a/src/guile/skribilo/package/sigplan.scm b/src/guile/skribilo/package/sigplan.scm
new file mode 100644
index 0000000..28d4e83
--- /dev/null
+++ b/src/guile/skribilo/package/sigplan.scm
@@ -0,0 +1,166 @@
+;;; sigplan.scm -- The Skribe style for ACMPROC articles.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package sigplan))
+
+;*---------------------------------------------------------------------*/
+;* LaTeX global customizations */
+;*---------------------------------------------------------------------*/
+(let ((le (find-engine 'latex)))
+ (engine-custom-set! le
+ 'documentclass
+ "\\documentclass[twocolumns]{sigplanconf}")
+ ;; &latex-author
+ (markup-writer '&latex-author le
+ :before (lambda (n e)
+ (let ((body (markup-body n)))
+ (printf "\\authorinfo{\n"
+ (if (pair? body) (length body) 1))))
+ :action (lambda (n e)
+ (let ((body (markup-body n)))
+ (for-each (lambda (a)
+ (display "}\n\\authorinfo{")
+ (output a e))
+ (if (pair? body) body (list body)))))
+ :after "}\n")
+ ;; author
+ (let ((old-author (markup-writer-get 'author le)))
+ (markup-writer 'author le
+ :options (writer-options old-author)
+ :action (writer-action old-author)))
+ ;; ACM category, terms, and keywords
+ (markup-writer '&acm-category le
+ :options '(:index :section :subsection)
+ :before (lambda (n e)
+ (display "\\category{")
+ (display (markup-option n :index))
+ (display "}")
+ (display "{")
+ (display (markup-option n :section))
+ (display "}")
+ (display "{")
+ (display (markup-option n :subsection))
+ (display "}\n["))
+ :after "]\n")
+ (markup-writer '&acm-terms le
+ :before "\\terms{"
+ :after "}")
+ (markup-writer '&acm-keywords le
+ :before "\\keywords{"
+ :after "}")
+ (markup-writer '&acm-copyright le
+ :action (lambda (n e)
+ (display "\\conferenceinfo{")
+ (output (markup-option n :conference) e)
+ (display ",} {")
+ (output (markup-option n :location) e)
+ (display "}\n")
+ (display "\\copyrightyear{")
+ (output (markup-option n :year) e)
+ (display "}\n")
+ (display "\\copyrightdata{")
+ (output (markup-option n :crdata) e)
+ (display "}\n"))))
+
+;*---------------------------------------------------------------------*/
+;* HTML global customizations */
+;*---------------------------------------------------------------------*/
+(let ((he (find-engine 'html)))
+ (markup-writer '&html-acmproc-abstract he
+ :action (lambda (n e)
+ (let* ((ebg (engine-custom e 'abstract-background))
+ (bg (or (and (string? ebg)
+ (> (string-length ebg) 0))
+ ebg
+ "#cccccc"))
+ (exp (p (center (color :bg bg :width 90.
+ (markup-body n))))))
+ (skribe-eval exp e))))
+ ;; ACM category, terms, and keywords
+ (markup-writer '&acm-category :action #f)
+ (markup-writer '&acm-terms :action #f)
+ (markup-writer '&acm-keywords :action #f)
+ (markup-writer '&acm-copyright :action #f))
+
+;*---------------------------------------------------------------------*/
+;* abstract ... */
+;*---------------------------------------------------------------------*/
+(define-markup (abstract #!rest opt #!key postscript)
+ (if (engine-format? "latex")
+ (section :number #f :title "ABSTRACT" (p (the-body opt)))
+ (let ((a (new markup
+ (markup '&html-acmproc-abstract)
+ (body (the-body opt)))))
+ (list (if postscript
+ (section :number #f :toc #f :title "Postscript download"
+ postscript))
+ (section :number #f :toc #f :title "Abstract" a)
+ (section :number #f :toc #f :title "Table of contents"
+ (toc :subsection #t))))))
+
+;*---------------------------------------------------------------------*/
+;* acm-category ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-category #!rest opt #!key index section subsection)
+ (new markup
+ (markup '&acm-category)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-terms ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-terms #!rest opt)
+ (new markup
+ (markup '&acm-terms)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-keywords ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-keywords #!rest opt)
+ (new markup
+ (markup '&acm-keywords)
+ (options (the-options opt))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* acm-copyright ... */
+;*---------------------------------------------------------------------*/
+(define-markup (acm-copyright #!rest opt #!key conference location year crdata)
+ (let* ((le (find-engine 'latex))
+ (cop (format "\\conferenceinfo{~a,} {~a}
+\\CopyrightYear{~a}
+\\crdata{~a}\n" conference location year crdata))
+ (old (engine-custom le 'predocument)))
+ (if (string? old)
+ (engine-custom-set! le 'predocument (string-append cop old))
+ (engine-custom-set! le 'predocument cop))))
+
+;*---------------------------------------------------------------------*/
+;* references ... */
+;*---------------------------------------------------------------------*/
+(define (references)
+ (list "\n\n"
+ (if (engine-format? "latex")
+ (font :size -1 (flush :side 'left (the-bibliography)))
+ (section :title "References"
+ (font :size -1 (the-bibliography))))))
diff --git a/src/guile/skribilo/package/skribe.scm b/src/guile/skribilo/package/skribe.scm
new file mode 100644
index 0000000..86969aa
--- /dev/null
+++ b/src/guile/skribilo/package/skribe.scm
@@ -0,0 +1,85 @@
+;;; skribe.scm -- The standard Skribe style (always loaded).
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+;*---------------------------------------------------------------------*/
+;* p ... */
+;*---------------------------------------------------------------------*/
+(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location)
+ (paragraph :ident ident :class class :loc &skribe-eval-location
+ (the-body opt)))
+
+;*---------------------------------------------------------------------*/
+;* fg ... */
+;*---------------------------------------------------------------------*/
+(define (fg c . body)
+ (color :fg c body))
+
+;*---------------------------------------------------------------------*/
+;* bg ... */
+;*---------------------------------------------------------------------*/
+(define (bg c . body)
+ (color :bg c body))
+
+;*---------------------------------------------------------------------*/
+;* counter ... */
+;* ------------------------------------------------------------- */
+;* This produces a kind of "local enumeration" that is: */
+;* (counting "toto," "tutu," "titi.") */
+;* produces: */
+;* i) toto, ii) tutu, iii) titi. */
+;*---------------------------------------------------------------------*/
+(define-markup (counter #!rest opts #!key (numbering 'roman))
+ (define items (if (eq? (car opts) :numbering) (cddr opts) opts))
+ (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x"))
+ (define (the-roman-number num)
+ (if (< num (vector-length vroman))
+ (list (list "(" (it (vector-ref vroman num)) ") "))
+ (skribe-error 'counter
+ "too many items for roman numbering"
+ (length items))))
+ (define (the-arabic-number num)
+ (list (list "(" (it (integer->string num)) ") ")))
+ (define (the-alpha-number num)
+ (list (list "(" (it (+ (integer->char #\a) num -1)) ") ")))
+ (let ((the-number (case numbering
+ ((roman) the-roman-number)
+ ((arabic) the-arabic-number)
+ ((alpha) the-alpha-number)
+ (else (skribe-error 'counter
+ "Illegal numbering"
+ numbering)))))
+ (let loop ((num 1)
+ (items items)
+ (res '()))
+ (if (null? items)
+ (reverse! res)
+ (loop (+ num 1)
+ (cdr items)
+ (cons (list (the-number num) (car items)) res))))))
+
+;*---------------------------------------------------------------------*/
+;* q */
+;*---------------------------------------------------------------------*/
+(define-markup (q #!rest opt)
+ (new markup
+ (markup 'q)
+ (options (the-options opt))
+ (body (the-body opt))))
+
diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm
new file mode 100644
index 0000000..7f731e3
--- /dev/null
+++ b/src/guile/skribilo/package/slide.scm
@@ -0,0 +1,274 @@
+;;; slide.scm -- Overhead transparencies.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-skribe-module (skribilo package slide))
+
+
+;*---------------------------------------------------------------------*/
+;* slide-options */
+;*---------------------------------------------------------------------*/
+(define-public &slide-load-options (skribe-load-options))
+
+
+;*---------------------------------------------------------------------*/
+;* %slide-the-slides ... */
+;*---------------------------------------------------------------------*/
+(define %slide-the-slides '())
+(define %slide-the-counter 0)
+
+;*---------------------------------------------------------------------*/
+;* slide ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide #!rest opt
+ #!key
+ (ident #f) (class #f)
+ (toc #t)
+ title (number #t)
+ (vspace #f) (vfill #f)
+ (transition #f)
+ (bg #f) (image #f))
+ (let ((s (new container
+ (markup 'slide)
+ (ident (if (not ident)
+ (symbol->string (gensym 'slide))
+ ident))
+ (class class)
+ (required-options '(:title :number :toc))
+ (options `((:number
+ ,(cond
+ ((number? number)
+ (set! %slide-the-counter number)
+ number)
+ (number
+ (set! %slide-the-counter
+ (+ 1 %slide-the-counter))
+ %slide-the-counter)
+ (else
+ #f)))
+ (:toc ,toc)
+ ,@(the-options opt :ident :class :vspace :toc)))
+ (body (if vspace
+ (list (slide-vspace vspace) (the-body opt))
+ (the-body opt))))))
+ (set! %slide-the-slides (cons s %slide-the-slides))
+ s))
+
+;*---------------------------------------------------------------------*/
+;* ref ... */
+;*---------------------------------------------------------------------*/
+(define %slide-old-ref ref)
+
+;; Extend the definition of `ref'.
+;; FIXME: This technique breaks `ref' for some reason.
+; (set! ref
+; (lambda args
+; ;; Filter out ARGS and look for a `:slide' keyword argument.
+; (let loop ((slide #f)
+; (opt '())
+; (args args))
+; (if (null? args)
+; (set! opt (reverse! opt))
+; (let ((s? (eq? (car args) :slide)))
+; (loop (if s? (cadr args) #f)
+; (if s? opt (cons (car args) opt))
+; (if s? (cddr args) (cdr args)))))
+
+; (format (current-error-port)
+; "slide.scm:ref: slide=~a opt=~a~%" slide opt)
+
+; (if (not slide)
+; (apply %slide-old-ref opt)
+; (new unresolved
+; (proc (lambda (n e env)
+; (cond
+; ((eq? slide 'next)
+; (let ((c (assq n %slide-the-slides)))
+; (if (pair? c)
+; (handle (cadr c))
+; #f)))
+; ((eq? slide 'prev)
+; (let ((c (assq n (reverse %slide-the-slides))))
+; (if (pair? c)
+; (handle (cadr c))
+; #f)))
+; ((number? slide)
+; (let loop ((s %slide-the-slides))
+; (cond
+; ((null? s)
+; #f)
+; ((= slide (markup-option
+; (car s) :number))
+; (handle (car s)))
+; (else
+; (loop (cdr s))))))
+; (else
+; #f)))))))))
+
+
+;*---------------------------------------------------------------------*/
+;* slide-pause ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-pause)
+ (new markup
+ (markup 'slide-pause)))
+
+;*---------------------------------------------------------------------*/
+;* slide-vspace ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-vspace #!rest opt #!key (unit 'cm))
+ (new markup
+ (markup 'slide-vspace)
+ (options `((:unit ,unit) ,@(the-options opt :unit)))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* slide-embed ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-embed #!rest opt
+ #!key
+ command
+ (geometry-opt "-geometry")
+ (geometry #f) (rgeometry #f)
+ (transient #f) (transient-opt #f)
+ (alt #f)
+ &skribe-eval-location)
+ (if (not (string? command))
+ (skribe-error 'slide-embed
+ "No command provided"
+ command)
+ (new markup
+ (markup 'slide-embed)
+ (loc &skribe-eval-location)
+ (required-options '(:alt))
+ (options `((:geometry-opt ,geometry-opt)
+ (:alt ,alt)
+ ,@(the-options opt :geometry-opt :alt)))
+ (body (the-body opt)))))
+
+;*---------------------------------------------------------------------*/
+;* slide-record ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-record #!rest opt #!key ident class tag (play #t))
+ (if (not tag)
+ (skribe-error 'slide-record "Tag missing" tag)
+ (new markup
+ (markup 'slide-record)
+ (ident ident)
+ (class class)
+ (options `((:play ,play) ,@(the-options opt)))
+ (body (the-body opt)))))
+
+;*---------------------------------------------------------------------*/
+;* slide-play ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-play #!rest opt #!key ident class tag color)
+ (if (not tag)
+ (skribe-error 'slide-play "Tag missing" tag)
+ (new markup
+ (markup 'slide-play)
+ (ident ident)
+ (class class)
+ (options `((:color ,(if color (skribe-use-color! color) #f))
+ ,@(the-options opt :color)))
+ (body (the-body opt)))))
+
+;*---------------------------------------------------------------------*/
+;* slide-play* ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-play* #!rest opt
+ #!key ident class color (scolor "#000000"))
+ (let ((body (the-body opt)))
+ (for-each (lambda (lbl)
+ (match-case lbl
+ ((?id ?col)
+ (skribe-use-color! col))))
+ body)
+ (new markup
+ (markup 'slide-play*)
+ (ident ident)
+ (class class)
+ (options `((:color ,(if color (skribe-use-color! color) #f))
+ (:scolor ,(if color (skribe-use-color! scolor) #f))
+ ,@(the-options opt :color :scolor)))
+ (body body))))
+
+
+
+;*---------------------------------------------------------------------*/
+;* slide-number ... */
+;*---------------------------------------------------------------------*/
+(define-public (slide-number)
+ (length (filter (lambda (n)
+ (and (is-markup? n 'slide)
+ (markup-option n :number)))
+ %slide-the-slides)))
+
+;*---------------------------------------------------------------------*/
+;* slide-topic ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-topic #!rest opt
+ #!key title (outline? #t)
+ (ident #f) (class "slide-topic"))
+ (new container
+ (markup 'slide-topic)
+ (required-options '(:title :outline?))
+ (ident (or ident (symbol->string (gensym 'slide-topic))))
+ (options `((:outline? ,outline?)
+ ,@(the-options opt :outline?)))
+ (body (the-body opt))))
+
+;*---------------------------------------------------------------------*/
+;* slide-subtopic ... */
+;*---------------------------------------------------------------------*/
+(define-markup (slide-subtopic #!rest opt
+ #!key title (outline? #f)
+ (ident #f) (class "slide-subtopic"))
+ (new container
+ (markup 'slide-subtopic)
+ (required-options '(:title :outline?))
+ (ident (or ident (symbol->string (gensym 'slide-subtopic))))
+ (options `((:outline? ,outline?)
+ ,@(the-options opt :outline?)))
+ (body (the-body opt))))
+
+
+
+;;;
+;;; Initialization.
+;;;
+
+(format (current-error-port) "Slides initializing...~%")
+
+;; Register specific implementations for lazy loading.
+(when-engine-is-loaded 'base
+ (lambda ()
+ (resolve-module '(skribilo package slide base))))
+(when-engine-is-loaded 'latex
+ (lambda ()
+ (resolve-module '(skribilo package slide latex))))
+(when-engine-is-loaded 'html
+ (lambda ()
+ (resolve-module '(skribilo package slide html))))
+(when-engine-is-loaded 'lout
+ (lambda ()
+ (resolve-module '(skribilo package slide lout))))
+
diff --git a/src/guile/skribilo/package/slide/Makefile.am b/src/guile/skribilo/package/slide/Makefile.am
new file mode 100644
index 0000000..53320fa
--- /dev/null
+++ b/src/guile/skribilo/package/slide/Makefile.am
@@ -0,0 +1,4 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/package/slide
+dist_guilemodule_DATA = base.scm latex.scm html.scm lout.scm
+
+## arch-tag: 56b5fa5c-bb6a-4692-b929-74bdd032431c
diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm
new file mode 100644
index 0000000..c8e652c
--- /dev/null
+++ b/src/guile/skribilo/package/slide/base.scm
@@ -0,0 +1,185 @@
+;;; base.scm -- Overhead transparencies, `base' engine.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo package slide base)
+ :use-module (skribilo utils syntax)
+
+ :use-module (skribilo package slide)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :autoload (skribilo package base) (symbol color itemize item)
+
+ :use-module (srfi srfi-1)
+
+ :export (%slide-outline-title %slide-outline-itemize-symbols))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Simple markups.
+;;;
+(let ((be (find-engine 'base)))
+
+ ;; slide-pause
+ (markup-writer 'slide-pause be
+ :action #f)
+ ;; slide-vspace
+ (markup-writer 'slide-vspace be
+ :options '()
+ :action #f)
+ ;; slide-embed
+ (markup-writer 'slide-embed be
+ :options '(:alt :geometry-opt)
+ :action (lambda (n e)
+ (output (markup-option n :alt) e)))
+ ;; slide-record
+ (markup-writer 'slide-record be
+ :options '(:tag :play)
+ :action (lambda (n e)
+ (output (markup-body n) e)))
+ ;; slide-play
+ (markup-writer 'slide-play be
+ :options '(:tag :color)
+ :action (lambda (n e)
+ (output (markup-option n :alt) e)))
+ ;; slide-play*
+ (markup-writer 'slide-play* be
+ :options '(:tag :color :scolor)
+ :action (lambda (n e)
+ (output (markup-option n :alt) e))))
+
+
+;;;
+;;; Helper functions for the default topic/subtopic handling.
+;;;
+
+(define (make-subtopic-list node recurse?-proc make-entry-proc
+ itemize-symbols)
+ ;; Make a list of the subtopic of `node'. Go recursive if `recurse?-proc'
+ ;; returns true. `make-entry-proc' is passed a node and returns an entry
+ ;; (a markup) for this node. `itemize-symbols' is a (circular) list
+ ;; containing the symbols to be passed to `itemize'.
+ (let* ((subtopic? (lambda (n)
+ (or (is-markup? n 'slide-subtopic)
+ (is-markup? n 'slide))))
+ (subtopic-types (if (is-markup? node 'slide-topic)
+ '(slide-subtopic slide)
+ '(slide-topic))))
+ (if (subtopic? node)
+ '()
+ (apply itemize
+ `(,@(if (is-markup? (car itemize-symbols) 'symbol)
+ `(:symbol ,(car itemize-symbols))
+ '())
+ ,@(map (lambda (t)
+ (item
+ (make-entry-proc t)
+ (if (recurse?-proc t)
+ (make-subtopic-list t recurse?-proc
+ make-entry-proc
+ (cdr itemize-symbols))
+ '())))
+ (filter (lambda (n)
+ (and (markup? n)
+ (member (markup-markup n)
+ subtopic-types)))
+ (markup-body node))))))))
+
+(define (make-topic-list current-topic recurse? make-entry-proc)
+ ;; Make a full topic list of the document which contains
+ ;; `current-topic'. Here, `make-entry-proc' takes a topic node and
+ ;; the current topic node as its arguments.
+ (let ((doc (ast-document current-topic)))
+ (make-subtopic-list doc
+ (lambda (t)
+ (and recurse? (eq? t current-topic)))
+ (lambda (t)
+ (make-entry-proc t current-topic))
+ %slide-outline-itemize-symbols)))
+
+(define (make-topic-entry topic current-topic)
+ ;; Produce an entry for `topic'. Colorize it based on the fact
+ ;; that the current topic is `current-topic' (it may need to be
+ ;; hightlighted).
+ (let ((title (markup-option topic :title))
+ (current? (eq? topic current-topic)))
+ (color :fg (if current? "#000000" "#666666")
+ (apply (if current? bold (lambda (x) x))
+ (list (markup-option topic :title))))))
+
+
+;;;
+;;; Default topic/subtopic handling.
+;;;
+
+;; Title for the automatically-generated outline slide.
+(define %slide-outline-title "")
+
+;; Circular list of symbols to be passed to `itemize' in outlines.
+(define %slide-outline-itemize-symbols
+ (let loop ((names '(#t "-" "bullet" "->" "middot")))
+ (if (null? names)
+ '()
+ (cons (if (string? (car names))
+ (symbol (car names))
+ (car names))
+ (loop (cdr names))))))
+
+
+(define (make-outline-slide topic engine)
+ (let ((parent-topic (if (is-markup? topic 'slide-topic)
+ topic
+ (find1-up (lambda (n)
+ (is-markup? n 'slide-topic))
+ topic))))
+ (output (slide :title %slide-outline-title :toc #f
+ :class (markup-option topic :class)
+ ;; The mark below is needed for cross-referencing by PDF
+ ;; bookmarks.
+ (if (markup-ident topic) (mark (markup-ident topic)) "")
+ (p (make-topic-list parent-topic #t
+ make-topic-entry)))
+ engine)))
+
+
+(markup-writer 'slide-topic (find-engine 'base)
+ :options '(:title :outline? :class :ident)
+ :action (lambda (n e)
+ (if (markup-option n :outline?)
+ (make-outline-slide n e))
+
+ (output (markup-body n) e)))
+
+(markup-writer 'slide-subtopic (find-engine 'base)
+ ;; FIXME: Largely untested.
+ :options '(:title :outline? :class :ident)
+ :action (lambda (n e)
+ (if (markup-option n :outline?)
+ (make-outline-slide n e))
+
+ (output (markup-body n) e)))
+
+
+;;; arch-tag: 1187ce0c-3ffc-4248-b68b-a7c77d6598b9
diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm
new file mode 100644
index 0000000..d47ef82
--- /dev/null
+++ b/src/guile/skribilo/package/slide/html.scm
@@ -0,0 +1,144 @@
+;;; html.scm -- HTML implementation of the `slide' package.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package slide html)
+ :use-module (skribilo package slide))
+
+
+(define-public (%slide-html-initialize!)
+ (let ((he (find-engine 'html)))
+ (skribe-message "HTML slides setup...\n")
+ ;; &html-page-title
+ (markup-writer '&html-document-title he
+ ;;:predicate (lambda (n e) %slide-initialized)
+ :action html-slide-title)
+ ;; slide
+ (markup-writer 'slide he
+ :options '(:title :number :transition :toc :bg)
+ :before (lambda (n e)
+ (printf "<a name=\"~a\">" (markup-ident n))
+ (display "<br>\n"))
+ :action (lambda (n e)
+ (let ((nb (markup-option n :number))
+ (t (markup-option n :title)))
+ (skribe-eval
+ (center
+ (color :width (slide-body-width e)
+ :bg (or (markup-option n :bg) "#ffffff")
+ (table :width 100.
+ (tr (th :align 'left
+ (list
+ (if nb
+ (format #f "~a / ~a -- " nb
+ (slide-number)))
+ t)))
+ (tr (td (hrule)))
+ (tr (td :width 100. :align 'left
+ (markup-body n))))
+ (linebreak)))
+ e)))
+ :after "<br>")
+ ;; slide-vspace
+ (markup-writer 'slide-vspace he
+ :action (lambda (n e) (display "<br>")))))
+
+
+;*---------------------------------------------------------------------*/
+;* slide-body-width ... */
+;*---------------------------------------------------------------------*/
+(define (slide-body-width e)
+ (let ((w (engine-custom e 'body-width)))
+ (if (or (number? w) (string? w)) w 95.)))
+
+;*---------------------------------------------------------------------*/
+;* html-slide-title ... */
+;*---------------------------------------------------------------------*/
+(define (html-slide-title n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (tbg (engine-custom e 'title-background))
+ (tfg (engine-custom e 'title-foreground))
+ (tfont (engine-custom e 'title-font)))
+ (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>"
+ (html-width (slide-body-width e)))
+ (if (string? tbg)
+ (printf "<td bgcolor=\"~a\">" tbg)
+ (display "<td>"))
+ (if (string? tfg)
+ (printf "<font color=\"~a\">" tfg))
+ (if title
+ (begin
+ (display "<center>")
+ (if (string? tfont)
+ (begin
+ (printf "<font ~a><strong>" tfont)
+ (output title e)
+ (display "</strong></font>"))
+ (begin
+ (printf "<div class=\"skribetitle\"><strong><big><big><big>")
+ (output title e)
+ (display "</big></big></big></strong</div>")))
+ (display "</center>\n")))
+ (if (not authors)
+ (display "\n")
+ (html-title-authors authors e))
+ (if (string? tfg)
+ (display "</font>"))
+ (display "</td></tr></tbody></table></center>\n")))
+
+
+
+;;;
+;;; Slide topics/subtopics.
+;;;
+
+(markup-writer 'slide-topic (find-engine 'html)
+ :options '(:title :outline? :class :ident)
+ :action (lambda (n e)
+ (let ((title (markup-option n :title))
+ (body (markup-body n)))
+ (display "\n<h2 class=\"slide-topic:title\">")
+ (if (markup-ident n)
+ (printf "<a name=\"~a\"></a>" (markup-ident n)))
+ (output title e)
+ (display "</h2> <br>\n")
+ (display "\n<div class=\"slide-topic:slide-list\">")
+ (for-each (lambda (s)
+ (output (markup-option s :title) e)
+ (display "&nbsp;--&nbsp;"))
+ (filter (lambda (n)
+ (or (is-markup? n 'slide-subtopic)
+ (is-markup? n 'slide)))
+ (markup-body n)))
+ (display "\n</div> <!-- slide-topic:slide-list -->")
+ (display "\n<hr><br>\n")
+
+ ;; the slides
+ (output (markup-body n) e))))
+
+
+;;;
+;;; Initialization.
+;;;
+
+(%slide-html-initialize!)
+
+
+;;; arch-tag: 8be0cdf2-b755-4baa-baf6-739cdd00e193
diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm
new file mode 100644
index 0000000..e187d3c
--- /dev/null
+++ b/src/guile/skribilo/package/slide/latex.scm
@@ -0,0 +1,394 @@
+;;; latex.scm -- LaTeX implementation of the `slide' package.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package slide latex)
+ :use-module (skribilo package slide))
+
+
+(define-public %slide-latex-mode 'seminar)
+
+(define-public (%slide-latex-initialize!)
+ (skribe-message "LaTeX slides setup...\n")
+ (case %slide-latex-mode
+ ((seminar)
+ (%slide-seminar-setup!))
+ ((advi)
+ (%slide-advi-setup!))
+ ((prosper)
+ (%slide-prosper-setup!))
+ (else
+ (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))
+
+
+;*---------------------------------------------------------------------*/
+;* &slide-seminar-predocument ... */
+;*---------------------------------------------------------------------*/
+(define &slide-seminar-predocument
+ "\\special{landscape}
+ \\slideframe{none}
+ \\centerslidesfalse
+ \\raggedslides[0pt]
+ \\renewcommand{\\slideleftmargin}{0.2in}
+ \\renewcommand{\\slidetopmargin}{0.3in}
+ \\newdimen\\slidewidth \\slidewidth 9in")
+
+;*---------------------------------------------------------------------*/
+;* &slide-seminar-maketitle ... */
+;*---------------------------------------------------------------------*/
+(define &slide-seminar-maketitle
+ "\\def\\labelitemi{$\\bullet$}
+ \\def\\labelitemii{$\\circ$}
+ \\def\\labelitemiii{$\\diamond$}
+ \\def\\labelitemiv{$\\cdot$}
+ \\pagestyle{empty}
+ \\slideframe{none}
+ \\centerslidestrue
+ \\begin{slide}
+ \\date{}
+ \\maketitle
+ \\end{slide}
+ \\slideframe{none}
+ \\centerslidesfalse")
+
+;*---------------------------------------------------------------------*/
+;* &slide-prosper-predocument ... */
+;*---------------------------------------------------------------------*/
+(define &slide-prosper-predocument
+ "\\slideCaption{}\n")
+
+;*---------------------------------------------------------------------*/
+;* latex */
+;*---------------------------------------------------------------------*/
+(define &latex-slide #f)
+(define &latex-pause #f)
+(define &latex-embed #f)
+(define &latex-record #f)
+(define &latex-play #f)
+(define &latex-play* #f)
+
+;;; FIXME: We shouldn't load `latex.scm' from here. Instead, we should
+;;; register a hook on its load.
+(let ((le (find-engine 'latex)))
+ ;; slide-vspace
+ (markup-writer 'slide-vspace le
+ :options '(:unit)
+ :action (lambda (n e)
+ (display "\n\\vspace{")
+ (output (markup-body n) e)
+ (printf " ~a}\n\n" (markup-option n :unit))))
+ ;; slide-slide
+ (markup-writer 'slide le
+ :options '(:title :number :transition :vfill :toc :vspace :image)
+ :action (lambda (n e)
+ (if (procedure? &latex-slide)
+ (&latex-slide n e))))
+ ;; slide-pause
+ (markup-writer 'slide-pause le
+ :options '()
+ :action (lambda (n e)
+ (if (procedure? &latex-pause)
+ (&latex-pause n e))))
+ ;; slide-embed
+ (markup-writer 'slide-embed le
+ :options '(:alt :command :geometry-opt :geometry
+ :rgeometry :transient :transient-opt)
+ :action (lambda (n e)
+ (if (procedure? &latex-embed)
+ (&latex-embed n e))))
+ ;; slide-record
+ (markup-writer 'slide-record le
+ :options '(:tag :play)
+ :action (lambda (n e)
+ (if (procedure? &latex-record)
+ (&latex-record n e))))
+ ;; slide-play
+ (markup-writer 'slide-play le
+ :options '(:tag :color)
+ :action (lambda (n e)
+ (if (procedure? &latex-play)
+ (&latex-play n e))))
+ ;; slide-play*
+ (markup-writer 'slide-play* le
+ :options '(:tag :color :scolor)
+ :action (lambda (n e)
+ (if (procedure? &latex-play*)
+ (&latex-play* n e)))))
+
+;*---------------------------------------------------------------------*/
+;* %slide-seminar-setup! ... */
+;*---------------------------------------------------------------------*/
+(define (%slide-seminar-setup!)
+ (skribe-message "Seminar slides setup...\n")
+ (let ((le (find-engine 'latex))
+ (be (find-engine 'base)))
+ ;; latex configuration
+ (define (seminar-slide n e)
+ (let ((nb (markup-option n :number))
+ (t (markup-option n :title)))
+ (display "\\begin{slide}\n")
+ (if nb (printf "~a/~a -- " nb (slide-number)))
+ (output t e)
+ (display "\\hrule\n"))
+ (output (markup-body n) e)
+ (if (markup-option n :vill) (display "\\vfill\n"))
+ (display "\\end{slide}\n"))
+ (engine-custom-set! le 'documentclass
+ "\\documentclass[landscape]{seminar}\n")
+ (let ((o (engine-custom le 'predocument)))
+ (engine-custom-set! le 'predocument
+ (if (string? o)
+ (string-append &slide-seminar-predocument o)
+ &slide-seminar-predocument)))
+ (engine-custom-set! le 'maketitle
+ &slide-seminar-maketitle)
+ (engine-custom-set! le 'hyperref-usepackage
+ "\\usepackage[setpagesize=false]{hyperref}\n")
+ ;; slide-slide
+ (set! &latex-slide seminar-slide)))
+
+;*---------------------------------------------------------------------*/
+;* %slide-advi-setup! ... */
+;*---------------------------------------------------------------------*/
+(define (%slide-advi-setup!)
+ (skribe-message "Generating `Advi Seminar' slides...\n")
+ (let ((le (find-engine 'latex))
+ (be (find-engine 'base)))
+ (define (advi-geometry geo)
+ (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo)))
+ (if (pair? r)
+ (let* ((w (cadr r))
+ (w' (string->integer w))
+ (w'' (number->string (/ w' *skribe-slide-advi-scale*)))
+ (h (caddr r))
+ (h' (string->integer h))
+ (h'' (number->string (/ h' *skribe-slide-advi-scale*))))
+ (values "" (string-append w "x" h "+!x+!y")))
+ (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo)))
+ (if (pair? r)
+ (let ((w (number->string (/ (string->integer (cadr r))
+ *skribe-slide-advi-scale*)))
+ (h (number->string (/ (string->integer (caddr r))
+ *skribe-slide-advi-scale*)))
+ (x (cadddr r))
+ (y (car (cddddr r))))
+ (values (string-append "width=" w "cm,height=" h "cm")
+ "!g"))
+ (values "" geo))))))
+ (define (advi-transition trans)
+ (cond
+ ((string? trans)
+ (printf "\\advitransition{~s}" trans))
+ ((and (symbol? trans)
+ (memq trans '(wipe block slide)))
+ (printf "\\advitransition{~s}" trans))
+ (else
+ #f)))
+ ;; latex configuration
+ (define (advi-slide n e)
+ (let ((i (markup-option n :image))
+ (n (markup-option n :number))
+ (t (markup-option n :title))
+ (lt (markup-option n :transition))
+ (gt (engine-custom e 'transition)))
+ (if (and i (engine-custom e 'advi))
+ (printf "\\advibg[global]{image=~a}\n"
+ (if (and (pair? i)
+ (null? (cdr i))
+ (string? (car i)))
+ (car i)
+ i)))
+ (display "\\begin{slide}\n")
+ (advi-transition (or lt gt))
+ (if n (printf "~a/~a -- " n (slide-number)))
+ (output t e)
+ (display "\\hrule\n"))
+ (output (markup-body n) e)
+ (if (markup-option n :vill) (display "\\vfill\n"))
+ (display "\\end{slide}\n\n\n"))
+ ;; advi record
+ (define (advi-record n e)
+ (display "\\advirecord")
+ (when (markup-option n :play) (display "[play]"))
+ (printf "{~a}{" (markup-option n :tag))
+ (output (markup-body n) e)
+ (display "}"))
+ ;; advi play
+ (define (advi-play n e)
+ (display "\\adviplay")
+ (let ((c (markup-option n :color)))
+ (when c
+ (display "[")
+ (display (skribe-get-latex-color c))
+ (display "]")))
+ (printf "{~a}" (markup-option n :tag)))
+ ;; advi play*
+ (define (advi-play* n e)
+ (let ((c (skribe-get-latex-color (markup-option n :color)))
+ (d (skribe-get-latex-color (markup-option n :scolor))))
+ (let loop ((lbls (markup-body n))
+ (last #f))
+ (when last
+ (display "\\adviplay[")
+ (display d)
+ (printf "]{~a}" last))
+ (when (pair? lbls)
+ (let ((lbl (car lbls)))
+ (match-case lbl
+ ((?id ?col)
+ (display "\\adviplay[")
+ (display (skribe-get-latex-color col))
+ (printf "]{" ~a "}" id)
+ (skribe-eval (slide-pause) e)
+ (loop (cdr lbls) id))
+ (else
+ (display "\\adviplay[")
+ (display c)
+ (printf "]{~a}" lbl)
+ (skribe-eval (slide-pause) e)
+ (loop (cdr lbls) lbl))))))))
+ (engine-custom-set! le 'documentclass
+ "\\documentclass{seminar}\n")
+ (let ((o (engine-custom le 'predocument)))
+ (engine-custom-set! le 'predocument
+ (if (string? o)
+ (string-append &slide-seminar-predocument o)
+ &slide-seminar-predocument)))
+ (engine-custom-set! le 'maketitle
+ &slide-seminar-maketitle)
+ (engine-custom-set! le 'usepackage
+ (string-append "\\usepackage{advi}\n"
+ (engine-custom le 'usepackage)))
+ ;; slide
+ (set! &latex-slide advi-slide)
+ (set! &latex-pause
+ (lambda (n e) (display "\\adviwait\n")))
+ (set! &latex-embed
+ (lambda (n e)
+ (let ((geometry-opt (markup-option n :geometry-opt))
+ (geometry (markup-option n :geometry))
+ (rgeometry (markup-option n :rgeometry))
+ (transient (markup-option n :transient))
+ (transient-opt (markup-option n :transient-opt))
+ (cmd (markup-option n :command)))
+ (let* ((a (string-append "ephemeral="
+ (symbol->string (gensym))))
+ (c (cond
+ (geometry
+ (string-append cmd " "
+ geometry-opt " "
+ geometry))
+ (rgeometry
+ (multiple-value-bind (aopt dopt)
+ (advi-geometry rgeometry)
+ (set! a (string-append a "," aopt))
+ (string-append cmd " "
+ geometry-opt " "
+ dopt)))
+ (else
+ cmd)))
+ (c (if (and transient transient-opt)
+ (string-append c " " transient-opt " !p")
+ c)))
+ (printf "\\adviembed[~a]{~a}\n" a c)))))
+ (set! &latex-record advi-record)
+ (set! &latex-play advi-play)
+ (set! &latex-play* advi-play*)))
+
+;*---------------------------------------------------------------------*/
+;* %slide-prosper-setup! ... */
+;*---------------------------------------------------------------------*/
+(define (%slide-prosper-setup!)
+ (skribe-message "Generating `Prosper' slides...\n")
+ (let ((le (find-engine 'latex))
+ (be (find-engine 'base))
+ (overlay-count 0))
+ ;; transitions
+ (define (prosper-transition trans)
+ (cond
+ ((string? trans)
+ (printf "[~s]" trans))
+ ((eq? trans 'slide)
+ (printf "[Blinds]"))
+ ((and (symbol? trans)
+ (memq trans '(split blinds box wipe dissolve glitter)))
+ (printf "[~s]"
+ (string-upcase (symbol->string trans))))
+ (else
+ #f)))
+ ;; latex configuration
+ (define (prosper-slide n e)
+ (let* ((i (markup-option n :image))
+ (t (markup-option n :title))
+ (lt (markup-option n :transition))
+ (gt (engine-custom e 'transition))
+ (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n))
+ (lpa (length pa)))
+ (set! overlay-count 1)
+ (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa)))
+ (display "\\begin{slide}")
+ (prosper-transition (or lt gt))
+ (display "{")
+ (output t e)
+ (display "}\n")
+ (output (markup-body n) e)
+ (display "\\end{slide}\n")
+ (if (>= lpa 1) (display "}\n"))
+ (newline)
+ (newline)))
+ (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n")
+ (let* ((cap (engine-custom le 'slide-caption))
+ (o (engine-custom le 'predocument))
+ (n (if (string? cap)
+ (format #f "~a\\slideCaption{~a}\n"
+ &slide-prosper-predocument
+ cap)
+ &slide-prosper-predocument)))
+ (engine-custom-set! le 'predocument
+ (if (string? o) (string-append n o) n)))
+ (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n")
+ ;; writers
+ (set! &latex-slide prosper-slide)
+ (set! &latex-pause
+ (lambda (n e)
+ (set! overlay-count (+ 1 overlay-count))
+ (printf "\\FromSlide{~s}%\n" overlay-count)))))
+
+;*---------------------------------------------------------------------*/
+;* Setup ... */
+;*---------------------------------------------------------------------*/
+(let* ((opt &slide-load-options)
+ (p (memq :prosper opt)))
+ (if (and (pair? p) (pair? (cdr p)) (cadr p))
+ ;; prosper
+ (set! %slide-latex-mode 'prosper)
+ (let ((a (memq :advi opt)))
+ (if (and (pair? a) (pair? (cdr a)) (cadr a))
+ ;; advi
+ (set! %slide-latex-mode 'advi)))))
+
+
+
+;;;
+;;; Initialization.
+;;;
+
+(%slide-latex-initialize!)
+
+;;; arch-tag: b99e2c65-55f7-462c-8482-f47c7e223538
diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm
new file mode 100644
index 0000000..d53cff1
--- /dev/null
+++ b/src/guile/skribilo/package/slide/lout.scm
@@ -0,0 +1,151 @@
+;;; lout.scm -- Lout implementation of the `slide' package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package slide lout)
+ :use-module (skribilo utils syntax)
+
+ ;; XXX: If changing the following `autoload' to `use-module' doesn't work,
+ ;; then you need to fix your Guile. See this thread about
+ ;; `make-autoload-interface':
+ ;;
+ ;; http://article.gmane.org/gmane.lisp.guile.devel/5748
+ ;; http://lists.gnu.org/archive/html/guile-devel/2006-03/msg00004.html .
+
+ :autoload (skribilo engine lout) (lout-tagify lout-output-pdf-meta-info
+ lout-verbatim-encoding))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; TODO:
+;;;
+;;; Make some more PS/PDF trickery.
+
+(format (current-error-port) "Lout slides setup...~%")
+
+(let ((le (find-engine 'lout)))
+
+ ;; FIXME: Automatically switching to `slides' is problematic, e.g., for the
+ ;; user manual which embeds slides.
+; ;; Automatically switch to the `slides' document type.
+; (engine-custom-set! le 'document-type 'slides))
+
+ (markup-writer 'slide le
+ :options '(:title :number :toc :ident) ;; '(:bg :vspace :image)
+
+ :validate (lambda (n e)
+ (eq? (engine-custom e 'document-type) 'slides))
+
+ :before (lambda (n e)
+ (display "\n@Overhead\n")
+ (display " @Title { ")
+ (output (markup-option n :title) e)
+ (display " }\n")
+ (if (markup-ident n)
+ (begin
+ (display " @Tag { ")
+ (display (lout-tagify (markup-ident n)))
+ (display " }\n")))
+ (if (markup-option n :number)
+ (begin
+ (display " @BypassNumber { ")
+ (output (markup-option n :number) e)
+ (display " }\n")))
+ (display "@Begin\n")
+
+ ;; `doc' documents produce their PDF outline right after
+ ;; `@Text @Begin'; other types of documents must produce it
+ ;; as part of their first chapter.
+ (lout-output-pdf-meta-info (ast-document n) e))
+
+ :after "@End @Overhead\n")
+
+ (markup-writer 'slide-vspace le
+ :options '(:unit)
+ :validate (lambda (n e)
+ (and (pair? (markup-body n))
+ (number? (car (markup-body n)))))
+ :action (lambda (n e)
+ (printf "\n//~a~a # slide-vspace\n"
+ (car (markup-body n))
+ (case (markup-option n :unit)
+ ((cm) "c")
+ ((point points pt) "p")
+ ((inch inches) "i")
+ (else
+ (skribe-error 'lout
+ "Unknown vspace unit"
+ (markup-option n :unit)))))))
+
+ (markup-writer 'slide-pause le
+ ;; FIXME: Use a `pdfmark' custom action and a PDF transition action.
+ ;; << /Type /Action
+ ;; << /S /Trans
+ ;; entry in the trans dict
+ ;; << /Type /Trans /S /Dissolve >>
+ :action (lambda (n e)
+ (let ((filter (make-string-replace lout-verbatim-encoding))
+ (pdfmark "
+[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark"))
+ (display (lout-embedded-postscript-code
+ (filter pdfmark))))))
+
+ ;; For movies, see
+ ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty .
+ (markup-writer 'slide-embed le
+ :options '(:alt :geometry :rgeometry :geometry-opt :command)
+ ;; FIXME: `pdfmark'.
+ ;; << /Type /Action /S /Launch
+ :action (lambda (n e)
+ (let ((command (markup-option n :command))
+ (filter (make-string-replace lout-verbatim-encoding))
+ (pdfmark "[ /Rect [ 0 ysize xsize 0 ]
+/Name /Comment
+/Contents (This is an embedded application)
+/ANN pdfmark
+
+[ /Type /Action
+/S /Launch
+/F (~a)
+/OBJ pdfmark"))
+ (display (string-append
+ "4c @Wide 3c @High "
+ (lout-embedded-postscript-code
+ (filter (format #f pdfmark command)))))))))
+
+
+
+;;;
+;;; Customs for a nice handling of topics/subtopics.
+;;;
+
+(let ((lout (find-engine 'lout)))
+ (if lout
+ (begin
+ (engine-custom-set! lout 'pdf-bookmark-node-pred
+ (lambda (n e)
+ (or (is-markup? n 'slide)
+ (is-markup? n 'slide-topic)
+ (is-markup? n 'slide-subtopic))))
+ (engine-custom-set! lout 'pdf-bookmark-closed-pred
+ (lambda (n e) #f)))))
+
+
+;;; arch-tag: 0c717553-5cbb-46ed-937a-f844b6aeb145
diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm
new file mode 100644
index 0000000..6d1b7a5
--- /dev/null
+++ b/src/guile/skribilo/package/web-article.scm
@@ -0,0 +1,241 @@
+;;; web-article.scm -- A Skribe style for producing web articles
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package web-article))
+
+;*---------------------------------------------------------------------*/
+;* &web-article-load-options ... */
+;*---------------------------------------------------------------------*/
+(define &web-article-load-options (skribe-load-options))
+
+;*---------------------------------------------------------------------*/
+;* web-article-body-width ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-body-width e)
+ (let ((w (engine-custom e 'body-width)))
+ (if (or (number? w) (string? w)) w 98.)))
+
+;*---------------------------------------------------------------------*/
+;* html-document-title-web ... */
+;*---------------------------------------------------------------------*/
+(define (html-document-title-web n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (tbg (engine-custom e 'title-background))
+ (tfg (engine-custom e 'title-foreground))
+ (tfont (engine-custom e 'title-font)))
+ (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>"
+ (html-width (web-article-body-width e)))
+ (if (string? tbg)
+ (printf "<td bgcolor=\"~a\">" tbg)
+ (display "<td>"))
+ (if (string? tfg)
+ (printf "<font color=\"~a\">" tfg))
+ (if title
+ (begin
+ (display "<center>")
+ (if (string? tfont)
+ (begin
+ (printf "<font ~a><b>" tfont)
+ (output title e)
+ (display "</b></font>"))
+ (begin
+ (printf "<h1>")
+ (output title e)
+ (display "</h1>")))
+ (display "</center>\n")))
+ (if (not authors)
+ (display "\n")
+ (html-title-authors authors e))
+ (if (string? tfg)
+ (display "</font>"))
+ (display "</td></tr></tbody></table></center>\n")))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-document-title ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-document-title n e)
+ (let* ((title (markup-body n))
+ (authors (markup-option n 'author))
+ (id (markup-ident n)))
+ ;; the title
+ (printf "<div id=\"~a\" class=\"document-title-title\">\n"
+ (string-canonicalize id))
+ (output title e)
+ (display "</div>\n")
+ ;; the authors
+ (printf "<div id=\"~a\" class=\"document-title-authors\">\n"
+ (string-canonicalize id))
+ (for-each (lambda (a) (output a e))
+ (cond
+ ((is-markup? authors 'author)
+ (list authors))
+ ((list? authors)
+ authors)
+ (else
+ '())))
+ (display "</div>\n")))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-author ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-author n e)
+ (let ((name (markup-option n :name))
+ (title (markup-option n :title))
+ (affiliation (markup-option n :affiliation))
+ (email (markup-option n :email))
+ (url (markup-option n :url))
+ (address (markup-option n :address))
+ (phone (markup-option n :phone))
+ (nfn (engine-custom e 'author-font))
+ (align (markup-option n :align)))
+ (when name
+ (printf "<span class=\"document-author-name\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output name e)
+ (display "</span>\n"))
+ (when title
+ (printf "<span class=\"document-author-title\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output title e)
+ (display "</span>\n"))
+ (when affiliation
+ (printf "<span class=\"document-author-affiliation\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output affiliation e)
+ (display "</span>\n"))
+ (when (pair? address)
+ (printf "<span class=\"document-author-address\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (for-each (lambda (a)
+ (output a e)
+ (newline))
+ address)
+ (display "</span>\n"))
+ (when phone
+ (printf "<span class=\"document-author-phone\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output phone e)
+ (display "</span>\n"))
+ (when email
+ (printf "<span class=\"document-author-email\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output email e)
+ (display "</span>\n"))
+ (when url
+ (printf "<span class=\"document-author-url\" id=\"~a\">"
+ (string-canonicalize (markup-ident n)))
+ (output url e)
+ (display "</span>\n"))))
+
+;*---------------------------------------------------------------------*/
+;* HTML settings */
+;*---------------------------------------------------------------------*/
+(define (web-article-modern-setup he)
+ (let ((sec (markup-writer-get 'section he))
+ (ft (markup-writer-get '&html-footnotes he)))
+ ;; &html-document-title
+ (markup-writer '&html-document-title he
+ :action html-document-title-web)
+ ;; section
+ (markup-writer 'section he
+ :options 'all
+ :before "<br>"
+ :action (lambda (n e)
+ (let ((e1 (make-engine 'html-web :delegate e))
+ (bg (engine-custom he 'section-background)))
+ (markup-writer 'section e1
+ :options 'all
+ :action (lambda (n e2) (output n e sec)))
+ (skribe-eval
+ (center (color :width (web-article-body-width e)
+ :margin 5 :bg bg n))
+ e1))))
+ ;; &html-footnotes
+ (markup-writer '&html-footnotes he
+ :options 'all
+ :before "<br>"
+ :action (lambda (n e)
+ (let ((e1 (make-engine 'html-web :delegate e))
+ (bg (engine-custom he 'section-background))
+ (fg (engine-custom he 'subsection-title-foreground)))
+ (markup-writer '&html-footnotes e1
+ :options 'all
+ :action (lambda (n e2)
+ (invoke (writer-action ft) n e)))
+ (skribe-eval
+ (center (color :width (web-article-body-width e)
+ :margin 5 :bg bg :fg fg n))
+ e1))))))
+
+;*---------------------------------------------------------------------*/
+;* web-article-css-setup ... */
+;*---------------------------------------------------------------------*/
+(define (web-article-css-setup he)
+ (let ((sec (markup-writer-get 'section he))
+ (ft (markup-writer-get '&html-footnotes he)))
+ ;; &html-document-title
+ (markup-writer '&html-document-title he
+ :before (lambda (n e)
+ (printf "<div id=\"~a\" class=\"document-title\">\n"
+ (string-canonicalize (markup-ident n))))
+ :action web-article-css-document-title
+ :after "</div>\n")
+ ;; author
+ (markup-writer 'author he
+ :options '(:name :title :affiliation :email :url :address :phone :photo :align)
+ :before (lambda (n e)
+ (printf "<span id=\"~a\" class=\"document-author\">\n"
+ (string-canonicalize (markup-ident n))))
+ :action web-article-css-author
+ :after "</span\n")
+ ;; section
+ (markup-writer 'section he
+ :options 'all
+ :before (lambda (n e)
+ (printf "<div class=\"section\" id=\"~a\">"
+ (string-canonicalize (markup-ident n))))
+ :action (lambda (n e) (output n e sec))
+ :after "</div>\n")
+ ;; &html-footnotes
+ (markup-writer '&html-footnotes he
+ :options 'all
+ :before (lambda (n e)
+ (printf "<div class=\"footnotes\" id=\"~a\">"
+ (string-canonicalize (markup-ident n))))
+ :action (lambda (n e)
+ (output n e ft))
+ :after "</div>\n")))
+
+;*---------------------------------------------------------------------*/
+;* Setup ... */
+;*---------------------------------------------------------------------*/
+(let* ((opt &web-article-load-options)
+ (p (memq :style opt))
+ (css (memq :css opt))
+ (he (find-engine 'html)))
+ (cond
+ ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css))
+ (web-article-css-setup he))
+ ((and (pair? css) (pair? (cdr css)) (string? (cadr css)))
+ (engine-custom-set! he 'css (cadr css))
+ (web-article-css-setup he))
+ (else
+ (web-article-modern-setup he))))
diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm
new file mode 100644
index 0000000..49197f1
--- /dev/null
+++ b/src/guile/skribilo/package/web-book.scm
@@ -0,0 +1,121 @@
+;;; web-book.scm -- The Skribe web book style.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-skribe-module (skribilo package web-book))
+
+;*---------------------------------------------------------------------*/
+;* html customization */
+;*---------------------------------------------------------------------*/
+(define he (find-engine 'html))
+(engine-custom-set! he 'main-browsing-extra #f)
+(engine-custom-set! he 'chapter-file #t)
+
+;*---------------------------------------------------------------------*/
+;* main-browsing ... */
+;*---------------------------------------------------------------------*/
+(define main-browsing
+ (lambda (n e)
+ ;; search the document
+ (let ((p (ast-document n)))
+ (cond
+ ((document? p)
+ ;; got it
+ (let* ((mt (markup-option p :margin-title))
+ (r (ref :handle (handle p)
+ :text (or mt (markup-option p :title))))
+ (fx (engine-custom e 'web-book-main-browsing-extra)))
+ (center
+ (table :width 97. :border 1 :frame 'box
+ :cellpadding 0 :cellspacing 0
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((text (bold "main page"))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg bg text) text))))
+ (tr :bg (engine-custom e 'background)
+ (td (apply table :width 100. :border 0
+ (tr (td :align 'left
+ :valign 'top
+ (bold "top:"))
+ (td :align 'right
+ :valign 'top r))
+ (if (procedure? fx)
+ (list (tr (td :width 100.
+ :colspan 2
+ (fx n e))))
+ '()))))))))
+ ((not p)
+ ;; no document!!!
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* chapter-browsing ... */
+;*---------------------------------------------------------------------*/
+(define chapter-browsing
+ (lambda (n e)
+ (center
+ (table :width 97. :border 1 :frame 'box
+ :cellpadding 0 :cellspacing 0
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((title (bold (markup-option n :title)))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg title) title))))
+ (tr :bg (engine-custom e 'background)
+ (td (toc (handle n) :chapter #t :section #t :subsection #t)))))))
+
+;*---------------------------------------------------------------------*/
+;* document-browsing ... */
+;*---------------------------------------------------------------------*/
+(define document-browsing
+ (lambda (n e)
+ (let ((chap (find1-down (lambda (n)
+ (is-markup? n 'chapter))
+ n)))
+ (center
+ (table :width 97. :border 1 :frame 'box
+ :cellpadding 0 :cellspacing 0
+ (tr :bg (engine-custom e 'title-background)
+ (th (let ((text (bold (if chap "Chapters" "Sections")))
+ (bg (engine-custom e 'background)))
+ (if bg (color :fg bg text) text))))
+ (tr :bg (engine-custom e 'background)
+ (td (if chap
+ (toc (handle n) :chapter #t :section #f)
+ (toc (handle n) :section #t :subsection #t)))))))))
+
+;*---------------------------------------------------------------------*/
+;* left margin ... */
+;*---------------------------------------------------------------------*/
+(engine-custom-set! he 'left-margin-size 20.)
+
+(engine-custom-set! he 'left-margin
+ (lambda (n e)
+ (let ((d (ast-document n))
+ (c (ast-chapter n)))
+ (list (linebreak 1)
+ (main-browsing n e)
+ (if (is-markup? c 'chapter)
+ (list (linebreak 2)
+ (chapter-browsing c e))
+ #f)
+ (if (document? d)
+ (list (linebreak 2)
+ (document-browsing d e))
+ #f)))))
+
diff --git a/src/guile/skribilo/parameters.scm b/src/guile/skribilo/parameters.scm
new file mode 100644
index 0000000..5893851
--- /dev/null
+++ b/src/guile/skribilo/parameters.scm
@@ -0,0 +1,88 @@
+;;; parameters.scm -- Skribilo settings as parameter objects.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo parameters)
+ :use-module (srfi srfi-39))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module defines parameter objects that may be used to specify
+;;; run-time parameters of a Skribilo process.
+;;;
+;;; Code:
+
+
+;;;
+;;; Switches.
+;;;
+
+(define (make-expect pred pred-name parameter)
+ (let ((msg (string-append parameter ": " pred-name " expected")))
+ (lambda (val)
+ (if (pred val)
+ val
+ (error msg val)))))
+
+(define-macro (define-number-parameter name)
+ `(define-public ,name
+ (make-parameter 0
+ (make-expect number? "number" ,(symbol->string name)))))
+
+(define-number-parameter *verbose*)
+(define-number-parameter *warning*)
+
+(define-public *load-rc-file?* (make-parameter #f))
+
+;;;
+;;; Paths.
+;;;
+
+
+(define-macro (define-path-parameter name)
+ `(define-public ,name
+ (make-parameter (list ".")
+ (make-expect list? "list" ,(symbol->string name)))))
+
+
+(define-path-parameter *document-path*)
+(define-path-parameter *bib-path*)
+(define-path-parameter *source-path*)
+(define-path-parameter *image-path*)
+
+
+;;;
+;;; Files.
+;;;
+
+(define-public *destination-file* (make-parameter "output.html"))
+(define-public *source-file* (make-parameter "default-input-file.skb"))
+
+;; Base prefix to remove from hyperlinks.
+(define-public *ref-base* (make-parameter ""))
+
+;;; TODO: Skribe used to have other parameters as global variables. See
+;;; which ones need to be kept.
+
+
+;;; arch-tag: 3c0d2e18-b997-4615-8a3d-b6622ae28874
+
+;;; parameters.scm ends here
diff --git a/src/stklos/prog.stk b/src/guile/skribilo/prog.scm
index 6301ece..266d607 100644
--- a/src/stklos/prog.stk
+++ b/src/guile/skribilo/prog.scm
@@ -1,39 +1,40 @@
-;;;;
-;;;; 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)
-;;;;
+;;; prog.scm -- All the stuff for the prog markup
+;;;
+;;; Copyright 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
-(define-module SKRIBE-PROG-MODULE
- (export make-prog-body resolve-line)
+(define-module (skribilo prog)
+ :use-module (ice-9 regex)
+ :autoload (ice-9 receive) (receive)
+ :use-module (skribilo lib) ;; `new'
+ :autoload (skribilo ast) (node? node-body)
+ :export (make-prog-body resolve-line))
;;; ======================================================================
;;;
;;; COMPATIBILITY
;;;
;;; ======================================================================
-(define pregexp-match regexp-match)
-(define pregexp-replace regexp-replace)
+(define pregexp-match string-match)
+(define pregexp-replace (lambda (rx str what)
+ (regexp-substitute/global #f rx str
+ 'pre what 'post)))
(define pregexp-quote regexp-quote)
@@ -48,22 +49,22 @@
;*---------------------------------------------------------------------*/
;* *lines* ... */
;*---------------------------------------------------------------------*/
-(define *lines* (make-hashtable))
+;; FIXME: Removed that global. Rework the thing.
+(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)
+(define (make-line-mark m line-ident b)
+ (let* ((n (list (mark line-ident) b)))
+ (hash-set! *lines* m n)
n))
;*---------------------------------------------------------------------*/
;* resolve-line ... */
;*---------------------------------------------------------------------*/
(define (resolve-line id)
- (hashtable-get *lines* id))
+ (hash-ref *lines* id))
;*---------------------------------------------------------------------*/
;* extract-string-mark ... */
@@ -88,7 +89,7 @@
(values #f line))
((string? line)
(extract-string-mark line mark regexp))
- ((pair? line)
+ ((list? line)
(let loop ((ls line)
(res '()))
(if (null? ls)
@@ -134,7 +135,7 @@
(loop r1
(+ r2 1)
res))))))
- ((pair? line)
+ ((list? line)
(let loop ((ls line)
(res '()))
(if (null? ls)
@@ -188,7 +189,7 @@
(string-append (make-string (- rl l) #\space) s))))
(let* ((regexp (and mark
- (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+"
+ (format #f "~a[-a-zA-Z_][-0-9a-zA-Z_]+"
(pregexp-quote mark))))
(src (cond
((not (pair? src)) (list src))
@@ -208,12 +209,12 @@
(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)))))
+ (let* ((line-ident (symbol->string (gensym "&prog-line")))
+ (n (new markup
+ (markup '&prog-line)
+ (ident line-ident)
+ (body (if m (make-line-mark m line-ident l) l)))))
(loop (cdr lines)
(+ lnum 1)
(cons n res))))))))
-) \ No newline at end of file
diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm
new file mode 100644
index 0000000..871d92c
--- /dev/null
+++ b/src/guile/skribilo/reader.scm
@@ -0,0 +1,106 @@
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo reader)
+ :use-module (srfi srfi-9) ;; records
+ :use-module (srfi srfi-17) ;; generalized `set!'
+ :use-module (srfi srfi-39) ;; parameter objects
+ :use-module (skribilo condition)
+ :autoload (srfi srfi-34) (raise)
+ :use-module (srfi srfi-35)
+ :export (%make-reader lookup-reader make-reader
+ %default-reader *document-reader*
+
+ &reader-search-error reader-search-error?
+ reader-search-error: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))
+
+
+;;; Error condition.
+
+(define-condition-type &reader-search-error &skribilo-error
+ reader-search-error?
+ (reader reader-search-error:reader))
+
+
+
+;;; 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
+reader)} module hierarchy. If no such reader was found, an error is
+raised."
+ (let ((m (false-if-exception
+ (resolve-module `(skribilo reader ,name)))))
+ (if (and (module? m)
+ (module-bound? m 'reader-specification))
+ (module-ref m 'reader-specification)
+ (raise (condition (&reader-search-error (reader name)))))))
+
+(define (make-reader name)
+ "Look for reader @var{name} and instantiate it."
+ (let* ((spec (lookup-reader name))
+ (make (reader:make spec)))
+ (make)))
+
+(define %default-reader (make-reader 'skribe))
+
+
+;;; Current document reader.
+
+(define *document-reader* (make-parameter %default-reader))
+
+
+;;; reader.scm ends here
diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am
new file mode 100644
index 0000000..807e4a7
--- /dev/null
+++ b/src/guile/skribilo/reader/Makefile.am
@@ -0,0 +1,2 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/reader
+dist_guilemodule_DATA = skribe.scm outline.scm
diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm
new file mode 100644
index 0000000..09792f5
--- /dev/null
+++ b/src/guile/skribilo/reader/outline.scm
@@ -0,0 +1,426 @@
+;;; outline.scm -- A reader for Emacs' outline syntax.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo reader outline)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo reader)
+ :use-module (ice-9 optargs)
+ :use-module (srfi srfi-11)
+
+ :autoload (ice-9 rdelim) (read-line)
+ :autoload (ice-9 regex) (make-regexp)
+
+ :export (reader-specification
+ make-outline-reader))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; A reader for Emacs' outline-mode syntax.
+;;;
+;;; Code:
+
+;;; TODO:
+;;;
+;;; - add source position information;
+;;; - handle `blockquote' (indented paragraph);
+;;; - handle sublists (indented lists) --- optional;
+;;; - handle inline Skribe code: `\n{skribe\n(table (tr ... ))\n}\n'
+
+
+
+
+;;;
+;;; Tools.
+;;;
+
+(define (apply-any procs args)
+ "Apply the procedure listed in @var{procs} to @var{args} until one of these
+procedure returns true."
+ (let loop ((procs procs))
+ (if (null? procs)
+ #f
+ (let ((result (apply (car procs) args)))
+ (if result result (loop (cdr procs)))))))
+
+(define (make-markup name body)
+ "Return a clean markup form, i.e., an s-exp whose @code{car} is a symbol
+equal to @var{name}, a markup name."
+ (cond ((list? body)
+ (cond ((null? body) `(,name))
+ ((symbol? (car body)) `(,name ,body))
+ (else `(,name ,@body))))
+ (else
+ (list name body))))
+
+
+(define (append-trees . trees)
+ "Append markup trees @var{trees}. Trees whose car is a symbol (e.g.,
+@code{(bold \"paf\")} will be considered as sub-trees of the resulting tree."
+ (let loop ((trees trees)
+ (result '()))
+ (if (null? trees)
+ result
+ (let ((tree (car trees)))
+ (loop (cdr trees)
+ (append result
+ (if (list? tree)
+ (cond ((null? tree) '())
+ ((symbol? (car tree)) (list tree))
+ (else tree))
+ (list tree))))))))
+
+(define (null-string? s)
+ (and (string? s) (string=? s "")))
+
+
+(define empty-line-rx (make-regexp "^([[:space:]]*|;.*)$"))
+(define (empty-line? s)
+ "Return true if string @var{s} denotes an ``empty'' line, i.e., a blank
+line or a line comment."
+ (regexp-exec empty-line-rx s))
+
+
+
+;;;
+;;; In-line markup, i.e., markup that doesn't span over multiple lines.
+;;;
+
+(define %inline-markup
+ ;; Note: the order matters because, for instance, URLs must be searched for
+ ;; _before_ italics (`/italic/').
+ `(("_([^_]+)_" .
+ ,(lambda (m)
+ (values (match:prefix m) ;; before
+ (match:substring m 1) ;; body
+ (match:suffix m) ;; after
+ (lambda (body) `(emph ,body))))) ;; process-body
+ ("(f|ht)tp://[a-zA-Z0-9\\._~%/-]+" .
+ ,(lambda (m)
+ (values (match:prefix m)
+ (match:substring m)
+ (match:suffix m)
+ (lambda (url) `(ref :url ,url)))))
+ ("\\/([^\\/]+)\\/" .
+ ,(lambda (m)
+ (values (match:prefix m)
+ (match:substring m 1)
+ (match:suffix m)
+ (lambda (body) `(it ,body)))))
+ ("\\*([^\\*]+)\\*" .
+ ,(lambda (m)
+ (values (match:prefix m)
+ (match:substring m 1)
+ (match:suffix m)
+ (lambda (body) `(bold ,body)))))
+ ("``(([^`^'])+)''" .
+ ,(lambda (m)
+ (values (match:prefix m)
+ (match:substring m 1)
+ (match:suffix m)
+ (lambda (body) `(q ,body)))))
+ ("`(([^`^'])+)'" .
+ ,(lambda (m)
+ (values (match:prefix m)
+ (match:substring m 1)
+ (match:suffix m)
+ (lambda (body) `(tt ,body)))))))
+
+(define (make-markup-processor rx proc)
+ (lambda (line)
+ (let ((match (regexp-exec rx line)))
+ (if match
+ (proc match)
+ #f))))
+
+(define (make-line-processor markup-alist)
+ "Returns a @dfn{line processor}. A line processor is a procedure that
+takes a string and returns a list."
+ (let* ((markups (map (lambda (rx+proc)
+ (cons (make-regexp (car rx+proc) regexp/extended)
+ (cdr rx+proc)))
+ markup-alist))
+ (procs (map (lambda (rx+proc)
+ (make-markup-processor (car rx+proc) (cdr rx+proc)))
+ markups)))
+ (lambda (line)
+ (let self ((line line))
+ ;;(format #t "self: ~a~%" line)
+ (cond ((string? line)
+ (let ((result (apply-any procs (list line))))
+ (if result
+ (let-values (((before body after proc-body)
+ result))
+ (let ((body+
+ (if (string=? (string-append before body after)
+ line)
+ body (self body))))
+ (if (and (null-string? before)
+ (null-string? after))
+ (proc-body body+)
+ (append-trees (self before)
+ (proc-body body+)
+ (self after)))))
+ line)))
+ (else
+ (error "line-processor: internal error" line)))))))
+
+(define %line-processor
+ (make-line-processor %inline-markup))
+
+
+
+;;;
+;;; Large-scale structures: paragraphs, chapters, sections, etc.
+;;;
+
+(define (process-paragraph line line-proc port)
+ (let loop ((line line)
+ (result '()))
+ (if (or (eof-object? line) (empty-line? line))
+ (cons 'p result)
+ (loop (read-line port)
+ (let ((line (line-proc line)))
+ (append-trees result line "\n"))))))
+
+(define (make-list-processor rx node-type extract-line-proc line-proc
+ end-of-node?)
+ "Return a procedure (a @dfn{list processor}) that takes a line and a port
+and returns an AST node of type @var{node-type} (a symbol, typically
+@code{itemize} or @code{enumerate}) along with a line. If the processor is
+not triggered, i.e., it is passed a line that does not match @var{rx}, then
+it returns @code{#f}."
+ (lambda (line port)
+ (let ((match (regexp-exec rx line)))
+ (if (not match)
+ #f
+ (let loop ((line line)
+ (contiguous-empty-lines 0)
+ (item '())
+ (body '()))
+ (if (eof-object? line)
+ (let ((body (if (null? item)
+ body
+ (cons `(item ,@(reverse! item)) body))))
+ (values line `(,node-type ,@(reverse! body))))
+ (let ((match (regexp-exec rx line)))
+ (cond (match
+ ;; reading the first line of an item
+ (loop (read-line port) 0
+ (append-trees
+ (line-proc (extract-line-proc match)))
+ body))
+
+ ((and (procedure? end-of-node?)
+ (end-of-node? line))
+ (values line
+ `(,node-type ,@(reverse! body))))
+
+ ((empty-line? line)
+ (cond ((>= contiguous-empty-lines 1)
+ ;; end of list
+ (values line
+ `(,node-type ,@(reverse! body))))
+
+ ((= contiguous-empty-lines 0)
+ ;; end of item: add ITEM to BODY
+ (loop (read-line port) 1 '()
+ (cons (make-markup 'item item)
+ body)))
+
+ (else
+ ;; skipping empty line
+ (loop (read-line port)
+ (+ 1 contiguous-empty-lines)
+ item body))))
+
+ (else
+ ;; reading an item: add LINE to ITEM
+ (loop (read-line port) 0
+ (append-trees item (line-proc line))
+ body))))))))))
+
+(define (make-node-processor rx node-type title-proc line-proc
+ subnode-procs end-of-node?)
+ "Return a procedure that reads the given string and return an AST node of
+type @var{node-type} or @code{#f}. When the original string matches the node
+header, then the rest of the node is read from @var{port}.
+@var{subnode-procs} is a list of node processors for node types subordinate
+to @var{node-type}."
+ (lambda (line port)
+ (let ((match (regexp-exec rx line)))
+ (if (not match)
+ #f
+ (let ((title (line-proc (title-proc match))))
+ (let loop ((line (read-line port))
+ (body '()))
+
+ (let ((subnode (and (not (eof-object? line))
+ (apply-any subnode-procs
+ (list line port)))))
+ (cond (subnode
+ (let-values (((line node) subnode))
+ (loop line (cons node body))))
+
+ ((or (eof-object? line)
+ (regexp-exec rx line)
+ (and (procedure? end-of-node?)
+ (end-of-node? line)))
+ (values line
+ `(,node-type :title ,title ,@(reverse! body))))
+
+ ((empty-line? line)
+ (loop (read-line port) body))
+
+ (else
+ (let ((par (process-paragraph line line-proc port)))
+ (loop (read-line port)
+ (cons par body))))))))))))
+
+
+(define (node-markup-line? line)
+ (define node-rx (make-regexp "^\\*+ (.+)$" regexp/extended))
+ (regexp-exec node-rx line))
+
+(define %list-processors
+ (list (make-list-processor (make-regexp "^[-~o] (.+)$" regexp/extended)
+ 'itemize
+ (lambda (m) (match:substring m 1))
+ %line-processor
+ node-markup-line?)
+ (make-list-processor (make-regexp "^([0-9]+)\\.? (.+)$"
+ regexp/extended)
+ 'enumerate
+ (lambda (m) (match:substring m 2))
+ %line-processor
+ node-markup-line?)))
+
+(define %node-processors
+ (let* ((subsubsection-proc
+ (make-node-processor (make-regexp "^\\*\\*\\*\\* (.+)$"
+ regexp/extended)
+ 'subsection
+ (lambda (m) (match:substring m 1))
+ %line-processor
+ %list-processors ;; no further subnodes
+ node-markup-line?))
+ (subsection-proc
+ (make-node-processor (make-regexp "^\\*\\*\\* (.+)$"
+ regexp/extended)
+ 'subsection
+ (lambda (m) (match:substring m 1))
+ %line-processor
+ (append %list-processors
+ (list subsubsection-proc))
+ node-markup-line?))
+ (section-proc
+ (make-node-processor (make-regexp "^\\*\\* (.+)$" regexp/extended)
+ 'section
+ (lambda (m) (match:substring m 1))
+ %line-processor
+ (append %list-processors
+ (list subsection-proc))
+ node-markup-line?)))
+ (list (make-node-processor (make-regexp "^\\* (.+)$" regexp/extended)
+ 'chapter
+ (lambda (m) (match:substring m 1))
+ %line-processor
+ (append %list-processors
+ (list section-proc))
+ #f))))
+
+
+
+
+;;;
+;;; The top-level parser.
+;;;
+
+(define (make-document-processor node-procs line-proc)
+ (lambda (line port)
+ (let self ((line line)
+ (doc '()))
+ ;;(format #t "doc-proc: ~a~%" line)
+ (if (eof-object? line)
+ (if (null? doc)
+ line
+ (reverse! doc))
+ (if (empty-line? line)
+ (self (read-line port) doc)
+ (let ((result (apply-any node-procs (list line port))))
+ (if result
+ (let-values (((line node) result))
+ (self line (cons node doc)))
+ (let ((par (process-paragraph line line-proc port)))
+ (self (read-line port)
+ (cons par doc))))))))))
+
+
+(define* (outline-reader :optional (port (current-input-port)))
+ (define modeline-rx
+ (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$"))
+ (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended))
+ (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended))
+
+ (let ((doc-proc (make-document-processor %node-processors %line-processor)))
+
+ (let loop ((title #f)
+ (author #f)
+ (line (read-line port)))
+
+ (if (eof-object? line)
+ (if (or title author)
+ `(document :title ,title :author (author :name ,author) '())
+ line)
+ (if (or (empty-line? line)
+ (regexp-exec modeline-rx line))
+ (loop title author (read-line port))
+ (let ((title-match (regexp-exec title-rx line)))
+ (if title-match
+ (loop (match:substring title-match 1)
+ author (read-line port))
+ (let ((author-match (regexp-exec author-rx line)))
+ (if author-match
+ (loop title (match:substring author-match 1)
+ (read-line port))
+
+ ;; Let's go.
+ `(document :title ,title
+ :author (author :name ,author)
+ ,@(doc-proc line port)))))))))))
+
+
+(define* (make-outline-reader :optional (version "0.1"))
+ outline-reader)
+
+
+
+;;; The reader specification.
+
+(define-reader outline "0.1" make-outline-reader)
+
+
+;;; arch-tag: 53473e73-c811-4eed-a0b4-22ada4d6ef08
+
+;;; outline.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..d3dbb5f
--- /dev/null
+++ b/src/guile/skribilo/reader/skribe.scm
@@ -0,0 +1,113 @@
+;;; skribe.scm -- A reader for the Skribe syntax.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo reader skribe)
+ :use-module (skribilo reader)
+ :use-module (ice-9 optargs)
+ :use-module (srfi srfi-1)
+
+ ;; the Scheme reader composition framework
+ :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:))
+
+ :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:
+
+;;; Note: We need guile-reader 0.2 at least.
+
+(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-colon-free-token-reader tr)
+ ;; Stolen from `guile-reader' 0.3.
+ "If token reader @var{tr} handles the @code{:} (colon) character, remove it
+from its specification and return the new token reader."
+ (let* ((spec (r:token-reader-specification tr))
+ (proc (r:token-reader-procedure tr)))
+ (r:make-token-reader (filter (lambda (chr)
+ (not (char=? chr #\:)))
+ spec)
+ proc)))
+
+(define &sharp-reader
+ ;; The reader for what comes after a `#' character.
+ (let* ((dsssl-keyword-reader ;; keywords à la `#!key'
+ (r:make-token-reader #\!
+ (r:token-reader-procedure
+ (r:standard-token-reader 'keyword)))))
+ (r:make-reader (cons dsssl-keyword-reader
+ (map r:standard-token-reader
+ '(character srfi-4 vector
+ number+radix boolean
+ srfi30-block-comment
+ srfi62-sexp-comment)))
+ #f ;; use default fault handler
+ 'reader/record-positions)))
+
+(define (%make-skribe-reader)
+ (let ((colon-keywords ;; keywords à la `:key' fashion
+ (r:make-token-reader #\:
+ (r:token-reader-procedure
+ (r:standard-token-reader 'keyword))))
+ (symbol-misc-chars-tr
+ ;; Make sure `:' is handled only by the keyword token reader.
+ (make-colon-free-token-reader
+ (r:standard-token-reader 'r6rs-symbol-misc-chars))))
+
+
+ ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since
+ ;; they consider square brackets as delimiters.
+ (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader)
+ colon-keywords
+ symbol-misc-chars-tr
+ (map r:standard-token-reader
+ `(whitespace
+ sexp string r6rs-number
+ r6rs-symbol-lower-case
+ r6rs-symbol-upper-case
+ quote-quasiquote-unquote
+ semicolon-comment
+ skribe-exp)))
+ #f ;; use the default fault handler
+ 'reader/record-positions
+ )))
+
+;; 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..ba5af6a
--- /dev/null
+++ b/src/guile/skribilo/resolve.scm
@@ -0,0 +1,296 @@
+;;; resolve.scm -- Skribilo reference resolution.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo resolve)
+ :use-module (skribilo debug)
+ :use-module (skribilo ast)
+ :use-module (skribilo utils syntax)
+
+ :use-module (oop goops)
+ :use-module (srfi srfi-39)
+
+ :use-module (skribilo condition)
+ :use-module (srfi srfi-34)
+ :use-module (srfi srfi-35)
+
+ :export (resolve! resolve-search-parent resolve-children resolve-children*
+ find1 resolve-counter resolve-parent resolve-ident
+ *document-being-resolved*))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+
+;;;
+;;; Resolving nodes.
+;;;
+
+;; The document being resolved. Note: This is only meant to be used by the
+;; compatibility layer in order to implement things like `find-markups'!
+(define *document-being-resolved* (make-parameter #f))
+
+(define *unresolved* (make-parameter #f))
+(define-generic do-resolve!)
+
+
+;;;; ======================================================================
+;;;;
+;;;; 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)
+
+ (if (document? ast)
+ ;; Bind nodes prior to resolution so that unresolved nodes can
+ ;; lookup nodes by identifier using `document-lookup-node' or
+ ;; `resolve-ident'.
+ (document-bind-nodes! ast))
+
+ (parameterize ((*unresolved* #f))
+ (let Loop ((ast ast))
+ (*unresolved* #f)
+ (let ((ast (do-resolve! ast engine env)))
+ (if (*unresolved*)
+ (begin
+ (debug-item "iterating over ast " ast)
+ (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
+ ((null? n*)
+ ast)
+ ((list? n*)
+ (set-car! n* (do-resolve! (car n*) engine env))
+ (Loop (cdr n*)))
+ ((pair? n*)
+ (set-car! n* (do-resolve! (car n*) engine env))
+ (set-cdr! n* (do-resolve! (cdr n*) engine env)))
+ (else
+ (raise (condition (&invalid-argument-error
+ (proc-name "do-resolve!<pair>")
+ (argument n*))))))))
+
+
+(define-method (do-resolve! (node <node>) engine env)
+ (if (ast-resolved? node)
+ node
+ (let ((body (slot-ref node 'body))
+ (options (slot-ref node 'options))
+ (parent (slot-ref node 'parent))
+ (unresolved? (*unresolved*)))
+ (with-debug 5 'do-resolve<body>
+ (debug-item "body=" body)
+ (parameterize ((*unresolved* #f))
+ (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))
+ (slot-set! node 'resolved? (not (*unresolved*))))
+
+ (*unresolved* (or unresolved? (not (ast-resolved? node))))
+ 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)
+ (parameterize ((*document-being-resolved* node))
+ (next-method)
+ ;; resolve the engine custom
+ (let ((env (append `((parent ,node)) env0)))
+ (for-each (lambda (c)
+ (let ((i (car c))
+ (a (cadr c)))
+ (debug-item "custom=" i " " a)
+ (set-car! (cdr c) (do-resolve! a engine env))))
+ (slot-ref engine 'customs)))
+ node))
+
+
+(define-method (do-resolve! (node <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 (proc node engine env))
+ (loc (ast-loc node)))
+ (when (ast? res)
+ (ast-loc-set! res loc)
+ (slot-set! res 'parent (assq 'parent env)))
+ (debug-item "res=" res)
+ (*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)
+ (raise (condition (&ast-orphan-error (ast 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))
+ (raise (condition (&ast-orphan-error (ast 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'.
+;;;
+;;; This function kind of sucks because the document where IDENT is to be
+;;; searched is not explictly passed. Thus, using `document-lookup-node' is
+;;; recommended instead of using this function.
+;;;
+
+(define (resolve-ident ident markup n e)
+ ;; Search for a node with identifier IDENT and markup type MARKUP. N is
+ ;; typically an `<unresolved>' node and the node lookup should be performed
+ ;; in its parent document. E is the "environment" (an alist).
+ (with-debug 4 'resolve-ident
+ (debug-item "ident=" ident)
+ (debug-item "markup=" markup)
+ (debug-item "n=" (if (markup? n) (markup-markup n) n))
+ (if (not (string? ident))
+ (raise (condition (&invalid-argument-error ;; type error
+ (proc-name "resolve-ident")
+ (argument ident))))
+ (let* ((doc (ast-document n))
+ (result (and doc (document-lookup-node doc ident))))
+ (if (or (not markup)
+ (and (markup? result) (eq? (markup-markup result) markup)))
+ result
+ #f)))))
+
diff --git a/src/stklos/source.stk b/src/guile/skribilo/source.scm
index a3102c1..a61de4f 100644
--- a/src/stklos/source.stk
+++ b/src/guile/skribilo/source.scm
@@ -1,81 +1,99 @@
+;;;; source.scm -- Highlighting source files.
+;;;;
+;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;;
;;;;
-;;;; 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,
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
;;;; 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 (<language> language? language-extractor language-fontifier
+ source-read-lines source-read-definition source-fontify)
+
+ :use-module (srfi srfi-35)
+ :autoload (srfi srfi-34) (raise)
+ :autoload (srfi srfi-13) (string-prefix-length)
+ :autoload (skribilo condition) (&file-search-error &file-open-error)
+
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo parameters)
+ :use-module (skribilo lib)
+ :use-module (oop goops)
+ :use-module (ice-9 rdelim))
-(define-module SKRIBE-SOURCE-MODULE
- (export source-read-lines source-read-definition source-fontify)
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;;
+;;; Class definition.
+;;;
-;; Temporary solution
-(define (language-extractor lang)
- (slot-ref lang 'extractor))
+(define-class <language> ()
+ (name :init-keyword :name :init-value #f :getter langage-name)
+ (fontifier :init-keyword :fontifier :init-value #f
+ :getter language-fontifier)
+ (extractor :init-keyword :extractor :init-value #f
+ :getter language-extractor))
-(define (language-fontifier lang)
- (slot-ref lang 'fontifier))
+(define (language? obj)
+ (is-a? obj <language>))
+
;*---------------------------------------------------------------------*/
;* 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))))))))))
+ (let ((p (search-path (*source-path*) file)))
+ (if (or (not (string? p)) (not (file-exists? p)))
+ (raise (condition (&file-search-error (file-name file)
+ (path (*source-path*)))))
+ (with-input-from-file p
+ (lambda ()
+ (if (> (*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 0) ;; In Guile, line nums are 0-origined.
+ (armedp (not (or (integer? start) (string? start))))
+ (s (read-line))
+ (r '()))
+ (cond
+ ((or (eof-object? s)
+ (and (integer? stop) (> l stop))
+ (and (string? stop)
+ (= (string-prefix-length 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)
+ (= (string-prefix-length start s) startl))
+ (loop (+ l 1) #t (read-line) r))
+ (else
+ (loop (+ l 1) #f (read-line) r))))))))))
;*---------------------------------------------------------------------*/
;* untabify ... */
@@ -119,22 +137,23 @@
;* source-read-definition ... */
;*---------------------------------------------------------------------*/
(define (source-read-definition file definition tab lang)
- (let ((p (find-path file (skribe-source-path))))
+ (let ((p (search-path (*source-path*) file)))
(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)))
+ (raise (condition (&file-search-error (file-name file)
+ (path (*source-path*))))))
+
(else
(let ((ip (open-input-file p)))
- (if (> *skribe-verbose* 0)
+ (if (> (*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)
+ (raise (condition (&file-open-error (file-name p))))
(unwind-protect
(let ((s ((language-extractor lang) ip definition tab)))
(if (not (string? s))
@@ -171,7 +190,7 @@
(if (= i j)
(reverse! r)
(reverse! (cons (substring str j i) r))))
- ((char=? (string-ref str i) #\Newline)
+ ((char=? (string-ref str i) #\newline)
(loop (+ i 1)
(+ i 1)
(if (= i j)
@@ -179,7 +198,7 @@
(cons* 'eol (substring str j i) r))))
((and (char=? (string-ref str i) #\cr)
(< (+ i 1) l)
- (char=? (string-ref str (+ i 1)) #\Newline))
+ (char=? (string-ref str (+ i 1)) #\newline))
(loop (+ i 2)
(+ i 2)
(if (= i j)
@@ -187,5 +206,3 @@
(cons* 'eol (substring str j i) r))))
(else
(loop (+ i 1) j r))))))
-
-)
diff --git a/src/common/sui.scm b/src/guile/skribilo/sui.scm
index eb6134b..e0a9b19 100644
--- a/src/common/sui.scm
+++ b/src/guile/skribilo/sui.scm
@@ -1,21 +1,53 @@
-;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/common/sui.scm */
-;* ------------------------------------------------------------- */
-;* Author : Manuel Serrano */
-;* Creation : Wed Dec 31 11:44:33 2003 */
-;* Last change : Tue Feb 17 11:35:32 2004 (serrano) */
-;* Copyright : 2003-04 Manuel Serrano */
-;* ------------------------------------------------------------- */
-;* Skribe Url Indexes */
-;* ------------------------------------------------------------- */
-;* Implementation: @label lib@ */
-;* bigloo: @path ../bigloo/sui.bgl@ */
-;*=====================================================================*/
+;;; sui.scm
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo sui)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo lib)
+ :use-module (ice-9 match)
+ :use-module (srfi srfi-1)
+ :autoload (skribilo parameters) (*verbose*)
+ :autoload (skribilo reader) (make-reader)
+
+ :export (load-sui sui-ref->url sui-title sui-file sui-key
+ sui-find-ref sui-search-ref sui-filter))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+;;; Author: Manuel Serrano
+;;; Commentary:
+;;;
+;;; Library dealing with Skribe URL Indexes (SUI).
+;;;
+;;; Code:
+
+
+;;; The contents of the file below are (almost) unchanged compared to Skribe
+;;; 1.2d's `sui.scm' file found in the `common' directory.
+
;*---------------------------------------------------------------------*/
;* *sui-table* ... */
;*---------------------------------------------------------------------*/
-(define *sui-table* (make-hashtable))
+(define *sui-table* (make-hash-table))
;*---------------------------------------------------------------------*/
;* load-sui ... */
@@ -24,21 +56,22 @@
;* Raise an error if the file cannot be open. */
;*---------------------------------------------------------------------*/
(define (load-sui path)
- (let ((sexp (hashtable-get *sui-table* path)))
+ (let ((sexp (hash-ref *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)))
+ (when (> (*verbose*) 0)
+ (format (current-error-port) " [loading sui: ~a]\n" path))
+ (let ((p (open-input-file path))
+ (read (make-reader 'skribe)))
(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))
+ (match sexp
+ (('sui (? string?) . _)
+ (hash-set! *sui-table* path sexp))
(else
(skribe-error 'load-sui
"Illegal `Skribe Url Index' file"
@@ -55,14 +88,14 @@
(let ((base (sui-file sui))
(file (car (car refs)))
(mark (cdr (car refs))))
- (format "~a/~a#~a" dir (or file base) mark)))))
+ (format #f "~a/~a#~a" dir (or file base) mark)))))
;*---------------------------------------------------------------------*/
;* sui-title ... */
;*---------------------------------------------------------------------*/
(define (sui-title sexp)
- (match-case sexp
- ((sui (and ?title (? string?)) . ?-)
+ (match sexp
+ (('sui (and title (? string?)) . _)
title)
(else
(skribe-error 'sui-title "Illegal `sui' format" sexp))))
@@ -77,8 +110,8 @@
;* sui-key ... */
;*---------------------------------------------------------------------*/
(define (sui-key sexp key)
- (match-case sexp
- ((sui ?- . ?rest)
+ (match sexp
+ (('sui _ . rest)
(let loop ((rest rest))
(and (pair? rest)
(if (eq? (car rest) key)
@@ -100,8 +133,8 @@
(section (assq :section opts))
(subsection (assq :subsection opts))
(subsubsection (assq :subsubsection opts)))
- (match-case sui
- ((sui (? string?) . ?refs)
+ (match sui
+ (('sui (? string?) . refs)
(cond
(mark (sui-search-ref 'marks refs (cadr mark) class))
(chapter (sui-search-ref 'chapters refs (cadr chapter) class))
@@ -147,13 +180,13 @@
(find-ref (cdar refs) val class)
(loop (cdr refs)))
'())))
-
+
;*---------------------------------------------------------------------*/
;* sui-filter ... */
;*---------------------------------------------------------------------*/
(define (sui-filter sui pred1 pred2)
- (match-case sui
- ((sui (? string?) . ?refs)
+ (match sui
+ (('sui (? string?) . refs)
(let loop ((refs refs)
(res '()))
(if (pair? refs)
diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am
new file mode 100644
index 0000000..9d9df6f
--- /dev/null
+++ b/src/guile/skribilo/utils/Makefile.am
@@ -0,0 +1,5 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/utils
+dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm \
+ keywords.scm strings.scm
+
+## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f
diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm
new file mode 100644
index 0000000..118f294
--- /dev/null
+++ b/src/guile/skribilo/utils/compat.scm
@@ -0,0 +1,309 @@
+;;; compat.scm -- Skribe compatibility module.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+
+(define-module (skribilo utils compat)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils files)
+ :use-module (skribilo parameters)
+ :use-module (skribilo evaluator)
+ :use-module (srfi srfi-1)
+ :autoload (srfi srfi-13) (string-rindex)
+ :use-module (srfi srfi-34)
+ :use-module (srfi srfi-35)
+ :use-module (ice-9 optargs)
+ :autoload (skribilo ast) (ast? document? document-lookup-node)
+ :autoload (skribilo condition) (file-search-error? &file-search-error)
+ :autoload (skribilo reader) (make-reader)
+ :autoload (skribilo lib) (type-name)
+ :autoload (skribilo resolve) (*document-being-resolved*)
+ :autoload (skribilo output) (*document-being-output*)
+ :use-module (skribilo debug)
+
+ :re-export (file-size) ;; re-exported from `(skribilo utils files)'
+ :replace (gensym))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module defines symbols for compatibility with Skribe 1.2.
+;;;
+;;; Code:
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+;;;
+;;; gensym
+;;;
+
+(define %gensym-orig (module-ref the-root-module 'gensym))
+
+(define gensym
+ ;; In Skribe, `gensym' accepts a symbol. Guile's `gensym' accepts only
+ ;; strings (or no argument).
+ (lambda obj
+ (apply %gensym-orig
+ (cond ((null? obj) '())
+ ((symbol? (car obj)) (list (symbol->string (car obj))))
+ ((string? (car obj)) (list (car obj)))
+ (else (skribe-error 'gensym "invalid argument" obj))))))
+
+
+;;;
+;;; Global variables that have been replaced by parameter objects
+;;; in `(skribilo parameters)'.
+;;;
+;;; FIXME: There's not much we can do about these variables (as opposed to
+;;; the _accessors_ below). Perhaps we should just not define them?
+;;;
+
+;;; 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* '())
+
+
+
+;;;
+;;; Accessors mapped to parameter objects.
+;;;
+
+(define-public skribe-path *document-path*)
+(define-public skribe-image-path *image-path*)
+(define-public skribe-source-path *source-path*)
+(define-public skribe-bib-path *bib-path*)
+
+(define-public (skribe-path-set! path) (*document-path* path))
+(define-public (skribe-image-path-set! path) (*image-path* path))
+(define-public (skribe-source-path-set! path) (*source-path* path))
+(define-public (skribe-bib-path-set! path) (*bib-path* path))
+
+
+
+;;;
+;;; Evaluator.
+;;;
+
+(define %skribe-known-files
+ ;; Like of Skribe package files and their equivalent Skribilo module.
+ '(("web-book.skr" . (skribilo package web-book))
+ ("web-article.skr" . (skribilo package web-article))
+ ("slide.skr" . (skribilo package slide))
+ ("sigplan.skr" . (skribilo package sigplan))
+ ("scribe.skr" . (skribilo package scribe))
+ ("lncs.skr" . (skribilo package lncs))
+ ("letter.skr" . (skribilo package letter))
+ ("jfp.skr" . (skribilo package jfp))
+ ("french.skr" . (skribilo package french))
+ ("acmproc.skr" . (skribilo package acmproc))))
+
+(define*-public (skribe-load file :rest args)
+ (guard (c ((file-search-error? c)
+ ;; Regular file loading failed. Try built-ins.
+ (let ((mod-name (assoc-ref %skribe-known-files file)))
+ (if mod-name
+ (begin
+ (if (> (*verbose*) 1)
+ (format (current-error-port)
+ " skribe-load: `~a' -> `~a'~%"
+ file mod-name))
+ (let ((mod (false-if-exception
+ (resolve-module mod-name))))
+ (if (not mod)
+ (raise c)
+ (begin
+ (set-module-uses!
+ (current-module)
+ (cons mod (module-uses (current-module))))
+ #t))))
+ (raise c)))))
+
+ ;; Try a regular `load-document'.
+ (apply load-document file args)))
+
+
+(define-public skribe-include include-document)
+(define-public skribe-load-options *load-options*)
+
+(define-public skribe-eval evaluate-document)
+(define-public skribe-eval-port evaluate-document-from-port)
+
+(set! %skribe-reader #f)
+(define*-public (skribe-read #:optional (port (current-input-port)))
+ (if (not %skribe-reader)
+ (set! %skribe-reader (make-reader 'skribe)))
+ (%skribe-reader port))
+
+
+
+;;;
+;;; Node lookup (formerly provided by `ast.scm').
+;;;
+
+(define-public (bind-markup! node)
+ (let ((doc (or (*document-being-resolved*)
+ (*document-being-output*))))
+ (if (document? doc)
+ (document-bind-node! doc node)
+ (error "Sorry, unable to achieve `bind-markup!'. Use `document-bind-node!' instead."
+ node))))
+
+(define-public (find-markups ident)
+ (let ((doc (or (*document-being-resolved*)
+ (*document-being-output*))))
+ (if (document? doc)
+ (let ((result (document-lookup-node doc ident)))
+ (if result
+ (list result)
+ #f))
+ (error "Sorry, unable to achieve `find-markups'. Use `document-lookup-node' instead."
+ ident))))
+
+(define-public (find-markup-ident ident)
+ (or (find-markups ident) '()))
+
+
+
+;;;
+;;; Debugging facilities.
+;;;
+
+(define-public (set-skribe-debug! val)
+ (*debug* val))
+
+(define-public (no-debug-color)
+ (*debug-use-colors?* #f))
+
+(define-public skribe-debug *debug*)
+
+(define-public (add-skribe-debug-symbol s)
+ (*watched-symbols* (cons s *watched-symbols*)))
+
+
+
+;;;
+;;; Compatibility with Bigloo.
+;;;
+
+(define-public (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-public (directory->list str)
+ (map basename (glob (string-append str "/*") (string-append "/.*"))))
+
+(define-macro (printf . args) `(format #t ,@args))
+(export-syntax printf)
+(define-public fprintf format)
+
+(define-public (fprint port . args)
+ (if port
+ (with-output-to-port port
+ (lambda ()
+ (for-each display args)
+ (display "\n")))))
+
+
+
+(define-public prefix file-prefix)
+(define-public suffix file-suffix)
+(define-public system->string system) ;; FIXME
+(define-public any? any)
+(define-public every? every)
+(define-public (find-file/path file path)
+ (search-path path file))
+
+(define-public process-input-port #f) ;process-input)
+(define-public process-output-port #f) ;process-output)
+(define-public process-error-port #f) ;process-error)
+
+;;; hash tables
+(define-public make-hashtable make-hash-table)
+(define-public hashtable? hash-table?)
+(define-public hashtable-get (lambda (h k) (hash-ref h k #f)))
+(define-public hashtable-put! hash-set!)
+(define-public (hashtable-update! table key update-proc init-value)
+ ;; This is a Bigloo-specific API.
+ (let ((handle (hash-get-handle table key)))
+ (if (not handle)
+ (hash-set! table key init-value)
+ (set-cdr! handle (update-proc (cdr handle))))))
+
+(define-public (hashtable->list h)
+ (hash-map->list (lambda (key val) val) h))
+
+(define-public (find-runtime-type obj)
+ (type-name obj))
+
+
+;;;
+;;; Miscellaneous.
+;;;
+
+(use-modules ((srfi srfi-19) #:renamer (symbol-prefix-proc 's19:)))
+
+(define-public (date)
+ (s19:date->string (s19:current-date) "~c"))
+
+(define-public (correct-arity? proc argcount)
+ (let ((a (procedure-property proc 'arity)))
+ (and (pair? a)
+ (let ((compulsory (car a))
+ (optional (cadr a))
+ (rest? (caddr a)))
+ (or rest?
+ (>= (+ compulsory optional) argcount))))))
+
+
+;;; compat.scm ends here
diff --git a/src/guile/skribilo/utils/files.scm b/src/guile/skribilo/utils/files.scm
new file mode 100644
index 0000000..6d89d4d
--- /dev/null
+++ b/src/guile/skribilo/utils/files.scm
@@ -0,0 +1,55 @@
+;;; files.scm -- File-related utilities.
+;;;
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo utils files)
+ :export (file-prefix file-suffix file-size))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module defines filesystem-related utility functions.
+;;;
+;;; Code:
+
+(define (file-size file)
+ (let ((file-info (false-if-exception (stat file))))
+ (if file-info
+ (stat:size file-info)
+ #f)))
+
+(define (file-prefix fn)
+ (if fn
+ (let ((dot (string-rindex fn #\.)))
+ (if dot (substring fn 0 dot) fn))
+ "./SKRIBILO-OUTPUT"))
+
+(define (file-suffix fn)
+ (if fn
+ (let ((dot (string-rindex fn #\.)))
+ (if dot
+ (substring fn (+ dot 1) (string-length fn))
+ ""))
+ #f))
+
+
+;;; arch-tag: b63d2a9f-a254-4e2d-8d85-df773bbc4a9b
+
+;;; files.scm ends here
diff --git a/src/guile/skribilo/utils/images.scm b/src/guile/skribilo/utils/images.scm
new file mode 100644
index 0000000..24405d6
--- /dev/null
+++ b/src/guile/skribilo/utils/images.scm
@@ -0,0 +1,99 @@
+;;; images.scm -- Images handling utilities.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo utils images)
+ :export (convert-image
+ *fig-convert-program* *bitmap-convert-program*)
+
+ :autoload (skribilo utils files) (file-suffix file-prefix)
+ :autoload (skribilo parameters) (*image-path* *verbose*)
+ :autoload (skribilo condition) (&file-search-error)
+ :autoload (srfi srfi-34) (raise)
+ :use-module (srfi srfi-35)
+ :use-module (srfi srfi-39))
+
+;;; Author: Erick Gallesio, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides convenience functions to handle image files, notably
+;;; for format conversion via ImageMagick's `convert'.
+;;;
+;;; Code:
+
+(define *fig-convert-program* (make-parameter "fig2dev -L"))
+(define *generic-convert-program* (make-parameter "convert"))
+
+(define (builtin-convert-image from fmt dir)
+ (let* ((s (file-suffix from))
+ (f (string-append (file-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 (*fig-convert-program*) " "
+ fmt " " from " > " to)
+ (string-append (*generic-convert-program*) " "
+ from " " to))))
+ (cond
+ ((> (*verbose*) 1)
+ (format (current-error-port) " [converting image: ~S (~S)]" from c))
+ ((> (*verbose*) 0)
+ (format (current-error-port) " [converting image: ~S]" from)))
+ (and (zero? (system c))
+ to))))))
+
+(define (convert-image file formats)
+ (let ((path (search-path (*image-path*) file)))
+ (if (not path)
+ (raise (condition (&file-search-error (file-name file)
+ (path (*image-path*)))))
+ (let ((suf (file-suffix file)))
+ (if (member suf formats)
+ (let* ((dir (if (string? (*destination-file*))
+ (dirname (*destination-file*))
+ #f)))
+ (if dir
+ (let* ((dest (basename path))
+ (dest-path (string-append dir "/" dest)))
+ (if (not (string=? path dest-path))
+ (copy-file path dest-path))
+ dest)
+ path))
+ (let loop ((fmts formats))
+ (if (null? fmts)
+ #f
+ (let* ((dir (if (string? (*destination-file*))
+ (dirname (*destination-file*))
+ "."))
+ (p (builtin-convert-image path (car fmts) dir)))
+ (if (string? p)
+ p
+ (loop (cdr fmts)))))))))))
+
+
+;;; arch-tag: a1992fa8-6073-4cd7-a018-80e2cc8d537c
+
+;;; images.scm ends here
diff --git a/src/guile/skribilo/utils/keywords.scm b/src/guile/skribilo/utils/keywords.scm
new file mode 100644
index 0000000..1bcd5dc
--- /dev/null
+++ b/src/guile/skribilo/utils/keywords.scm
@@ -0,0 +1,99 @@
+;;; keywords.scm -- Convenience procedures for keyword-argument handling.
+;;;
+;;; Copyright 2003, 2004 Manuel Serrano
+;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo utils keywords)
+ :export (the-body the-options list-split))
+
+;;; Author: Manuel Serrano, Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides convenience functions to handle keyword arguments.
+;;; These are typically used by markup functions.
+;;;
+;;; Code:
+
+(define (the-body opt+)
+ ;; Filter out the keyword arguments from OPT+.
+ (let loop ((opt* opt+)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-body "Illegal body" opt*))
+ ((keyword? (car opt*))
+ (if (null? (cdr opt*))
+ (skribe-error 'the-body "Illegal option" (car opt*))
+ (loop (cddr opt*) res)))
+ (else
+ (loop (cdr opt*) (cons (car opt*) res))))))
+
+(define (the-options opt+ . out)
+ ;; Return a list made of keyword arguments (i.e., each time, a keyword
+ ;; followed by its associated value). The OUT argument should be a list
+ ;; containing keyword argument names to be filtered out (e.g.,
+ ;; `(#:ident)').
+ (let loop ((opt* opt+)
+ (res '()))
+ (cond
+ ((null? opt*)
+ (reverse! res))
+ ((not (pair? opt*))
+ (skribe-error 'the-options "Illegal options" opt*))
+ ((keyword? (car opt*))
+ (cond
+ ((null? (cdr opt*))
+ (skribe-error 'the-options "Illegal option" (car opt*)))
+ ((memq (car opt*) out)
+ (loop (cdr opt*) res))
+ (else
+ (loop (cdr opt*)
+ (cons (list (car opt*) (cadr opt*)) res)))))
+ (else
+ (loop (cdr opt*) res)))))
+
+(define (list-split l num . fill)
+ (let loop ((l l)
+ (i 0)
+ (acc '())
+ (res '()))
+ (cond
+ ((null? l)
+ (reverse! (cons (if (or (null? fill) (= i num))
+ (reverse! acc)
+ (append! (reverse! acc)
+ (make-list (- num i) (car fill))))
+ res)))
+ ((= i num)
+ (loop l
+ 0
+ '()
+ (cons (reverse! acc) res)))
+ (else
+ (loop (cdr l)
+ (+ i 1)
+ (cons (car l) acc)
+ res)))))
+
+;;; arch-tag: 3e9066d5-6d7d-4da5-922b-cc3d4ba8476e
+
+;;; keywords.scm ends here
diff --git a/src/guile/skribilo/utils/strings.scm b/src/guile/skribilo/utils/strings.scm
new file mode 100644
index 0000000..e8e8f8f
--- /dev/null
+++ b/src/guile/skribilo/utils/strings.scm
@@ -0,0 +1,145 @@
+;;; strings.scm -- Convenience functions to manipulate strings.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo utils strings)
+ :export (strip-ref-base string-canonicalize
+ make-string-replace)
+ :autoload (skribilo parameters) (*ref-base*)
+ :use-module (skribilo lib)
+ :use-module (srfi srfi-13))
+
+
+;;;
+;;; Utilities.
+;;;
+
+(define (strip-ref-base file)
+ ;; Given FILE, a file path (a string), remove `(*ref-base*)' from it.
+ ;; This is useful, e.g., for hyperlinks.
+ (if (not (string? (*ref-base*)))
+ file
+ (let ((l (string-length (*ref-base*))))
+ (cond
+ ((not (> (string-length file) (+ l 2)))
+ file)
+ ((not (string-contains file (*ref-base*) 0 l))
+ file)
+ ((not (char=? (string-ref file l) #\/))
+ file)
+ (else
+ (substring file (+ l 1) (string-length file)))))))
+
+
+(define (string-canonicalize old)
+ ;; Return a string that is a canonical summarized representation of string
+ ;; OLD. This is a one-way function.
+ (let* ((l (string-length old))
+ (new (make-string l)))
+ (let loop ((r 0)
+ (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))))))
+
+
+
+
+;;;
+;;; String writing.
+;;;
+
+;;
+;; (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
+ (let ((chars (make-hash-table)))
+
+ ;; Setup a hash table equivalent to LST.
+ (for-each (lambda (chr)
+ (hashq-set! chars (car chr) (cadr chr)))
+ lst)
+
+ ;; Help the GC.
+ (set! lst #f)
+
+ (lambda (str)
+ (let ((out (open-output-string)))
+ (string-for-each (lambda (ch)
+ (let ((res (hashq-ref chars ch #f)))
+ (display (if res res ch) out)))
+ str)
+ (get-output-string out)))))
+
+(define %html-replacements
+ '((#\" "&quot;") (#\& "&amp;") (#\< "&lt;") (#\> "&gt;")))
+
+(define %string->html
+ (%make-general-string-replace %html-replacements))
+
+(define (make-string-replace lst)
+ (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2))))))
+ (cond
+ ((equal? l %html-replacements)
+ %string->html)
+ (else
+ (%make-general-string-replace lst)))))
+
diff --git a/src/guile/skribilo/utils/syntax.scm b/src/guile/skribilo/utils/syntax.scm
new file mode 100644
index 0000000..44bff09
--- /dev/null
+++ b/src/guile/skribilo/utils/syntax.scm
@@ -0,0 +1,81 @@
+;;; syntax.scm -- Syntactic candy for Skribilo modules.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo utils syntax)
+ :use-module (skribilo reader)
+ :use-module (system reader library)
+ :use-module (system reader compat) ;; make sure `current-reader' exists
+ :use-module (system reader confinement)
+ :export (%skribe-reader %skribilo-module-reader)
+ :export-syntax (unwind-protect unless when))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides syntactic candy for Skribilo modules, i.e., a syntax
+;;; similar to Guile's default syntax with a few extensions, plus various
+;;; convenience macros.
+;;;
+;;; Code:
+
+(define %skribilo-module-reader
+ ;; The syntax used to read Skribilo modules.
+ (apply make-alternate-guile-reader
+ '(colon-keywords no-scsh-block-comments
+ srfi30-block-comments srfi62-sexp-comments)
+ (lambda (chr port read)
+ (let ((file (port-filename port))
+ (line (port-line port))
+ (column (port-column port)))
+ (error (string-append
+ (if (string? file)
+ (format #f "~a:~a:~a: " file line column)
+ "")
+ "unexpected character in Skribilo module")
+ chr)))
+
+ ;; By default, don't record positions: this yields a nice read
+ ;; performance improvement.
+ (if (memq 'debug (debug-options))
+ (list 'reader/record-positions)
+ '())))
+
+(define %skribe-reader
+ ;; The Skribe syntax reader.
+ (make-reader 'skribe))
+
+
+(define-macro (unwind-protect expr1 expr2)
+ ;; This is no completely correct.
+ `(dynamic-wind
+ (lambda () #f)
+ (lambda () ,expr1)
+ (lambda () ,expr2)))
+
+(define-macro (unless condition . exprs)
+ `(if (not ,condition) (begin ,@exprs)))
+
+(define-macro (when condition . exprs)
+ `(if ,condition (begin ,@exprs)))
+
+;;; arch-tag: 9a0e0638-64f0-480a-ab19-49e8bfcbcd9b
+
+;;; syntax.scm ends here
diff --git a/src/stklos/verify.stk b/src/guile/skribilo/verify.scm
index da9b132..052b5cc 100644
--- a/src/stklos/verify.stk
+++ b/src/guile/skribilo/verify.scm
@@ -1,35 +1,40 @@
-;;;;
-;;;; 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 SKRIBE-VERIFY-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-WRITER-MODULE
- SKRIBE-RUNTIME-MODULE)
- (export verify)
+;;; verify.scm -- Skribe AST verification.
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo verify)
+ :autoload (skribilo engine) (engine-ident processor-get-engine)
+ :autoload (skribilo writer) (writer? writer-options lookup-markup-writer)
+ :autoload (skribilo lib) (skribe-warning/ast skribe-warning
+ skribe-error)
+ :export (verify))
+(use-modules (skribilo debug)
+ (skribilo ast)
+ (skribilo utils syntax)
+ (oop goops))
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
(define-generic verify)
;;;
@@ -46,7 +51,7 @@
(for-each (lambda (o)
(if (not (memq o options))
(skribe-error (engine-ident engine)
- (format "Option unsupported: ~a, supported options: ~a" o options)
+ (format #f "option unsupported: ~a, supported options: ~a" o options)
markup)))
required-options)
(slot-set! writer 'verified? #t)))))
@@ -55,16 +60,16 @@
;;; 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)
+ (lambda (o2)
(for-each
- (lambda (o)
+ (lambda (o)
(if (and (keyword? o)
(not (eq? o :&skribe-eval-location))
(not (memq o lopts)))
@@ -72,32 +77,32 @@
3
markup
'verify
- (format "Engine ~a does not support markup ~a option `~a' -- ~a"
+ (format #f "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
+;;; V E R I F Y
;;;
;;; ======================================================================
;;; TOP
-(define-method verify ((obj <top>) e)
+(define-method (verify (obj <top>) e)
obj)
;;; PAIR
-(define-method verify ((obj <pair>) e)
+(define-method (verify (obj <pair>) e)
(for-each (lambda (x) (verify x e)) obj)
obj)
;;; PROCESSOR
-(define-method verify ((obj <processor>) e)
+(define-method (verify (obj <processor>) e)
(let ((combinator (slot-ref obj 'combinator))
(engine (slot-ref obj 'engine))
(body (slot-ref obj 'body)))
@@ -105,7 +110,7 @@
obj))
;;; NODE
-(define-method verify ((node <node>) e)
+(define-method (verify (node <node>) e)
;; Verify body
(verify (slot-ref node 'body) e)
;; Verify options
@@ -114,11 +119,11 @@
node)
;;; MARKUP
-(define-method verify ((node <markup>) e)
+(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))
+ (debug-item "e=" (engine-ident e))
(next-method)
@@ -133,14 +138,14 @@
(skribe-warning
1
node
- (format "Node `~a' forbidden here by ~a engine"
+ (format #f "node `~a' forbidden here by ~a engine"
(markup-markup node)
(engine-ident e))))))))
node))
;;; DOCUMENT
-(define-method verify ((node <document>) e)
+(define-method (verify (node <document>) e)
(next-method)
;; verify the engine customs
@@ -151,7 +156,5 @@
(slot-ref e 'customs))
node)
-
-
-)
+;;; verify.scm ends here \ No newline at end of file
diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm
new file mode 100644
index 0000000..b16819d
--- /dev/null
+++ b/src/guile/skribilo/writer.scm
@@ -0,0 +1,261 @@
+;;; writer.scm -- Markup writers.
+;;;
+;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+;;; USA.
+
+(define-module (skribilo writer)
+ :export (<writer> writer? write-object writer-options writer-ident
+ writer-before writer-action writer-after writer-class
+
+ invoke markup-writer markup-writer-get markup-writer-get*
+ lookup-markup-writer copy-markup-writer)
+
+ :use-module (skribilo utils syntax)
+ :autoload (srfi srfi-1) (find filter)
+ :autoload (skribilo engine) (engine? engine-ident? default-engine))
+
+
+(use-modules (skribilo debug)
+ (skribilo output)
+ (skribilo ast)
+ (skribilo lib)
+
+ (oop goops)
+ (ice-9 optargs))
+
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Class definition.
+;;;
+
+(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 (obj <writer>) port)
+ (format port "#[~A (~A) ~A]"
+ (class-name (class-of obj))
+ (slot-ref obj 'ident)
+ (object-address obj)))
+
+
+
+;;;
+;;; Writer methods.
+;;;
+
+(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)))))
+
+
+
+(define (make-writer-predicate markup predicate class)
+ (define (%always-true n e) #t)
+
+ (let* ((t2 (if class
+ (lambda (n e)
+ (and (equal? (markup-class n) class)))
+ #f)))
+ (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
+ (if (procedure? t2)
+ (lambda (n e)
+ (and (t2 n e) (predicate n e)))
+ predicate)))
+ t2)))
+
+
+;;;
+;;; `markup-writer'
+;;;
+
+(define* (markup-writer markup ;; #:optional (engine #f)
+ #:key (predicate #f) (class #f) (options '())
+ (validate #f)
+ (before #f)
+ (action 'unspecified)
+ (after #f)
+ #:rest engine)
+ ;;; FIXME: `lambda*' sucks and fails when both optional arguments and
+ ;;; keyword arguments are used together. In particular, if ENGINE is not
+ ;;; specified by the caller but other keyword arguments are specified, it
+ ;;; will consider the value of ENGINE to be the first keyword found.
+
+; (let ((e (or engine (default-engine))))
+ (let ((e (or (if (and (list? engine) (not (keyword? (car engine))))
+ (car engine)
+ #f)
+ (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))))))
+
+
+
+;;;
+;;; Finding a markup writer.
+;;;
+
+(define (lookup-markup-writer node e)
+ ;; Find the writer that applies best to NODE. See also `markup-writer-get'
+ ;; and `markup-writer-get*'.
+
+ (define (matching-writer writers)
+ (find (lambda (w)
+ (let ((pred (slot-ref w 'pred)))
+ (if (procedure? pred)
+ (pred node e)
+ #t)))
+ writers))
+
+ (let* ((writers (slot-ref e 'writers))
+ (node-writers (hashq-ref writers (markup-markup node) '()))
+ (delegate (slot-ref e 'delegate)))
+
+ (or (matching-writer node-writers)
+ (matching-writer (slot-ref e 'free-writers))
+ (and (engine? delegate)
+ (lookup-markup-writer node delegate)))))
+
+
+(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f))
+ ;; Get a markup writer for MARKUP (a symbol) in ENGINE, with class CLASS
+ ;; and user predicate PRED. [FIXME: Useless since PRED is a procedure and
+ ;; therefore not comparable?]
+
+ (define (matching-writer writers)
+ (find (lambda (w)
+ (and (if class (equal? (writer-class w) class) #t)
+ (or (unspecified? pred)
+ (eq? (slot-ref w 'upred) pred))))
+ writers))
+
+ (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* ((writers (slot-ref e 'writers))
+ (markup-writers (hashq-ref writers markup '()))
+ (delegate (slot-ref e 'delegate)))
+
+ (or (matching-writer markup-writers)
+ (and (engine? delegate)
+ (markup-writer-get markup delegate
+ :class class :pred pred))))))))
+
+
+(define* (markup-writer-get* markup #:optional engine #:key (class #f))
+ ;; Finds all writers, recursively going through the engine hierarchy, that
+ ;; match MARKUP with optional CLASS attribute.
+
+ (define (matching-writers writers)
+ (filter (lambda (w)
+ (or (not class)
+ (equal? (writer-class w) class)))
+ writers))
+
+ (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* ((writers (slot-ref e 'writers))
+ (markup-writers (hashq-ref writers markup '()))
+ (delegate (slot-ref e 'delegate)))
+
+ (append (matching-writers writers)
+ (if (engine? delegate)
+ (markup-writer-get* markup delegate :class class)
+ '())))))))
+
+
+(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))))
+
+;;; writer.scm ends here
diff --git a/src/skribe-config.in b/src/skribe-config.in
new file mode 100644
index 0000000..2a03e26
--- /dev/null
+++ b/src/skribe-config.in
@@ -0,0 +1,64 @@
+#!/bin/sh
+#
+# Author: Erick Gallesio [eg@essi.fr]
+# Creation date: 19-Nov-2003 21:04 (eg)
+# Last file update: 19-Nov-2003 22:29 (eg)
+
+
+function usage()
+{
+ cat <<EOF
+Usage: skribe-config [OPTIONS]
+Options:
+ [--prefix | -p] Prefix that was given during the build
+ [--version | -v] Version of Skribe that is installed
+ [--skr-dir | -k] Display the skr directory location
+ [--extension-dir | -e] Display the extension directory location
+ [--doc-dir | -d] Display the documentation directory location
+ [--emacs-dir | -m] Display the emacs directory location
+ [--scheme | -s] Display the Scheme systeme used
+ [--help | -h | -?] Show a list of options
+EOF
+ exit $1
+}
+
+
+if test $# -eq 0; then
+ usage 1 1>&2
+fi
+
+while test $# -gt 0; do
+ case $1 in
+ --prefix|-p)
+ echo @PREFIX@
+ ;;
+ --version|-v)
+ echo @SKRIBE_RELEASE@
+ ;;
+ --extension-dir|-e)
+ echo @SKRIBE_EXT_DIR@
+ ;;
+ --skr-dir|-k)
+ echo @SKRIBE_SKR_DIR@
+ ;;
+ --doc-dir|-d)
+ echo @SKRIBE_DOC_DIR@
+ ;;
+ --emacs-dir|-m)
+ echo @SKRIBE_EMACS_DIR@
+ ;;
+ --scheme|-s)
+ echo @SYSTEM@
+ ;;
+ --help|-h|-\?)
+ usage 0 1>&2
+ ;;
+ *)
+ echo "bad option $1" 1>&2
+ usage 1 1>&2
+ ;;
+ esac
+ shift
+done
+exit 0
+
diff --git a/src/skribilo.in b/src/skribilo.in
new file mode 100755
index 0000000..8d49f84
--- /dev/null
+++ b/src/skribilo.in
@@ -0,0 +1,40 @@
+#!/bin/sh
+
+# Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+#
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+# USA.
+
+# The `skribilo' executable.
+
+# Note: In Guile 1.8+ (or 1.9), when Guile is run in batch mode with
+# `--debug', it produces a clean stack trace when an exception is
+# raised and uncaught. On earlier versions, it behaves as if
+# `--debug' had not been passed, not displaying a stack trace. See
+# http://lists.gnu.org/archive/html/guile-devel/2006-01/msg00022.html
+# for details.
+#
+# In any case, don't pass `--debug' by default (for performance
+# reason). When needed, the use should explicitly set the `GUILE'
+# environment variable to, e.g., "guile --debug".
+
+main='(module-ref (resolve-module '\''(skribilo)) '\'main')'
+exec ${GUILE-@GUILE@} -c "
+(use-modules (skribilo condition))
+
+(call-with-skribilo-error-catch
+ (lambda ()
+ (apply $main (cdr (command-line)))))" "$@"
diff --git a/src/stklos/Makefile.in b/src/stklos/Makefile.in
deleted file mode 100644
index 80a26de..0000000
--- a/src/stklos/Makefile.in
+++ /dev/null
@@ -1,110 +0,0 @@
-#
-# 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/stklos/biblio.stk b/src/stklos/biblio.stk
deleted file mode 100644
index 5691588..0000000
--- a/src/stklos/biblio.stk
+++ /dev/null
@@ -1,161 +0,0 @@
-;;;;
-;;;; biblio.stk -- Bibliography functions
-;;;;
-;;;; 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.main.st
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 31-Aug-2003 22:07 (eg)
-;;;; Last file update: 28-Oct-2004 21:19 (eg)
-;;;;
-
-
-
-(define-module SKRIBE-BIBLIO-MODULE
- (import SKRIBE-RUNTIME-MODULE)
- (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)
-
-(include "../common/bib.scm")
-
-;;;; ======================================================================
-;;;;
-;;;; Utilities
-;;;;
-;;;; ======================================================================
-
-(define (make-bib-table ident)
- (make-hashtable))
-
-(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/stklos/configure.stk b/src/stklos/configure.stk
deleted file mode 100644
index ece7abc..0000000
--- a/src/stklos/configure.stk
+++ /dev/null
@@ -1,90 +0,0 @@
-;;;;
-;;;; configure.stk -- Skribe configuration options
-;;;;
-;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 10-Feb-2004 11:47 (eg)
-;;;; Last file update: 17-Feb-2004 09:43 (eg)
-;;;;
-
-(define-module SKRIBE-CONFIGURE-MODULE
- (export skribe-configure skribe-enforce-configure)
-
-
-(define %skribe-conf
- `((:release ,(skribe-release))
- (:scheme ,(skribe-scheme))
- (:url ,(skribe-url))
- (:doc-dir ,(skribe-doc-dir))
- (:ext-dir ,(skribe-ext-dir))
- (:default-path ,(skribe-default-path))))
-
-;;;
-;;; SKRIBE-CONFIGURE
-;;;
-(define (skribe-configure . opt)
- (let ((conf %skribe-conf))
- (cond
- ((null? opt)
- conf)
- ((null? (cdr opt))
- (let ((cell (assq (car opt) conf)))
- (if (pair? cell)
- (cadr cell)
- 'void)))
- (else
- (let loop ((opt opt))
- (cond
- ((null? opt)
- #t)
- ((not (keyword? (car opt)))
- #f)
- ((or (null? (cdr opt)) (keyword? (cadr opt)))
- #f)
- (else
- (let ((cell (assq (car opt) conf)))
- (if (and (pair? cell)
- (if (procedure? (cadr opt))
- ((cadr opt) (cadr cell))
- (equal? (cadr opt) (cadr cell))))
- (loop (cddr opt))
- #f)))))))))
-;;;
-;;; SKRIBE-ENFORCE-CONFIGURE ...
-;;;
-(define (skribe-enforce-configure . opt)
- (let loop ((o opt))
- (when (pair? o)
- (cond
- ((or (not (keyword? (car o)))
- (null? (cdr o)))
- (skribe-error 'skribe-enforce-configure "Illegal enforcement" opt))
- ((skribe-configure (car o) (cadr o))
- (loop (cddr o)))
- (else
- (skribe-error 'skribe-enforce-configure
- (format "Configuration mismatch: ~a" (car o))
- (if (procedure? (cadr o))
- (format "provided `~a'"
- (skribe-configure (car o)))
- (format "provided `~a', required `~a'"
- (skribe-configure (car o))
- (cadr o)))))))))
-) \ No newline at end of file
diff --git a/src/stklos/debug.stk b/src/stklos/debug.stk
deleted file mode 100644
index a9fefde..0000000
--- a/src/stklos/debug.stk
+++ /dev/null
@@ -1,161 +0,0 @@
-;;;;
-;;;; debug.stk -- Debug Facilities (stolen to Manuel Serrano)
-;;;;
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 10-Aug-2003 20:45 (eg)
-;;;; Last file update: 28-Oct-2004 13:16 (eg)
-;;;;
-
-
-(define-module SKRIBE-DEBUG-MODULE
- (export 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)
- (when (or (>= *skribe-debug* *skribe-margin-debug-level*)
- *skribe-debug-item*)
- (display *debug-margin* *debug-port*)
- (display (debug-color (- *debug-depth* 1) "- ") *debug-port*)
- (for-each (lambda (a) (display a *debug-port*)) args)
- (newline *debug-port*)))
-
-;;(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)
- `((in-module SKRIBE-DEBUG-MODULE %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/stklos/engine.stk b/src/stklos/engine.stk
deleted file mode 100644
index a13ed0f..0000000
--- a/src/stklos/engine.stk
+++ /dev/null
@@ -1,242 +0,0 @@
-;;;;
-;;;; engines.stk -- Skribe Engines Stuff
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 24-Jul-2003 20:33 (eg)
-;;;; Last file update: 28-Oct-2004 21:21 (eg)
-;;;;
-
-(define-module SKRIBE-ENGINE-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-EVAL-MODULE)
-
- (export default-engine default-engine-set!
- make-engine copy-engine find-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)
- (unless (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)))))
-
-;;;
-;;; 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
- ;;
- (unless (is-a? e <engine>)
- (skribe-error ident "Illegal engine" e))
-
- ;; check the options
- (unless (or (eq? opt 'all) (list? opt))
- (skribe-error ident "Illegal options" opt))
-
- ;; check the correctness of the predicate
- (check-procedure "predicate" pred 2)
-
- ;; check the correctness of the validation proc
- (when 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)
-
-
-(select-module STklos)
diff --git a/src/stklos/eval.stk b/src/stklos/eval.stk
deleted file mode 100644
index 3acace9..0000000
--- a/src/stklos/eval.stk
+++ /dev/null
@@ -1,149 +0,0 @@
-;;;;
-;;;; eval.stk -- Skribe Evaluator
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 27-Jul-2003 09:15 (eg)
-;;;; Last file update: 28-Oct-2004 15:05 (eg)
-;;;;
-
-
-;; FIXME; On peut implémenter maintenant skribe-warning/node
-
-
-(define-module SKRIBE-EVAL-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-VERIFY-MODULE
- SKRIBE-RESOLVE-MODULE SKRIBE-OUTPUT-MODULE)
- (export skribe-eval skribe-eval-port skribe-load skribe-load-options
- skribe-include)
-
-
-(define *skribe-loaded* '()) ;; List of already loaded files
-(define *skribe-load-options* '())
-
-(define (%evaluate expr)
- (with-handler
- (lambda (c)
- (flush-output-port (current-error-port))
- (raise c))
- (eval expr (find-module 'STklos))))
-
-;;;
-;;; 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 :rest opt :key engine path)
- (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))))))))
-) \ No newline at end of file
diff --git a/src/stklos/lib.stk b/src/stklos/lib.stk
deleted file mode 100644
index 3c3b9f0..0000000
--- a/src/stklos/lib.stk
+++ /dev/null
@@ -1,317 +0,0 @@
-;;;;
-;;;; 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)
-;;;;
-
-;;;
-;;; NEW
-;;;
-(define (maybe-copy obj)
- (if (pair-mutable? obj)
- obj
- (copy-tree obj)))
-
-(define-macro (new class . parameters)
- `(make ,(string->symbol (format "<~a>" class))
- ,@(apply append (map (lambda (x)
- `(,(make-keyword (car x)) (maybe-copy ,(cadr x))))
- parameters))))
-
-;;;
-;;; DEFINE-MARKUP
-;;;
-(define-macro (define-markup bindings . body)
- ;; This is just a STklos extended lambda. Nothing to do
- `(define ,bindings ,@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))))))
-
-
-;;;
-;;; UNSPECIFIED?
-;;;
-(define (unspecified? obj)
- (eq? obj 'unspecified))
-
-;;;; ======================================================================
-;;;;
-;;;; 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 (symbol-append . l)
- (string->symbol (apply string-append (map symbol->string l))))
-
-
-(define (make-list n . fill)
- (let ((fill (if (null? fill) (void) (car fill))))
- (let Loop ((i n) (res '()))
- (if (zero? i)
- res
- (Loop (- i 1) (cons fill res))))))
-
-
-(define string-capitalize string-titlecase)
-(define prefix file-prefix)
-(define suffix file-suffix)
-(define system->string exec)
-(define any? any)
-(define every? every)
-(define cons* list*)
-(define find-file/path find-path)
-(define process-input-port process-input)
-(define process-output-port process-output)
-(define process-error-port process-error)
-
-;;;
-;;; h a s h t a b l e s
-;;;
-(define make-hashtable (lambda () (make-hash-table equal?)))
-(define hashtable? hash-table?)
-(define hashtable-get (lambda (h k) (hash-table-get h k #f)))
-(define hashtable-put! hash-table-put!)
-(define hashtable-update! hash-table-update!)
-(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)))
diff --git a/src/stklos/main.stk b/src/stklos/main.stk
deleted file mode 100644
index 4905423..0000000
--- a/src/stklos/main.stk
+++ /dev/null
@@ -1,264 +0,0 @@
-;;;;
-;;;; skribe.stk -- Skribe Main
-;;;;
-;;;; 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: 24-Jul-2003 20:33 (eg)
-;;;; Last file update: 6-Mar-2004 16:13 (eg)
-;;;;
-
-;; FIXME: These are horrible hacks
-;(DESCRIBE 1 (current-error-port)) ; to make compiler happy
-(set! *compiler-options* '()) ;HORREUR pour éviter les warnings du compilo
-
-
-(include "../common/configure.scm")
-(include "../common/param.scm")
-
-(include "vars.stk")
-(include "reader.stk")
-(include "configure.stk")
-(include "types.stk")
-(include "debug.stk")
-(include "lib.stk")
-(include "../common/lib.scm")
-(include "resolve.stk")
-(include "writer.stk")
-(include "verify.stk")
-(include "output.stk")
-(include "prog.stk")
-(include "eval.stk")
-(include "runtime.stk")
-(include "engine.stk")
-(include "biblio.stk")
-(include "source.stk")
-(include "lisp.stk")
-(include "xml.stk")
-(include "c.stk")
-(include "color.stk")
-(include "../common/sui.scm")
-
-(import SKRIBE-EVAL-MODULE
- SKRIBE-CONFIGURE-MODULE
- SKRIBE-RUNTIME-MODULE
- SKRIBE-ENGINE-MODULE
- SKRIBE-EVAL-MODULE
- SKRIBE-WRITER-MODULE
- SKRIBE-VERIFY-MODULE
- SKRIBE-OUTPUT-MODULE
- SKRIBE-BIBLIO-MODULE
- SKRIBE-PROG-MODULE
- SKRIBE-RESOLVE-MODULE
- SKRIBE-SOURCE-MODULE
- SKRIBE-LISP-MODULE
- SKRIBE-XML-MODULE
- SKRIBE-C-MODULE
- SKRIBE-DEBUG-MODULE
- SKRIBE-COLOR-MODULE)
-
-(include "../common/index.scm")
-(include "../common/api.scm")
-
-
-;;; KLUDGE for allowing redefinition of Skribe INCLUDE
-(remove-expander! 'include)
-
-
-;;;; ======================================================================
-;;;;
-;;;; P A R S E - A R G S
-;;;;
-;;;; ======================================================================
-(define (parse-args args)
-
- (define (version)
- (format #t "skribe v~A\n" (skribe-release)))
-
- (define (query)
- (version)
- (for-each (lambda (x)
- (let ((s (keyword->string (car x))))
- (printf " ~a: ~a\n" s (cadr x))))
- (skribe-configure)))
-
- ;;
- ;; parse-args starts here
- ;;
- (let ((paths '())
- (engine #f))
- (parse-arguments args
- "Usage: skribe [options] [input]"
- "General options:"
- (("target" :alternate "t" :arg target
- :help "sets the output format to <target>")
- (set! engine (string->symbol target)))
- (("I" :arg path :help "adds <path> to Skribe path")
- (set! paths (cons path paths)))
- (("B" :arg path :help "adds <path> to bibliography path")
- (skribe-bib-path-set! (cons path (skribe-bib-path))))
- (("S" :arg path :help "adds <path> to source path")
- (skribe-source-path-set! (cons path (skribe-source-path))))
- (("P" :arg path :help "adds <path> to image path")
- (skribe-image-path-set! (cons path (skribe-image-path))))
- (("split-chapters" :alternate "C" :arg chapter
- :help "emit chapter's sections in separate files")
- (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*)))
- (("preload" :arg file :help "preload <file>")
- (set! *skribe-preload* (cons file *skribe-preload*)))
- (("use-variant" :alternate "u" :arg variant
- :help "use <variant> output format")
- (set! *skribe-variants* (cons variant *skribe-variants*)))
- (("base" :alternate "b" :arg base
- :help "base prefix to remove from hyperlinks")
- (set! *skribe-ref-base* base))
- (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>")
- (set! *skribe-rc-directory* dir))
-
- "File options:"
- (("no-init-file" :help "Dont load rc Skribe file")
- (set! *load-rc* #f))
- (("output" :alternate "o" :arg file :help "set the output to <file>")
- (set! *skribe-dest* file)
- (let* ((s (file-suffix file))
- (c (assoc s *skribe-auto-mode-alist*)))
- (when (and (pair? c) (symbol? (cdr c)))
- (set! *skribe-engine* (cdr c)))))
-
- "Misc:"
- (("help" :alternate "h" :help "provides help for the command")
- (arg-usage (current-error-port))
- (exit 0))
- (("options" :help "display the skribe options and exit")
- (arg-usage (current-output-port) #t)
- (exit 0))
- (("version" :alternate "V" :help "displays the version of Skribe")
- (version)
- (exit 0))
- (("query" :alternate "q"
- :help "displays informations about Skribe conf.")
- (query)
- (exit 0))
- (("verbose" :alternate "v" :arg level
- :help "sets the verbosity to <level>. Use -v0 for crystal silence")
- (let ((val (string->number level)))
- (when (integer? val)
- (set! *skribe-verbose* val))))
- (("warning" :alternate "w" :arg level
- :help "sets the verbosity to <level>. Use -w0 for crystal silence")
- (let ((val (string->number level)))
- (when (integer? val)
- (set! *skribe-warning* val))))
- (("debug" :alternate "g" :arg level :help "sets the debug <level>")
- (let ((val (string->number level)))
- (if (integer? val)
- (set-skribe-debug! val)
- (begin
- ;; Use the symbol for debug
- (set-skribe-debug! 1)
- (add-skribe-debug-symbol (string->symbol level))))))
- (("no-color" :help "disable coloring for output")
- (no-debug-color))
- (("custom" :alternate "c" :arg key=val :help "Preset custom value")
- (let ((args (string-split key=val "=")))
- (if (and (list args) (= (length args) 2))
- (let ((key (car args))
- (val (cadr args)))
- (set! *skribe-precustom* (cons (cons (string->symbol key) val)
- *skribe-precustom*)))
- (error 'parse-arguments "Bad custom ~S" key=val))))
- (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>")
- (with-input-from-string expr
- (lambda () (eval (read)))))
- (else
- (set! *skribe-src* other-arguments)))
-
- ;; we have to configure Skribe path according to the environment variable
- (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH")))
- (if path
- (string-split path ":")
- '()))
- (reverse! paths)
- (skribe-default-path)))
- ;; Final initializations
- (when engine
- (set! *skribe-engine* engine))))
-
-;;;; ======================================================================
-;;;;
-;;;; L O A D - R C
-;;;;
-;;;; ======================================================================
-(define (load-rc)
- (when *load-rc*
- (let ((file (make-path *skribe-rc-directory* *skribe-rc-file*)))
- (when (and file (file-exists? file))
- (load file)))))
-
-
-
-;;;; ======================================================================
-;;;;
-;;;; S K R I B E
-;;;;
-;;;; ======================================================================
-(define (doskribe)
- (let ((e (find-engine *skribe-engine*)))
- (if (and (engine? e) (pair? *skribe-precustom*))
- (for-each (lambda (cv)
- (engine-custom-set! e (car cv) (cdr cv)))
- *skribe-precustom*))
- (if (pair? *skribe-src*)
- (for-each (lambda (f) (skribe-load f :engine *skribe-engine*))
- *skribe-src*)
- (skribe-eval-port (current-input-port) *skribe-engine*))))
-
-
-;;;; ======================================================================
-;;;;
-;;;; M A I N
-;;;;
-;;;; ======================================================================
-(define (main args)
- ;; Load the user rc file
- (load-rc)
-
- ;; Parse command line
- (parse-args args)
-
- ;; Load the base file to bootstrap the system as well as the files
- ;; that are in the *skribe-preload* variable
- (skribe-load "base.skr" :engine 'base)
- (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) *skribe-preload*)
-
- ;; Load the specified variants
- (for-each (lambda (x) (skribe-load (format "~a.skr" x) :engine *skribe-engine*))
- (reverse! *skribe-variants*))
-
-;; (if (string? *skribe-dest*)
-;; (with-handler (lambda (kind loc msg)
-;; (remove-file *skribe-dest*)
-;; (error loc msg))
-;; (with-output-to-file *skribe-dest* doskribe))
-;; (doskribe))
-(if (string? *skribe-dest*)
- (with-output-to-file *skribe-dest* doskribe)
- (doskribe))
-
- 0)
diff --git a/src/stklos/output.stk b/src/stklos/output.stk
deleted file mode 100644
index 3c00323..0000000
--- a/src/stklos/output.stk
+++ /dev/null
@@ -1,158 +0,0 @@
-;;;;
-;;;; 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 SKRIBE-OUTPUT-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-WRITER-MODULE)
- (export output)
-
-
-(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/stklos/reader.stk b/src/stklos/reader.stk
deleted file mode 100644
index bd38562..0000000
--- a/src/stklos/reader.stk
+++ /dev/null
@@ -1,136 +0,0 @@
-;;;;
-;;;; reader.stk -- Reader hook for the open bracket
-;;;;
-;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@unice.fr]
-;;;; Creation date: 6-Dec-2001 22:59 (eg)
-;;;; Last file update: 28-Feb-2004 10:22 (eg)
-;;;;
-
-;; Examples of ISO-2022-JP (here for cut'n paste tests, since my japanese
-;; is *very* limited ;-).
-;;
-;; "Japan" $BF|K\(B
-;; "China and Chinese music" $BCf9q$HCf9q$N2;3Z(B
-
-
-;;
-;; This function is a hook for the standard reader. After defining,
-;; %read-bracket, the reader calls it when it encounters an open
-;; bracket
-
-
-(define (%read-bracket in)
-
- (define (read-japanese in)
- ;; This function reads an ISO-2022-JP sequence. Susch s sequence is coded
- ;; as "^[$B......^[(B" . When entering in this function the current
- ;; character is 'B' (the opening sequence one). Function reads until the
- ;; end of the sequence and return it as a string
- (read-char in) ;; to skip the starting #\B
- (let ((res (open-output-string)))
- (let Loop ((c (peek-char in)))
- (cond
- ((eof-object? c) ;; EOF
- (error '%read-bracket "EOF encountered"))
- ((char=? c #\escape)
- (read-char in)
- (let ((next1 (peek-char in)))
- (if (char=? next1 #\()
- (begin
- (read-char in)
- (let ((next2 (peek-char in)))
- (if (char=? next2 #\B)
- (begin
- (read-char in)
- (format "\033$B~A\033(B" (get-output-string res)))
- (begin
- (format res "\033~A" next1)
- (Loop next2)))))
- (begin
- (display #\escape res)
- (Loop next1)))))
- (else (display (read-char in) res)
- (Loop (peek-char in)))))))
- ;;
- ;; Body of %read-bracket starts here
- ;;
- (let ((out (open-output-string))
- (res '())
- (in-string? #f))
-
- (read-char in) ; skip open bracket
-
- (let Loop ((c (peek-char in)))
- (cond
- ((eof-object? c) ;; EOF
- (error '%read-bracket "EOF encountered"))
-
- ((char=? c #\escape) ;; ISO-2022-JP string?
- (read-char in)
- (let ((next1 (peek-char in)))
- (if (char=? next1 #\$)
- (begin
- (read-char in)
- (let ((next2 (peek-char in)))
- (if (char=? next2 #\B)
- (begin
- (set! res
- (append! res
- (list (get-output-string out)
- (list 'unquote
- (list 'jp
- (read-japanese in))))))
- (set! out (open-output-string)))
- (format out "\033~A" next1))))
- (display #\escape out)))
- (Loop (peek-char in)))
-
- ((char=? c #\\) ;; Quote char
- (read-char in)
- (display (read-char in) out)
- (Loop (peek-char in)))
-
- ((and (not in-string?) (char=? c #\,)) ;; Comma
- (read-char in)
- (let ((next (peek-char in)))
- (if (char=? next #\()
- (begin
- (set! res (append! res (list (get-output-string out)
- (list 'unquote
- (read in)))))
- (set! out (open-output-string)))
- (display #\, out))
- (Loop (peek-char in))))
-
- ((and (not in-string?) (char=? c #\[)) ;; Open bracket
- (display (%read-bracket in) out)
- (Loop (peek-char in)))
-
- ((and (not in-string?) (char=? c #\])) ;; Close bracket
- (read-char in)
- (let ((str (get-output-string out)))
- (list 'quasiquote
- (append! res (if (string=? str "") '() (list str))))))
-
- (else (when (char=? c #\") (set! in-string? (not in-string?)))
- (display (read-char in) out)
- (Loop (peek-char in)))))))
-
diff --git a/src/stklos/resolve.stk b/src/stklos/resolve.stk
deleted file mode 100644
index 91dc965..0000000
--- a/src/stklos/resolve.stk
+++ /dev/null
@@ -1,255 +0,0 @@
-;;;;
-;;;; 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 SKRIBE-RESOLVE-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-RUNTIME-MODULE)
- (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/stklos/runtime.stk b/src/stklos/runtime.stk
deleted file mode 100644
index 58d0d45..0000000
--- a/src/stklos/runtime.stk
+++ /dev/null
@@ -1,456 +0,0 @@
-;;;;
-;;;; runtime.stk -- Skribe runtime system
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 13-Aug-2003 18:47 (eg)
-;;;; Last file update: 15-Nov-2004 14:03 (eg)
-;;;;
-
-(define-module SKRIBE-RUNTIME-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-VERIFY-MODULE SKRIBE-RESOLVE-MODULE
- SKRIBE-OUTPUT-MODULE SKRIBE-EVAL-MODULE)
-
- (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
- )
-
-;;;; ======================================================================
-;;;;
-;;;; U T I L I T I E S
-;;;;
-;;;; ======================================================================
-(define skribe-load 'function-defined-below)
-
-
-;;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/stklos/types.stk b/src/stklos/types.stk
deleted file mode 100644
index fb16230..0000000
--- a/src/stklos/types.stk
+++ /dev/null
@@ -1,294 +0,0 @@
-;;;;
-;;;; types.stk -- Definition of Skribe classes
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 12-Aug-2003 22:18 (eg)
-;;;; Last file update: 28-Oct-2004 16:18 (eg)
-;;;;
-
-
-(define *node-table* (make-hash-table equal?))
- ; Used to stores the nodes of an AST.
- ; It permits to retrieve a node from its
- ; identifier.
-
-
-;;;; ======================================================================
-;;;;
-;;;; <AST>
-;;;;
-;;;; ======================================================================
-;;FIXME: set! location in <ast>
-(define-class <ast> ()
- ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified)
- (loc :init-form #f)))
-
-(define (ast? obj) (is-a? obj <ast>))
-(define (ast-loc obj) (slot-ref obj 'loc))
-(define (ast-loc-set! obj v) (slot-set! obj 'loc v))
-
-;;;; ======================================================================
-;;;;
-;;;; <COMMAND>
-;;;;
-;;;; ======================================================================
-(define-class <command> (<ast>)
- ((fmt :init-keyword :fmt)
- (body :init-keyword :body)))
-
-(define (command? obj) (is-a? obj <command>))
-(define (command-fmt obj) (slot-ref obj 'fmt))
-(define (command-body obj) (slot-ref obj 'body))
-
-;;;; ======================================================================
-;;;;
-;;;; <UNRESOLVED>
-;;;;
-;;;; ======================================================================
-(define-class <unresolved> (<ast>)
- ((proc :init-keyword :proc)))
-
-(define (unresolved? obj) (is-a? obj <unresolved>))
-(define (unresolved-proc obj) (slot-ref obj 'proc))
-
-;;;; ======================================================================
-;;;;
-;;;; <HANDLE>
-;;;;
-;;;; ======================================================================
-(define-class <handle> (<ast>)
- ((ast :init-keyword :ast :init-form #f :getter handle-ast)))
-
-(define (handle? obj) (is-a? obj <handle>))
-(define (handle-ast obj) (slot-ref obj 'ast))
-
-
-;;;; ======================================================================
-;;;;
-;;;; <NODE>
-;;;;
-;;;; ======================================================================
-(define-class <node> (<ast>)
- ((required-options :init-keyword :required-options :init-form '())
- (options :init-keyword :options :init-form '())
- (body :init-keyword :body :init-form #f
- :getter node-body)))
-
-(define (node? obj) (is-a? obj <node>))
-(define (node-options obj) (slot-ref obj 'options))
-(define node-loc ast-loc)
-
-
-;;;; ======================================================================
-;;;;
-;;;; <PROCESSOR>
-;;;;
-;;;; ======================================================================
-(define-class <processor> (<node>)
- ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1))
- (engine :init-keyword :engine :init-form 'unspecified)
- (procedure :init-keyword :procedure :init-form (lambda (n e) n))))
-
-(define (processor? obj) (is-a? obj <processor>))
-(define (processor-combinator obj) (slot-ref obj 'combinator))
-(define (processor-engine obj) (slot-ref obj 'engine))
-
-;;;; ======================================================================
-;;;;
-;;;; <MARKUP>
-;;;;
-;;;; ======================================================================
-(define-class <markup> (<node>)
- ((ident :init-keyword :ident :getter markup-ident :init-form #f)
- (class :init-keyword :class :getter markup-class :init-form #f)
- (markup :init-keyword :markup :getter markup-markup)))
-
-
-(define (bind-markup! node)
- (hash-table-update! *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-table-get *node-table* ident #f))
-
-
-(define-method write-object ((obj <markup>) port)
- (format port "#[~A (~A/~A) ~A]"
- (class-name (class-of obj))
- (slot-ref obj 'markup)
- (slot-ref obj 'ident)
- (address-of obj)))
-
-;;;; ======================================================================
-;;;;
-;;;; <CONTAINER>
-;;;;
-;;;; ======================================================================
-(define-class <container> (<markup>)
- ((env :init-keyword :env :init-form '())))
-
-(define (container? obj) (is-a? obj <container>))
-(define (container-env obj) (slot-ref obj 'env))
-(define container-options markup-options)
-(define container-ident markup-ident)
-(define container-body node-body)
-
-
-
-;;;; ======================================================================
-;;;;
-;;;; <DOCUMENT>
-;;;;
-;;;; ======================================================================
-(define-class <document> (<container>)
- ())
-
-(define (document? obj) (is-a? obj <document>))
-(define (document-ident obj) (slot-ref obj 'ident))
-(define (document-body obj) (slot-ref obj 'body))
-(define document-options markup-options)
-(define document-env container-env)
-
-
-;;;; ======================================================================
-;;;;
-;;;; <ENGINE>
-;;;;
-;;;; ======================================================================
-(define-class <engine> ()
- ((ident :init-keyword :ident :init-form '???)
- (format :init-keyword :format :init-form "raw")
- (info :init-keyword :info :init-form '())
- (version :init-keyword :version :init-form 'unspecified)
- (delegate :init-keyword :delegate :init-form #f)
- (writers :init-keyword :writers :init-form '())
- (filter :init-keyword :filter :init-form #f)
- (customs :init-keyword :custom :init-form '())
- (symbol-table :init-keyword :symbol-table :init-form '())))
-
-
-
-(define (engine? obj)
- (is-a? obj <engine>))
-
-(define (engine-ident obj) ;; Define it here since the doc searches it
- (slot-ref obj 'ident))
-
-(define (engine-format obj) ;; Define it here since the doc searches it
- (slot-ref obj 'format))
-
-(define (engine-customs obj) ;; Define it here since the doc searches it
- (slot-ref obj 'customs))
-
-(define (engine-filter obj) ;; Define it here since the doc searches it
- (slot-ref obj 'filter))
-
-(define (engine-symbol-table obj) ;; Define it here since the doc searches it
- (slot-ref obj 'symbol-table))
-
-
-;;;; ======================================================================
-;;;;
-;;;; <WRITER>
-;;;;
-;;;; ======================================================================
-(define-class <writer> ()
- ((ident :init-keyword :ident :init-form '??? :getter writer-ident)
- (class :init-keyword :class :initform 'unspecified
- :getter writer-class)
- (pred :init-keyword :pred :init-form 'unspecified)
- (upred :init-keyword :upred :init-form 'unspecified)
- (options :init-keyword :options :init-form '() :getter writer-options)
- (verified? :init-keyword :verified? :init-form #f)
- (validate :init-keyword :validate :init-form #f)
- (before :init-keyword :before :init-form #f :getter writer-before)
- (action :init-keyword :action :init-form #f :getter writer-action)
- (after :init-keyword :after :init-form #f :getter writer-after)))
-
-(define (writer? obj)
- (is-a? obj <writer>))
-
-(define-method write-object ((obj <writer>) port)
- (format port "#[~A (~A) ~A]"
- (class-name (class-of obj))
- (slot-ref obj 'ident)
- (address-of obj)))
-
-;;;; ======================================================================
-;;;;
-;;;; <LANGUAGE>
-;;;;
-;;;; ======================================================================
-(define-class <language> ()
- ((name :init-keyword :name :init-form #f :getter langage-name)
- (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier)
- (extractor :init-keyword :extractor :init-form #f :getter langage-extractor)))
-
-(define (language? obj)
- (is-a? obj <language>))
-
-
-;;;; ======================================================================
-;;;;
-;;;; <LOCATION>
-;;;;
-;;;; ======================================================================
-(define-class <location> ()
- ((file :init-keyword :file :getter location-file)
- (pos :init-keyword :pos :getter location-pos)
- (line :init-keyword :line :getter location-line)))
-
-(define (location? obj)
- (is-a? obj <location>))
-
-(define (ast-location obj)
- (let ((loc (slot-ref obj 'loc)))
- (if (location? loc)
- (let* ((fname (location-file loc))
- (line (location-line loc))
- (pwd (getcwd))
- (len (string-length pwd))
- (lenf (string-length fname))
- (file (if (and (substring=? pwd fname len)
- (> lenf len))
- (substring fname len (+ 1 (string-length fname)))
- fname)))
- (format "~a, line ~a" file line))
- "no source location")))
diff --git a/src/stklos/vars.stk b/src/stklos/vars.stk
deleted file mode 100644
index 1c875f8..0000000
--- a/src/stklos/vars.stk
+++ /dev/null
@@ -1,82 +0,0 @@
-;;;;
-;;;; vars.stk -- Skribe Globals
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 11-Aug-2003 16:18 (eg)
-;;;; Last file update: 26-Feb-2004 20:36 (eg)
-;;;;
-
-
-;;;
-;;; Switches
-;;;
-(define *skribe-verbose* 0)
-(define *skribe-warning* 5)
-(define *load-rc* #t)
-
-;;;
-;;; PATH variables
-;;;
-(define *skribe-path* #f)
-(define *skribe-bib-path* '("."))
-(define *skribe-source-path* '("."))
-(define *skribe-image-path* '("."))
-
-
-(define *skribe-rc-directory*
- (make-path (getenv "HOME") ".skribe"))
-
-
-;;;
-;;; In and out ports
-;;;
-(define *skribe-src* '())
-(define *skribe-dest* #f)
-
-;;;
-;;; Engine
-;;;
-(define *skribe-engine* 'html) ;; Use HTML by default
-
-;;;
-;;; Misc
-;;;
-(define *skribe-chapter-split* '())
-(define *skribe-ref-base* #f)
-(define *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter
-(define *skribe-variants* '())
-
-
-
-
-;;; Forward definitions (to avoid warnings when compiling Skribe)
-;;; This is a KLUDGE.
-(define mark #f)
-(define ref #f)
-;;(define invoke 3)
-(define lookup-markup-writer #f)
-
-(define-module SKRIBE-ENGINE-MODULE
- (define find-engine #f))
-
-(define-module SKRIBE-OUTPUT-MODULE)
-
-(define-module SKRIBE-RUNTIME-MODULE)
diff --git a/src/stklos/writer.stk b/src/stklos/writer.stk
deleted file mode 100644
index 2b0f91c..0000000
--- a/src/stklos/writer.stk
+++ /dev/null
@@ -1,211 +0,0 @@
-;;;;
-;;;; 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 SKRIBE-WRITER-MODULE
- (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-OUTPUT-MODULE)
- (export invoke markup-writer markup-writer-get markup-writer-get*
- lookup-markup-writer copy-markup-writer)
-
-;;;; ======================================================================
-;;;;
-;;;; 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))))
-
-)
diff --git a/src/stklos/xml.stk b/src/stklos/xml.stk
deleted file mode 100644
index 47dd46f..0000000
--- a/src/stklos/xml.stk
+++ /dev/null
@@ -1,52 +0,0 @@
-;;;;
-;;;; 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 SKRIBE-XML-MODULE
- (export xml)
- (import SKRIBE-SOURCE-MODULE)
-
-(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)))
-)