aboutsummaryrefslogtreecommitdiff
path: root/legacy
diff options
context:
space:
mode:
Diffstat (limited to 'legacy')
-rw-r--r--legacy/bigloo/Makefile271
-rw-r--r--legacy/bigloo/api.bgl117
-rw-r--r--legacy/bigloo/api.sch91
-rw-r--r--legacy/bigloo/asm.scm99
-rw-r--r--legacy/bigloo/bib.bgl161
-rw-r--r--legacy/bigloo/c.scm134
-rw-r--r--legacy/bigloo/color.scm702
-rw-r--r--legacy/bigloo/configure.bgl90
-rw-r--r--legacy/bigloo/debug.sch54
-rw-r--r--legacy/bigloo/debug.scm188
-rw-r--r--legacy/bigloo/engine.scm262
-rw-r--r--legacy/bigloo/eval.scm335
-rw-r--r--legacy/bigloo/evapi.scm39
-rw-r--r--legacy/bigloo/index.bgl32
-rw-r--r--legacy/bigloo/lib.bgl340
-rw-r--r--legacy/bigloo/lisp.scm530
-rw-r--r--legacy/bigloo/main.scm96
-rw-r--r--legacy/bigloo/new.sch17
-rw-r--r--legacy/bigloo/output.scm167
-rw-r--r--legacy/bigloo/param.bgl134
-rw-r--r--legacy/bigloo/parseargs.scm186
-rw-r--r--legacy/bigloo/prog.scm196
-rw-r--r--legacy/bigloo/read.scm482
-rw-r--r--legacy/bigloo/resolve.scm283
-rw-r--r--legacy/bigloo/source.scm238
-rw-r--r--legacy/bigloo/sui.bgl34
-rw-r--r--legacy/bigloo/types.scm685
-rw-r--r--legacy/bigloo/verify.scm143
-rw-r--r--legacy/bigloo/writer.scm232
-rw-r--r--legacy/bigloo/xml.scm92
-rw-r--r--legacy/stklos/Makefile.in110
-rw-r--r--legacy/stklos/biblio.stk161
-rw-r--r--legacy/stklos/c-lex.l67
-rw-r--r--legacy/stklos/c.stk95
-rw-r--r--legacy/stklos/color.stk622
-rw-r--r--legacy/stklos/configure.stk90
-rw-r--r--legacy/stklos/debug.stk161
-rw-r--r--legacy/stklos/engine.stk242
-rw-r--r--legacy/stklos/eval.stk149
-rw-r--r--legacy/stklos/lib.stk317
-rw-r--r--legacy/stklos/lisp-lex.l91
-rw-r--r--legacy/stklos/lisp.stk294
-rw-r--r--legacy/stklos/main.stk264
-rw-r--r--legacy/stklos/output.stk158
-rw-r--r--legacy/stklos/prog.stk219
-rw-r--r--legacy/stklos/reader.stk136
-rw-r--r--legacy/stklos/resolve.stk255
-rw-r--r--legacy/stklos/runtime.stk456
-rw-r--r--legacy/stklos/source.stk191
-rw-r--r--legacy/stklos/types.stk294
-rw-r--r--legacy/stklos/vars.stk82
-rw-r--r--legacy/stklos/verify.stk157
-rw-r--r--legacy/stklos/writer.stk211
-rw-r--r--legacy/stklos/xml-lex.l64
-rw-r--r--legacy/stklos/xml.stk52
55 files changed, 11368 insertions, 0 deletions
diff --git a/legacy/bigloo/Makefile b/legacy/bigloo/Makefile
new file mode 100644
index 0000000..02d2b6a
--- /dev/null
+++ b/legacy/bigloo/Makefile
@@ -0,0 +1,271 @@
+#*=====================================================================*/
+#* 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/legacy/bigloo/api.bgl b/legacy/bigloo/api.bgl
new file mode 100644
index 0000000..55493b0
--- /dev/null
+++ b/legacy/bigloo/api.bgl
@@ -0,0 +1,117 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/api.sch b/legacy/bigloo/api.sch
new file mode 100644
index 0000000..390b8fa
--- /dev/null
+++ b/legacy/bigloo/api.sch
@@ -0,0 +1,91 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/asm.scm b/legacy/bigloo/asm.scm
new file mode 100644
index 0000000..03196ac
--- /dev/null
+++ b/legacy/bigloo/asm.scm
@@ -0,0 +1,99 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/bib.bgl b/legacy/bigloo/bib.bgl
new file mode 100644
index 0000000..6b0f7dd
--- /dev/null
+++ b/legacy/bigloo/bib.bgl
@@ -0,0 +1,161 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/c.scm b/legacy/bigloo/c.scm
new file mode 100644
index 0000000..07290ce
--- /dev/null
+++ b/legacy/bigloo/c.scm
@@ -0,0 +1,134 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/color.scm b/legacy/bigloo/color.scm
new file mode 100644
index 0000000..e481d65
--- /dev/null
+++ b/legacy/bigloo/color.scm
@@ -0,0 +1,702 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/configure.bgl b/legacy/bigloo/configure.bgl
new file mode 100644
index 0000000..e100d8d
--- /dev/null
+++ b/legacy/bigloo/configure.bgl
@@ -0,0 +1,90 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/debug.sch b/legacy/bigloo/debug.sch
new file mode 100644
index 0000000..9b53c84
--- /dev/null
+++ b/legacy/bigloo/debug.sch
@@ -0,0 +1,54 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/debug.scm b/legacy/bigloo/debug.scm
new file mode 100644
index 0000000..8f1691c
--- /dev/null
+++ b/legacy/bigloo/debug.scm
@@ -0,0 +1,188 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/engine.scm b/legacy/bigloo/engine.scm
new file mode 100644
index 0000000..bd8a027
--- /dev/null
+++ b/legacy/bigloo/engine.scm
@@ -0,0 +1,262 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/eval.scm b/legacy/bigloo/eval.scm
new file mode 100644
index 0000000..b5c6548
--- /dev/null
+++ b/legacy/bigloo/eval.scm
@@ -0,0 +1,335 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/evapi.scm b/legacy/bigloo/evapi.scm
new file mode 100644
index 0000000..6f0d49e
--- /dev/null
+++ b/legacy/bigloo/evapi.scm
@@ -0,0 +1,39 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/index.bgl b/legacy/bigloo/index.bgl
new file mode 100644
index 0000000..9697981
--- /dev/null
+++ b/legacy/bigloo/index.bgl
@@ -0,0 +1,32 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/lib.bgl b/legacy/bigloo/lib.bgl
new file mode 100644
index 0000000..6dd6d37
--- /dev/null
+++ b/legacy/bigloo/lib.bgl
@@ -0,0 +1,340 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/lisp.scm b/legacy/bigloo/lisp.scm
new file mode 100644
index 0000000..65a8227
--- /dev/null
+++ b/legacy/bigloo/lisp.scm
@@ -0,0 +1,530 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/main.scm b/legacy/bigloo/main.scm
new file mode 100644
index 0000000..5b9e5e5
--- /dev/null
+++ b/legacy/bigloo/main.scm
@@ -0,0 +1,96 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/new.sch b/legacy/bigloo/new.sch
new file mode 100644
index 0000000..16bb7d5
--- /dev/null
+++ b/legacy/bigloo/new.sch
@@ -0,0 +1,17 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/new.sch */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Sun Aug 17 11:58:30 2003 */
+;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */
+;* Copyright : 2003 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* The new facility */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* new ... */
+;*---------------------------------------------------------------------*/
+(define-macro (new id . inits)
+ `(,(symbol-append 'instantiate::% id) ,@inits))
+
diff --git a/legacy/bigloo/output.scm b/legacy/bigloo/output.scm
new file mode 100644
index 0000000..4bc6271
--- /dev/null
+++ b/legacy/bigloo/output.scm
@@ -0,0 +1,167 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/param.bgl b/legacy/bigloo/param.bgl
new file mode 100644
index 0000000..6ff6b42
--- /dev/null
+++ b/legacy/bigloo/param.bgl
@@ -0,0 +1,134 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/parseargs.scm b/legacy/bigloo/parseargs.scm
new file mode 100644
index 0000000..4ce58c4
--- /dev/null
+++ b/legacy/bigloo/parseargs.scm
@@ -0,0 +1,186 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/prog.scm b/legacy/bigloo/prog.scm
new file mode 100644
index 0000000..baad0f0
--- /dev/null
+++ b/legacy/bigloo/prog.scm
@@ -0,0 +1,196 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/read.scm b/legacy/bigloo/read.scm
new file mode 100644
index 0000000..91cd345
--- /dev/null
+++ b/legacy/bigloo/read.scm
@@ -0,0 +1,482 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/resolve.scm b/legacy/bigloo/resolve.scm
new file mode 100644
index 0000000..8248a4f
--- /dev/null
+++ b/legacy/bigloo/resolve.scm
@@ -0,0 +1,283 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/source.scm b/legacy/bigloo/source.scm
new file mode 100644
index 0000000..babadff
--- /dev/null
+++ b/legacy/bigloo/source.scm
@@ -0,0 +1,238 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/sui.bgl b/legacy/bigloo/sui.bgl
new file mode 100644
index 0000000..63c5477
--- /dev/null
+++ b/legacy/bigloo/sui.bgl
@@ -0,0 +1,34 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/types.scm b/legacy/bigloo/types.scm
new file mode 100644
index 0000000..b8babd4
--- /dev/null
+++ b/legacy/bigloo/types.scm
@@ -0,0 +1,685 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/verify.scm b/legacy/bigloo/verify.scm
new file mode 100644
index 0000000..602a951
--- /dev/null
+++ b/legacy/bigloo/verify.scm
@@ -0,0 +1,143 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/writer.scm b/legacy/bigloo/writer.scm
new file mode 100644
index 0000000..ce515bf
--- /dev/null
+++ b/legacy/bigloo/writer.scm
@@ -0,0 +1,232 @@
+;*=====================================================================*/
+;* 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/legacy/bigloo/xml.scm b/legacy/bigloo/xml.scm
new file mode 100644
index 0000000..d4c662e
--- /dev/null
+++ b/legacy/bigloo/xml.scm
@@ -0,0 +1,92 @@
+;*=====================================================================*/
+;* 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/legacy/stklos/Makefile.in b/legacy/stklos/Makefile.in
new file mode 100644
index 0000000..80a26de
--- /dev/null
+++ b/legacy/stklos/Makefile.in
@@ -0,0 +1,110 @@
+#
+# Makefile.in -- Skribe Src Makefile
+#
+# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+#
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+# USA.
+#
+# Author: Erick Gallesio [eg@essi.fr]
+# Creation date: 10-Aug-2003 20:26 (eg)
+# Last file update: 6-Mar-2004 16:00 (eg)
+#
+include ../../etc/stklos/Makefile.skb
+
+prefix=@PREFIX@
+
+SKR = $(wildcard ../../skr/*.skr)
+
+DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \
+ ../common/index.scm ../common/bib.scm ../common/lib.scm
+
+SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \
+ eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \
+ resolve.stk runtime.stk source.stk types.stk vars.stk \
+ verify.stk writer.stk xml.stk
+
+LEXFILES = c-lex.l lisp-lex.l xml-lex.l
+
+LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk
+
+BINDIR=../../bin
+
+EXE= $(BINDIR)/skribe.stklos
+
+PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES)
+
+SFLAGS=
+
+all: $(EXE)
+
+Makefile: Makefile.in
+ (cd ../../etc/stklos; autoconf; configure)
+
+$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS)
+ stklos-compile $(SFLAGS) -o $(EXE) main.stk && \
+ chmod $(BMASK) $(EXE)
+
+#
+# Lex files
+#
+lisp-lex.stk: lisp-lex.l
+ stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex
+
+xml-lex.stk: xml-lex.l
+ stklos-genlex xml-lex.l xml-lex.stk xml-lex
+
+c-lex.stk: c-lex.l
+ stklos-genlex c-lex.l c-lex.stk c-lex
+
+
+install: $(INSTALL_BINDIR)
+ cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \
+ && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos
+ rm -f $(INSTALL_BINDIR)/skribe
+ ln -s skribe.stklos $(INSTALL_BINDIR)/skribe
+
+uninstall:
+ rm $(INSTALL_BINDIR)/skribe
+ rm $(INSTALL_BINDIR)/skribe.stklos
+
+$(BINDIR):
+ mkdir -p $(BINDIR) && chmod a+rx $(BINDIR)
+
+$(INSTALL_BINDIR):
+ mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR)
+
+##
+## Services
+##
+tags: TAGS
+
+TAGS: $(SRCS)
+ etags -l scheme $(SRCS)
+
+pop:
+ @echo $(PRCS_FILES:%=src/stklos/%)
+
+links:
+ ln -s $(DEPS) .
+ ln -s $(SKR) .
+
+clean:
+ /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr
+
+distclean: clean
+ /bin/rm -f Makefile
+ /bin/rm -f ../common/configure.scm
diff --git a/legacy/stklos/biblio.stk b/legacy/stklos/biblio.stk
new file mode 100644
index 0000000..5691588
--- /dev/null
+++ b/legacy/stklos/biblio.stk
@@ -0,0 +1,161 @@
+;;;;
+;;;; 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/legacy/stklos/c-lex.l b/legacy/stklos/c-lex.l
new file mode 100644
index 0000000..a5b337e
--- /dev/null
+++ b/legacy/stklos/c-lex.l
@@ -0,0 +1,67 @@
+;;;;
+;;;; c-lex.l -- C fontifier for Skribe
+;;;;
+;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 6-Mar-2004 15:35 (eg)
+;;;; Last file update: 7-Mar-2004 00:10 (eg)
+;;;;
+
+space [ \n\9]
+letter [_a-zA-Z]
+alphanum [_a-zA-Z0-9]
+
+%%
+
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+;;Comments
+/\*.*\*/ (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+//.* (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Identifiers (only letters since we are interested in keywords only)
+[_a-zA-Z]+ (let* ((ident (string->symbol yytext))
+ (tmp (memq ident *the-keys*)))
+ (if tmp
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+ yytext))
+
+;; Regular text
+[^\"a-zA-Z]+ (begin yytext)
+
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
+
+
+
+
+
+
+ \ No newline at end of file
diff --git a/legacy/stklos/c.stk b/legacy/stklos/c.stk
new file mode 100644
index 0000000..265c421
--- /dev/null
+++ b/legacy/stklos/c.stk
@@ -0,0 +1,95 @@
+;;;;
+;;;; 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/legacy/stklos/color.stk b/legacy/stklos/color.stk
new file mode 100644
index 0000000..0cb829f
--- /dev/null
+++ b/legacy/stklos/color.stk
@@ -0,0 +1,622 @@
+;;;;
+;;;; 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/legacy/stklos/configure.stk b/legacy/stklos/configure.stk
new file mode 100644
index 0000000..ece7abc
--- /dev/null
+++ b/legacy/stklos/configure.stk
@@ -0,0 +1,90 @@
+;;;;
+;;;; 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/legacy/stklos/debug.stk b/legacy/stklos/debug.stk
new file mode 100644
index 0000000..a9fefde
--- /dev/null
+++ b/legacy/stklos/debug.stk
@@ -0,0 +1,161 @@
+;;;;
+;;;; 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/legacy/stklos/engine.stk b/legacy/stklos/engine.stk
new file mode 100644
index 0000000..a13ed0f
--- /dev/null
+++ b/legacy/stklos/engine.stk
@@ -0,0 +1,242 @@
+;;;;
+;;;; 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/legacy/stklos/eval.stk b/legacy/stklos/eval.stk
new file mode 100644
index 0000000..3acace9
--- /dev/null
+++ b/legacy/stklos/eval.stk
@@ -0,0 +1,149 @@
+;;;;
+;;;; 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/legacy/stklos/lib.stk b/legacy/stklos/lib.stk
new file mode 100644
index 0000000..3c3b9f0
--- /dev/null
+++ b/legacy/stklos/lib.stk
@@ -0,0 +1,317 @@
+;;;;
+;;;; 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/legacy/stklos/lisp-lex.l b/legacy/stklos/lisp-lex.l
new file mode 100644
index 0000000..efad24b
--- /dev/null
+++ b/legacy/stklos/lisp-lex.l
@@ -0,0 +1,91 @@
+;;;; -*- Scheme -*-
+;;;;
+;;;; lisp-lex.l -- SILex input for the Lisp Languages
+;;;;
+;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 21-Dec-2003 17:19 (eg)
+;;;; Last file update: 5-Jan-2004 18:24 (eg)
+;;;;
+
+space [ \n\9]
+letter [#?!_:a-zA-Z\-]
+digit [0-9]
+
+
+%%
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+\;.* (new markup
+ (markup '&source-line-comment)
+ (body yytext))
+
+;; Skribe text (i.e. [....])
+\[|\] (if *bracket-highlight*
+ (new markup
+ (markup '&source-bracket)
+ (body yytext))
+ yytext)
+;; Spaces & parenthesis
+[ \n\9\(\)]+ (begin
+ yytext)
+
+;; Identifier (real syntax is slightly more complicated but we are
+;; interested here in the identifiers that we will fontify)
+[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0)))
+ (cond
+ ((or (char=? c #\:)
+ (char=? (string-ref yytext
+ (- (string-length yytext) 1))
+ #\:))
+ ;; Scheme keyword
+ (new markup
+ (markup '&source-type)
+ (body yytext)))
+ ((char=? c #\<)
+ ;; STklos class
+ (let* ((len (string-length yytext))
+ (c (string-ref yytext (- len 1))))
+ (if (char=? c #\>)
+ (if *class-highlight*
+ (new markup
+ (markup '&source-module)
+ (body yytext))
+ yytext) ; no
+ yytext))) ; no
+ (else
+ (let ((tmp (assoc (string->symbol yytext)
+ *the-keys*)))
+ (if tmp
+ (new markup
+ (markup (cdr tmp))
+ (body yytext))
+ yytext)))))
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext)
+
+
+; LocalWords: fontify
diff --git a/legacy/stklos/lisp.stk b/legacy/stklos/lisp.stk
new file mode 100644
index 0000000..9bfe75a
--- /dev/null
+++ b/legacy/stklos/lisp.stk
@@ -0,0 +1,294 @@
+;;;;
+;;;; 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/legacy/stklos/main.stk b/legacy/stklos/main.stk
new file mode 100644
index 0000000..4905423
--- /dev/null
+++ b/legacy/stklos/main.stk
@@ -0,0 +1,264 @@
+;;;;
+;;;; 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/legacy/stklos/output.stk b/legacy/stklos/output.stk
new file mode 100644
index 0000000..3c00323
--- /dev/null
+++ b/legacy/stklos/output.stk
@@ -0,0 +1,158 @@
+;;;;
+;;;; 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/legacy/stklos/prog.stk b/legacy/stklos/prog.stk
new file mode 100644
index 0000000..6301ece
--- /dev/null
+++ b/legacy/stklos/prog.stk
@@ -0,0 +1,219 @@
+;;;;
+;;;; 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/legacy/stklos/reader.stk b/legacy/stklos/reader.stk
new file mode 100644
index 0000000..bd38562
--- /dev/null
+++ b/legacy/stklos/reader.stk
@@ -0,0 +1,136 @@
+;;;;
+;;;; 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/legacy/stklos/resolve.stk b/legacy/stklos/resolve.stk
new file mode 100644
index 0000000..91dc965
--- /dev/null
+++ b/legacy/stklos/resolve.stk
@@ -0,0 +1,255 @@
+;;;;
+;;;; 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/legacy/stklos/runtime.stk b/legacy/stklos/runtime.stk
new file mode 100644
index 0000000..58d0d45
--- /dev/null
+++ b/legacy/stklos/runtime.stk
@@ -0,0 +1,456 @@
+;;;;
+;;;; 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/legacy/stklos/source.stk b/legacy/stklos/source.stk
new file mode 100644
index 0000000..a3102c1
--- /dev/null
+++ b/legacy/stklos/source.stk
@@ -0,0 +1,191 @@
+;;;;
+;;;; 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/legacy/stklos/types.stk b/legacy/stklos/types.stk
new file mode 100644
index 0000000..fb16230
--- /dev/null
+++ b/legacy/stklos/types.stk
@@ -0,0 +1,294 @@
+;;;;
+;;;; 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/legacy/stklos/vars.stk b/legacy/stklos/vars.stk
new file mode 100644
index 0000000..1c875f8
--- /dev/null
+++ b/legacy/stklos/vars.stk
@@ -0,0 +1,82 @@
+;;;;
+;;;; 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/legacy/stklos/verify.stk b/legacy/stklos/verify.stk
new file mode 100644
index 0000000..da9b132
--- /dev/null
+++ b/legacy/stklos/verify.stk
@@ -0,0 +1,157 @@
+;;;;
+;;;; 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/legacy/stklos/writer.stk b/legacy/stklos/writer.stk
new file mode 100644
index 0000000..2b0f91c
--- /dev/null
+++ b/legacy/stklos/writer.stk
@@ -0,0 +1,211 @@
+;;;;
+;;;; 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/legacy/stklos/xml-lex.l b/legacy/stklos/xml-lex.l
new file mode 100644
index 0000000..5d9a8d9
--- /dev/null
+++ b/legacy/stklos/xml-lex.l
@@ -0,0 +1,64 @@
+;;;; -*- Scheme -*-
+;;;;
+;;;; xml-lex.l -- SILex input for the XML languages
+;;;;
+;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;;
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;;; USA.
+;;;;
+;;;; Author: Erick Gallesio [eg@essi.fr]
+;;;; Creation date: 21-Dec-2003 17:19 (eg)
+;;;; Last file update: 21-Dec-2003 22:38 (eg)
+;;;;
+
+space [ \n\9]
+
+%%
+
+;; Strings
+\"[^\"]*\" (new markup
+ (markup '&source-string)
+ (body yytext))
+'[^']*' (new markup
+ (markup '&source-string)
+ (body yytext))
+
+;;Comment
+<!--(.|\n)*--> (new markup
+ (markup '&source-comment)
+ (body yytext))
+
+;; Markup
+<[^>\n ]+|> (new markup
+ (markup '&source-module)
+ (body yytext))
+
+;; Regular text
+[^<>\"']+ (begin yytext)
+
+
+<<EOF>> 'eof
+<<ERROR>> (skribe-error 'xml-fontifier "Parse error" yytext)
+
+
+
+
+
+
+
+
+ \ No newline at end of file
diff --git a/legacy/stklos/xml.stk b/legacy/stklos/xml.stk
new file mode 100644
index 0000000..47dd46f
--- /dev/null
+++ b/legacy/stklos/xml.stk
@@ -0,0 +1,52 @@
+;;;;
+;;;; 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)))
+)