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