summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Makefile41
-rw-r--r--src/Makefile.am1
-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/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.scm283
-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/api.scm1249
-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/index.scm126
-rw-r--r--src/common/lib.scm238
-rw-r--r--src/common/param.scm69
-rw-r--r--src/common/sui.scm166
-rw-r--r--src/guile/Makefile.am4
-rw-r--r--src/guile/skribilo/Makefile.am9
-rw-r--r--src/guile/skribilo/Makefile.in517
-rw-r--r--src/guile/skribilo/coloring/Makefile.am2
-rw-r--r--src/guile/skribilo/coloring/lisp.scm113
-rw-r--r--src/guile/skribilo/coloring/xml.scm119
-rw-r--r--src/guile/skribilo/config.scm.in2
-rw-r--r--src/guile/skribilo/engine/Makefile.am5
-rw-r--r--src/guile/skribilo/engine/html.scm2
-rw-r--r--src/guile/skribilo/engine/latex.scm2
-rw-r--r--src/guile/skribilo/engine/lout.scm185
-rw-r--r--src/guile/skribilo/evaluator.scm62
-rw-r--r--src/guile/skribilo/lib.scm59
-rw-r--r--src/guile/skribilo/module.scm15
-rw-r--r--src/guile/skribilo/package/Makefile.am4
-rw-r--r--src/guile/skribilo/package/acmproc.scm155
-rw-r--r--src/guile/skribilo/package/french.scm (renamed from src/bigloo/new.sch)20
-rw-r--r--src/guile/skribilo/package/jfp.scm319
-rw-r--r--src/guile/skribilo/package/letter.scm148
-rw-r--r--src/guile/skribilo/package/lncs.scm149
-rw-r--r--src/guile/skribilo/package/scribe.scm231
-rw-r--r--src/guile/skribilo/package/sigplan.scm157
-rw-r--r--src/guile/skribilo/package/skribe.scm76
-rw-r--r--src/guile/skribilo/package/slide.scm667
-rw-r--r--src/guile/skribilo/package/web-article.scm232
-rw-r--r--src/guile/skribilo/package/web-book.scm109
-rw-r--r--src/guile/skribilo/reader/Makefile.am2
-rw-r--r--src/guile/skribilo/reader/skribe.scm46
-rw-r--r--src/guile/skribilo/resolve.scm4
-rw-r--r--src/guile/skribilo/skribe/Makefile.am2
-rw-r--r--src/guile/skribilo/skribe/api.scm10
-rw-r--r--src/guile/skribilo/skribe/index.scm12
-rw-r--r--src/guile/skribilo/skribe/param.scm19
-rw-r--r--src/guile/skribilo/source.scm23
-rw-r--r--src/guile/skribilo/types.scm14
-rw-r--r--src/stklos/Makefile.in110
-rw-r--r--src/stklos/biblio.stk161
-rw-r--r--src/stklos/c-lex.l67
-rw-r--r--src/stklos/c.stk95
-rw-r--r--src/stklos/color.stk622
-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/lisp-lex.l91
-rw-r--r--src/stklos/lisp.stk294
-rw-r--r--src/stklos/main.stk264
-rw-r--r--src/stklos/output.stk158
-rw-r--r--src/stklos/prog.stk219
-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/source.stk191
-rw-r--r--src/stklos/types.stk294
-rw-r--r--src/stklos/vars.stk82
-rw-r--r--src/stklos/verify.stk157
-rw-r--r--src/stklos/writer.stk211
-rw-r--r--src/stklos/xml-lex.l64
-rw-r--r--src/stklos/xml.stk52
99 files changed, 3109 insertions, 13833 deletions
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..1d3db1f
--- /dev/null
+++ b/src/Makefile.am
@@ -0,0 +1 @@
+SUBDIRS = guile
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 e481d65..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 0 0 0))
- ((string-ci=? name "white")
- (values #xff #xff #xff))
- (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/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 8248a4f..0000000
--- a/src/bigloo/resolve.scm
+++ /dev/null
@@ -1,283 +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))
- (let ((e `((parent ,node) ,@env ,@env0)))
- (set! body (do-resolve! body engine e))
- 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 (proc node 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/api.scm b/src/common/api.scm
deleted file mode 100644
index eb657c7..0000000
--- a/src/common/api.scm
+++ /dev/null
@@ -1,1249 +0,0 @@
-;*=====================================================================*/
-;* 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@ */
-;*=====================================================================*/
-
-;*---------------------------------------------------------------------*/
-;* include ... */
-;*---------------------------------------------------------------------*/
-(define-markup (include file)
- (if (not (string? file))
- (skribe-error 'include "Illegal file (string expected)" file)
- (skribe-include file)))
-
-;*---------------------------------------------------------------------*/
-;* document ... */
-;*---------------------------------------------------------------------*/
-(define-markup (document #!rest
- opts
- #!key
- (ident #f) (class "document")
- (title #f) (html-title #f) (author #f)
- (ending #f) (env '()))
- (new document
- (markup 'document)
- (ident (or ident
- (ast->string title)
- (symbol->string (gensym 'document))))
- (class class)
- (required-options '(:title :author :ending))
- (options (the-options opts :ident :class :env))
- (body (the-body opts))
- (env (append env
- (list (list 'chapter-counter 0) (list 'chapter-env '())
- (list 'section-counter 0) (list 'section-env '())
- (list 'footnote-counter 0) (list 'footnote-env '())
- (list 'figure-counter 0) (list 'figure-env '()))))))
-
-;*---------------------------------------------------------------------*/
-;* author ... */
-;*---------------------------------------------------------------------*/
-(define-markup (author #!rest
- opts
- #!key
- (ident #f) (class "author")
- name
- (title #f)
- (affiliation #f)
- (email #f)
- (url #f)
- (address #f)
- (phone #f)
- (photo #f)
- (align 'center))
- (if (not (memq align '(center left right)))
- (skribe-error 'author "Illegal align value" align)
- (new container
- (markup 'author)
- (ident (or ident (symbol->string (gensym 'author))))
- (class class)
- (required-options '(:name :title :affiliation :email :url :address :phone :photo :align))
- (options `((:name ,name)
- (:align ,align)
- ,@(the-options opts :ident :class)))
- (body #f))))
-
-;*---------------------------------------------------------------------*/
-;* toc ... */
-;*---------------------------------------------------------------------*/
-(define-markup (toc #!rest
- opts
- #!key
- (ident #f) (class "toc")
- (chapter #t) (section #t) (subsection #f))
- (let ((body (the-body opts)))
- (new container
- (markup 'toc)
- (ident (or ident (symbol->string (gensym 'toc))))
- (class class)
- (required-options '())
- (options `((:chapter ,chapter)
- (:section ,section)
- (:subsection ,subsection)
- ,@(the-options opts :ident :class)))
- (body (cond
- ((null? body)
- (new unresolved
- (proc (lambda (n e env)
- (handle
- (resolve-search-parent n env document?))))))
- ((null? (cdr body))
- (if (handle? (car body))
- (car body)
- (skribe-error 'toc
- "Illegal argument (handle expected)"
- (if (markup? (car body))
- (markup-markup (car body))
- "???"))))
- (else
- (skribe-error 'toc "Illegal argument" body)))))))
-
-;*---------------------------------------------------------------------*/
-;* chapter ... ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/sectioning.skb:chapter@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:chapter@ */
-;*---------------------------------------------------------------------*/
-(define-markup (chapter #!rest
- opts
- #!key
- (ident #f) (class "chapter")
- title (html-title #f) (file #f) (toc #t) (number #t))
- (new container
- (markup 'chapter)
- (ident (or ident (symbol->string (gensym 'chapter))))
- (class class)
- (required-options '(:title :file :toc :number))
- (options `((:toc ,toc)
- (:number ,(and number
- (new unresolved
- (proc (lambda (n e env)
- (resolve-counter n
- env
- 'chapter
- number))))))
- ,@(the-options opts :ident :class)))
- (body (the-body opts))
- (env (list (list 'section-counter 0) (list 'section-env '())
- (list 'footnote-counter 0) (list 'footnote-env '())))))
-
-;*---------------------------------------------------------------------*/
-;* section-number ... */
-;*---------------------------------------------------------------------*/
-(define (section-number number markup)
- (and number
- (new unresolved
- (proc (lambda (n e env)
- (resolve-counter n env markup number))))))
-
-;*---------------------------------------------------------------------*/
-;* section ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/sectioning.skb:section@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:sectionr@ */
-;*---------------------------------------------------------------------*/
-(define-markup (section #!rest
- opts
- #!key
- (ident #f) (class "section")
- title (file #f) (toc #t) (number #t))
- (new container
- (markup 'section)
- (ident (or ident (symbol->string (gensym 'section))))
- (class class)
- (required-options '(:title :toc :file :toc :number))
- (options `((:number ,(section-number number 'section))
- (:toc ,toc)
- ,@(the-options opts :ident :class)))
- (body (the-body opts))
- (env (if file
- (list (list 'subsection-counter 0) (list 'subsection-env '())
- (list 'footnote-counter 0) (list 'footnote-env '()))
- (list (list 'subsection-counter 0) (list 'subsection-env '()))))))
-
-;*---------------------------------------------------------------------*/
-;* subsection ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/sectioning.skb:subsection@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:subsectionr@ */
-;*---------------------------------------------------------------------*/
-(define-markup (subsection #!rest
- opts
- #!key
- (ident #f) (class "subsection")
- title (file #f) (toc #t) (number #t))
- (new container
- (markup 'subsection)
- (ident (or ident (symbol->string (gensym 'subsection))))
- (class class)
- (required-options '(:title :toc :file :number))
- (options `((:number ,(section-number number 'subsection))
- (:toc ,toc)
- ,@(the-options opts :ident :class)))
- (body (the-body opts))
- (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '())))))
-
-;*---------------------------------------------------------------------*/
-;* subsubsection ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/sectioning.skb:subsubsection@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:subsubsectionr@ */
-;*---------------------------------------------------------------------*/
-(define-markup (subsubsection #!rest
- opts
- #!key
- (ident #f) (class "subsubsection")
- title (file #f) (toc #f) (number #t))
- (new container
- (markup 'subsubsection)
- (ident (or ident (symbol->string (gensym 'subsubsection))))
- (class class)
- (required-options '(:title :toc :number :file))
- (options `((:number ,(section-number number 'subsubsection))
- (:toc ,toc)
- ,@(the-options opts :ident :class)))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* paragraph ... */
-;*---------------------------------------------------------------------*/
-(define-simple-markup paragraph)
-
-;*---------------------------------------------------------------------*/
-;* footnote ... */
-;*---------------------------------------------------------------------*/
-(define-markup (footnote #!rest opts
- #!key (ident #f) (class "footnote") (label #t))
- ;; The `:label' option used to be called `:number'.
- (new container
- (markup 'footnote)
- (ident (symbol->string (gensym 'footnote)))
- (class class)
- (required-options '())
- (options `((:label
- ,(cond ((string? label) label)
- ((number? label) label)
- ((not label) label)
- (else
- (new unresolved
- (proc (lambda (n e env)
- (resolve-counter n env
- 'footnote #t)))))
- ,@(the-options opts :ident :class)))))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* linebreak ... */
-;*---------------------------------------------------------------------*/
-(define-markup (linebreak #!rest opts #!key (ident #f) (class #f))
- (let ((ln (new markup
- (ident (or ident (symbol->string (gensym 'linebreak))))
- (class class)
- (markup 'linebreak)))
- (num (the-body opts)))
- (cond
- ((null? num)
- ln)
- ((not (null? (cdr num)))
- (skribe-error 'linebreak "Illegal arguments" num))
- ((not (and (integer? (car num)) (positive? (car num))))
- (skribe-error 'linebreak "Illegal argument" (car num)))
- (else
- (vector->list (make-vector (car num) ln))))))
-
-;*---------------------------------------------------------------------*/
-;* hrule ... */
-;*---------------------------------------------------------------------*/
-(define-markup (hrule #!rest
- opts
- #!key
- (ident #f) (class #f)
- (width 100.) (height 1))
- (new markup
- (markup 'hrule)
- (ident (or ident (symbol->string (gensym 'hrule))))
- (class class)
- (required-options '())
- (options `((:width ,width)
- (:height ,height)
- ,@(the-options opts :ident :class)))
- (body #f)))
-
-;*---------------------------------------------------------------------*/
-;* color ... */
-;*---------------------------------------------------------------------*/
-(define-markup (color #!rest
- opts
- #!key
- (ident #f) (class "color")
- (bg #f) (fg #f) (width #f) (margin #f))
- (new container
- (markup 'color)
- (ident (or ident (symbol->string (gensym 'color))))
- (class class)
- (required-options '(:bg :fg :width))
- (options `((:bg ,(if bg (skribe-use-color! bg) bg))
- (:fg ,(if fg (skribe-use-color! fg) fg))
- ,@(the-options opts :ident :class :bg :fg)))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* frame ... */
-;*---------------------------------------------------------------------*/
-(define-markup (frame #!rest
- opts
- #!key
- (ident #f) (class "frame")
- (width #f) (margin 2) (border 1))
- (new container
- (markup 'frame)
- (ident (or ident (symbol->string (gensym 'frame))))
- (class class)
- (required-options '(:width :border :margin))
- (options `((:margin ,margin)
- (:border ,(cond
- ((integer? border) border)
- (border 1)
- (else #f)))
- ,@(the-options opts :ident :class)))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* font ... */
-;*---------------------------------------------------------------------*/
-(define-markup (font #!rest
- opts
- #!key
- (ident #f) (class #f)
- (size #f) (face #f))
- (new container
- (markup 'font)
- (ident (or ident (symbol->string (gensym 'font))))
- (class class)
- (required-options '(:size))
- (options (the-options opts :ident :class))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* flush ... */
-;*---------------------------------------------------------------------*/
-(define-markup (flush #!rest
- opts
- #!key
- (ident #f) (class #f)
- side)
- (case side
- ((center left right)
- (new container
- (markup 'flush)
- (ident (or ident (symbol->string (gensym 'flush))))
- (class class)
- (required-options '(:side))
- (options (the-options opts :ident :class))
- (body (the-body opts))))
- (else
- (skribe-error 'flush "Illegal side" side))))
-
-;*---------------------------------------------------------------------*/
-;* center ... */
-;*---------------------------------------------------------------------*/
-(define-simple-container center)
-
-;*---------------------------------------------------------------------*/
-;* pre ... */
-;*---------------------------------------------------------------------*/
-(define-simple-container pre)
-
-;*---------------------------------------------------------------------*/
-;* prog ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/prgm.skb:prog@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:prog@ */
-;*---------------------------------------------------------------------*/
-(define-markup (prog #!rest
- opts
- #!key
- (ident #f) (class "prog")
- (line 1) (linedigit #f) (mark ";!"))
- (if (not (or (string? mark) (eq? mark #f)))
- (skribe-error 'prog "Illegal mark" mark)
- (new container
- (markup 'prog)
- (ident (or ident (symbol->string (gensym 'prog))))
- (class class)
- (required-options '(:line :mark))
- (options (the-options opts :ident :class :linedigit))
- (body (make-prog-body (the-body opts) line linedigit mark)))))
-
-;*---------------------------------------------------------------------*/
-;* source ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/prgm.skb:source@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:source@ */
-;*---------------------------------------------------------------------*/
-(define-markup (source #!rest
- opts
- #!key
- language
- (file #f) (start #f) (stop #f)
- (definition #f) (tab 8))
- (let ((body (the-body opts)))
- (cond
- ((and (not (null? body)) (or file start stop definition))
- (skribe-error 'source
- "file, start/stop, and definition are exclusive with body"
- body))
- ((and start stop definition)
- (skribe-error 'source
- "start/stop are exclusive with a definition"
- body))
- ((and (or start stop definition) (not file))
- (skribe-error 'source
- "start/stop and definition require a file specification"
- file))
- ((and definition (not language))
- (skribe-error 'source
- "definition requires a language specification"
- definition))
- ((and file (not (string? file)))
- (skribe-error 'source "Illegal file" file))
- ((and start (not (or (integer? start) (string? start))))
- (skribe-error 'source "Illegal start" start))
- ((and stop (not (or (integer? stop) (string? stop))))
- (skribe-error 'source "Illegal start" stop))
- ((and (integer? start) (integer? stop) (> start stop))
- (skribe-error 'source
- "start line > stop line"
- (format "~a/~a" start stop)))
- ((and language (not (language? language)))
- (skribe-error 'source "Illegal language" language))
- ((and tab (not (integer? tab)))
- (skribe-error 'source "Illegal tab" tab))
- (file
- (let ((s (if (not definition)
- (source-read-lines file start stop tab)
- (source-read-definition file definition tab language))))
- (if language
- (source-fontify s language)
- s)))
- (language
- (source-fontify body language))
- (else
- body))))
-
-;*---------------------------------------------------------------------*/
-;* language ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/prgm.skb:language@ */
-;*---------------------------------------------------------------------*/
-(define-markup (language #!key name (fontifier #f) (extractor #f))
- (if (not (string? name))
- (skribe-type-error 'language "Illegal name, " name "string")
- (new language
- (name name)
- (fontifier fontifier)
- (extractor extractor))))
-
-;*---------------------------------------------------------------------*/
-;* figure ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/figure.skb:figure@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:figure@ */
-;*---------------------------------------------------------------------*/
-(define-markup (figure #!rest
- opts
- #!key
- (ident #f) (class "figure")
- (legend #f) (number #t) (multicolumns #f))
- (new container
- (markup 'figure)
- (ident (or ident
- (let ((s (ast->string legend)))
- (if (not (string=? s ""))
- s
- (symbol->string (gensym 'figure))))))
- (class class)
- (required-options '(:legend :number :multicolumns))
- (options `((:number
- ,(new unresolved
- (proc (lambda (n e env)
- (resolve-counter n env 'figure number)))))
- ,@(the-options opts :ident :class)))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* parse-list-of ... */
-;* ------------------------------------------------------------- */
-;* The function table accepts two different prototypes. It */
-;* may receive its N elements in a list of N elements or in */
-;* a list of one element which is a list of N elements. This */
-;* gets rid of APPLY when calling container markup such as ITEMIZE */
-;* or TABLE. */
-;*---------------------------------------------------------------------*/
-(define (parse-list-of for markup lst)
- (cond
- ((null? lst)
- '())
- ((and (pair? lst)
- (or (pair? (car lst)) (null? (car lst)))
- (null? (cdr lst)))
- (parse-list-of for markup (car lst)))
- (else
- (let loop ((lst lst))
- (cond
- ((null? lst)
- '())
- ((pair? (car lst))
- (loop (car lst)))
- (else
- (let ((r (car lst)))
- (if (not (is-markup? r markup))
- (skribe-warning 2
- for
- (format "Illegal `~a' element, `~a' expected"
- (if (markup? r)
- (markup-markup r)
- (find-runtime-type r))
- markup)))
- (cons r (loop (cdr lst))))))))))
-
-;*---------------------------------------------------------------------*/
-;* itemize ... */
-;*---------------------------------------------------------------------*/
-(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol)
- (new container
- (markup 'itemize)
- (ident (or ident (symbol->string (gensym 'itemize))))
- (class class)
- (required-options '(:symbol))
- (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
- (body (parse-list-of 'itemize 'item (the-body opts)))))
-
-;*---------------------------------------------------------------------*/
-;* enumerate ... */
-;*---------------------------------------------------------------------*/
-(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol)
- (new container
- (markup 'enumerate)
- (ident (or ident (symbol->string (gensym 'enumerate))))
- (class class)
- (required-options '(:symbol))
- (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
- (body (parse-list-of 'enumerate 'item (the-body opts)))))
-
-;*---------------------------------------------------------------------*/
-;* description ... */
-;*---------------------------------------------------------------------*/
-(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol)
- (new container
- (markup 'description)
- (ident (or ident (symbol->string (gensym 'description))))
- (class class)
- (required-options '(:symbol))
- (options `((:symbol ,symbol) ,@(the-options opts :ident :class)))
- (body (parse-list-of 'description 'item (the-body opts)))))
-
-;*---------------------------------------------------------------------*/
-;* item ... */
-;*---------------------------------------------------------------------*/
-(define-markup (item #!rest opts #!key (ident #f) (class #f) key)
- (if (and key (not (or (string? key)
- (number? key)
- (markup? key)
- (pair? key))))
- (skribe-type-error 'item "Illegal key:" key "node")
- (new container
- (markup 'item)
- (ident (or ident (symbol->string (gensym 'item))))
- (class class)
- (required-options '(:key))
- (options `((:key ,key) ,@(the-options opts :ident :class :key)))
- (body (the-body opts)))))
-
-;*---------------------------------------------------------------------*/
-;* table */
-;*---------------------------------------------------------------------*/
-(define-markup (table #!rest
- opts
- #!key
- (ident #f) (class #f)
- (border #f) (width #f)
- (frame 'none) (rules 'none)
- (cellstyle 'collapse) (cellpadding #f) (cellspacing #f))
- (let ((frame (cond
- ((string? frame)
- (string->symbol frame))
- ((not frame)
- #f)
- (else
- frame)))
- (rules (cond
- ((string? rules)
- (string->symbol rules))
- ((not rules)
- #f)
- (else
- rules)))
- (frame-vals '(none above below hsides vsides lhs rhs box border))
- (rules-vals '(none rows cols all header))
- (cells-vals '(collapse separate)))
- (cond
- ((and frame (not (memq frame frame-vals)))
- (skribe-error 'table
- (format "frame should be one of \"~a\"" frame-vals)
- frame))
- ((and rules (not (memq rules rules-vals)))
- (skribe-error 'table
- (format "rules should be one of \"~a\"" rules-vals)
- rules))
- ((not (or (memq cellstyle cells-vals)
- (string? cellstyle)
- (number? cellstyle)))
- (skribe-error 'table
- (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals)
- cellstyle))
- (else
- (new container
- (markup 'table)
- (ident (or ident (symbol->string (gensym 'table))))
- (class class)
- (required-options '(:width :frame :rules))
- (options `((:frame ,frame)
- (:rules ,rules)
- (:cellstyle ,cellstyle)
- ,@(the-options opts :ident :class)))
- (body (parse-list-of 'table 'tr (the-body opts))))))))
-
-;*---------------------------------------------------------------------*/
-;* tr ... */
-;*---------------------------------------------------------------------*/
-(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f))
- (new container
- (markup 'tr)
- (ident (or ident (symbol->string (gensym 'tr))))
- (class class)
- (required-options '())
- (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '())
- ,@(the-options opts :ident :class :bg)))
- (body (parse-list-of 'tr 'tc (the-body opts)))))
-
-;*---------------------------------------------------------------------*/
-;* tc... */
-;*---------------------------------------------------------------------*/
-(define-markup (tc m
- #!rest
- opts
- #!key
- (ident #f) (class #f)
- (width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
- (let ((align (if (string? align)
- (string->symbol align)
- align))
- (valign (if (string? valign)
- (string->symbol valign)
- valign)))
- (cond
- ((not (integer? colspan))
- (skribe-type-error 'tc "Illegal colspan, " colspan "integer"))
- ((not (symbol? align))
- (skribe-type-error 'tc "Illegal align, " align "align"))
- ((not (memq align '(#f center left right)))
- (skribe-error
- 'tc
- "align should be one of 'left', `center', or `right'"
- align))
- ((not (memq valign '(#f top middle center bottom)))
- (skribe-error
- 'tc
- "valign should be one of 'top', `middle', `center', or `bottom'"
- valign))
- (else
- (new container
- (markup 'tc)
- (ident (or ident (symbol->string (gensym 'tc))))
- (class class)
- (required-options '(:width :align :valign :colspan))
- (options `((markup ,m)
- (:align ,align)
- (:valign ,valign)
- (:colspan ,colspan)
- ,@(if bg
- `((:bg ,(if bg (skribe-use-color! bg) bg)))
- '())
- ,@(the-options opts :ident :class :bg :align :valign)))
- (body (the-body opts)))))))
-
-;*---------------------------------------------------------------------*/
-;* th ... */
-;*---------------------------------------------------------------------*/
-(define-markup (th #!rest
- opts
- #!key
- (ident #f) (class #f)
- (width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
- (apply tc 'th opts))
-
-;*---------------------------------------------------------------------*/
-;* td ... */
-;*---------------------------------------------------------------------*/
-(define-markup (td #!rest
- opts
- #!key
- (ident #f) (class #f)
- (width #f) (align 'center) (valign #f)
- (colspan 1) (bg #f))
- (apply tc 'td opts))
-
-;*---------------------------------------------------------------------*/
-;* image ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/image.skb:image@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:image@ */
-;* latex: @ref ../../skr/latex.skr:image@ */
-;*---------------------------------------------------------------------*/
-(define-markup (image #!rest
- opts
- #!key
- (ident #f) (class #f)
- file (url #f) (width #f) (height #f) (zoom #f))
- (cond
- ((not (or (string? file) (string? url)))
- (skribe-error 'image "No file or url provided" file))
- ((and (string? file) (string? url))
- (skribe-error 'image "Both file and url provided" (list file url)))
- (else
- (new markup
- (markup 'image)
- (ident (or ident (symbol->string (gensym 'image))))
- (class class)
- (required-options '(:file :url :width :height))
- (options (the-options opts :ident :class))
- (body (the-body opts))))))
-
-;*---------------------------------------------------------------------*/
-;* blockquote */
-;*---------------------------------------------------------------------*/
-(define-simple-markup blockquote)
-
-;*---------------------------------------------------------------------*/
-;* Ornaments ... */
-;*---------------------------------------------------------------------*/
-(define-simple-markup roman)
-(define-simple-markup bold)
-(define-simple-markup underline)
-(define-simple-markup strike)
-(define-simple-markup emph)
-(define-simple-markup kbd)
-(define-simple-markup it)
-(define-simple-markup tt)
-(define-simple-markup code)
-(define-simple-markup var)
-(define-simple-markup samp)
-(define-simple-markup sf)
-(define-simple-markup sc)
-(define-simple-markup sub)
-(define-simple-markup sup)
-
-;*---------------------------------------------------------------------*/
-;* char ... */
-;*---------------------------------------------------------------------*/
-(define-markup (char char)
- (cond
- ((char? char)
- (string char))
- ((integer? char)
- (string (integer->char char)))
- ((and (string? char) (= (string-length char) 1))
- char)
- (else
- (skribe-error 'char "Illegal char" char))))
-
-;*---------------------------------------------------------------------*/
-;* symbol ... */
-;*---------------------------------------------------------------------*/
-(define-markup (symbol symbol)
- (let ((v (cond
- ((symbol? symbol)
- (symbol->string symbol))
- ((string? symbol)
- symbol)
- (else
- (skribe-error 'symbol
- "Illegal argument (symbol expected)"
- symbol)))))
- (new markup
- (markup 'symbol)
- (body v))))
-
-;*---------------------------------------------------------------------*/
-;* ! ... */
-;*---------------------------------------------------------------------*/
-(define-markup (! format #!rest node)
- (if (not (string? format))
- (skribe-type-error '! "Illegal format:" format "string")
- (new command
- (fmt format)
- (body node))))
-
-;*---------------------------------------------------------------------*/
-;* processor ... */
-;*---------------------------------------------------------------------*/
-(define-markup (processor #!rest opts
- #!key (combinator #f) (engine #f) (procedure #f))
- (cond
- ((and combinator (not (procedure? combinator)))
- (skribe-error 'processor "Combinator not a procedure" combinator))
- ((and engine (not (engine? engine)))
- (skribe-error 'processor "Illegal engine" engine))
- ((and procedure
- (or (not (procedure? procedure))
- (not (correct-arity? procedure 2))))
- (skribe-error 'processor "Illegal procedure" procedure))
- (else
- (new processor
- (combinator combinator)
- (engine engine)
- (procedure (or procedure (lambda (n e) n)))
- (body (the-body opts))))))
-
-;*---------------------------------------------------------------------*/
-;* Processors ... */
-;*---------------------------------------------------------------------*/
-(define-processor-markup html-processor)
-(define-processor-markup tex-processor)
-
-;*---------------------------------------------------------------------*/
-;* handle ... */
-;*---------------------------------------------------------------------*/
-(define-markup (handle #!rest opts
- #!key (ident #f) (class "handle") value section)
- (let ((body (the-body opts)))
- (cond
- (section
- (error 'handle "Illegal handle `section' option" section)
- (new unresolved
- (proc (lambda (n e env)
- (let ((s (resolve-ident section 'section n env)))
- (new handle
- (ast s)))))))
- ((and (pair? body)
- (null? (cdr body))
- (markup? (car body)))
- (new handle
- (ast (car body))))
- (else
- (skribe-error 'handle "Illegal handle" opts)))))
-
-;*---------------------------------------------------------------------*/
-;* mailto ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/links.skb:mailto@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:mailto@ */
-;*---------------------------------------------------------------------*/
-(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text)
- (new markup
- (markup 'mailto)
- (ident (or ident (symbol->string (gensym 'ident))))
- (class class)
- (required-options '(:text))
- (options (the-options opts :ident :class))
- (body (the-body opts))))
-
-;*---------------------------------------------------------------------*/
-;* *mark-table* ... */
-;*---------------------------------------------------------------------*/
-(define *mark-table* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* mark ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/links.skb:mark@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:mark@ */
-;*---------------------------------------------------------------------*/
-(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f))
- (let ((bd (the-body opts)))
- (cond
- ((and (pair? bd) (not (null? (cdr bd))))
- (skribe-error 'mark "Too many argument provided" bd))
- ((null? bd)
- (skribe-error 'mark "Missing argument" '()))
- ((not (string? (car bd)))
- (skribe-type-error 'mark "Illegal ident:" (car bd) "string"))
- (ident
- (skribe-error 'mark "Illegal `ident:' option" ident))
- (else
- (let* ((bs (ast->string bd))
- (n (new markup
- (markup 'mark)
- (ident bs)
- (class class)
- (options (the-options opts :ident :class :text))
- (body text))))
- (hashtable-put! *mark-table* bs n)
- n)))))
-
-;*---------------------------------------------------------------------*/
-;* ref ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/links.skb:ref@ */
-;* writer: */
-;* html: @ref ../../skr/html.skr:ref@ */
-;* latex: @ref ../../skr/latex.skr:ref@ */
-;*---------------------------------------------------------------------*/
-(define-markup (ref #!rest
- opts
- #!key
- (class #f)
- (ident #f)
- (text #f)
- (chapter #f)
- (section #f)
- (subsection #f)
- (subsubsection #f)
- (bib #f)
- (bib-table (default-bib-table))
- (url #f)
- (figure #f)
- (mark #f)
- (handle #f)
- (line #f)
- (skribe #f)
- (page #f))
- (define (unref ast text kind)
- (let ((msg (format "Can't find `~a': " kind)))
- (if (ast? ast)
- (begin
- (skribe-warning/ast 1 ast 'ref msg text)
- (new markup
- (markup 'unref)
- (ident (symbol->string 'unref))
- (class class)
- (required-options '(:text))
- (options `((kind ,kind) ,@(the-options opts :ident :class)))
- (body (list text ": " (ast->file-location ast)))))
- (begin
- (skribe-warning 1 'ref msg text)
- (new markup
- (markup 'unref)
- (ident (symbol->string 'unref))
- (class class)
- (required-options '(:text))
- (options `((kind ,kind) ,@(the-options opts :ident :class)))
- (body text))))))
- (define (skribe-ref skribe)
- (let ((path (find-file/path skribe (skribe-path))))
- (if (not path)
- (unref #f skribe 'sui-file)
- (let* ((sui (load-sui path))
- (os (the-options opts :skribe :class :text))
- (u (sui-ref->url (dirname path) sui ident os)))
- (if (not u)
- (unref #f os 'sui-ref)
- (ref :url u :text text :ident ident :class class))))))
- (define (handle-ref text)
- (new markup
- (markup 'ref)
- (ident (symbol->string 'ref))
- (class class)
- (required-options '(:text))
- (options `((kind handle) ,@(the-options opts :ident :class)))
- (body text)))
- (define (doref text kind)
- (if (not (string? text))
- (skribe-type-error 'ref "Illegal reference" text "string")
- (new unresolved
- (proc (lambda (n e env)
- (let ((s (resolve-ident text kind n env)))
- (if s
- (new markup
- (markup 'ref)
- (ident (symbol->string 'ref))
- (class class)
- (required-options '(:text))
- (options `((kind ,kind)
- (mark ,text)
- ,@(the-options opts :ident :class)))
- (body (new handle
- (ast s))))
- (unref n text (or kind 'ident)))))))))
- (define (mark-ref mark)
- (if (not (string? mark))
- (skribe-type-error 'mark "Illegal mark, " mark "string")
- (new unresolved
- (proc (lambda (n e env)
- (let ((s (hashtable-get *mark-table* mark)))
- (if s
- (new markup
- (markup 'ref)
- (ident (symbol->string 'ref))
- (class class)
- (required-options '(:text))
- (options `((kind mark)
- (mark ,mark)
- ,@(the-options opts :ident :class)))
- (body (new handle
- (ast s))))
- (unref n mark 'mark))))))))
- (define (make-bib-ref v)
- (let ((s (resolve-bib bib-table v)))
- (if s
- (let* ((n (new markup
- (markup 'bib-ref)
- (ident (symbol->string 'bib-ref))
- (class class)
- (required-options '(:text))
- (options (the-options opts :ident :class))
- (body (new handle
- (ast s)))))
- (h (new handle (ast n)))
- (o (markup-option s 'used)))
- (markup-option-add! s 'used (if (pair? o) (cons h o) (list h)))
- n)
- (unref #f v 'bib))))
- (define (bib-ref text)
- (if (pair? text)
- (new markup
- (markup 'bib-ref+)
- (ident (symbol->string 'bib-ref+))
- (class class)
- (options (the-options opts :ident :class))
- (body (map make-bib-ref text)))
- (make-bib-ref text)))
- (define (url-ref)
- (new markup
- (markup 'url-ref)
- (ident (symbol->string 'url-ref))
- (class class)
- (required-options '(:url :text))
- (options (the-options opts :ident :class))))
- (define (line-ref line)
- (new unresolved
- (proc (lambda (n e env)
- (let ((l (resolve-line line)))
- (if (pair? l)
- (new markup
- (markup 'line-ref)
- (ident (symbol->string 'line-ref))
- (class class)
- (options `((:text ,(markup-ident (car l)))
- ,@(the-options opts :ident :class)))
- (body (new handle
- (ast (car l)))))
- (unref n line 'line)))))))
- (let ((b (the-body opts)))
- (if (not (null? b))
- (skribe-warning 1 'ref "Arguments ignored " b))
- (cond
- (skribe (skribe-ref skribe))
- (handle (handle-ref handle))
- (ident (doref ident #f))
- (chapter (doref chapter 'chapter))
- (section (doref section 'section))
- (subsection (doref subsection 'subsection))
- (subsubsection (doref subsubsection 'subsubsection))
- (figure (doref figure 'figure))
- (mark (mark-ref mark))
- (bib (bib-ref bib))
- (url (url-ref))
- (line (line-ref line))
- (else (skribe-error 'ref "Illegal reference" opts)))))
-
-;*---------------------------------------------------------------------*/
-;* resolve ... */
-;*---------------------------------------------------------------------*/
-(define-markup (resolve fun)
- (new unresolved
- (proc fun)))
-
-;*---------------------------------------------------------------------*/
-;* bibliography ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/bib.skb:bibliography@ */
-;*---------------------------------------------------------------------*/
-(define-markup (bibliography #!rest files
- #!key
- (command #f) (bib-table (default-bib-table)))
- (for-each (lambda (f)
- (cond
- ((string? f)
- (bib-load! bib-table f command))
- ((pair? f)
- (bib-add! bib-table f))
- (else
- (skribe-error "bibliography" "Illegal entry" f))))
- (the-body files)))
-
-;*---------------------------------------------------------------------*/
-;* the-bibliography ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/bib.skb:the-bibliography@ */
-;* writer: */
-;* base: @ref ../../skr/base.skr:the-bibliography@ */
-;*---------------------------------------------------------------------*/
-(define-markup (the-bibliography #!rest opts
- #!key
- pred
- (bib-table (default-bib-table))
- (sort bib-sort/authors)
- (count 'partial))
- (if (not (memq count '(partial full)))
- (skribe-error 'the-bibliography
- "Cound must be either `partial' or `full'"
- count)
- (new unresolved
- (proc (lambda (n e env)
- (resolve-the-bib bib-table
- (new handle (ast n))
- sort
- pred
- count
- (the-options opts)))))))
-
-;*---------------------------------------------------------------------*/
-;* make-index ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/index.skb:make-index@ */
-;*---------------------------------------------------------------------*/
-(define-markup (make-index ident)
- (make-index-table ident))
-
-;*---------------------------------------------------------------------*/
-;* index ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/index.skb:index@ */
-;*---------------------------------------------------------------------*/
-(define-markup (index #!rest
- opts
- #!key
- (ident #f) (class "index")
- (note #f) (index #f) (shape #f)
- (url #f))
- (let* ((entry-name (the-body opts))
- (ename (cond
- ((string? entry-name)
- entry-name)
- ((and (pair? entry-name) (every string? entry-name))
- (apply string-append entry-name))
- (else
- (skribe-error
- 'index
- "entry-name must be either a string or a list of strings"
- entry-name))))
- (table (cond
- ((not index) (default-index))
- ((index? index) index)
- (else (skribe-type-error 'index
- "Illegal index table, "
- index
- "index"))))
- (m (mark (symbol->string (gensym))))
- (h (new handle (ast m)))
- (new (new markup
- (markup '&index-entry)
- (ident (or ident (symbol->string (gensym 'index))))
- (class class)
- (options `((name ,ename) ,@(the-options opts :ident :class)))
- (body (if url
- (ref :url url :text (or shape ename))
- (ref :handle h :text (or shape ename)))))))
- ;; New is bound to a dummy option of the mark in order
- ;; to make new options verified.
- (markup-option-add! m 'to-verify new)
- (hashtable-update! table
- ename
- (lambda (cur) (cons new cur))
- (list new))
- m))
-
-;*---------------------------------------------------------------------*/
-;* the-index ... */
-;* ------------------------------------------------------------- */
-;* doc: */
-;* @ref ../../doc/user/index.skb:the-index@ */
-;* writer: */
-;* base: @ref ../../skr/base.skr:the-index@ */
-;* html: @ref ../../skr/html.skr:the-index-header@ */
-;*---------------------------------------------------------------------*/
-(define-markup (the-index #!rest
- opts
- #!key
- (ident #f)
- (class "the-index")
- (split #f)
- (char-offset 0)
- (header-limit 50)
- (column 1))
- (let ((bd (the-body opts)))
- (cond
- ((not (and (integer? char-offset) (>= char-offset 0)))
- (skribe-error 'the-index "Illegal char offset" char-offset))
- ((not (integer? column))
- (skribe-error 'the-index "Illegal column number" column))
- ((not (every? index? bd))
- (skribe-error 'the-index
- "Illegal indexes"
- (filter (lambda (o) (not (index? o))) bd)))
- (else
- (new unresolved
- (proc (lambda (n e env)
- (resolve-the-index (ast-loc n)
- ident class
- bd
- split
- char-offset
- header-limit
- column))))))))
diff --git a/src/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/index.scm b/src/common/index.scm
deleted file mode 100644
index 65c271f..0000000
--- a/src/common/index.scm
+++ /dev/null
@@ -1,126 +0,0 @@
-;*=====================================================================*/
-;* 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? ... */
-;*---------------------------------------------------------------------*/
-(define (index? obj)
- (hashtable? obj))
-
-;*---------------------------------------------------------------------*/
-;* *index-table* ... */
-;*---------------------------------------------------------------------*/
-(define *index-table* #f)
-
-;*---------------------------------------------------------------------*/
-;* make-index-table ... */
-;*---------------------------------------------------------------------*/
-(define (make-index-table ident)
- (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* default-index ... */
-;*---------------------------------------------------------------------*/
-(define (default-index)
- (if (not *index-table*)
- (set! *index-table* (make-index-table "default-index")))
- *index-table*)
-
-;*---------------------------------------------------------------------*/
-;* resolve-the-index ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-the-index loc i c indexes split char-offset header-limit col)
- ;; fetch the descriminating index name letter
- (define (index-ref n)
- (let ((name (markup-option n 'name)))
- (if (>= char-offset (string-length name))
- (skribe-error 'the-index "char-offset out of bound" char-offset)
- (string-ref name char-offset))))
- ;; sort a bucket of entries (the entries in a bucket share there name)
- (define (sort-entries-bucket ie)
- (sort ie
- (lambda (i1 i2)
- (or (not (markup-option i1 :note))
- (markup-option i2 :note)))))
- ;; accumulate all the entries starting with the same letter
- (define (letter-references refs)
- (let ((letter (index-ref (car (car refs)))))
- (let loop ((refs refs)
- (acc '()))
- (if (or (null? refs)
- (not (char-ci=? letter (index-ref (car (car refs))))))
- (values (char-upcase letter) acc refs)
- (loop (cdr refs) (cons (car refs) acc))))))
- ;; merge the buckets that comes from different index tables
- (define (merge-buckets buckets)
- (if (null? buckets)
- '()
- (let loop ((buckets buckets)
- (res '()))
- (cond
- ((null? (cdr buckets))
- (reverse! (cons (car buckets) res)))
- ((string=? (markup-option (car (car buckets)) 'name)
- (markup-option (car (cadr buckets)) 'name))
- ;; we merge
- (loop (cons (append (car buckets) (cadr buckets))
- (cddr buckets))
- res))
- (else
- (loop (cdr buckets)
- (cons (car buckets) res)))))))
- (let* ((entries (apply append (map hashtable->list indexes)))
- (sorted (map sort-entries-bucket
- (merge-buckets
- (sort entries
- (lambda (e1 e2)
- (string-ci<?
- (markup-option (car e1) 'name)
- (markup-option (car e2) 'name))))))))
- (if (and (not split) (< (apply + (map length sorted)) header-limit))
- (new markup
- (markup '&the-index)
- (loc loc)
- (ident i)
- (class c)
- (options `((:column ,col)))
- (body sorted))
- (let loop ((refs sorted)
- (lrefs '())
- (body '()))
- (if (null? refs)
- (new markup
- (markup '&the-index)
- (loc loc)
- (ident i)
- (class c)
- (options `((:column ,col)
- (header ,(new markup
- (markup '&the-index-header)
- (loc loc)
- (body (reverse! lrefs))))))
- (body (reverse! body)))
- (call-with-values
- (lambda () (letter-references refs))
- (lambda (l lr next-refs)
- (let* ((s (string l))
- (m (mark (symbol->string (gensym s)) :text s))
- (h (new handle (loc loc) (ast m)))
- (r (ref :handle h :text s)))
- (ast-loc-set! m loc)
- (ast-loc-set! r loc)
- (loop next-refs
- (cons r lrefs)
- (append lr (cons m body)))))))))))
-
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/common/sui.scm b/src/common/sui.scm
deleted file mode 100644
index eb6134b..0000000
--- a/src/common/sui.scm
+++ /dev/null
@@ -1,166 +0,0 @@
-;*=====================================================================*/
-;* 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-table* ... */
-;*---------------------------------------------------------------------*/
-(define *sui-table* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* load-sui ... */
-;* ------------------------------------------------------------- */
-;* Returns a SUI sexp if already loaded. Load it otherwise. */
-;* Raise an error if the file cannot be open. */
-;*---------------------------------------------------------------------*/
-(define (load-sui path)
- (let ((sexp (hashtable-get *sui-table* path)))
- (or sexp
- (begin
- (when (> *skribe-verbose* 0)
- (fprintf (current-error-port) " [loading sui: ~a]\n" path))
- (let ((p (open-input-file path)))
- (if (not (input-port? p))
- (skribe-error 'load-sui
- "Can't find `Skribe Url Index' file"
- path)
- (unwind-protect
- (let ((sexp (read p)))
- (match-case sexp
- ((sui (? string?) . ?-)
- (hashtable-put! *sui-table* path sexp))
- (else
- (skribe-error 'load-sui
- "Illegal `Skribe Url Index' file"
- path)))
- sexp)
- (close-input-port p))))))))
-
-;*---------------------------------------------------------------------*/
-;* sui-ref->url ... */
-;*---------------------------------------------------------------------*/
-(define (sui-ref->url dir sui ident opts)
- (let ((refs (sui-find-ref sui ident opts)))
- (and (pair? refs)
- (let ((base (sui-file sui))
- (file (car (car refs)))
- (mark (cdr (car refs))))
- (format "~a/~a#~a" dir (or file base) mark)))))
-
-;*---------------------------------------------------------------------*/
-;* sui-title ... */
-;*---------------------------------------------------------------------*/
-(define (sui-title sexp)
- (match-case sexp
- ((sui (and ?title (? string?)) . ?-)
- title)
- (else
- (skribe-error 'sui-title "Illegal `sui' format" sexp))))
-
-;*---------------------------------------------------------------------*/
-;* sui-file ... */
-;*---------------------------------------------------------------------*/
-(define (sui-file sexp)
- (sui-key sexp :file))
-
-;*---------------------------------------------------------------------*/
-;* sui-key ... */
-;*---------------------------------------------------------------------*/
-(define (sui-key sexp key)
- (match-case sexp
- ((sui ?- . ?rest)
- (let loop ((rest rest))
- (and (pair? rest)
- (if (eq? (car rest) key)
- (and (pair? (cdr rest))
- (cadr rest))
- (loop (cdr rest))))))
- (else
- (skribe-error 'sui-key "Illegal `sui' format" sexp))))
-
-;*---------------------------------------------------------------------*/
-;* sui-find-ref ... */
-;*---------------------------------------------------------------------*/
-(define (sui-find-ref sui ident opts)
- (let ((ident (assq :ident opts))
- (mark (assq :mark opts))
- (class (let ((c (assq :class opts)))
- (and (pair? c) (cadr c))))
- (chapter (assq :chapter opts))
- (section (assq :section opts))
- (subsection (assq :subsection opts))
- (subsubsection (assq :subsubsection opts)))
- (match-case sui
- ((sui (? string?) . ?refs)
- (cond
- (mark (sui-search-ref 'marks refs (cadr mark) class))
- (chapter (sui-search-ref 'chapters refs (cadr chapter) class))
- (section (sui-search-ref 'sections refs (cadr section) class))
- (subsection (sui-search-ref 'subsections refs (cadr subsection) class))
- (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class))
- (ident (sui-search-all-refs sui ident class))
- (else '())))
- (else
- (skribe-error 'sui-find-ref "Illegal `sui' format" sui)))))
-
-;*---------------------------------------------------------------------*/
-;* sui-search-all-refs ... */
-;*---------------------------------------------------------------------*/
-(define (sui-search-all-refs sui id refs)
- '())
-
-;*---------------------------------------------------------------------*/
-;* sui-search-ref ... */
-;*---------------------------------------------------------------------*/
-(define (sui-search-ref kind refs val class)
- (define (find-ref refs val class)
- (map (lambda (r)
- (let ((f (memq :file r))
- (c (memq :mark r)))
- (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c)))))
- (filter (if class
- (lambda (m)
- (and (pair? m)
- (string? (car m))
- (string=? (car m) val)
- (let ((c (memq :class m)))
- (and (pair? c)
- (eq? (cadr c) class)))))
- (lambda (m)
- (and (pair? m)
- (string? (car m))
- (string=? (car m) val))))
- refs)))
- (let loop ((refs refs))
- (if (pair? refs)
- (if (and (pair? (car refs)) (eq? (caar refs) kind))
- (find-ref (cdar refs) val class)
- (loop (cdr refs)))
- '())))
-
-;*---------------------------------------------------------------------*/
-;* sui-filter ... */
-;*---------------------------------------------------------------------*/
-(define (sui-filter sui pred1 pred2)
- (match-case sui
- ((sui (? string?) . ?refs)
- (let loop ((refs refs)
- (res '()))
- (if (pair? refs)
- (if (and (pred1 (car refs)))
- (loop (cdr refs)
- (cons (filter pred2 (cdar refs)) res))
- (loop (cdr refs) res))
- (reverse! res))))
- (else
- (skribe-error 'sui-filter "Illegal `sui' format" sui))))
diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am
new file mode 100644
index 0000000..afe4667
--- /dev/null
+++ b/src/guile/Makefile.am
@@ -0,0 +1,4 @@
+SUBDIRS = skribilo
+
+bin_SCRIPTS = skribilo.scm
+EXTRA_DIST = README
diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am
new file mode 100644
index 0000000..c86f2f3
--- /dev/null
+++ b/src/guile/skribilo/Makefile.am
@@ -0,0 +1,9 @@
+guilemoduledir = $(GUILE_SITE)/skribilo
+dist_guilemodule_DATA = biblio.scm color.scm config.scm \
+ debug.scm engine.scm evaluator.scm \
+ lib.scm module.scm output.scm prog.scm \
+ reader.scm resolve.scm runtime.scm \
+ source.scm types.scm vars.scm verify.scm \
+ writer.scm
+
+SUBDIRS = reader engine package skribe coloring
diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in
index 80a26de..add7d0e 100644
--- a/src/guile/skribilo/Makefile.in
+++ b/src/guile/skribilo/Makefile.in
@@ -1,110 +1,463 @@
-#
-# 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.
-#
+# Makefile.in generated by automake 1.9.6 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005 Free Software Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
# 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
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
-prefix=@PREFIX@
+@SET_MAKE@
-SKR = $(wildcard ../../skr/*.skr)
+srcdir = @srcdir@
+top_srcdir = @top_srcdir@
+VPATH = @srcdir@
+pkgdatadir = $(datadir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+top_builddir = ../../..
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+INSTALL = @INSTALL@
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+subdir = src/guile/skribilo
+DIST_COMMON = $(dist_guilemodule_DATA) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(srcdir)/config.scm.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES = config.scm
+SOURCES =
+DIST_SOURCES =
+RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \
+ html-recursive info-recursive install-data-recursive \
+ install-exec-recursive install-info-recursive \
+ install-recursive installcheck-recursive installdirs-recursive \
+ pdf-recursive ps-recursive uninstall-info-recursive \
+ uninstall-recursive
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = `echo $$p | sed -e 's|^.*/||'`;
+am__installdirs = "$(DESTDIR)$(guilemoduledir)"
+dist_guilemoduleDATA_INSTALL = $(INSTALL_DATA)
+DATA = $(dist_guilemodule_DATA)
+ETAGS = etags
+CTAGS = ctags
+DIST_SUBDIRS = $(SUBDIRS)
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+GUILE = @GUILE@
+GUILE_CONFIG = @GUILE_CONFIG@
+GUILE_SITE = @GUILE_SITE@
+GUILE_TOOLS = @GUILE_TOOLS@
+HAVE_LOUT_FALSE = @HAVE_LOUT_FALSE@
+HAVE_LOUT_TRUE = @HAVE_LOUT_TRUE@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LOUT = @LOUT@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+SKRIBILO_DOC_DIR = @SKRIBILO_DOC_DIR@
+SKRIBILO_EXT_DIR = @SKRIBILO_EXT_DIR@
+SKRIBILO_SKR_PATH = @SKRIBILO_SKR_PATH@
+STRIP = @STRIP@
+VERSION = @VERSION@
+ac_ct_STRIP = @ac_ct_STRIP@
+am__leading_dot = @am__leading_dot@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build_alias = @build_alias@
+datadir = @datadir@
+exec_prefix = @exec_prefix@
+host_alias = @host_alias@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localstatedir = @localstatedir@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+guilemoduledir = $(GUILE_SITE)/skribilo
+dist_guilemodule_DATA = biblio.scm color.scm config.scm \
+ debug.scm engine.scm evaluator.scm \
+ lib.scm module.scm output.scm prog.scm \
+ reader.scm resolve.scm runtime.scm \
+ source.scm types.scm vars.scm verify.scm \
+ writer.scm
-DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \
- ../common/index.scm ../common/bib.scm ../common/lib.scm
+SUBDIRS = reader engine package skribe coloring
+all: all-recursive
-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
+.SUFFIXES:
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \
+ && exit 0; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/guile/skribilo/Makefile'; \
+ cd $(top_srcdir) && \
+ $(AUTOMAKE) --gnu src/guile/skribilo/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
-LEXFILES = c-lex.l lisp-lex.l xml-lex.l
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
-LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+config.scm: $(top_builddir)/config.status $(srcdir)/config.scm.in
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
+uninstall-info-am:
+install-dist_guilemoduleDATA: $(dist_guilemodule_DATA)
+ @$(NORMAL_INSTALL)
+ test -z "$(guilemoduledir)" || $(mkdir_p) "$(DESTDIR)$(guilemoduledir)"
+ @list='$(dist_guilemodule_DATA)'; for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ f=$(am__strip_dir) \
+ echo " $(dist_guilemoduleDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(guilemoduledir)/$$f'"; \
+ $(dist_guilemoduleDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(guilemoduledir)/$$f"; \
+ done
-BINDIR=../../bin
+uninstall-dist_guilemoduleDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(dist_guilemodule_DATA)'; for p in $$list; do \
+ f=$(am__strip_dir) \
+ echo " rm -f '$(DESTDIR)$(guilemoduledir)/$$f'"; \
+ rm -f "$(DESTDIR)$(guilemoduledir)/$$f"; \
+ done
-EXE= $(BINDIR)/skribe.stklos
+# This directory's subdirectories are mostly independent; you can cd
+# into them and run `make' without going through this Makefile.
+# To change the values of `make' variables: instead of editing Makefiles,
+# (1) if the variable is set in `config.status', edit `config.status'
+# (which will cause the Makefiles to be regenerated when you run `make');
+# (2) otherwise, pass the desired values on the `make' command line.
+$(RECURSIVE_TARGETS):
+ @failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ target=`echo $@ | sed s/-recursive//`; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ dot_seen=yes; \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done; \
+ if test "$$dot_seen" = "no"; then \
+ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \
+ fi; test -z "$$fail"
-PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES)
+mostlyclean-recursive clean-recursive distclean-recursive \
+maintainer-clean-recursive:
+ @failcom='exit 1'; \
+ for f in x $$MAKEFLAGS; do \
+ case $$f in \
+ *=* | --[!k]*);; \
+ *k*) failcom='fail=yes';; \
+ esac; \
+ done; \
+ dot_seen=no; \
+ case "$@" in \
+ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \
+ *) list='$(SUBDIRS)' ;; \
+ esac; \
+ rev=''; for subdir in $$list; do \
+ if test "$$subdir" = "."; then :; else \
+ rev="$$subdir $$rev"; \
+ fi; \
+ done; \
+ rev="$$rev ."; \
+ target=`echo $@ | sed s/-recursive//`; \
+ for subdir in $$rev; do \
+ echo "Making $$target in $$subdir"; \
+ if test "$$subdir" = "."; then \
+ local_target="$$target-am"; \
+ else \
+ local_target="$$target"; \
+ fi; \
+ (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \
+ || eval $$failcom; \
+ done && test -z "$$fail"
+tags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \
+ done
+ctags-recursive:
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \
+ done
-SFLAGS=
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) ' { files[$$0] = 1; } \
+ END { for (i in files) print i; }'`; \
+ mkid -fID $$unique
+tags: TAGS
-all: $(EXE)
+TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ tags=; \
+ here=`pwd`; \
+ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \
+ include_option=--etags-include; \
+ empty_fix=.; \
+ else \
+ include_option=--include; \
+ empty_fix=; \
+ fi; \
+ list='$(SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test ! -f $$subdir/TAGS || \
+ tags="$$tags $$include_option=$$here/$$subdir/TAGS"; \
+ fi; \
+ done; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) ' { files[$$0] = 1; } \
+ END { for (i in files) print i; }'`; \
+ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$tags $$unique; \
+ fi
+ctags: CTAGS
+CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ tags=; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) ' { files[$$0] = 1; } \
+ END { for (i in files) print i; }'`; \
+ test -z "$(CTAGS_ARGS)$$tags$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$tags $$unique
-Makefile: Makefile.in
- (cd ../../etc/stklos; autoconf; configure)
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && cd $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) $$here
-$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS)
- stklos-compile $(SFLAGS) -o $(EXE) main.stk && \
- chmod $(BMASK) $(EXE)
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
-#
-# Lex files
-#
-lisp-lex.stk: lisp-lex.l
- stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \
+ list='$(DISTFILES)'; for file in $$list; do \
+ case $$file in \
+ $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \
+ $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \
+ esac; \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test "$$dir" != "$$file" && test "$$dir" != "."; then \
+ dir="/$$dir"; \
+ $(mkdir_p) "$(distdir)$$dir"; \
+ else \
+ dir=''; \
+ fi; \
+ if test -d $$d/$$file; then \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \
+ fi; \
+ cp -pR $$d/$$file $(distdir)$$dir || exit 1; \
+ else \
+ test -f $(distdir)/$$file \
+ || cp -p $$d/$$file $(distdir)/$$file \
+ || exit 1; \
+ fi; \
+ done
+ list='$(DIST_SUBDIRS)'; for subdir in $$list; do \
+ if test "$$subdir" = .; then :; else \
+ test -d "$(distdir)/$$subdir" \
+ || $(mkdir_p) "$(distdir)/$$subdir" \
+ || exit 1; \
+ distdir=`$(am__cd) $(distdir) && pwd`; \
+ top_distdir=`$(am__cd) $(top_distdir) && pwd`; \
+ (cd $$subdir && \
+ $(MAKE) $(AM_MAKEFLAGS) \
+ top_distdir="$$top_distdir" \
+ distdir="$$distdir/$$subdir" \
+ distdir) \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+check: check-recursive
+all-am: Makefile $(DATA)
+installdirs: installdirs-recursive
+installdirs-am:
+ for dir in "$(DESTDIR)$(guilemoduledir)"; do \
+ test -z "$$dir" || $(mkdir_p) "$$dir"; \
+ done
+install: install-recursive
+install-exec: install-exec-recursive
+install-data: install-data-recursive
+uninstall: uninstall-recursive
-xml-lex.stk: xml-lex.l
- stklos-genlex xml-lex.l xml-lex.stk xml-lex
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
-c-lex.stk: c-lex.l
- stklos-genlex c-lex.l c-lex.stk c-lex
+installcheck: installcheck-recursive
+install-strip:
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ `test -z '$(STRIP)' || \
+ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install
+mostlyclean-generic:
+clean-generic:
-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
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-uninstall:
- rm $(INSTALL_BINDIR)/skribe
- rm $(INSTALL_BINDIR)/skribe.stklos
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-recursive
-$(BINDIR):
- mkdir -p $(BINDIR) && chmod a+rx $(BINDIR)
+clean-am: clean-generic mostlyclean-am
-$(INSTALL_BINDIR):
- mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR)
+distclean: distclean-recursive
+ -rm -f Makefile
+distclean-am: clean-am distclean-generic distclean-tags
-##
-## Services
-##
-tags: TAGS
+dvi: dvi-recursive
+
+dvi-am:
+
+html: html-recursive
+
+info: info-recursive
+
+info-am:
+
+install-data-am: install-dist_guilemoduleDATA
+
+install-exec-am:
+
+install-info: install-info-recursive
+
+install-man:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-recursive
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-recursive
+
+mostlyclean-am: mostlyclean-generic
+
+pdf: pdf-recursive
+
+pdf-am:
+
+ps: ps-recursive
-TAGS: $(SRCS)
- etags -l scheme $(SRCS)
+ps-am:
-pop:
- @echo $(PRCS_FILES:%=src/stklos/%)
+uninstall-am: uninstall-dist_guilemoduleDATA uninstall-info-am
-links:
- ln -s $(DEPS) .
- ln -s $(SKR) .
+uninstall-info: uninstall-info-recursive
-clean:
- /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr
+.PHONY: $(RECURSIVE_TARGETS) CTAGS GTAGS all all-am check check-am \
+ clean clean-generic clean-recursive ctags ctags-recursive \
+ distclean distclean-generic distclean-recursive distclean-tags \
+ distdir dvi dvi-am html html-am info info-am install \
+ install-am install-data install-data-am \
+ install-dist_guilemoduleDATA install-exec install-exec-am \
+ install-info install-info-am install-man install-strip \
+ installcheck installcheck-am installdirs installdirs-am \
+ maintainer-clean maintainer-clean-generic \
+ maintainer-clean-recursive mostlyclean mostlyclean-generic \
+ mostlyclean-recursive pdf pdf-am ps ps-am tags tags-recursive \
+ uninstall uninstall-am uninstall-dist_guilemoduleDATA \
+ uninstall-info-am
-distclean: clean
- /bin/rm -f Makefile
- /bin/rm -f ../common/configure.scm
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am
new file mode 100644
index 0000000..d518553
--- /dev/null
+++ b/src/guile/skribilo/coloring/Makefile.am
@@ -0,0 +1,2 @@
+guilemoduledir = $(GUILE_SITE)/skribilo
+dist_guilemodule_DATA = c.scm lisp.scm xml.scm
diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm
index 53cf670..ad02431 100644
--- a/src/guile/skribilo/coloring/lisp.scm
+++ b/src/guile/skribilo/coloring/lisp.scm
@@ -1,46 +1,46 @@
;;;;
-;;;; lisp.stk -- Lisp Family Fontification
-;;;;
+;;;; lisp.scm -- Lisp Family Fontification
+;;;;
;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
+;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;;
+;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
-;;;;
+;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
-;;;;
+;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 16-Oct-2003 22:17 (eg)
;;;; Last file update: 28-Oct-2004 21:14 (eg)
;;;;
-(require "lex-rt") ;; to avoid module problems
+(define-module (skribilo coloring lisp)
+ :use-module (skribilo source)
+ :use-module (skribilo lib)
+ :use-module (skribilo runtime)
+ :export (skribe scheme stklos bigloo lisp))
-(define-module (skribilo lisp)
- :export (skribe scheme stklos bigloo lisp)
- :import (skribe source))
-(include "lisp-lex.stk") ;; SILex generated
-
-(define *bracket-highlight* #f)
-(define *class-highlight* #f)
-(define *the-keys* #f)
+(define *bracket-highlight* (make-fluid))
+(define *class-highlight* (make-fluid))
+(define *the-keys* (make-fluid))
-(define *lisp-keys* #f)
-(define *scheme-keys* #f)
-(define *skribe-keys* #f)
-(define *stklos-keys* #f)
-(define *lisp-keys* #f)
+(define *lisp-keys* (make-fluid))
+(define *scheme-keys* (make-fluid))
+(define *skribe-keys* (make-fluid))
+(define *stklos-keys* (make-fluid))
+(define *lisp-keys* (make-fluid))
;;;
@@ -57,17 +57,17 @@
(define (lisp-family-fontifier s)
- (let ((lex (lisp-lex (open-input-string s))))
- (let Loop ((token (lexer-next-token lex))
+ (let ((lisp-input (open-input-string s)))
+ (let loop ((token (read lisp-input))
(res '()))
- (if (eq? token 'eof)
+ (if (eof-object? token)
(reverse! res)
- (Loop (lexer-next-token lex)
+ (loop (read lisp-input)
(cons token res))))))
;;;; ======================================================================
;;;;
-;;;; LISP
+;;;; LISP
;;;;
;;;; ======================================================================
(define (lisp-extractor iport def tab)
@@ -77,17 +77,17 @@
(lambda (exp)
(match-case exp
(((or defun defmacro) ?fun ?- . ?-)
- (and (eq? def fun) exp))
+ (and (eq? def fun) exp))
((defvar ?var . ?-)
- (and (eq? var def) exp))
+ (and (eq? var def) exp))
(else
- #f)))))
+ #f)))))
(define (init-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))
@@ -95,9 +95,9 @@
*lisp-keys*)
(define (lisp-fontifier s)
- (fluid-let ((*the-keys* (init-lisp-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
+ (with-fluids ((*the-keys* (init-lisp-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
(lisp-family-fontifier s)))
@@ -109,7 +109,7 @@
;;;; ======================================================================
;;;;
-;;;; SCHEME
+;;;; SCHEME
;;;;
;;;; ======================================================================
(define (scheme-extractor iport def tab)
@@ -130,7 +130,7 @@
(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))
@@ -139,11 +139,11 @@
(define (scheme-fontifier s)
- (fluid-let ((*the-keys* (init-scheme-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
+ (with-fluids ((*the-keys* (init-scheme-keys))
+ (*bracket-highlight* #f)
+ (*class-highlight* #f))
(lisp-family-fontifier s)))
-
+
(define scheme
(new language
@@ -153,7 +153,7 @@
;;;; ======================================================================
;;;;
-;;;; STKLOS
+;;;; STKLOS
;;;;
;;;; ======================================================================
(define (stklos-extractor iport def tab)
@@ -164,11 +164,11 @@
(match-case exp
(((or define define-generic define-method define-macro)
(?fun . ?-) . ?-)
- (and (eq? def fun) exp))
+ (and (eq? def fun) exp))
(((or define define-module) (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
+ (and (eq? var def) exp))
(else
- #f)))))
+ #f)))))
(define (init-stklos-keys)
@@ -192,9 +192,9 @@
(define (stklos-fontifier s)
- (fluid-let ((*the-keys* (init-stklos-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
+ (with-fluids ((*the-keys* (init-stklos-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
(lisp-family-fontifier s)))
@@ -206,7 +206,7 @@
;;;; ======================================================================
;;;;
-;;;; SKRIBE
+;;;; SKRIBE
;;;;
;;;; ======================================================================
(define (skribe-extractor iport def tab)
@@ -250,12 +250,12 @@
(map (lambda (x) (cons x '&source-define))
'(define-markup)))))
*skribe-keys*)
-
+
(define (skribe-fontifier s)
- (fluid-let ((*the-keys* (init-skribe-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
+ (with-fluids ((*the-keys* (init-skribe-keys))
+ (*bracket-highlight* #t)
+ (*class-highlight* #t))
(lisp-family-fontifier s)))
@@ -267,7 +267,7 @@
;;;; ======================================================================
;;;;
-;;;; BIGLOO
+;;;; BIGLOO
;;;;
;;;; ======================================================================
(define (bigloo-extractor iport def tab)
@@ -279,15 +279,14 @@
(((or define define-inline define-generic
define-method define-macro define-expander)
(?fun . ?-) . ?-)
- (and (eq? def fun) exp))
+ (and (eq? def fun) exp))
(((or define define-struct define-library) (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
+ (and (eq? var def) exp))
(else
- #f)))))
+ #f)))))
(define bigloo
(new language
(name "bigloo")
(fontifier scheme-fontifier)
(extractor bigloo-extractor)))
-
diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm
index d71e98c..e3db36f 100644
--- a/src/guile/skribilo/coloring/xml.scm
+++ b/src/guile/skribilo/coloring/xml.scm
@@ -1,53 +1,82 @@
-;;;;
-;;;; xml.stk -- XML Fontification stuff
-;;;;
-;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 16-Oct-2003 22:33 (eg)
-;;;; Last file update: 28-Dec-2003 17:33 (eg)
-;;;;
-
-
-;(require "lex-rt") ;; to avoid module problems
-
-
-(define-module (skribilo xml)
- :export (xml))
-
-(use-modules (skribilo source))
-
-(include "xml-lex.stk") ;; SILex generated
-
-(define (xml-fontifier s)
- (let ((lex (xml-lex (open-input-string s))))
- (let Loop ((token (lexer-next-token lex))
- (res '()))
- (if (eq? token 'eof)
- (reverse! res)
- (Loop (lexer-next-token lex)
- (cons token res))))))
+;;; 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/config.scm.in b/src/guile/skribilo/config.scm.in
index a5e3b7c..51e7a93 100644
--- a/src/guile/skribilo/config.scm.in
+++ b/src/guile/skribilo/config.scm.in
@@ -3,7 +3,7 @@
(define-module (skribilo config))
-(define-public (skribilo-release) "1.3")
+(define-public (skribilo-release) "1.2")
(define-public (skribilo-url) "http://www.laas.fr/~lcourtes/")
(define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@")
(define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@")
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/html.scm b/src/guile/skribilo/engine/html.scm
index 3ad7da6..6e0dc85 100644
--- a/src/guile/skribilo/engine/html.scm
+++ b/src/guile/skribilo/engine/html.scm
@@ -82,7 +82,7 @@
;*---------------------------------------------------------------------*/
;* html-engine ... */
;*---------------------------------------------------------------------*/
-(define html-engine
+(define-public html-engine
;; setup the html engine
(default-engine-set!
(make-engine 'html
diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm
index 8bd0ae3..2a59b4f 100644
--- a/src/guile/skribilo/engine/latex.scm
+++ b/src/guile/skribilo/engine/latex.scm
@@ -16,6 +16,8 @@
;* @ref ../../doc/user/latexe.skb:ref@ */
;*=====================================================================*/
+(define-skribe-module (skribilo engine latex))
+
;*---------------------------------------------------------------------*/
;* latex-verbatim-encoding ... */
;*---------------------------------------------------------------------*/
diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm
index b675e8a..36df9f9 100644
--- a/src/guile/skribilo/engine/lout.scm
+++ b/src/guile/skribilo/engine/lout.scm
@@ -384,10 +384,10 @@
" @PageMark @Tag\n"
"}\n\n"
- "# @SkribeLeaders is used in `toc'\n"
+ "# @SkribiloLeaders is used in `toc'\n"
"# (this is mostly copied from the expert's guide)\n"
- "def @SkribeLeaders { "
- ,leader " |" ,leader-space " @SkribeLeaders }\n\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.
@@ -397,7 +397,8 @@
(author (markup-option doc :author))
(date-line (engine-custom engine 'date-line))
(cover-sheet? (engine-custom engine 'cover-sheet?))
- (multi-column? (> 1 (engine-custom engine 'column-number))))
+ (multi-column? (> (engine-custom engine 'column-number) 1)))
+
(if multi-column?
;; In single-column document, `@FullWidth' yields a blank page.
(display "\n@FullWidth {"))
@@ -1205,7 +1206,7 @@
(entry-proc node engine)
(display " &1rt @OneCol { ")
- (printf " @SkribeLeaders & @PageOf { ~a }"
+ (printf " @SkribiloLeaders & @PageOf { ~a }"
(lout-tagify (markup-ident node)))
(display " &0io } }")
@@ -2876,93 +2877,93 @@
;*---------------------------------------------------------------------*/
;* Slides */
;* */
-;* At some point, this should move to `slide.skr'. */
-;*---------------------------------------------------------------------*/
-; (skribe-load "slide.skr")
-
-; (markup-writer 'slide
-; ;; FIXME: In `slide.skr', `:ident' is systematically generated.
-; :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
-; :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
-; ;; 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
-; :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))))))))
+;* At some point, we might want to move this to `slide.scm'. */
+;*---------------------------------------------------------------------*/
+
+(use-modules (skribilo packages slide))
+
+(markup-writer 'slide
+ :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
+ :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
+ ;; 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
+ :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))))))))
;*---------------------------------------------------------------------*/
;* Restore the base engine */
diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm
index 703186c..def3280 100644
--- a/src/guile/skribilo/evaluator.scm
+++ b/src/guile/skribilo/evaluator.scm
@@ -39,8 +39,11 @@
(skribilo types)
(skribilo lib)
(skribilo vars)
+
(ice-9 optargs)
- (oop goops))
+ (oop goops)
+ (srfi srfi-13)
+ (srfi srfi-1))
@@ -49,8 +52,21 @@
(define *skribe-loaded* '()) ;; List of already loaded files
(define *skribe-load-options* '())
+;;;
+;;; %EVALUATE
+;;;
(define (%evaluate expr)
- (eval expr (current-module)))
+ (let ((result (eval expr (current-module))))
+ (if (or (ast? result) (markup? result))
+ (let ((file (source-property expr 'filename))
+ (line (source-property expr 'line))
+ (column (source-property expr 'column)))
+ (format #t "~%~%*** source props for `~a': ~a~%~%"
+ result (source-properties expr))
+ (slot-set! result 'loc
+ (make <location>
+ :file file :line line :pos column))))
+ result))
@@ -74,6 +90,8 @@
(reader %default-reader))
(with-debug 2 'skribe-eval-port
(debug-item "engine=" engine)
+ (debug-item "reader=" reader)
+
(let ((e (if (symbol? engine) (find-engine engine) engine)))
(debug-item "e=" e)
(if (not (is-a? e <engine>))
@@ -104,22 +122,31 @@
((engine? engine) engine)
((not (symbol? engine))
(skribe-error 'skribe-load
- "Illegal engine" engine))
+ "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 (search-path path file)))
+ (path (append (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))
+ %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))))))
(set! *skribe-load-options* opt)
(unless (and (string? filep) (file-exists? filep))
(skribe-error 'skribe-load
(string-append "cannot find `" file "' in path")
- (skribe-path)))
+ path))
;; Load this file if not already done
(unless (member filep *skribe-loaded*)
@@ -139,22 +166,23 @@
;;;
(define* (skribe-include file #:optional (path (skribe-path)))
(unless (every string? path)
- (skribe-error 'skribe-include "Illegal path" path))
+ (skribe-error 'skribe-include "illegal path" path))
(let ((path (search-path path file)))
(unless (and (string? path) (file-exists? path))
(skribe-error 'skribe-load
- (format "Cannot find ~S in path" file)
+ (format #t "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)))
+ (let Loop ((exp (%default-reader (current-input-port)))
(res '()))
(if (eof-object? exp)
(if (and (pair? res) (null? (cdr res)))
- (car res)
- (reverse! res))
- (Loop (read (current-input-port))
+ (car res)
+ (reverse! res))
+ (Loop (%default-reader (current-input-port))
(cons (%evaluate exp) res))))))))
diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm
index 8667f7e..2961fc6 100644
--- a/src/guile/skribilo/lib.scm
+++ b/src/guile/skribilo/lib.scm
@@ -1,5 +1,5 @@
;;;
-;;; lib.stk -- Utilities
+;;; lib.scm -- Utilities
;;;
;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;
@@ -18,11 +18,6 @@
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
-;;;
-;;; Author: Erick Gallesio [eg@essi.fr]
-;;; Creation date: 11-Aug-2003 20:29 (eg)
-;;; Last file update: 27-Oct-2004 12:41 (eg)
-;;;
(read-set! keywords 'prefix)
@@ -59,7 +54,9 @@
hashtable->list
skribe-read
- find-runtime-type)
+ find-runtime-type
+
+ date)
:export-syntax (new define-markup define-simple-markup
define-simple-container define-processor-markup
@@ -73,6 +70,8 @@
:use-module (skribilo vars)
:use-module (srfi srfi-1)
+ :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) ;; date
+ :use-module (oop goops)
:use-module (ice-9 optargs))
@@ -81,11 +80,20 @@
;;;
;;; NEW
;;;
+
+(define %types-module (resolve-module '(skribilo types)))
+
(define-macro (new class . parameters)
- `(make ,(string->symbol (format #f "<~a>" class))
- ,@(apply append (map (lambda (x)
- `(,(symbol->keyword (car x)) ,(cadr x)))
- parameters))))
+ ;; Thanks to the trick below, modules don't need to import `(oop goops)'
+ ;; and `(skribilo types)' 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
@@ -99,12 +107,23 @@
(let loop ((args args)
(result '())
(rest-arg #f))
- (if (null? args)
- (if rest-arg (append (reverse result) rest-arg) (reverse result))
- (let ((is-rest-arg? (eq? (car args) #:rest)))
- (loop (if is-rest-arg? (cddr args) (cdr args))
- (if is-rest-arg? result (cons (car args) result))
- (if is-rest-arg? (list (car args) (cadr args)) rest-arg))))))
+ (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)))
@@ -376,3 +395,9 @@
(define-macro (when condition . exprs)
`(if ,condition (begin ,@exprs)))
+
+(define (date)
+ (s19:date->string (s19:current-date) "~c"))
+
+
+;;; lib.scm ends here
diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm
index 1a8f622..bb0c5ad 100644
--- a/src/guile/skribilo/module.scm
+++ b/src/guile/skribilo/module.scm
@@ -42,7 +42,6 @@
'((srfi srfi-1) ;; lists
(srfi srfi-13) ;; strings
;(srfi srfi-19) ;; date and time
- (oop goops) ;; `make'
(ice-9 optargs) ;; `define*'
(ice-9 and-let-star) ;; `and-let*'
(ice-9 receive) ;; `receive'
@@ -60,9 +59,13 @@
(skribilo output)
(skribilo evaluator)
(skribilo color)
- (skribilo debug)))
+ (skribilo debug)
+ (skribilo source) ;; `source-read-lines', `source-fontify', etc.
+ (skribilo coloring lisp) ;; `skribe', `scheme', `lisp'
+ (skribilo coloring xml) ;; `xml'
+ ))
-(define *skribe-core-modules*
+(define %skribe-core-modules
'("utils" "api" "bib" "index" "param" "sui"))
(define-macro (define-skribe-module name . options)
@@ -81,7 +84,7 @@
,(string->symbol
mod))))
(and (not (equal? m name)) m)))
- *skribe-core-modules*)))))
+ %skribe-core-modules)))))
;; Make it available to the top-level module.
@@ -106,7 +109,7 @@ execution of Skribilo/Skribe code."
(map (lambda (mod)
`(skribilo skribe
,(string->symbol mod)))
- *skribe-core-modules*)))
+ %skribe-core-modules)))
(set-module-name! the-module '(skribilo-user))
the-module))
@@ -152,7 +155,7 @@ hierarchy and in @code{(run-time-module)}."
(module-use! (run-time-module)
(resolve-module `(skribilo skribe
,(string->symbol mod)))))
- *skribe-core-modules*))
+ %skribe-core-modules))
;;; module.scm ends here
diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am
new file mode 100644
index 0000000..6e047d3
--- /dev/null
+++ b/src/guile/skribilo/package/Makefile.am
@@ -0,0 +1,4 @@
+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
diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm
new file mode 100644
index 0000000..4accc7c
--- /dev/null
+++ b/src/guile/skribilo/package/acmproc.scm
@@ -0,0 +1,155 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/acmproc.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Sep 28 14:40:38 2003 */
+;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */
+;* Copyright : 2003-05 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe style for ACMPROC articles. */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* 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/bigloo/new.sch b/src/guile/skribilo/package/french.scm
index 16bb7d5..bd095db 100644
--- a/src/bigloo/new.sch
+++ b/src/guile/skribilo/package/french.scm
@@ -1,17 +1,21 @@
;*=====================================================================*/
-;* serrano/prgm/project/skribe/src/bigloo/new.sch */
+;* serrano/prgm/project/skribe/skr/letter.skr */
;* ------------------------------------------------------------- */
;* Author : Manuel Serrano */
-;* Creation : Sun Aug 17 11:58:30 2003 */
-;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */
+;* Creation : Fri Oct 3 12:22:13 2003 */
+;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */
;* Copyright : 2003 Manuel Serrano */
;* ------------------------------------------------------------- */
-;* The new facility */
+;* French Skribe style */
;*=====================================================================*/
+(define-skribe-module (skribilo package french))
+
;*---------------------------------------------------------------------*/
-;* new ... */
+;* LaTeX configuration */
;*---------------------------------------------------------------------*/
-(define-macro (new id . inits)
- `(,(symbol-append 'instantiate::% id) ,@inits))
-
+(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..108b938
--- /dev/null
+++ b/src/guile/skribilo/package/jfp.scm
@@ -0,0 +1,319 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/jfp.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Sep 28 14:40:38 2003 */
+;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe style for JFP articles. */
+;*=====================================================================*/
+
+(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..1c39301
--- /dev/null
+++ b/src/guile/skribilo/package/letter.scm
@@ -0,0 +1,148 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/letter.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Fri Oct 3 12:22:13 2003 */
+;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Skribe style for letters */
+;*=====================================================================*/
+
+(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..2f027d0
--- /dev/null
+++ b/src/guile/skribilo/package/lncs.scm
@@ -0,0 +1,149 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/lncs.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Sep 28 14:40:38 2003 */
+;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe style for LNCS articles. */
+;*=====================================================================*/
+
+(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/scribe.scm b/src/guile/skribilo/package/scribe.scm
new file mode 100644
index 0000000..8e99c76
--- /dev/null
+++ b/src/guile/skribilo/package/scribe.scm
@@ -0,0 +1,231 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/scribe.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Tue Jul 29 10:07:21 2003 */
+;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */
+;* Copyright : 2003 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Scribe Compatibility kit */
+;*=====================================================================*/
+
+(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..b5269dc
--- /dev/null
+++ b/src/guile/skribilo/package/sigplan.scm
@@ -0,0 +1,157 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/sigplan.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Sep 28 14:40:38 2003 */
+;* Last change : Wed May 18 16:00:38 2005 (serrano) */
+;* Copyright : 2003-05 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe style for ACMPROC articles. */
+;*=====================================================================*/
+
+(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..86425ac
--- /dev/null
+++ b/src/guile/skribilo/package/skribe.scm
@@ -0,0 +1,76 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/skribe.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Fri Jan 11 11:23:12 2002 */
+;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */
+;* Copyright : 2002-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The standard Skribe style (always loaded). */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* 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..37ee054
--- /dev/null
+++ b/src/guile/skribilo/package/slide.scm
@@ -0,0 +1,667 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/slide.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Fri Oct 3 12:22:13 2003 */
+;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Skribe style for slides */
+;*=====================================================================*/
+
+(define-skribe-module (skribilo package slide))
+
+;*---------------------------------------------------------------------*/
+;* slide-options */
+;*---------------------------------------------------------------------*/
+(define &slide-load-options (skribe-load-options))
+
+;*---------------------------------------------------------------------*/
+;* &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")
+
+;*---------------------------------------------------------------------*/
+;* %slide-the-slides ... */
+;*---------------------------------------------------------------------*/
+(define %slide-the-slides '())
+(define %slide-the-counter 0)
+(define %slide-initialized #f)
+(define %slide-latex-mode 'seminar)
+
+;*---------------------------------------------------------------------*/
+;* %slide-initialize! ... */
+;*---------------------------------------------------------------------*/
+(define (%slide-initialize!)
+ (unless %slide-initialized
+ (set! %slide-initialized #t)
+ (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 ... */
+;*---------------------------------------------------------------------*/
+(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))
+ (%slide-initialize!)
+ (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)
+
+(define-markup (ref #!rest opt #!key (slide #f))
+ (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))))
+
+;*---------------------------------------------------------------------*/
+;* base */
+;*---------------------------------------------------------------------*/
+(let ((be (find-engine 'base)))
+ (skribe-message "Base slides setup...\n")
+ ;; 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))))
+
+;*---------------------------------------------------------------------*/
+;* 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-number ... */
+;*---------------------------------------------------------------------*/
+(define (slide-number)
+ (length (filter (lambda (n)
+ (and (is-markup? n 'slide)
+ (markup-option n :number)))
+ %slide-the-slides)))
+
+;*---------------------------------------------------------------------*/
+;* html */
+;*---------------------------------------------------------------------*/
+(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 "~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>"))))
+
+;*---------------------------------------------------------------------*/
+;* 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)
+
+(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 "~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)))))
diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm
new file mode 100644
index 0000000..6a480be
--- /dev/null
+++ b/src/guile/skribilo/package/web-article.scm
@@ -0,0 +1,232 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/web-article.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sat Jan 10 09:09:43 2004 */
+;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */
+;* Copyright : 2004 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* A Skribe style for producing web articles */
+;*=====================================================================*/
+
+(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..a954c7a
--- /dev/null
+++ b/src/guile/skribilo/package/web-book.scm
@@ -0,0 +1,109 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/skr/web-book.skr */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Mon Sep 1 10:54:32 2003 */
+;* Last change : Mon Nov 8 10:43:46 2004 (eg) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The Skribe web book style. */
+;*=====================================================================*/
+
+(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 (color :fg (engine-custom e 'background)
+ (bold "main page"))))
+ (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 (color :fg (engine-custom e 'background)
+ (bold (markup-option n :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 (color :fg (engine-custom e 'background)
+ (bold (if chap "Chapters" "Sections")))))
+ (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/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am
new file mode 100644
index 0000000..a1c58fb
--- /dev/null
+++ b/src/guile/skribilo/reader/Makefile.am
@@ -0,0 +1,2 @@
+guilemoduledir = $(GUILE_SITE)/skribilo/reader
+dist_guilemodule_DATA = skribe.scm
diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm
index 673a166..714f19e 100644
--- a/src/guile/skribilo/reader/skribe.scm
+++ b/src/guile/skribilo/reader/skribe.scm
@@ -22,7 +22,7 @@
:use-module (skribilo reader)
:use-module (ice-9 optargs)
- ;; the Scheme reader composition framework
+ ;; the Scheme reader composition framework
:use-module ((system reader) #:renamer (symbol-prefix-proc 'r:))
:export (reader-specification
@@ -54,19 +54,39 @@ the Skribe syntax."
(sharp-reader (r:make-reader (cons dsssl-keyword-reader
(map r:standard-token-reader
'(character srfi-4
+ vector
number+radix
- boolean))))))
- (r:make-reader (cons (r:make-token-reader #\# sharp-reader)
- (map r:standard-token-reader
- `(whitespace
- sexp string number
- symbol-lower-case
- symbol-upper-case
- symbol-misc-chars
- quote-quasiquote-unquote
- semicolon-comment
- keyword ;; keywords à la `:key'
- skribe-exp))))))
+ boolean)))
+ #f ;; use default fault handler
+ 'reader/record-positions))
+ (colon-keywords ;; keywords à la `:key' fashion
+ (r:make-token-reader #\:
+ (r:token-reader-procedure
+ (r:standard-token-reader 'keyword))))
+ (square-bracket-free-symbol-misc-chars
+ (let* ((tr (r:standard-token-reader 'guile-symbol-misc-chars))
+ (tr-spec (r:token-reader-specification tr))
+ (tr-proc (r:token-reader-procedure tr)))
+ (r:make-token-reader (filter (lambda (chr)
+ (not (or (eq? chr #\[)
+ (eq? chr #\]))))
+ tr-spec)
+ tr-proc))))
+
+ (r:make-reader (cons* (r:make-token-reader #\# sharp-reader)
+ colon-keywords
+ square-bracket-free-symbol-misc-chars
+ (map r:standard-token-reader
+ `(whitespace
+ sexp string guile-number
+ guile-symbol-lower-case
+ guile-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))
diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm
index 14f36b2..a39bb77 100644
--- a/src/guile/skribilo/resolve.scm
+++ b/src/guile/skribilo/resolve.scm
@@ -178,7 +178,7 @@
(cadr c)
n)))
((eq? (slot-ref n 'parent) 'unspecified)
- (skribe-error 'resolve-parent "Orphan node" n))
+ (skribe-error 'resolve-parent "orphan node" n))
(else
(slot-ref n 'parent)))))
@@ -211,7 +211,7 @@
(let ((c (assq (symbol-append cnt '-counter) e)))
(if (not (pair? c))
(if (or (null? opt) (not (car opt)) (null? e))
- (skribe-error cnt "Orphan node" n)
+ (skribe-error cnt "orphan node" n)
(begin
(set-cdr! (last-pair e)
(list (list (symbol-append cnt '-counter) 0)
diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am
new file mode 100644
index 0000000..2850c4d
--- /dev/null
+++ b/src/guile/skribilo/skribe/Makefile.am
@@ -0,0 +1,2 @@
+guilemoduledir = $(GUILE_SITE)/skribilo
+dist_guilemodule_DATA = api.scm bib.scm index.scm param.scm sui.scm utils.scm
diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm
index d66b3b4..34528ac 100644
--- a/src/guile/skribilo/skribe/api.scm
+++ b/src/guile/skribilo/skribe/api.scm
@@ -274,8 +274,8 @@
(new unresolved
(proc (lambda (n e env)
(resolve-counter n env
- 'footnote #t)))))
- ,@(the-options opts :ident :class)))))
+ 'footnote #t))))))
+ ,@(the-options opts :ident :class))))
(body (the-body opts))))
;*---------------------------------------------------------------------*/
@@ -466,9 +466,9 @@
"start line > stop line"
(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)
@@ -489,7 +489,7 @@
;*---------------------------------------------------------------------*/
(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)
diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm
index 840a179..415cadf 100644
--- a/src/guile/skribilo/skribe/index.scm
+++ b/src/guile/skribilo/skribe/index.scm
@@ -36,24 +36,24 @@
;*---------------------------------------------------------------------*/
;* index? ... */
;*---------------------------------------------------------------------*/
-(define (index? obj)
+(define-public (index? obj)
(hashtable? obj))
;*---------------------------------------------------------------------*/
;* *index-table* ... */
;*---------------------------------------------------------------------*/
-(define *index-table* #f)
+(define-public *index-table* #f)
;*---------------------------------------------------------------------*/
;* make-index-table ... */
;*---------------------------------------------------------------------*/
-(define (make-index-table ident)
+(define-public (make-index-table ident)
(make-hashtable))
;*---------------------------------------------------------------------*/
;* default-index ... */
;*---------------------------------------------------------------------*/
-(define (default-index)
+(define-public (default-index)
(if (not *index-table*)
(set! *index-table* (make-index-table "default-index")))
*index-table*)
@@ -61,7 +61,7 @@
;*---------------------------------------------------------------------*/
;* resolve-the-index ... */
;*---------------------------------------------------------------------*/
-(define (resolve-the-index loc i c indexes split char-offset header-limit col)
+(define-public (resolve-the-index loc i c indexes split char-offset header-limit col)
;; fetch the descriminating index name letter
(define (index-ref n)
(let ((name (markup-option n 'name)))
@@ -70,7 +70,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)))))
diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm
index 8daca62..6aebd0a 100644
--- a/src/guile/skribilo/skribe/param.scm
+++ b/src/guile/skribilo/skribe/param.scm
@@ -44,15 +44,16 @@
;* *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)))
+ ;; Note: In Skribilo, this list is completely useless.
+ '(("html" . html)
+ ("sui" . sui)
+ ("tex" . latex)
+ ("ctex" . context)
+ ("xml" . xml)
+ ("info" . info)
+ ("txt" . ascii)
+ ("mgp" . mgp)
+ ("man" . man)))
;*---------------------------------------------------------------------*/
;* *skribe-auto-load-alist* ... */
diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm
index c682687..e03deae 100644
--- a/src/guile/skribilo/source.scm
+++ b/src/guile/skribilo/source.scm
@@ -1,7 +1,8 @@
;;;;
-;;;; source.stk -- Skibe SOURCE implementation stuff
+;;;; source.scm -- Highlighting source files.
;;;;
;;;; 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
@@ -19,24 +20,16 @@
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 3-Sep-2003 12:22 (eg)
-;;;; Last file update: 27-Oct-2004 20:09 (eg)
-;;;;
(define-module (skribilo source)
:export (source-read-lines source-read-definition source-fontify)
- :use-module (skribilo vars))
-
-
-;; Temporary solution
-(define (language-extractor lang)
- (slot-ref lang 'extractor))
+ :use-module (skribilo types)
+ :use-module (skribilo vars)
+ :use-module (skribilo lib)
+ :use-module (ice-9 rdelim))
-(define (language-fontifier lang)
- (slot-ref lang 'fontifier))
;*---------------------------------------------------------------------*/
@@ -172,7 +165,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)
@@ -180,7 +173,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)
diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm
index 4b3729c..ac1edc4 100644
--- a/src/guile/skribilo/types.scm
+++ b/src/guile/skribilo/types.scm
@@ -43,7 +43,7 @@
container-ident container-body
<document> document? document-ident document-body
document-options document-end
- <language> language?
+ <language> language? language-extractor language-fontifier
<location> location? ast-location
location-file location-line location-pos
@@ -66,14 +66,6 @@
(parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified)
(loc :init-value #f))
-(define-method (initialize (ast <ast>) . args)
- (next-method)
- (let ((file (port-filename (current-input-port)))
- (line (port-line (current-input-port)))
- (column (port-column (current-input-port))))
- (slot-set! ast 'loc
- (make <location>
- :file file :line line :pos (* line column)))))
(define (ast? obj) (is-a? obj <ast>))
(define (ast-loc obj) (slot-ref obj 'loc))
@@ -291,8 +283,8 @@
;;; ======================================================================
(define-class <language> ()
(name :init-keyword :name :init-value #f :getter langage-name)
- (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier)
- (extractor :init-keyword :extractor :init-value #f :getter langage-extractor))
+ (fontifier :init-keyword :fontifier :init-value #f :getter language-fontifier)
+ (extractor :init-keyword :extractor :init-value #f :getter language-extractor))
(define (language? obj)
(is-a? obj <language>))
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/c-lex.l b/src/stklos/c-lex.l
deleted file mode 100644
index a5b337e..0000000
--- a/src/stklos/c-lex.l
+++ /dev/null
@@ -1,67 +0,0 @@
-;;;;
-;;;; c-lex.l -- C fontifier for Skribe
-;;;;
-;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 6-Mar-2004 15:35 (eg)
-;;;; Last file update: 7-Mar-2004 00:10 (eg)
-;;;;
-
-space [ \n\9]
-letter [_a-zA-Z]
-alphanum [_a-zA-Z0-9]
-
-%%
-
-;; Strings
-\"[^\"]*\" (new markup
- (markup '&source-string)
- (body yytext))
-;;Comments
-/\*.*\*/ (new markup
- (markup '&source-line-comment)
- (body yytext))
-//.* (new markup
- (markup '&source-line-comment)
- (body yytext))
-
-;; Identifiers (only letters since we are interested in keywords only)
-[_a-zA-Z]+ (let* ((ident (string->symbol yytext))
- (tmp (memq ident *the-keys*)))
- (if tmp
- (new markup
- (markup '&source-module)
- (body yytext))
- yytext))
-
-;; Regular text
-[^\"a-zA-Z]+ (begin yytext)
-
-
-
-<<EOF>> 'eof
-<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
-
-
-
-
-
-
- \ No newline at end of file
diff --git a/src/stklos/c.stk b/src/stklos/c.stk
deleted file mode 100644
index 265c421..0000000
--- a/src/stklos/c.stk
+++ /dev/null
@@ -1,95 +0,0 @@
-;;;;
-;;;; c.stk -- C fontifier for Skribe
-;;;;
-;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 6-Mar-2004 15:35 (eg)
-;;;; Last file update: 7-Mar-2004 00:12 (eg)
-;;;;
-
-(require "lex-rt") ;; to avoid module problems
-
-(define-module SKRIBE-C-MODULE
- (export c java)
- (import SKRIBE-SOURCE-MODULE)
-
-(include "c-lex.stk") ;; SILex generated
-
-
-(define *the-keys* #f)
-
-(define *c-keys* #f)
-(define *java-keys* #f)
-
-
-(define (fontifier s)
- (let ((lex (c-lex (open-input-string s))))
- (let Loop ((token (lexer-next-token lex))
- (res '()))
- (if (eq? token 'eof)
- (reverse! res)
- (Loop (lexer-next-token lex)
- (cons token res))))))
-
-;;;; ======================================================================
-;;;;
-;;;; C
-;;;;
-;;;; ======================================================================
-(define (init-c-keys)
- (unless *c-keys*
- (set! *c-keys* '(for while return break continue void
- do if else typedef struct union goto switch case
- static extern default)))
- *c-keys*)
-
-(define (c-fontifier s)
- (fluid-let ((*the-keys* (init-c-keys)))
- (fontifier s)))
-
-(define c
- (new language
- (name "C")
- (fontifier c-fontifier)
- (extractor #f)))
-
-;;;; ======================================================================
-;;;;
-;;;; JAVA
-;;;;
-;;;; ======================================================================
-(define (init-java-keys)
- (unless *java-keys*
- (set! *java-keys* (append (init-c-keys)
- '(public final class throw catch))))
- *java-keys*)
-
-(define (java-fontifier s)
- (fluid-let ((*the-keys* (init-java-keys)))
- (fontifier s)))
-
-(define java
- (new language
- (name "java")
- (fontifier java-fontifier)
- (extractor #f)))
-
-)
-
diff --git a/src/stklos/color.stk b/src/stklos/color.stk
deleted file mode 100644
index 0cb829f..0000000
--- a/src/stklos/color.stk
+++ /dev/null
@@ -1,622 +0,0 @@
-;;;;
-;;;; 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)
-;;;;
-
-(define-module SKRIBE-COLOR-MODULE
- (export skribe-color->rgb skribe-get-used-colors skribe-use-color!)
-
-(define *used-colors* '())
-
-(define *skribe-rgb-alist* '(
- ("snow" . "255 250 250")
- ("ghostwhite" . "248 248 255")
- ("whitesmoke" . "245 245 245")
- ("gainsboro" . "220 220 220")
- ("floralwhite" . "255 250 240")
- ("oldlace" . "253 245 230")
- ("linen" . "250 240 230")
- ("antiquewhite" . "250 235 215")
- ("papayawhip" . "255 239 213")
- ("blanchedalmond" . "255 235 205")
- ("bisque" . "255 228 196")
- ("peachpuff" . "255 218 185")
- ("navajowhite" . "255 222 173")
- ("moccasin" . "255 228 181")
- ("cornsilk" . "255 248 220")
- ("ivory" . "255 255 240")
- ("lemonchiffon" . "255 250 205")
- ("seashell" . "255 245 238")
- ("honeydew" . "240 255 240")
- ("mintcream" . "245 255 250")
- ("azure" . "240 255 255")
- ("aliceblue" . "240 248 255")
- ("lavender" . "230 230 250")
- ("lavenderblush" . "255 240 245")
- ("mistyrose" . "255 228 225")
- ("white" . "255 255 255")
- ("black" . "0 0 0")
- ("darkslategrey" . "47 79 79")
- ("dimgrey" . "105 105 105")
- ("slategrey" . "112 128 144")
- ("lightslategrey" . "119 136 153")
- ("grey" . "190 190 190")
- ("lightgrey" . "211 211 211")
- ("midnightblue" . "25 25 112")
- ("navy" . "0 0 128")
- ("navyblue" . "0 0 128")
- ("cornflowerblue" . "100 149 237")
- ("darkslateblue" . "72 61 139")
- ("slateblue" . "106 90 205")
- ("mediumslateblue" . "123 104 238")
- ("lightslateblue" . "132 112 255")
- ("mediumblue" . "0 0 205")
- ("royalblue" . "65 105 225")
- ("blue" . "0 0 255")
- ("dodgerblue" . "30 144 255")
- ("deepskyblue" . "0 191 255")
- ("skyblue" . "135 206 235")
- ("lightskyblue" . "135 206 250")
- ("steelblue" . "70 130 180")
- ("lightsteelblue" . "176 196 222")
- ("lightblue" . "173 216 230")
- ("powderblue" . "176 224 230")
- ("paleturquoise" . "175 238 238")
- ("darkturquoise" . "0 206 209")
- ("mediumturquoise" . "72 209 204")
- ("turquoise" . "64 224 208")
- ("cyan" . "0 255 255")
- ("lightcyan" . "224 255 255")
- ("cadetblue" . "95 158 160")
- ("mediumaquamarine" . "102 205 170")
- ("aquamarine" . "127 255 212")
- ("darkgreen" . "0 100 0")
- ("darkolivegreen" . "85 107 47")
- ("darkseagreen" . "143 188 143")
- ("seagreen" . "46 139 87")
- ("mediumseagreen" . "60 179 113")
- ("lightseagreen" . "32 178 170")
- ("palegreen" . "152 251 152")
- ("springgreen" . "0 255 127")
- ("lawngreen" . "124 252 0")
- ("green" . "0 255 0")
- ("chartreuse" . "127 255 0")
- ("mediumspringgreen" . "0 250 154")
- ("greenyellow" . "173 255 47")
- ("limegreen" . "50 205 50")
- ("yellowgreen" . "154 205 50")
- ("forestgreen" . "34 139 34")
- ("olivedrab" . "107 142 35")
- ("darkkhaki" . "189 183 107")
- ("khaki" . "240 230 140")
- ("palegoldenrod" . "238 232 170")
- ("lightgoldenrodyellow" . "250 250 210")
- ("lightyellow" . "255 255 224")
- ("yellow" . "255 255 0")
- ("gold" . "255 215 0")
- ("lightgoldenrod" . "238 221 130")
- ("goldenrod" . "218 165 32")
- ("darkgoldenrod" . "184 134 11")
- ("rosybrown" . "188 143 143")
- ("indianred" . "205 92 92")
- ("saddlebrown" . "139 69 19")
- ("sienna" . "160 82 45")
- ("peru" . "205 133 63")
- ("burlywood" . "222 184 135")
- ("beige" . "245 245 220")
- ("wheat" . "245 222 179")
- ("sandybrown" . "244 164 96")
- ("tan" . "210 180 140")
- ("chocolate" . "210 105 30")
- ("firebrick" . "178 34 34")
- ("brown" . "165 42 42")
- ("darksalmon" . "233 150 122")
- ("salmon" . "250 128 114")
- ("lightsalmon" . "255 160 122")
- ("orange" . "255 165 0")
- ("darkorange" . "255 140 0")
- ("coral" . "255 127 80")
- ("lightcoral" . "240 128 128")
- ("tomato" . "255 99 71")
- ("orangered" . "255 69 0")
- ("red" . "255 0 0")
- ("hotpink" . "255 105 180")
- ("deeppink" . "255 20 147")
- ("pink" . "255 192 203")
- ("lightpink" . "255 182 193")
- ("palevioletred" . "219 112 147")
- ("maroon" . "176 48 96")
- ("mediumvioletred" . "199 21 133")
- ("violetred" . "208 32 144")
- ("magenta" . "255 0 255")
- ("violet" . "238 130 238")
- ("plum" . "221 160 221")
- ("orchid" . "218 112 214")
- ("mediumorchid" . "186 85 211")
- ("darkorchid" . "153 50 204")
- ("darkviolet" . "148 0 211")
- ("blueviolet" . "138 43 226")
- ("purple" . "160 32 240")
- ("mediumpurple" . "147 112 219")
- ("thistle" . "216 191 216")
- ("snow1" . "255 250 250")
- ("snow2" . "238 233 233")
- ("snow3" . "205 201 201")
- ("snow4" . "139 137 137")
- ("seashell1" . "255 245 238")
- ("seashell2" . "238 229 222")
- ("seashell3" . "205 197 191")
- ("seashell4" . "139 134 130")
- ("antiquewhite1" . "255 239 219")
- ("antiquewhite2" . "238 223 204")
- ("antiquewhite3" . "205 192 176")
- ("antiquewhite4" . "139 131 120")
- ("bisque1" . "255 228 196")
- ("bisque2" . "238 213 183")
- ("bisque3" . "205 183 158")
- ("bisque4" . "139 125 107")
- ("peachpuff1" . "255 218 185")
- ("peachpuff2" . "238 203 173")
- ("peachpuff3" . "205 175 149")
- ("peachpuff4" . "139 119 101")
- ("navajowhite1" . "255 222 173")
- ("navajowhite2" . "238 207 161")
- ("navajowhite3" . "205 179 139")
- ("navajowhite4" . "139 121 94")
- ("lemonchiffon1" . "255 250 205")
- ("lemonchiffon2" . "238 233 191")
- ("lemonchiffon3" . "205 201 165")
- ("lemonchiffon4" . "139 137 112")
- ("cornsilk1" . "255 248 220")
- ("cornsilk2" . "238 232 205")
- ("cornsilk3" . "205 200 177")
- ("cornsilk4" . "139 136 120")
- ("ivory1" . "255 255 240")
- ("ivory2" . "238 238 224")
- ("ivory3" . "205 205 193")
- ("ivory4" . "139 139 131")
- ("honeydew1" . "240 255 240")
- ("honeydew2" . "224 238 224")
- ("honeydew3" . "193 205 193")
- ("honeydew4" . "131 139 131")
- ("lavenderblush1" . "255 240 245")
- ("lavenderblush2" . "238 224 229")
- ("lavenderblush3" . "205 193 197")
- ("lavenderblush4" . "139 131 134")
- ("mistyrose1" . "255 228 225")
- ("mistyrose2" . "238 213 210")
- ("mistyrose3" . "205 183 181")
- ("mistyrose4" . "139 125 123")
- ("azure1" . "240 255 255")
- ("azure2" . "224 238 238")
- ("azure3" . "193 205 205")
- ("azure4" . "131 139 139")
- ("slateblue1" . "131 111 255")
- ("slateblue2" . "122 103 238")
- ("slateblue3" . "105 89 205")
- ("slateblue4" . "71 60 139")
- ("royalblue1" . "72 118 255")
- ("royalblue2" . "67 110 238")
- ("royalblue3" . "58 95 205")
- ("royalblue4" . "39 64 139")
- ("blue1" . "0 0 255")
- ("blue2" . "0 0 238")
- ("blue3" . "0 0 205")
- ("blue4" . "0 0 139")
- ("dodgerblue1" . "30 144 255")
- ("dodgerblue2" . "28 134 238")
- ("dodgerblue3" . "24 116 205")
- ("dodgerblue4" . "16 78 139")
- ("steelblue1" . "99 184 255")
- ("steelblue2" . "92 172 238")
- ("steelblue3" . "79 148 205")
- ("steelblue4" . "54 100 139")
- ("deepskyblue1" . "0 191 255")
- ("deepskyblue2" . "0 178 238")
- ("deepskyblue3" . "0 154 205")
- ("deepskyblue4" . "0 104 139")
- ("skyblue1" . "135 206 255")
- ("skyblue2" . "126 192 238")
- ("skyblue3" . "108 166 205")
- ("skyblue4" . "74 112 139")
- ("lightskyblue1" . "176 226 255")
- ("lightskyblue2" . "164 211 238")
- ("lightskyblue3" . "141 182 205")
- ("lightskyblue4" . "96 123 139")
- ("lightsteelblue1" . "202 225 255")
- ("lightsteelblue2" . "188 210 238")
- ("lightsteelblue3" . "162 181 205")
- ("lightsteelblue4" . "110 123 139")
- ("lightblue1" . "191 239 255")
- ("lightblue2" . "178 223 238")
- ("lightblue3" . "154 192 205")
- ("lightblue4" . "104 131 139")
- ("lightcyan1" . "224 255 255")
- ("lightcyan2" . "209 238 238")
- ("lightcyan3" . "180 205 205")
- ("lightcyan4" . "122 139 139")
- ("paleturquoise1" . "187 255 255")
- ("paleturquoise2" . "174 238 238")
- ("paleturquoise3" . "150 205 205")
- ("paleturquoise4" . "102 139 139")
- ("cadetblue1" . "152 245 255")
- ("cadetblue2" . "142 229 238")
- ("cadetblue3" . "122 197 205")
- ("cadetblue4" . "83 134 139")
- ("turquoise1" . "0 245 255")
- ("turquoise2" . "0 229 238")
- ("turquoise3" . "0 197 205")
- ("turquoise4" . "0 134 139")
- ("cyan1" . "0 255 255")
- ("cyan2" . "0 238 238")
- ("cyan3" . "0 205 205")
- ("cyan4" . "0 139 139")
- ("aquamarine1" . "127 255 212")
- ("aquamarine2" . "118 238 198")
- ("aquamarine3" . "102 205 170")
- ("aquamarine4" . "69 139 116")
- ("darkseagreen1" . "193 255 193")
- ("darkseagreen2" . "180 238 180")
- ("darkseagreen3" . "155 205 155")
- ("darkseagreen4" . "105 139 105")
- ("seagreen1" . "84 255 159")
- ("seagreen2" . "78 238 148")
- ("seagreen3" . "67 205 128")
- ("seagreen4" . "46 139 87")
- ("palegreen1" . "154 255 154")
- ("palegreen2" . "144 238 144")
- ("palegreen3" . "124 205 124")
- ("palegreen4" . "84 139 84")
- ("springgreen1" . "0 255 127")
- ("springgreen2" . "0 238 118")
- ("springgreen3" . "0 205 102")
- ("springgreen4" . "0 139 69")
- ("green1" . "0 255 0")
- ("green2" . "0 238 0")
- ("green3" . "0 205 0")
- ("green4" . "0 139 0")
- ("chartreuse1" . "127 255 0")
- ("chartreuse2" . "118 238 0")
- ("chartreuse3" . "102 205 0")
- ("chartreuse4" . "69 139 0")
- ("olivedrab1" . "192 255 62")
- ("olivedrab2" . "179 238 58")
- ("olivedrab3" . "154 205 50")
- ("olivedrab4" . "105 139 34")
- ("darkolivegreen1" . "202 255 112")
- ("darkolivegreen2" . "188 238 104")
- ("darkolivegreen3" . "162 205 90")
- ("darkolivegreen4" . "110 139 61")
- ("khaki1" . "255 246 143")
- ("khaki2" . "238 230 133")
- ("khaki3" . "205 198 115")
- ("khaki4" . "139 134 78")
- ("lightgoldenrod1" . "255 236 139")
- ("lightgoldenrod2" . "238 220 130")
- ("lightgoldenrod3" . "205 190 112")
- ("lightgoldenrod4" . "139 129 76")
- ("lightyellow1" . "255 255 224")
- ("lightyellow2" . "238 238 209")
- ("lightyellow3" . "205 205 180")
- ("lightyellow4" . "139 139 122")
- ("yellow1" . "255 255 0")
- ("yellow2" . "238 238 0")
- ("yellow3" . "205 205 0")
- ("yellow4" . "139 139 0")
- ("gold1" . "255 215 0")
- ("gold2" . "238 201 0")
- ("gold3" . "205 173 0")
- ("gold4" . "139 117 0")
- ("goldenrod1" . "255 193 37")
- ("goldenrod2" . "238 180 34")
- ("goldenrod3" . "205 155 29")
- ("goldenrod4" . "139 105 20")
- ("darkgoldenrod1" . "255 185 15")
- ("darkgoldenrod2" . "238 173 14")
- ("darkgoldenrod3" . "205 149 12")
- ("darkgoldenrod4" . "139 101 8")
- ("rosybrown1" . "255 193 193")
- ("rosybrown2" . "238 180 180")
- ("rosybrown3" . "205 155 155")
- ("rosybrown4" . "139 105 105")
- ("indianred1" . "255 106 106")
- ("indianred2" . "238 99 99")
- ("indianred3" . "205 85 85")
- ("indianred4" . "139 58 58")
- ("sienna1" . "255 130 71")
- ("sienna2" . "238 121 66")
- ("sienna3" . "205 104 57")
- ("sienna4" . "139 71 38")
- ("burlywood1" . "255 211 155")
- ("burlywood2" . "238 197 145")
- ("burlywood3" . "205 170 125")
- ("burlywood4" . "139 115 85")
- ("wheat1" . "255 231 186")
- ("wheat2" . "238 216 174")
- ("wheat3" . "205 186 150")
- ("wheat4" . "139 126 102")
- ("tan1" . "255 165 79")
- ("tan2" . "238 154 73")
- ("tan3" . "205 133 63")
- ("tan4" . "139 90 43")
- ("chocolate1" . "255 127 36")
- ("chocolate2" . "238 118 33")
- ("chocolate3" . "205 102 29")
- ("chocolate4" . "139 69 19")
- ("firebrick1" . "255 48 48")
- ("firebrick2" . "238 44 44")
- ("firebrick3" . "205 38 38")
- ("firebrick4" . "139 26 26")
- ("brown1" . "255 64 64")
- ("brown2" . "238 59 59")
- ("brown3" . "205 51 51")
- ("brown4" . "139 35 35")
- ("salmon1" . "255 140 105")
- ("salmon2" . "238 130 98")
- ("salmon3" . "205 112 84")
- ("salmon4" . "139 76 57")
- ("lightsalmon1" . "255 160 122")
- ("lightsalmon2" . "238 149 114")
- ("lightsalmon3" . "205 129 98")
- ("lightsalmon4" . "139 87 66")
- ("orange1" . "255 165 0")
- ("orange2" . "238 154 0")
- ("orange3" . "205 133 0")
- ("orange4" . "139 90 0")
- ("darkorange1" . "255 127 0")
- ("darkorange2" . "238 118 0")
- ("darkorange3" . "205 102 0")
- ("darkorange4" . "139 69 0")
- ("coral1" . "255 114 86")
- ("coral2" . "238 106 80")
- ("coral3" . "205 91 69")
- ("coral4" . "139 62 47")
- ("tomato1" . "255 99 71")
- ("tomato2" . "238 92 66")
- ("tomato3" . "205 79 57")
- ("tomato4" . "139 54 38")
- ("orangered1" . "255 69 0")
- ("orangered2" . "238 64 0")
- ("orangered3" . "205 55 0")
- ("orangered4" . "139 37 0")
- ("red1" . "255 0 0")
- ("red2" . "238 0 0")
- ("red3" . "205 0 0")
- ("red4" . "139 0 0")
- ("deeppink1" . "255 20 147")
- ("deeppink2" . "238 18 137")
- ("deeppink3" . "205 16 118")
- ("deeppink4" . "139 10 80")
- ("hotpink1" . "255 110 180")
- ("hotpink2" . "238 106 167")
- ("hotpink3" . "205 96 144")
- ("hotpink4" . "139 58 98")
- ("pink1" . "255 181 197")
- ("pink2" . "238 169 184")
- ("pink3" . "205 145 158")
- ("pink4" . "139 99 108")
- ("lightpink1" . "255 174 185")
- ("lightpink2" . "238 162 173")
- ("lightpink3" . "205 140 149")
- ("lightpink4" . "139 95 101")
- ("palevioletred1" . "255 130 171")
- ("palevioletred2" . "238 121 159")
- ("palevioletred3" . "205 104 137")
- ("palevioletred4" . "139 71 93")
- ("maroon1" . "255 52 179")
- ("maroon2" . "238 48 167")
- ("maroon3" . "205 41 144")
- ("maroon4" . "139 28 98")
- ("violetred1" . "255 62 150")
- ("violetred2" . "238 58 140")
- ("violetred3" . "205 50 120")
- ("violetred4" . "139 34 82")
- ("magenta1" . "255 0 255")
- ("magenta2" . "238 0 238")
- ("magenta3" . "205 0 205")
- ("magenta4" . "139 0 139")
- ("orchid1" . "255 131 250")
- ("orchid2" . "238 122 233")
- ("orchid3" . "205 105 201")
- ("orchid4" . "139 71 137")
- ("plum1" . "255 187 255")
- ("plum2" . "238 174 238")
- ("plum3" . "205 150 205")
- ("plum4" . "139 102 139")
- ("mediumorchid1" . "224 102 255")
- ("mediumorchid2" . "209 95 238")
- ("mediumorchid3" . "180 82 205")
- ("mediumorchid4" . "122 55 139")
- ("darkorchid1" . "191 62 255")
- ("darkorchid2" . "178 58 238")
- ("darkorchid3" . "154 50 205")
- ("darkorchid4" . "104 34 139")
- ("purple1" . "155 48 255")
- ("purple2" . "145 44 238")
- ("purple3" . "125 38 205")
- ("purple4" . "85 26 139")
- ("mediumpurple1" . "171 130 255")
- ("mediumpurple2" . "159 121 238")
- ("mediumpurple3" . "137 104 205")
- ("mediumpurple4" . "93 71 139")
- ("thistle1" . "255 225 255")
- ("thistle2" . "238 210 238")
- ("thistle3" . "205 181 205")
- ("thistle4" . "139 123 139")
- ("grey0" . "0 0 0")
- ("grey1" . "3 3 3")
- ("grey2" . "5 5 5")
- ("grey3" . "8 8 8")
- ("grey4" . "10 10 10")
- ("grey5" . "13 13 13")
- ("grey6" . "15 15 15")
- ("grey7" . "18 18 18")
- ("grey8" . "20 20 20")
- ("grey9" . "23 23 23")
- ("grey10" . "26 26 26")
- ("grey11" . "28 28 28")
- ("grey12" . "31 31 31")
- ("grey13" . "33 33 33")
- ("grey14" . "36 36 36")
- ("grey15" . "38 38 38")
- ("grey16" . "41 41 41")
- ("grey17" . "43 43 43")
- ("grey18" . "46 46 46")
- ("grey19" . "48 48 48")
- ("grey20" . "51 51 51")
- ("grey21" . "54 54 54")
- ("grey22" . "56 56 56")
- ("grey23" . "59 59 59")
- ("grey24" . "61 61 61")
- ("grey25" . "64 64 64")
- ("grey26" . "66 66 66")
- ("grey27" . "69 69 69")
- ("grey28" . "71 71 71")
- ("grey29" . "74 74 74")
- ("grey30" . "77 77 77")
- ("grey31" . "79 79 79")
- ("grey32" . "82 82 82")
- ("grey33" . "84 84 84")
- ("grey34" . "87 87 87")
- ("grey35" . "89 89 89")
- ("grey36" . "92 92 92")
- ("grey37" . "94 94 94")
- ("grey38" . "97 97 97")
- ("grey39" . "99 99 99")
- ("grey40" . "102 102 102")
- ("grey41" . "105 105 105")
- ("grey42" . "107 107 107")
- ("grey43" . "110 110 110")
- ("grey44" . "112 112 112")
- ("grey45" . "115 115 115")
- ("grey46" . "117 117 117")
- ("grey47" . "120 120 120")
- ("grey48" . "122 122 122")
- ("grey49" . "125 125 125")
- ("grey50" . "127 127 127")
- ("grey51" . "130 130 130")
- ("grey52" . "133 133 133")
- ("grey53" . "135 135 135")
- ("grey54" . "138 138 138")
- ("grey55" . "140 140 140")
- ("grey56" . "143 143 143")
- ("grey57" . "145 145 145")
- ("grey58" . "148 148 148")
- ("grey59" . "150 150 150")
- ("grey60" . "153 153 153")
- ("grey61" . "156 156 156")
- ("grey62" . "158 158 158")
- ("grey63" . "161 161 161")
- ("grey64" . "163 163 163")
- ("grey65" . "166 166 166")
- ("grey66" . "168 168 168")
- ("grey67" . "171 171 171")
- ("grey68" . "173 173 173")
- ("grey69" . "176 176 176")
- ("grey70" . "179 179 179")
- ("grey71" . "181 181 181")
- ("grey72" . "184 184 184")
- ("grey73" . "186 186 186")
- ("grey74" . "189 189 189")
- ("grey75" . "191 191 191")
- ("grey76" . "194 194 194")
- ("grey77" . "196 196 196")
- ("grey78" . "199 199 199")
- ("grey79" . "201 201 201")
- ("grey80" . "204 204 204")
- ("grey81" . "207 207 207")
- ("grey82" . "209 209 209")
- ("grey83" . "212 212 212")
- ("grey84" . "214 214 214")
- ("grey85" . "217 217 217")
- ("grey86" . "219 219 219")
- ("grey87" . "222 222 222")
- ("grey88" . "224 224 224")
- ("grey89" . "227 227 227")
- ("grey90" . "229 229 229")
- ("grey91" . "232 232 232")
- ("grey92" . "235 235 235")
- ("grey93" . "237 237 237")
- ("grey94" . "240 240 240")
- ("grey95" . "242 242 242")
- ("grey96" . "245 245 245")
- ("grey97" . "247 247 247")
- ("grey98" . "250 250 250")
- ("grey99" . "252 252 252")
- ("grey100" . "255 255 255")
- ("darkgrey" . "169 169 169")
- ("darkblue" . "0 0 139")
- ("darkcyan" . "0 139 139")
- ("darkmagenta" . "139 0 139")
- ("darkred" . "139 0 0")
- ("lightgreen" . "144 238 144")))
-
-
-(define (%convert-color str)
- (let ((col (assoc str *skribe-rgb-alist*)))
- (cond
- (col
- (let* ((p (open-input-string (cdr col)))
- (r (read p))
- (g (read p))
- (b (read p)))
- (values r g b)))
- ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7))
- (values (string->number (substring str 1 3) 16)
- (string->number (substring str 3 5) 16)
- (string->number (substring str 5 7) 16)))
- ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13))
- (values (string->number (substring str 1 5) 16)
- (string->number (substring str 5 9) 16)
- (string->number (substring str 9 13) 16)))
- (else
- (values 0 0 0)))))
-
-;;;
-;;; SKRIBE-COLOR->RGB
-;;;
-(define (skribe-color->rgb spec)
- (cond
- ((string? spec) (%convert-color spec))
- ((integer? spec)
- (values (bit-and #xff (bit-shift spec -16))
- (bit-and #xff (bit-shift spec -8))
- (bit-and #xff spec)))
- (else
- (values 0 0 0))))
-
-;;;
-;;; SKRIBE-GET-USED-COLORS
-;;;
-(define (skribe-get-used-colors)
- *used-colors*)
-
-;;;
-;;; SKRIBE-USE-COLOR!
-;;;
-(define (skribe-use-color! color)
- (set! *used-colors* (cons color *used-colors*))
- color)
-
-) \ No newline at end of file
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/lisp-lex.l b/src/stklos/lisp-lex.l
deleted file mode 100644
index efad24b..0000000
--- a/src/stklos/lisp-lex.l
+++ /dev/null
@@ -1,91 +0,0 @@
-;;;; -*- Scheme -*-
-;;;;
-;;;; lisp-lex.l -- SILex input for the Lisp Languages
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 21-Dec-2003 17:19 (eg)
-;;;; Last file update: 5-Jan-2004 18:24 (eg)
-;;;;
-
-space [ \n\9]
-letter [#?!_:a-zA-Z\-]
-digit [0-9]
-
-
-%%
-;; Strings
-\"[^\"]*\" (new markup
- (markup '&source-string)
- (body yytext))
-
-;;Comment
-\;.* (new markup
- (markup '&source-line-comment)
- (body yytext))
-
-;; Skribe text (i.e. [....])
-\[|\] (if *bracket-highlight*
- (new markup
- (markup '&source-bracket)
- (body yytext))
- yytext)
-;; Spaces & parenthesis
-[ \n\9\(\)]+ (begin
- yytext)
-
-;; Identifier (real syntax is slightly more complicated but we are
-;; interested here in the identifiers that we will fontify)
-[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0)))
- (cond
- ((or (char=? c #\:)
- (char=? (string-ref yytext
- (- (string-length yytext) 1))
- #\:))
- ;; Scheme keyword
- (new markup
- (markup '&source-type)
- (body yytext)))
- ((char=? c #\<)
- ;; STklos class
- (let* ((len (string-length yytext))
- (c (string-ref yytext (- len 1))))
- (if (char=? c #\>)
- (if *class-highlight*
- (new markup
- (markup '&source-module)
- (body yytext))
- yytext) ; no
- yytext))) ; no
- (else
- (let ((tmp (assoc (string->symbol yytext)
- *the-keys*)))
- (if tmp
- (new markup
- (markup (cdr tmp))
- (body yytext))
- yytext)))))
-
-
-<<EOF>> 'eof
-<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
-
-
-; LocalWords: fontify
diff --git a/src/stklos/lisp.stk b/src/stklos/lisp.stk
deleted file mode 100644
index 9bfe75a..0000000
--- a/src/stklos/lisp.stk
+++ /dev/null
@@ -1,294 +0,0 @@
-;;;;
-;;;; lisp.stk -- Lisp Family Fontification
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 16-Oct-2003 22:17 (eg)
-;;;; Last file update: 28-Oct-2004 21:14 (eg)
-;;;;
-
-(require "lex-rt") ;; to avoid module problems
-
-(define-module SKRIBE-LISP-MODULE
- (export skribe scheme stklos bigloo lisp)
- (import SKRIBE-SOURCE-MODULE)
-
-(include "lisp-lex.stk") ;; SILex generated
-
-(define *bracket-highlight* #f)
-(define *class-highlight* #f)
-(define *the-keys* #f)
-
-(define *lisp-keys* #f)
-(define *scheme-keys* #f)
-(define *skribe-keys* #f)
-(define *stklos-keys* #f)
-(define *lisp-keys* #f)
-
-
-;;;
-;;; DEFINITION-SEARCH
-;;;
-(define (definition-search inp tab test)
- (let Loop ((exp (%read inp)))
- (unless (eof-object? exp)
- (if (test exp)
- (let ((start (and (%epair? exp) (%epair-line exp)))
- (stop (port-current-line inp)))
- (source-read-lines (port-file-name inp) start stop tab))
- (Loop (%read inp))))))
-
-
-(define (lisp-family-fontifier s)
- (let ((lex (lisp-lex (open-input-string s))))
- (let Loop ((token (lexer-next-token lex))
- (res '()))
- (if (eq? token 'eof)
- (reverse! res)
- (Loop (lexer-next-token lex)
- (cons token res))))))
-
-;;;; ======================================================================
-;;;;
-;;;; LISP
-;;;;
-;;;; ======================================================================
-(define (lisp-extractor iport def tab)
- (definition-search
- iport
- tab
- (lambda (exp)
- (match-case exp
- (((or defun defmacro) ?fun ?- . ?-)
- (and (eq? def fun) exp))
- ((defvar ?var . ?-)
- (and (eq? var def) exp))
- (else
- #f)))))
-
-(define (init-lisp-keys)
- (unless *lisp-keys*
- (set! *lisp-keys*
- (append ;; key
- (map (lambda (x) (cons x '&source-keyword))
- '(setq if let let* letrec cond case else progn lambda))
- ;; define
- (map (lambda (x) (cons x '&source-define))
- '(defun defclass defmacro)))))
- *lisp-keys*)
-
-(define (lisp-fontifier s)
- (fluid-let ((*the-keys* (init-lisp-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
- (lisp-family-fontifier s)))
-
-
-(define lisp
- (new language
- (name "lisp")
- (fontifier lisp-fontifier)
- (extractor lisp-extractor)))
-
-;;;; ======================================================================
-;;;;
-;;;; SCHEME
-;;;;
-;;;; ======================================================================
-(define (scheme-extractor iport def tab)
- (definition-search
- iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-macro) (?fun . ?-) . ?-)
- (and (eq? def fun) exp))
- ((define (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
- (else
- #f)))))
-
-
-(define (init-scheme-keys)
- (unless *scheme-keys*
- (set! *scheme-keys*
- (append ;; key
- (map (lambda (x) (cons x '&source-keyword))
- '(set! if let let* letrec quote cond case else begin do lambda))
- ;; define
- (map (lambda (x) (cons x '&source-define))
- '(define define-syntax)))))
- *scheme-keys*)
-
-
-(define (scheme-fontifier s)
- (fluid-let ((*the-keys* (init-scheme-keys))
- (*bracket-highlight* #f)
- (*class-highlight* #f))
- (lisp-family-fontifier s)))
-
-
-(define scheme
- (new language
- (name "scheme")
- (fontifier scheme-fontifier)
- (extractor scheme-extractor)))
-
-;;;; ======================================================================
-;;;;
-;;;; STKLOS
-;;;;
-;;;; ======================================================================
-(define (stklos-extractor iport def tab)
- (definition-search
- iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-generic define-method define-macro)
- (?fun . ?-) . ?-)
- (and (eq? def fun) exp))
- (((or define define-module) (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
- (else
- #f)))))
-
-
-(define (init-stklos-keys)
- (unless *stklos-keys*
- (init-scheme-keys)
- (set! *stklos-keys* (append *scheme-keys*
- ;; Markups
- (map (lambda (x) (cons x '&source-key))
- '(select-module import export))
- ;; Key
- (map (lambda (x) (cons x '&source-keyword))
- '(case-lambda dotimes match-case match-lambda))
- ;; Define
- (map (lambda (x) (cons x '&source-define))
- '(define-generic define-class
- define-macro define-method define-module))
- ;; error
- (map (lambda (x) (cons x '&source-error))
- '(error call/cc)))))
- *stklos-keys*)
-
-
-(define (stklos-fontifier s)
- (fluid-let ((*the-keys* (init-stklos-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
- (lisp-family-fontifier s)))
-
-
-(define stklos
- (new language
- (name "stklos")
- (fontifier stklos-fontifier)
- (extractor stklos-extractor)))
-
-;;;; ======================================================================
-;;;;
-;;;; SKRIBE
-;;;;
-;;;; ======================================================================
-(define (skribe-extractor iport def tab)
- (definition-search
- iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-macro define-markup) (?fun . ?-) . ?-)
- (and (eq? def fun) exp))
- ((define (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
- ((markup-output (quote ?mk) . ?-)
- (and (eq? mk def) exp))
- (else
- #f)))))
-
-
-(define (init-skribe-keys)
- (unless *skribe-keys*
- (init-stklos-keys)
- (set! *skribe-keys* (append *stklos-keys*
- ;; Markups
- (map (lambda (x) (cons x '&source-markup))
- '(bold it emph tt color ref index underline
- roman figure center pre flush hrule
- linebreak image kbd code var samp
- sc sf sup sub
- itemize description enumerate item
- table tr td th item prgm author
- prgm hook font
- document chapter section subsection
- subsubsection paragraph p handle resolve
- processor abstract margin toc
- table-of-contents current-document
- current-chapter current-section
- document-sections* section-number
- footnote print-index include skribe-load
- slide))
- ;; Define
- (map (lambda (x) (cons x '&source-define))
- '(define-markup)))))
- *skribe-keys*)
-
-
-(define (skribe-fontifier s)
- (fluid-let ((*the-keys* (init-skribe-keys))
- (*bracket-highlight* #t)
- (*class-highlight* #t))
- (lisp-family-fontifier s)))
-
-
-(define skribe
- (new language
- (name "skribe")
- (fontifier skribe-fontifier)
- (extractor skribe-extractor)))
-
-;;;; ======================================================================
-;;;;
-;;;; BIGLOO
-;;;;
-;;;; ======================================================================
-(define (bigloo-extractor iport def tab)
- (definition-search
- iport
- tab
- (lambda (exp)
- (match-case exp
- (((or define define-inline define-generic
- define-method define-macro define-expander)
- (?fun . ?-) . ?-)
- (and (eq? def fun) exp))
- (((or define define-struct define-library) (and (? symbol?) ?var) . ?-)
- (and (eq? var def) exp))
- (else
- #f)))))
-
-(define bigloo
- (new language
- (name "bigloo")
- (fontifier scheme-fontifier)
- (extractor bigloo-extractor)))
-
-)
diff --git a/src/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/prog.stk b/src/stklos/prog.stk
deleted file mode 100644
index 6301ece..0000000
--- a/src/stklos/prog.stk
+++ /dev/null
@@ -1,219 +0,0 @@
-;;;;
-;;;; prog.stk -- All the stuff for the prog markup
-;;;;
-;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 31-Aug-2003 23:42 (eg)
-;;;; Last file update: 22-Oct-2003 19:35 (eg)
-;;;;
-
-(define-module SKRIBE-PROG-MODULE
- (export make-prog-body resolve-line)
-
-;;; ======================================================================
-;;;
-;;; COMPATIBILITY
-;;;
-;;; ======================================================================
-(define pregexp-match regexp-match)
-(define pregexp-replace regexp-replace)
-(define pregexp-quote regexp-quote)
-
-
-(define (node-body-set! b v)
- (slot-set! b 'body v))
-
-;;;
-;;; FIXME: Tout le module peut se factoriser
-;;; définir en bigloo node-body-set
-
-
-;*---------------------------------------------------------------------*/
-;* *lines* ... */
-;*---------------------------------------------------------------------*/
-(define *lines* (make-hashtable))
-
-;*---------------------------------------------------------------------*/
-;* make-line-mark ... */
-;*---------------------------------------------------------------------*/
-(define (make-line-mark m lnum b)
- (let* ((ls (number->string lnum))
- (n (list (mark ls) b)))
- (hashtable-put! *lines* m n)
- n))
-
-;*---------------------------------------------------------------------*/
-;* resolve-line ... */
-;*---------------------------------------------------------------------*/
-(define (resolve-line id)
- (hashtable-get *lines* id))
-
-;*---------------------------------------------------------------------*/
-;* extract-string-mark ... */
-;*---------------------------------------------------------------------*/
-(define (extract-string-mark line mark regexp)
- (let ((m (pregexp-match regexp line)))
- (if (pair? m)
- (values (substring (car m)
- (string-length mark)
- (string-length (car m)))
- (pregexp-replace regexp line ""))
- (values #f line))))
-
-;*---------------------------------------------------------------------*/
-;* extract-mark ... */
-;* ------------------------------------------------------------- */
-;* Extract the prog mark from a line. */
-;*---------------------------------------------------------------------*/
-(define (extract-mark line mark regexp)
- (cond
- ((not regexp)
- (values #f line))
- ((string? line)
- (extract-string-mark line mark regexp))
- ((pair? line)
- (let loop ((ls line)
- (res '()))
- (if (null? ls)
- (values #f line)
- (receive (m l)
- (extract-mark (car ls) mark regexp)
- (if (not m)
- (loop (cdr ls) (cons l res))
- (values m (append (reverse! res) (cons l (cdr ls)))))))))
- ((node? line)
- (receive (m l)
- (extract-mark (node-body line) mark regexp)
- (if (not m)
- (values #f line)
- (begin
- (node-body-set! line l)
- (values m line)))))
- (else
- (values #f line))))
-
-;*---------------------------------------------------------------------*/
-;* split-line ... */
-;*---------------------------------------------------------------------*/
-(define (split-line line)
- (cond
- ((string? line)
- (let ((l (string-length line)))
- (let loop ((r1 0)
- (r2 0)
- (res '()))
- (cond
- ((= r2 l)
- (if (= r1 r2)
- (reverse! res)
- (reverse! (cons (substring line r1 r2) res))))
- ((char=? (string-ref line r2) #\Newline)
- (loop (+ r2 1)
- (+ r2 1)
- (if (= r1 r2)
- (cons 'eol res)
- (cons* 'eol (substring line r1 r2) res))))
- (else
- (loop r1
- (+ r2 1)
- res))))))
- ((pair? line)
- (let loop ((ls line)
- (res '()))
- (if (null? ls)
- res
- (loop (cdr ls) (append res (split-line (car ls)))))))
- (else
- (list line))))
-
-;*---------------------------------------------------------------------*/
-;* flat-lines ... */
-;*---------------------------------------------------------------------*/
-(define (flat-lines lines)
- (apply append (map split-line lines)))
-
-;*---------------------------------------------------------------------*/
-;* collect-lines ... */
-;*---------------------------------------------------------------------*/
-(define (collect-lines lines)
- (let loop ((lines (flat-lines lines))
- (res '())
- (tmp '()))
- (cond
- ((null? lines)
- (reverse! (cons (reverse! tmp) res)))
- ((eq? (car lines) 'eol)
- (cond
- ((null? (cdr lines))
- (reverse! (cons (reverse! tmp) res)))
- ((and (null? res) (null? tmp))
- (loop (cdr lines)
- res
- '()))
- (else
- (loop (cdr lines)
- (cons (reverse! tmp) res)
- '()))))
- (else
- (loop (cdr lines)
- res
- (cons (car lines) tmp))))))
-
-;*---------------------------------------------------------------------*/
-;* make-prog-body ... */
-;*---------------------------------------------------------------------*/
-(define (make-prog-body src lnum-init ldigit mark)
- (define (int->str i rl)
- (let* ((s (number->string i))
- (l (string-length s)))
- (if (= l rl)
- s
- (string-append (make-string (- rl l) #\space) s))))
-
- (let* ((regexp (and mark
- (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+"
- (pregexp-quote mark))))
- (src (cond
- ((not (pair? src)) (list src))
- ((and (pair? (car src)) (null? (cdr src))) (car src))
- (else src)))
- (lines (collect-lines src))
- (lnum (if (integer? lnum-init) lnum-init 1))
- (s (number->string (+ (if (integer? ldigit)
- (max lnum (expt 10 (- ldigit 1)))
- lnum)
- (length lines))))
- (cs (string-length s)))
- (let loop ((lines lines)
- (lnum lnum)
- (res '()))
- (if (null? lines)
- (reverse! res)
- (receive (m l)
- (extract-mark (car lines) mark regexp)
- (let ((n (new markup
- (markup '&prog-line)
- (ident (and lnum-init (int->str lnum cs)))
- (body (if m (make-line-mark m lnum l) l)))))
- (loop (cdr lines)
- (+ lnum 1)
- (cons n res))))))))
-
-) \ No newline at end of file
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/source.stk b/src/stklos/source.stk
deleted file mode 100644
index a3102c1..0000000
--- a/src/stklos/source.stk
+++ /dev/null
@@ -1,191 +0,0 @@
-;;;;
-;;;; source.stk -- Skibe SOURCE implementation stuff
-;;;;
-;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 3-Sep-2003 12:22 (eg)
-;;;; Last file update: 27-Oct-2004 20:09 (eg)
-;;;;
-
-
-
-(define-module SKRIBE-SOURCE-MODULE
- (export source-read-lines source-read-definition source-fontify)
-
-
-;; Temporary solution
-(define (language-extractor lang)
- (slot-ref lang 'extractor))
-
-(define (language-fontifier lang)
- (slot-ref lang 'fontifier))
-
-
-;*---------------------------------------------------------------------*/
-;* source-read-lines ... */
-;*---------------------------------------------------------------------*/
-(define (source-read-lines file start stop tab)
- (let ((p (find-path file (skribe-source-path))))
- (if (or (not (string? p)) (not (file-exists? p)))
- (skribe-error 'source
- (format "Can't find `~a' source file in path" file)
- (skribe-source-path))
- (with-input-from-file p
- (lambda ()
- (if (> *skribe-verbose* 0)
- (format (current-error-port) " [source file: ~S]\n" p))
- (let ((startl (if (string? start) (string-length start) -1))
- (stopl (if (string? stop) (string-length stop) -1)))
- (let loop ((l 1)
- (armedp (not (or (integer? start) (string? start))))
- (s (read-line))
- (r '()))
- (cond
- ((or (eof-object? s)
- (and (integer? stop) (> l stop))
- (and (string? stop) (substring=? stop s stopl)))
- (apply string-append (reverse! r)))
- (armedp
- (loop (+ l 1)
- #t
- (read-line)
- (cons* "\n" (untabify s tab) r)))
- ((and (integer? start) (>= l start))
- (loop (+ l 1)
- #t
- (read-line)
- (cons* "\n" (untabify s tab) r)))
- ((and (string? start) (substring=? start s startl))
- (loop (+ l 1) #t (read-line) r))
- (else
- (loop (+ l 1) #f (read-line) r))))))))))
-
-;*---------------------------------------------------------------------*/
-;* untabify ... */
-;*---------------------------------------------------------------------*/
-(define (untabify obj tab)
- (if (not tab)
- obj
- (let ((len (string-length obj))
- (tabl tab))
- (let loop ((i 0)
- (col 1))
- (cond
- ((= i len)
- (let ((nlen (- col 1)))
- (if (= len nlen)
- obj
- (let ((new (make-string col #\space)))
- (let liip ((i 0)
- (j 0)
- (col 1))
- (cond
- ((= i len)
- new)
- ((char=? (string-ref obj i) #\tab)
- (let ((next-tab (* (/ (+ col tabl)
- tabl)
- tabl)))
- (liip (+ i 1)
- next-tab
- next-tab)))
- (else
- (string-set! new j (string-ref obj i))
- (liip (+ i 1) (+ j 1) (+ col 1)))))))))
- ((char=? (string-ref obj i) #\tab)
- (loop (+ i 1)
- (* (/ (+ col tabl) tabl) tabl)))
- (else
- (loop (+ i 1) (+ col 1))))))))
-
-;*---------------------------------------------------------------------*/
-;* source-read-definition ... */
-;*---------------------------------------------------------------------*/
-(define (source-read-definition file definition tab lang)
- (let ((p (find-path file (skribe-source-path))))
- (cond
- ((not (language-extractor lang))
- (skribe-error 'source
- "The specified language has not defined extractor"
- (slot-ref lang 'name)))
- ((or (not p) (not (file-exists? p)))
- (skribe-error 'source
- (format "Can't find `~a' program file in path" file)
- (skribe-source-path)))
- (else
- (let ((ip (open-input-file p)))
- (if (> *skribe-verbose* 0)
- (format (current-error-port) " [source file: ~S]\n" p))
- (if (not (input-port? ip))
- (skribe-error 'source "Can't open file for input" p)
- (unwind-protect
- (let ((s ((language-extractor lang) ip definition tab)))
- (if (not (string? s))
- (skribe-error 'source
- "Can't find definition"
- definition)
- s))
- (close-input-port ip))))))))
-
-;*---------------------------------------------------------------------*/
-;* source-fontify ... */
-;*---------------------------------------------------------------------*/
-(define (source-fontify o language)
- (define (fontify f o)
- (cond
- ((string? o) (f o))
- ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o))
- (else o)))
- (let ((f (language-fontifier language)))
- (if (procedure? f)
- (fontify f o)
- o)))
-
-;*---------------------------------------------------------------------*/
-;* split-string-newline ... */
-;*---------------------------------------------------------------------*/
-(define (split-string-newline str)
- (let ((l (string-length str)))
- (let loop ((i 0)
- (j 0)
- (r '()))
- (cond
- ((= i l)
- (if (= i j)
- (reverse! r)
- (reverse! (cons (substring str j i) r))))
- ((char=? (string-ref str i) #\Newline)
- (loop (+ i 1)
- (+ i 1)
- (if (= i j)
- (cons 'eol r)
- (cons* 'eol (substring str j i) r))))
- ((and (char=? (string-ref str i) #\cr)
- (< (+ i 1) l)
- (char=? (string-ref str (+ i 1)) #\Newline))
- (loop (+ i 2)
- (+ i 2)
- (if (= i j)
- (cons 'eol r)
- (cons* 'eol (substring str j i) r))))
- (else
- (loop (+ i 1) j r))))))
-
-)
diff --git a/src/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/verify.stk b/src/stklos/verify.stk
deleted file mode 100644
index da9b132..0000000
--- a/src/stklos/verify.stk
+++ /dev/null
@@ -1,157 +0,0 @@
-;;;;
-;;;; 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)
-
-
-(define-generic verify)
-
-;;;
-;;; CHECK-REQUIRED-OPTIONS
-;;;
-(define (check-required-options markup writer engine)
- (let ((required-options (slot-ref markup 'required-options))
- (ident (slot-ref writer 'ident))
- (options (slot-ref writer 'options))
- (verified? (slot-ref writer 'verified?)))
- (or verified?
- (eq? options 'all)
- (begin
- (for-each (lambda (o)
- (if (not (memq o options))
- (skribe-error (engine-ident engine)
- (format "Option unsupported: ~a, supported options: ~a" o options)
- markup)))
- required-options)
- (slot-set! writer 'verified? #t)))))
-
-;;;
-;;; CHECK-OPTIONS
-;;;
-(define (check-options lopts markup engine)
-
- ;; Only keywords are checked, symbols are voluntary left unchecked. */
- (with-debug 6 'check-options
- (debug-item "markup=" (markup-markup markup))
- (debug-item "options=" (slot-ref markup 'options))
- (debug-item "lopts=" lopts)
- (for-each
- (lambda (o2)
- (for-each
- (lambda (o)
- (if (and (keyword? o)
- (not (eq? o :&skribe-eval-location))
- (not (memq o lopts)))
- (skribe-warning/ast
- 3
- markup
- 'verify
- (format "Engine ~a does not support markup ~a option `~a' -- ~a"
- (engine-ident engine)
- (markup-markup markup)
- o
- (markup-option markup o)))))
- o2))
- (slot-ref markup 'options))))
-
-
-;;; ======================================================================
-;;;
-;;; V E R I F Y
-;;;
-;;; ======================================================================
-
-;;; TOP
-(define-method verify ((obj <top>) e)
- obj)
-
-;;; PAIR
-(define-method verify ((obj <pair>) e)
- (for-each (lambda (x) (verify x e)) obj)
- obj)
-
-;;; PROCESSOR
-(define-method verify ((obj <processor>) e)
- (let ((combinator (slot-ref obj 'combinator))
- (engine (slot-ref obj 'engine))
- (body (slot-ref obj 'body)))
- (verify body (processor-get-engine combinator engine e))
- obj))
-
-;;; NODE
-(define-method verify ((node <node>) e)
- ;; Verify body
- (verify (slot-ref node 'body) e)
- ;; Verify options
- (for-each (lambda (o) (verify (cadr o) e))
- (slot-ref node 'options))
- node)
-
-;;; MARKUP
-(define-method verify ((node <markup>) e)
- (with-debug 5 'verify::<markup>
- (debug-item "node=" (markup-markup node))
- (debug-item "options=" (slot-ref node 'options))
- (debug-item "e=" (engine-ident e))
-
- (next-method)
-
- (let ((w (lookup-markup-writer node e)))
- (when (writer? w)
- (check-required-options node w e)
- (when (pair? (writer-options w))
- (check-options (slot-ref w 'options) node e))
- (let ((validate (slot-ref w 'validate)))
- (when (procedure? validate)
- (unless (validate node e)
- (skribe-warning
- 1
- node
- (format "Node `~a' forbidden here by ~a engine"
- (markup-markup node)
- (engine-ident e))))))))
- node))
-
-
-;;; DOCUMENT
-(define-method verify ((node <document>) e)
- (next-method)
-
- ;; verify the engine customs
- (for-each (lambda (c)
- (let ((i (car c))
- (a (cadr c)))
- (set-car! (cdr c) (verify a e))))
- (slot-ref e 'customs))
-
- node)
-
-
-)
-
diff --git a/src/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-lex.l b/src/stklos/xml-lex.l
deleted file mode 100644
index 5d9a8d9..0000000
--- a/src/stklos/xml-lex.l
+++ /dev/null
@@ -1,64 +0,0 @@
-;;;; -*- Scheme -*-
-;;;;
-;;;; xml-lex.l -- SILex input for the XML languages
-;;;;
-;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
-;;;;
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program; if not, write to the Free Software
-;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-;;;; USA.
-;;;;
-;;;; Author: Erick Gallesio [eg@essi.fr]
-;;;; Creation date: 21-Dec-2003 17:19 (eg)
-;;;; Last file update: 21-Dec-2003 22:38 (eg)
-;;;;
-
-space [ \n\9]
-
-%%
-
-;; Strings
-\"[^\"]*\" (new markup
- (markup '&source-string)
- (body yytext))
-'[^']*' (new markup
- (markup '&source-string)
- (body yytext))
-
-;;Comment
-<!--(.|\n)*--> (new markup
- (markup '&source-comment)
- (body yytext))
-
-;; Markup
-<[^>\n ]+|> (new markup
- (markup '&source-module)
- (body yytext))
-
-;; Regular text
-[^<>\"']+ (begin yytext)
-
-
-<<EOF>> 'eof
-<<ERROR>> (skribe-error 'xml-fontifier "Parse error" yytext)
-
-
-
-
-
-
-
-
- \ No newline at end of file
diff --git a/src/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)))
-)