From a85155f7c411761cfbd75431f265675ae0f394e3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Fri, 1 Jul 2005 13:33:34 +0000 Subject: Lots of changes. Too many changes to describe here, among which, moving the `(skribe)' module namespace to `(skribilo)'. This is work in progress. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-1 --- src/guile/skribe/Makefile.in | 110 --- src/guile/skribe/biblio.scm | 161 ---- src/guile/skribe/c-lex.l | 67 -- src/guile/skribe/c.scm | 93 --- src/guile/skribe/color.scm | 621 ---------------- src/guile/skribe/configure.scm | 112 --- src/guile/skribe/debug.scm | 160 ---- src/guile/skribe/engine.scm | 249 ------- src/guile/skribe/eval.scm | 153 ---- src/guile/skribe/lib.scm | 332 --------- src/guile/skribe/lisp-lex.l | 91 --- src/guile/skribe/lisp.scm | 293 -------- src/guile/skribe/output.scm | 162 ---- src/guile/skribe/prog.scm | 218 ------ src/guile/skribe/reader.scm | 136 ---- src/guile/skribe/resolve.scm | 260 ------- src/guile/skribe/runtime.scm | 460 ------------ src/guile/skribe/source.scm | 190 ----- src/guile/skribe/types.scm | 314 -------- src/guile/skribe/vars.scm | 82 --- src/guile/skribe/verify.scm | 161 ---- src/guile/skribe/writer.scm | 217 ------ src/guile/skribe/xml-lex.l | 64 -- src/guile/skribe/xml.scm | 53 -- src/guile/skribilo.scm | 68 +- src/guile/skribilo/Makefile.in | 110 +++ src/guile/skribilo/biblio.scm | 159 ++++ src/guile/skribilo/color.scm | 621 ++++++++++++++++ src/guile/skribilo/coloring/c-lex.l | 67 ++ src/guile/skribilo/coloring/c.scm | 93 +++ src/guile/skribilo/coloring/lisp-lex.l | 91 +++ src/guile/skribilo/coloring/lisp.scm | 293 ++++++++ src/guile/skribilo/coloring/xml-lex.l | 64 ++ src/guile/skribilo/coloring/xml.scm | 53 ++ src/guile/skribilo/config.scm.in | 21 + src/guile/skribilo/debug.scm | 161 ++++ src/guile/skribilo/engine.scm | 251 +++++++ src/guile/skribilo/eval.scm | 186 +++++ src/guile/skribilo/lib.scm | 360 +++++++++ src/guile/skribilo/module.scm | 118 +++ src/guile/skribilo/output.scm | 162 ++++ src/guile/skribilo/prog.scm | 218 ++++++ src/guile/skribilo/reader.scm | 82 +++ src/guile/skribilo/reader/skribe.scm | 80 ++ src/guile/skribilo/resolve.scm | 260 +++++++ src/guile/skribilo/runtime.scm | 458 ++++++++++++ src/guile/skribilo/skribe/api.scm | 1260 ++++++++++++++++++++++++++++++++ src/guile/skribilo/skribe/bib.scm | 215 ++++++ src/guile/skribilo/skribe/index.scm | 149 ++++ src/guile/skribilo/skribe/param.scm | 93 +++ src/guile/skribilo/skribe/sui.scm | 187 +++++ src/guile/skribilo/skribe/utils.scm | 259 +++++++ src/guile/skribilo/source.scm | 190 +++++ src/guile/skribilo/types.scm | 315 ++++++++ src/guile/skribilo/vars.scm | 65 ++ src/guile/skribilo/verify.scm | 161 ++++ src/guile/skribilo/writer.scm | 217 ++++++ 57 files changed, 7053 insertions(+), 4793 deletions(-) delete mode 100644 src/guile/skribe/Makefile.in delete mode 100644 src/guile/skribe/biblio.scm delete mode 100644 src/guile/skribe/c-lex.l delete mode 100644 src/guile/skribe/c.scm delete mode 100644 src/guile/skribe/color.scm delete mode 100644 src/guile/skribe/configure.scm delete mode 100644 src/guile/skribe/debug.scm delete mode 100644 src/guile/skribe/engine.scm delete mode 100644 src/guile/skribe/eval.scm delete mode 100644 src/guile/skribe/lib.scm delete mode 100644 src/guile/skribe/lisp-lex.l delete mode 100644 src/guile/skribe/lisp.scm delete mode 100644 src/guile/skribe/output.scm delete mode 100644 src/guile/skribe/prog.scm delete mode 100644 src/guile/skribe/reader.scm delete mode 100644 src/guile/skribe/resolve.scm delete mode 100644 src/guile/skribe/runtime.scm delete mode 100644 src/guile/skribe/source.scm delete mode 100644 src/guile/skribe/types.scm delete mode 100644 src/guile/skribe/vars.scm delete mode 100644 src/guile/skribe/verify.scm delete mode 100644 src/guile/skribe/writer.scm delete mode 100644 src/guile/skribe/xml-lex.l delete mode 100644 src/guile/skribe/xml.scm create mode 100644 src/guile/skribilo/Makefile.in create mode 100644 src/guile/skribilo/biblio.scm create mode 100644 src/guile/skribilo/color.scm create mode 100644 src/guile/skribilo/coloring/c-lex.l create mode 100644 src/guile/skribilo/coloring/c.scm create mode 100644 src/guile/skribilo/coloring/lisp-lex.l create mode 100644 src/guile/skribilo/coloring/lisp.scm create mode 100644 src/guile/skribilo/coloring/xml-lex.l create mode 100644 src/guile/skribilo/coloring/xml.scm create mode 100644 src/guile/skribilo/config.scm.in create mode 100644 src/guile/skribilo/debug.scm create mode 100644 src/guile/skribilo/engine.scm create mode 100644 src/guile/skribilo/eval.scm create mode 100644 src/guile/skribilo/lib.scm create mode 100644 src/guile/skribilo/module.scm create mode 100644 src/guile/skribilo/output.scm create mode 100644 src/guile/skribilo/prog.scm create mode 100644 src/guile/skribilo/reader.scm create mode 100644 src/guile/skribilo/reader/skribe.scm create mode 100644 src/guile/skribilo/resolve.scm create mode 100644 src/guile/skribilo/runtime.scm create mode 100644 src/guile/skribilo/skribe/api.scm create mode 100644 src/guile/skribilo/skribe/bib.scm create mode 100644 src/guile/skribilo/skribe/index.scm create mode 100644 src/guile/skribilo/skribe/param.scm create mode 100644 src/guile/skribilo/skribe/sui.scm create mode 100644 src/guile/skribilo/skribe/utils.scm create mode 100644 src/guile/skribilo/source.scm create mode 100644 src/guile/skribilo/types.scm create mode 100644 src/guile/skribilo/vars.scm create mode 100644 src/guile/skribilo/verify.scm create mode 100644 src/guile/skribilo/writer.scm 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 -# -# -# 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 -;;;; Copyright 2005 Ludovic Courtès -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -<> (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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; 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 -;;;; -;;;; -;;;; 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 :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 ) - (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 - :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 -;;;; -;;;; -;;;; 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 )) - (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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -<> (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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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) ) - (%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 ) 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 ) e) - (let ((f (slot-ref e 'filter))) - (if (procedure? f) - (display (f node)) - (display node)))) - - -(define-method (out (node ) e) - (out (number->string node) e)) - - -(define-method (out (n ) 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 ) 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 ) e) - 'unspecified) - - -(define-method (out (n ) e) - (skribe-error 'output "Orphan unresolved" n)) - - -(define-method (out (node ) 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 ) 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 ) engine env) - (let ((body (slot-ref node 'body)) - (options (slot-ref node 'options)) - (parent (slot-ref node 'parent))) - (with-debug 5 'do-resolve - (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 ) 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 - (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 ) 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 ) engine env) - (with-debug 5 'do-resolve - (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 ) engine env) - node) - - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-PARENT -;;;; -;;;; ====================================================================== -(define (resolve-parent n e) - (with-debug 5 'resolve-parent - (debug-item "n=" n) - (cond - ((not (is-a? n )) - (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 ) 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 -;;;; -;;;; -;;;; 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 )) -;; (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 """ out)) -;; ((#\&) (display "&" out)) -;; ((#\<) (display "<" out)) -;; ((#\>) (display ">" 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 ">"))) - 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 )) "") -(define-method (ast->string (ast )) ast) -(define-method (ast->string (ast )) (number->string ast)) - -(define-method (ast->string (ast )) - (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 )) - (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-body obj) obj))) -;;NEW (cond -;;NEW ((pair? obj) -;;NEW (apply append (map (lambda (o) (loop o)) obj))) -;;NEW ((is-a? obj ) -;;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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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-loc ast-loc-set! - command? command-fmt command-body - unresolved? unresolved-proc - handle? handle-ast - node? node-options node-loc - engine? engine-ident engine-format engine-customs - engine-filter engine-symbol-table - writer? write-object - processor? processor-combinator processor-engine - markup? bind-markup! markup-options is-markup? - markup-body find-markups write-object - container? container-options - container-ident container-body - document? document-ident document-body - document-options document-end - language? - 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. - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -;;FIXME: set! location in -(define-class () - (parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) - (loc :init-form #f)) - -(define (ast? obj) (is-a? obj )) -(define (ast-loc obj) (slot-ref obj 'loc)) -(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (fmt :init-keyword :fmt) - (body :init-keyword :body)) - -(define (command? obj) (is-a? obj )) -(define (command-fmt obj) (slot-ref obj 'fmt)) -(define (command-body obj) (slot-ref obj 'body)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (proc :init-keyword :proc)) - -(define (unresolved? obj) (is-a? obj )) -(define (unresolved-proc obj) (slot-ref obj 'proc)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (ast :init-keyword :ast :init-form #f :getter handle-ast)) - -(define (handle? obj) (is-a? obj )) -(define (handle-ast obj) (slot-ref obj 'ast)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) - -(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)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) - -(define-method (write-object (obj ) port) - (format port "#[~A (~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) -(define (node-options obj) (slot-ref obj 'options)) -(define node-loc ast-loc) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) -(define (processor-combinator obj) (slot-ref obj 'combinator)) -(define (processor-engine obj) (slot-ref obj 'engine)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 ) initargs) - (next-method) - (bind-markup! self)) - - -(define (markup? obj) (is-a? obj )) -(define (markup-options obj) (slot-ref obj 'options)) -(define markup-body node-body) - - -(define (is-markup? obj markup) - (and (is-a? obj ) - (eq? (slot-ref obj 'markup) markup))) - - - -(define (find-markups ident) - (hash-ref *node-table* ident #f)) - - -(define-method (write-object (obj ) port) - (format port "#[~A (~A/~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'markup) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (env :init-keyword :env :init-form '())) - -(define (container? obj) (is-a? obj )) -(define (container-env obj) (slot-ref obj 'env)) -(define container-options markup-options) -(define container-ident markup-ident) -(define container-body node-body) - - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class ()) - -(define (document? obj) (is-a? obj )) -(define (document-ident obj) (slot-ref obj 'ident)) -(define (document-body obj) (slot-ref obj 'body)) -(define document-options markup-options) -(define document-env container-env) - - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - (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 )) - -(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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 ) e) - obj) - -;;; PAIR -(define-method (verify (obj ) e) - (for-each (lambda (x) (verify x e)) obj) - obj) - -;;; PROCESSOR -(define-method (verify (obj ) 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 ) 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 ) e) - (with-debug 5 'verify:: - (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 ) 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 - (new markup - (markup '&source-comment) - (body yytext)) - -;; Markup -<[^>\n ]+|> (new markup - (markup '&source-module) - (body yytext)) - -;; Regular text -[^<>\"']+ (begin yytext) - - -<> 'eof -<> (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 -;;;; -;;;; -;;;; 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))) - diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm index e766830..c352f7f 100755 --- a/src/guile/skribilo.scm +++ b/src/guile/skribilo.scm @@ -6,26 +6,26 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" ;;;; ;;;; skribilo.scm -;;;; +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI ;;;; Copyright 2005 Ludovic Courtès -;;;; -;;;; +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 24-Jul-2003 20:33 (eg) ;;;; Last file update: 6-Mar-2004 16:13 (eg) @@ -65,21 +65,21 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" the-arg)))))))) ; (use-modules (skribe eval) -; (skribe configure) -; (skribe runtime) -; (skribe engine) -; (skribe writer) -; (skribe verify) -; (skribe output) -; (skribe biblio) -; (skribe prog) -; (skribe resolve) -; (skribe source) -; (skribe lisp) -; (skribe xml) -; (skribe c) -; (skribe debug) -; (skribe color)) +; (skribe configure) +; (skribe runtime) +; (skribe engine) +; (skribe writer) +; (skribe verify) +; (skribe output) +; (skribe biblio) +; (skribe prog) +; (skribe resolve) +; (skribe source) +; (skribe lisp) +; (skribe xml) +; (skribe c) +; (skribe debug) +; (skribe color)) (use-modules (skribe runtime) (skribe configure) @@ -192,7 +192,7 @@ specifications." (set-skribe-debug! val) (begin ;; Use the symbol for debug - (set-skribe-debug! 1) + (set-skribe-debug! 1) (add-skribe-debug-symbol (string->symbol level)))))) (("no-color" :help "disable coloring for output") (no-debug-color)) @@ -265,7 +265,7 @@ Processes a Skribilo/Skribe source file and produces its output. (let ((s (keyword->string (car x)))) (printf " ~a: ~a\n" s (cadr x)))) (skribe-configure))) - + ;; ;; parse-args starts here ;; @@ -286,21 +286,21 @@ Processes a Skribilo/Skribe source file and produces its output. (("P" :arg path :help "adds to image path") (skribe-image-path-set! (cons path (skribe-image-path)))) (("split-chapters" :alternate "C" :arg chapter - :help "emit chapter's sections in separate files") + :help "emit chapter's sections in separate files") (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) (("preload" :arg file :help "preload ") (set! *skribe-preload* (cons file *skribe-preload*))) (("use-variant" :alternate "u" :arg variant - :help "use output format") + :help "use output format") (set! *skribe-variants* (cons variant *skribe-variants*))) (("base" :alternate "b" :arg base - :help "base prefix to remove from hyperlinks") + :help "base prefix to remove from hyperlinks") (set! *skribe-ref-base* base)) (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to ") (set! *skribe-rc-directory* dir)) - + "File options:" - (("no-init-file" :help "Dont load rc Skribe file") + (("no-init-file" :help "Dont load rc Skribe file") (set! *load-rc* #f)) (("output" :alternate "o" :arg file :help "set the output to ") (set! *skribe-dest* file) @@ -310,7 +310,7 @@ Processes a Skribilo/Skribe source file and produces its output. (set! *skribe-engine* (cdr c))))) "Misc:" - (("help" :alternate "h" :help "provides help for the command") + (("help" :alternate "h" :help "provides help for the command") (arg-usage (current-error-port)) (exit 0)) (("options" :help "display the skribe options and exit") @@ -320,7 +320,7 @@ Processes a Skribilo/Skribe source file and produces its output. (version) (exit 0)) (("query" :alternate "q" - :help "displays informations about Skribe conf.") + :help "displays informations about Skribe conf.") (query) (exit 0)) (("verbose" :alternate "v" :arg level @@ -339,7 +339,7 @@ Processes a Skribilo/Skribe source file and produces its output. (set-skribe-debug! val) (begin ;; Use the symbol for debug - (set-skribe-debug! 1) + (set-skribe-debug! 1) (add-skribe-debug-symbol (string->symbol level)))))) (("no-color" :help "disable coloring for output") (no-debug-color)) @@ -356,10 +356,10 @@ Processes a Skribilo/Skribe source file and produces its output. (lambda () (eval (read))))) (else (set! *skribe-src* other-arguments))) - + ;; we have to configure Skribe path according to the environment variable (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH"))) - (if path + (if path (string-split path ":") '())) (reverse! paths) diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in new file mode 100644 index 0000000..80a26de --- /dev/null +++ b/src/guile/skribilo/Makefile.in @@ -0,0 +1,110 @@ +# +# Makefile.in -- Skribe Src Makefile +# +# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +# +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +# USA. +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 10-Aug-2003 20:26 (eg) +# Last file update: 6-Mar-2004 16:00 (eg) +# +include ../../etc/stklos/Makefile.skb + +prefix=@PREFIX@ + +SKR = $(wildcard ../../skr/*.skr) + +DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ + ../common/index.scm ../common/bib.scm ../common/lib.scm + +SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ + eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ + resolve.stk runtime.stk source.stk types.stk vars.stk \ + verify.stk writer.stk xml.stk + +LEXFILES = c-lex.l lisp-lex.l xml-lex.l + +LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk + +BINDIR=../../bin + +EXE= $(BINDIR)/skribe.stklos + +PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) + +SFLAGS= + +all: $(EXE) + +Makefile: Makefile.in + (cd ../../etc/stklos; autoconf; configure) + +$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) + stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ + chmod $(BMASK) $(EXE) + +# +# Lex files +# +lisp-lex.stk: lisp-lex.l + stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex + +xml-lex.stk: xml-lex.l + stklos-genlex xml-lex.l xml-lex.stk xml-lex + +c-lex.stk: c-lex.l + stklos-genlex c-lex.l c-lex.stk c-lex + + +install: $(INSTALL_BINDIR) + cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ + && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos + rm -f $(INSTALL_BINDIR)/skribe + ln -s skribe.stklos $(INSTALL_BINDIR)/skribe + +uninstall: + rm $(INSTALL_BINDIR)/skribe + rm $(INSTALL_BINDIR)/skribe.stklos + +$(BINDIR): + mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) + +$(INSTALL_BINDIR): + mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) + +## +## Services +## +tags: TAGS + +TAGS: $(SRCS) + etags -l scheme $(SRCS) + +pop: + @echo $(PRCS_FILES:%=src/stklos/%) + +links: + ln -s $(DEPS) . + ln -s $(SKR) . + +clean: + /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr + +distclean: clean + /bin/rm -f Makefile + /bin/rm -f ../common/configure.scm diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm new file mode 100644 index 0000000..0a4fc98 --- /dev/null +++ b/src/guile/skribilo/biblio.scm @@ -0,0 +1,159 @@ +;;; +;;; biblio.scm -- Bibliography functions +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005 Ludovic Courtès +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA.main.st +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 31-Aug-2003 22:07 (eg) +;;; Last file update: 28-Oct-2004 21:19 (eg) +;;; + + + +(define-module (skribilo biblio) + :use-module (skribilo runtime) + :export (bib-tables? make-bib-table default-bib-table + bib-load! resolve-bib resolve-the-bib + bib-sort/authors bib-sort/idents bib-sort/dates)) + +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + + + +;;; ====================================================================== +;;; +;;; Utilities +;;; +;;; ====================================================================== + +(define (make-bib-table ident) + (make-hash-table)) + +(define (bib-table? obj) + (hashtable? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;; +;; Utilities +;; +(define (%bib-error who entry) + (let ((msg "bibliography syntax error on entry")) + (if (%epair? entry) + (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) + (skribe-error who msg entry)))) + +;;; ====================================================================== +;;; +;;; BIB-DUPLICATE +;;; +;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + + +;;; ====================================================================== +;;; +;;; PARSE-BIB +;;; +;;; ====================================================================== +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-file-name port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table key))) + (if old + (bib-duplicate ident from old) + (hash-table-put! table + key + (make-bib-entry kind key fields from))) + (Loop (read port)))) + (else + (%bib-error 'bib-parse entry)))))))) + + +;;; ====================================================================== +;;; +;;; BIB-ADD! +;;; +;;; ====================================================================== +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate key #f old) + (hash-table-put! table + key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + + +;;; ====================================================================== +;;; +;;; SKRIBE-OPEN-BIB-FILE +;;; +;;; ====================================================================== +;; FIXME: Factoriser +(define (skribe-open-bib-file file command) + (let ((path (find-path file *skribe-bib-path*))) + (if (string? path) + (begin + (when (> *skribe-verbose* 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format command path)) + path))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm new file mode 100644 index 0000000..1e762e6 --- /dev/null +++ b/src/guile/skribilo/color.scm @@ -0,0 +1,621 @@ +;;;; +;;;; color.scm -- Skribe Color Management +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 25-Oct-2003 00:10 (eg) +;;;; Last file update: 12-Feb-2004 18:24 (eg) +;;;; + +(define-module (skribilo color) + :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + +(define *used-colors* '()) + +(define *skribe-rgb-alist* '( + ("snow" . "255 250 250") + ("ghostwhite" . "248 248 255") + ("whitesmoke" . "245 245 245") + ("gainsboro" . "220 220 220") + ("floralwhite" . "255 250 240") + ("oldlace" . "253 245 230") + ("linen" . "250 240 230") + ("antiquewhite" . "250 235 215") + ("papayawhip" . "255 239 213") + ("blanchedalmond" . "255 235 205") + ("bisque" . "255 228 196") + ("peachpuff" . "255 218 185") + ("navajowhite" . "255 222 173") + ("moccasin" . "255 228 181") + ("cornsilk" . "255 248 220") + ("ivory" . "255 255 240") + ("lemonchiffon" . "255 250 205") + ("seashell" . "255 245 238") + ("honeydew" . "240 255 240") + ("mintcream" . "245 255 250") + ("azure" . "240 255 255") + ("aliceblue" . "240 248 255") + ("lavender" . "230 230 250") + ("lavenderblush" . "255 240 245") + ("mistyrose" . "255 228 225") + ("white" . "255 255 255") + ("black" . "0 0 0") + ("darkslategrey" . "47 79 79") + ("dimgrey" . "105 105 105") + ("slategrey" . "112 128 144") + ("lightslategrey" . "119 136 153") + ("grey" . "190 190 190") + ("lightgrey" . "211 211 211") + ("midnightblue" . "25 25 112") + ("navy" . "0 0 128") + ("navyblue" . "0 0 128") + ("cornflowerblue" . "100 149 237") + ("darkslateblue" . "72 61 139") + ("slateblue" . "106 90 205") + ("mediumslateblue" . "123 104 238") + ("lightslateblue" . "132 112 255") + ("mediumblue" . "0 0 205") + ("royalblue" . "65 105 225") + ("blue" . "0 0 255") + ("dodgerblue" . "30 144 255") + ("deepskyblue" . "0 191 255") + ("skyblue" . "135 206 235") + ("lightskyblue" . "135 206 250") + ("steelblue" . "70 130 180") + ("lightsteelblue" . "176 196 222") + ("lightblue" . "173 216 230") + ("powderblue" . "176 224 230") + ("paleturquoise" . "175 238 238") + ("darkturquoise" . "0 206 209") + ("mediumturquoise" . "72 209 204") + ("turquoise" . "64 224 208") + ("cyan" . "0 255 255") + ("lightcyan" . "224 255 255") + ("cadetblue" . "95 158 160") + ("mediumaquamarine" . "102 205 170") + ("aquamarine" . "127 255 212") + ("darkgreen" . "0 100 0") + ("darkolivegreen" . "85 107 47") + ("darkseagreen" . "143 188 143") + ("seagreen" . "46 139 87") + ("mediumseagreen" . "60 179 113") + ("lightseagreen" . "32 178 170") + ("palegreen" . "152 251 152") + ("springgreen" . "0 255 127") + ("lawngreen" . "124 252 0") + ("green" . "0 255 0") + ("chartreuse" . "127 255 0") + ("mediumspringgreen" . "0 250 154") + ("greenyellow" . "173 255 47") + ("limegreen" . "50 205 50") + ("yellowgreen" . "154 205 50") + ("forestgreen" . "34 139 34") + ("olivedrab" . "107 142 35") + ("darkkhaki" . "189 183 107") + ("khaki" . "240 230 140") + ("palegoldenrod" . "238 232 170") + ("lightgoldenrodyellow" . "250 250 210") + ("lightyellow" . "255 255 224") + ("yellow" . "255 255 0") + ("gold" . "255 215 0") + ("lightgoldenrod" . "238 221 130") + ("goldenrod" . "218 165 32") + ("darkgoldenrod" . "184 134 11") + ("rosybrown" . "188 143 143") + ("indianred" . "205 92 92") + ("saddlebrown" . "139 69 19") + ("sienna" . "160 82 45") + ("peru" . "205 133 63") + ("burlywood" . "222 184 135") + ("beige" . "245 245 220") + ("wheat" . "245 222 179") + ("sandybrown" . "244 164 96") + ("tan" . "210 180 140") + ("chocolate" . "210 105 30") + ("firebrick" . "178 34 34") + ("brown" . "165 42 42") + ("darksalmon" . "233 150 122") + ("salmon" . "250 128 114") + ("lightsalmon" . "255 160 122") + ("orange" . "255 165 0") + ("darkorange" . "255 140 0") + ("coral" . "255 127 80") + ("lightcoral" . "240 128 128") + ("tomato" . "255 99 71") + ("orangered" . "255 69 0") + ("red" . "255 0 0") + ("hotpink" . "255 105 180") + ("deeppink" . "255 20 147") + ("pink" . "255 192 203") + ("lightpink" . "255 182 193") + ("palevioletred" . "219 112 147") + ("maroon" . "176 48 96") + ("mediumvioletred" . "199 21 133") + ("violetred" . "208 32 144") + ("magenta" . "255 0 255") + ("violet" . "238 130 238") + ("plum" . "221 160 221") + ("orchid" . "218 112 214") + ("mediumorchid" . "186 85 211") + ("darkorchid" . "153 50 204") + ("darkviolet" . "148 0 211") + ("blueviolet" . "138 43 226") + ("purple" . "160 32 240") + ("mediumpurple" . "147 112 219") + ("thistle" . "216 191 216") + ("snow1" . "255 250 250") + ("snow2" . "238 233 233") + ("snow3" . "205 201 201") + ("snow4" . "139 137 137") + ("seashell1" . "255 245 238") + ("seashell2" . "238 229 222") + ("seashell3" . "205 197 191") + ("seashell4" . "139 134 130") + ("antiquewhite1" . "255 239 219") + ("antiquewhite2" . "238 223 204") + ("antiquewhite3" . "205 192 176") + ("antiquewhite4" . "139 131 120") + ("bisque1" . "255 228 196") + ("bisque2" . "238 213 183") + ("bisque3" . "205 183 158") + ("bisque4" . "139 125 107") + ("peachpuff1" . "255 218 185") + ("peachpuff2" . "238 203 173") + ("peachpuff3" . "205 175 149") + ("peachpuff4" . "139 119 101") + ("navajowhite1" . "255 222 173") + ("navajowhite2" . "238 207 161") + ("navajowhite3" . "205 179 139") + ("navajowhite4" . "139 121 94") + ("lemonchiffon1" . "255 250 205") + ("lemonchiffon2" . "238 233 191") + ("lemonchiffon3" . "205 201 165") + ("lemonchiffon4" . "139 137 112") + ("cornsilk1" . "255 248 220") + ("cornsilk2" . "238 232 205") + ("cornsilk3" . "205 200 177") + ("cornsilk4" . "139 136 120") + ("ivory1" . "255 255 240") + ("ivory2" . "238 238 224") + ("ivory3" . "205 205 193") + ("ivory4" . "139 139 131") + ("honeydew1" . "240 255 240") + ("honeydew2" . "224 238 224") + ("honeydew3" . "193 205 193") + ("honeydew4" . "131 139 131") + ("lavenderblush1" . "255 240 245") + ("lavenderblush2" . "238 224 229") + ("lavenderblush3" . "205 193 197") + ("lavenderblush4" . "139 131 134") + ("mistyrose1" . "255 228 225") + ("mistyrose2" . "238 213 210") + ("mistyrose3" . "205 183 181") + ("mistyrose4" . "139 125 123") + ("azure1" . "240 255 255") + ("azure2" . "224 238 238") + ("azure3" . "193 205 205") + ("azure4" . "131 139 139") + ("slateblue1" . "131 111 255") + ("slateblue2" . "122 103 238") + ("slateblue3" . "105 89 205") + ("slateblue4" . "71 60 139") + ("royalblue1" . "72 118 255") + ("royalblue2" . "67 110 238") + ("royalblue3" . "58 95 205") + ("royalblue4" . "39 64 139") + ("blue1" . "0 0 255") + ("blue2" . "0 0 238") + ("blue3" . "0 0 205") + ("blue4" . "0 0 139") + ("dodgerblue1" . "30 144 255") + ("dodgerblue2" . "28 134 238") + ("dodgerblue3" . "24 116 205") + ("dodgerblue4" . "16 78 139") + ("steelblue1" . "99 184 255") + ("steelblue2" . "92 172 238") + ("steelblue3" . "79 148 205") + ("steelblue4" . "54 100 139") + ("deepskyblue1" . "0 191 255") + ("deepskyblue2" . "0 178 238") + ("deepskyblue3" . "0 154 205") + ("deepskyblue4" . "0 104 139") + ("skyblue1" . "135 206 255") + ("skyblue2" . "126 192 238") + ("skyblue3" . "108 166 205") + ("skyblue4" . "74 112 139") + ("lightskyblue1" . "176 226 255") + ("lightskyblue2" . "164 211 238") + ("lightskyblue3" . "141 182 205") + ("lightskyblue4" . "96 123 139") + ("lightsteelblue1" . "202 225 255") + ("lightsteelblue2" . "188 210 238") + ("lightsteelblue3" . "162 181 205") + ("lightsteelblue4" . "110 123 139") + ("lightblue1" . "191 239 255") + ("lightblue2" . "178 223 238") + ("lightblue3" . "154 192 205") + ("lightblue4" . "104 131 139") + ("lightcyan1" . "224 255 255") + ("lightcyan2" . "209 238 238") + ("lightcyan3" . "180 205 205") + ("lightcyan4" . "122 139 139") + ("paleturquoise1" . "187 255 255") + ("paleturquoise2" . "174 238 238") + ("paleturquoise3" . "150 205 205") + ("paleturquoise4" . "102 139 139") + ("cadetblue1" . "152 245 255") + ("cadetblue2" . "142 229 238") + ("cadetblue3" . "122 197 205") + ("cadetblue4" . "83 134 139") + ("turquoise1" . "0 245 255") + ("turquoise2" . "0 229 238") + ("turquoise3" . "0 197 205") + ("turquoise4" . "0 134 139") + ("cyan1" . "0 255 255") + ("cyan2" . "0 238 238") + ("cyan3" . "0 205 205") + ("cyan4" . "0 139 139") + ("aquamarine1" . "127 255 212") + ("aquamarine2" . "118 238 198") + ("aquamarine3" . "102 205 170") + ("aquamarine4" . "69 139 116") + ("darkseagreen1" . "193 255 193") + ("darkseagreen2" . "180 238 180") + ("darkseagreen3" . "155 205 155") + ("darkseagreen4" . "105 139 105") + ("seagreen1" . "84 255 159") + ("seagreen2" . "78 238 148") + ("seagreen3" . "67 205 128") + ("seagreen4" . "46 139 87") + ("palegreen1" . "154 255 154") + ("palegreen2" . "144 238 144") + ("palegreen3" . "124 205 124") + ("palegreen4" . "84 139 84") + ("springgreen1" . "0 255 127") + ("springgreen2" . "0 238 118") + ("springgreen3" . "0 205 102") + ("springgreen4" . "0 139 69") + ("green1" . "0 255 0") + ("green2" . "0 238 0") + ("green3" . "0 205 0") + ("green4" . "0 139 0") + ("chartreuse1" . "127 255 0") + ("chartreuse2" . "118 238 0") + ("chartreuse3" . "102 205 0") + ("chartreuse4" . "69 139 0") + ("olivedrab1" . "192 255 62") + ("olivedrab2" . "179 238 58") + ("olivedrab3" . "154 205 50") + ("olivedrab4" . "105 139 34") + ("darkolivegreen1" . "202 255 112") + ("darkolivegreen2" . "188 238 104") + ("darkolivegreen3" . "162 205 90") + ("darkolivegreen4" . "110 139 61") + ("khaki1" . "255 246 143") + ("khaki2" . "238 230 133") + ("khaki3" . "205 198 115") + ("khaki4" . "139 134 78") + ("lightgoldenrod1" . "255 236 139") + ("lightgoldenrod2" . "238 220 130") + ("lightgoldenrod3" . "205 190 112") + ("lightgoldenrod4" . "139 129 76") + ("lightyellow1" . "255 255 224") + ("lightyellow2" . "238 238 209") + ("lightyellow3" . "205 205 180") + ("lightyellow4" . "139 139 122") + ("yellow1" . "255 255 0") + ("yellow2" . "238 238 0") + ("yellow3" . "205 205 0") + ("yellow4" . "139 139 0") + ("gold1" . "255 215 0") + ("gold2" . "238 201 0") + ("gold3" . "205 173 0") + ("gold4" . "139 117 0") + ("goldenrod1" . "255 193 37") + ("goldenrod2" . "238 180 34") + ("goldenrod3" . "205 155 29") + ("goldenrod4" . "139 105 20") + ("darkgoldenrod1" . "255 185 15") + ("darkgoldenrod2" . "238 173 14") + ("darkgoldenrod3" . "205 149 12") + ("darkgoldenrod4" . "139 101 8") + ("rosybrown1" . "255 193 193") + ("rosybrown2" . "238 180 180") + ("rosybrown3" . "205 155 155") + ("rosybrown4" . "139 105 105") + ("indianred1" . "255 106 106") + ("indianred2" . "238 99 99") + ("indianred3" . "205 85 85") + ("indianred4" . "139 58 58") + ("sienna1" . "255 130 71") + ("sienna2" . "238 121 66") + ("sienna3" . "205 104 57") + ("sienna4" . "139 71 38") + ("burlywood1" . "255 211 155") + ("burlywood2" . "238 197 145") + ("burlywood3" . "205 170 125") + ("burlywood4" . "139 115 85") + ("wheat1" . "255 231 186") + ("wheat2" . "238 216 174") + ("wheat3" . "205 186 150") + ("wheat4" . "139 126 102") + ("tan1" . "255 165 79") + ("tan2" . "238 154 73") + ("tan3" . "205 133 63") + ("tan4" . "139 90 43") + ("chocolate1" . "255 127 36") + ("chocolate2" . "238 118 33") + ("chocolate3" . "205 102 29") + ("chocolate4" . "139 69 19") + ("firebrick1" . "255 48 48") + ("firebrick2" . "238 44 44") + ("firebrick3" . "205 38 38") + ("firebrick4" . "139 26 26") + ("brown1" . "255 64 64") + ("brown2" . "238 59 59") + ("brown3" . "205 51 51") + ("brown4" . "139 35 35") + ("salmon1" . "255 140 105") + ("salmon2" . "238 130 98") + ("salmon3" . "205 112 84") + ("salmon4" . "139 76 57") + ("lightsalmon1" . "255 160 122") + ("lightsalmon2" . "238 149 114") + ("lightsalmon3" . "205 129 98") + ("lightsalmon4" . "139 87 66") + ("orange1" . "255 165 0") + ("orange2" . "238 154 0") + ("orange3" . "205 133 0") + ("orange4" . "139 90 0") + ("darkorange1" . "255 127 0") + ("darkorange2" . "238 118 0") + ("darkorange3" . "205 102 0") + ("darkorange4" . "139 69 0") + ("coral1" . "255 114 86") + ("coral2" . "238 106 80") + ("coral3" . "205 91 69") + ("coral4" . "139 62 47") + ("tomato1" . "255 99 71") + ("tomato2" . "238 92 66") + ("tomato3" . "205 79 57") + ("tomato4" . "139 54 38") + ("orangered1" . "255 69 0") + ("orangered2" . "238 64 0") + ("orangered3" . "205 55 0") + ("orangered4" . "139 37 0") + ("red1" . "255 0 0") + ("red2" . "238 0 0") + ("red3" . "205 0 0") + ("red4" . "139 0 0") + ("deeppink1" . "255 20 147") + ("deeppink2" . "238 18 137") + ("deeppink3" . "205 16 118") + ("deeppink4" . "139 10 80") + ("hotpink1" . "255 110 180") + ("hotpink2" . "238 106 167") + ("hotpink3" . "205 96 144") + ("hotpink4" . "139 58 98") + ("pink1" . "255 181 197") + ("pink2" . "238 169 184") + ("pink3" . "205 145 158") + ("pink4" . "139 99 108") + ("lightpink1" . "255 174 185") + ("lightpink2" . "238 162 173") + ("lightpink3" . "205 140 149") + ("lightpink4" . "139 95 101") + ("palevioletred1" . "255 130 171") + ("palevioletred2" . "238 121 159") + ("palevioletred3" . "205 104 137") + ("palevioletred4" . "139 71 93") + ("maroon1" . "255 52 179") + ("maroon2" . "238 48 167") + ("maroon3" . "205 41 144") + ("maroon4" . "139 28 98") + ("violetred1" . "255 62 150") + ("violetred2" . "238 58 140") + ("violetred3" . "205 50 120") + ("violetred4" . "139 34 82") + ("magenta1" . "255 0 255") + ("magenta2" . "238 0 238") + ("magenta3" . "205 0 205") + ("magenta4" . "139 0 139") + ("orchid1" . "255 131 250") + ("orchid2" . "238 122 233") + ("orchid3" . "205 105 201") + ("orchid4" . "139 71 137") + ("plum1" . "255 187 255") + ("plum2" . "238 174 238") + ("plum3" . "205 150 205") + ("plum4" . "139 102 139") + ("mediumorchid1" . "224 102 255") + ("mediumorchid2" . "209 95 238") + ("mediumorchid3" . "180 82 205") + ("mediumorchid4" . "122 55 139") + ("darkorchid1" . "191 62 255") + ("darkorchid2" . "178 58 238") + ("darkorchid3" . "154 50 205") + ("darkorchid4" . "104 34 139") + ("purple1" . "155 48 255") + ("purple2" . "145 44 238") + ("purple3" . "125 38 205") + ("purple4" . "85 26 139") + ("mediumpurple1" . "171 130 255") + ("mediumpurple2" . "159 121 238") + ("mediumpurple3" . "137 104 205") + ("mediumpurple4" . "93 71 139") + ("thistle1" . "255 225 255") + ("thistle2" . "238 210 238") + ("thistle3" . "205 181 205") + ("thistle4" . "139 123 139") + ("grey0" . "0 0 0") + ("grey1" . "3 3 3") + ("grey2" . "5 5 5") + ("grey3" . "8 8 8") + ("grey4" . "10 10 10") + ("grey5" . "13 13 13") + ("grey6" . "15 15 15") + ("grey7" . "18 18 18") + ("grey8" . "20 20 20") + ("grey9" . "23 23 23") + ("grey10" . "26 26 26") + ("grey11" . "28 28 28") + ("grey12" . "31 31 31") + ("grey13" . "33 33 33") + ("grey14" . "36 36 36") + ("grey15" . "38 38 38") + ("grey16" . "41 41 41") + ("grey17" . "43 43 43") + ("grey18" . "46 46 46") + ("grey19" . "48 48 48") + ("grey20" . "51 51 51") + ("grey21" . "54 54 54") + ("grey22" . "56 56 56") + ("grey23" . "59 59 59") + ("grey24" . "61 61 61") + ("grey25" . "64 64 64") + ("grey26" . "66 66 66") + ("grey27" . "69 69 69") + ("grey28" . "71 71 71") + ("grey29" . "74 74 74") + ("grey30" . "77 77 77") + ("grey31" . "79 79 79") + ("grey32" . "82 82 82") + ("grey33" . "84 84 84") + ("grey34" . "87 87 87") + ("grey35" . "89 89 89") + ("grey36" . "92 92 92") + ("grey37" . "94 94 94") + ("grey38" . "97 97 97") + ("grey39" . "99 99 99") + ("grey40" . "102 102 102") + ("grey41" . "105 105 105") + ("grey42" . "107 107 107") + ("grey43" . "110 110 110") + ("grey44" . "112 112 112") + ("grey45" . "115 115 115") + ("grey46" . "117 117 117") + ("grey47" . "120 120 120") + ("grey48" . "122 122 122") + ("grey49" . "125 125 125") + ("grey50" . "127 127 127") + ("grey51" . "130 130 130") + ("grey52" . "133 133 133") + ("grey53" . "135 135 135") + ("grey54" . "138 138 138") + ("grey55" . "140 140 140") + ("grey56" . "143 143 143") + ("grey57" . "145 145 145") + ("grey58" . "148 148 148") + ("grey59" . "150 150 150") + ("grey60" . "153 153 153") + ("grey61" . "156 156 156") + ("grey62" . "158 158 158") + ("grey63" . "161 161 161") + ("grey64" . "163 163 163") + ("grey65" . "166 166 166") + ("grey66" . "168 168 168") + ("grey67" . "171 171 171") + ("grey68" . "173 173 173") + ("grey69" . "176 176 176") + ("grey70" . "179 179 179") + ("grey71" . "181 181 181") + ("grey72" . "184 184 184") + ("grey73" . "186 186 186") + ("grey74" . "189 189 189") + ("grey75" . "191 191 191") + ("grey76" . "194 194 194") + ("grey77" . "196 196 196") + ("grey78" . "199 199 199") + ("grey79" . "201 201 201") + ("grey80" . "204 204 204") + ("grey81" . "207 207 207") + ("grey82" . "209 209 209") + ("grey83" . "212 212 212") + ("grey84" . "214 214 214") + ("grey85" . "217 217 217") + ("grey86" . "219 219 219") + ("grey87" . "222 222 222") + ("grey88" . "224 224 224") + ("grey89" . "227 227 227") + ("grey90" . "229 229 229") + ("grey91" . "232 232 232") + ("grey92" . "235 235 235") + ("grey93" . "237 237 237") + ("grey94" . "240 240 240") + ("grey95" . "242 242 242") + ("grey96" . "245 245 245") + ("grey97" . "247 247 247") + ("grey98" . "250 250 250") + ("grey99" . "252 252 252") + ("grey100" . "255 255 255") + ("darkgrey" . "169 169 169") + ("darkblue" . "0 0 139") + ("darkcyan" . "0 139 139") + ("darkmagenta" . "139 0 139") + ("darkred" . "139 0 0") + ("lightgreen" . "144 238 144"))) + + +(define (%convert-color str) + (let ((col (assoc str *skribe-rgb-alist*))) + (cond + (col + (let* ((p (open-input-string (cdr col))) + (r (read p)) + (g (read p)) + (b (read p))) + (values r g b))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7)) + (values (string->number (substring str 1 3) 16) + (string->number (substring str 3 5) 16) + (string->number (substring str 5 7) 16))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13)) + (values (string->number (substring str 1 5) 16) + (string->number (substring str 5 9) 16) + (string->number (substring str 9 13) 16))) + (else + (values 0 0 0))))) + +;;; +;;; SKRIBE-COLOR->RGB +;;; +(define (skribe-color->rgb spec) + (cond + ((string? spec) (%convert-color spec)) + ((integer? spec) + (values (bit-and #xff (bit-shift spec -16)) + (bit-and #xff (bit-shift spec -8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;;; +;;; SKRIBE-GET-USED-COLORS +;;; +(define (skribe-get-used-colors) + *used-colors*) + +;;; +;;; SKRIBE-USE-COLOR! +;;; +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) + diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l new file mode 100644 index 0000000..a5b337e --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l @@ -0,0 +1,67 @@ +;;;; +;;;; c-lex.l -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + + + + + + \ No newline at end of file diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm new file mode 100644 index 0000000..baa3e53 --- /dev/null +++ b/src/guile/skribilo/coloring/c.scm @@ -0,0 +1,93 @@ +;;;; +;;;; c.stk -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:12 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module (skribilo c) + :export (c java) + :import (skribe runtime)) + +(include "c-lex.stk") ;; SILex generated + + +(define *the-keys* #f) + +(define *c-keys* #f) +(define *java-keys* #f) + + +(define (fontifier s) + (let ((lex (c-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; C +;;;; +;;;; ====================================================================== +(define (init-c-keys) + (unless *c-keys* + (set! *c-keys* '(for while return break continue void + do if else typedef struct union goto switch case + static extern default))) + *c-keys*) + +(define (c-fontifier s) + (fluid-let ((*the-keys* (init-c-keys))) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;;;; ====================================================================== +;;;; +;;;; JAVA +;;;; +;;;; ====================================================================== +(define (init-java-keys) + (unless *java-keys* + (set! *java-keys* (append (init-c-keys) + '(public final class throw catch)))) + *java-keys*) + +(define (java-fontifier s) + (fluid-let ((*the-keys* (init-java-keys))) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) + diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l new file mode 100644 index 0000000..efad24b --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l @@ -0,0 +1,91 @@ +;;;; -*- Scheme -*- +;;;; +;;;; lisp-lex.l -- SILex input for the Lisp Languages +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm new file mode 100644 index 0000000..53cf670 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp.scm @@ -0,0 +1,293 @@ +;;;; +;;;; lisp.stk -- Lisp Family Fontification +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 16-Oct-2003 22:17 (eg) +;;;; Last file update: 28-Oct-2004 21:14 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module (skribilo lisp) + :export (skribe scheme stklos bigloo lisp) + :import (skribe source)) + +(include "lisp-lex.stk") ;; SILex generated + +(define *bracket-highlight* #f) +(define *class-highlight* #f) +(define *the-keys* #f) + +(define *lisp-keys* #f) +(define *scheme-keys* #f) +(define *skribe-keys* #f) +(define *stklos-keys* #f) +(define *lisp-keys* #f) + + +;;; +;;; DEFINITION-SEARCH +;;; +(define (definition-search inp tab test) + (let Loop ((exp (%read inp))) + (unless (eof-object? exp) + (if (test exp) + (let ((start (and (%epair? exp) (%epair-line exp))) + (stop (port-current-line inp))) + (source-read-lines (port-file-name inp) start stop tab)) + (Loop (%read inp)))))) + + +(define (lisp-family-fontifier s) + (let ((lex (lisp-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; LISP +;;;; +;;;; ====================================================================== +(define (lisp-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (and (eq? def fun) exp)) + ((defvar ?var . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define (init-lisp-keys) + (unless *lisp-keys* + (set! *lisp-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(setq if let let* letrec cond case else progn lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(defun defclass defmacro))))) + *lisp-keys*) + +(define (lisp-fontifier s) + (fluid-let ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SCHEME +;;;; +;;;; ====================================================================== +(define (scheme-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-scheme-keys) + (unless *scheme-keys* + (set! *scheme-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(set! if let let* letrec quote cond case else begin do lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(define define-syntax))))) + *scheme-keys*) + + +(define (scheme-fontifier s) + (fluid-let ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;;;; ====================================================================== +;;;; +;;;; STKLOS +;;;; +;;;; ====================================================================== +(define (stklos-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-generic define-method define-macro) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-module) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-stklos-keys) + (unless *stklos-keys* + (init-scheme-keys) + (set! *stklos-keys* (append *scheme-keys* + ;; Markups + (map (lambda (x) (cons x '&source-key)) + '(select-module import export)) + ;; Key + (map (lambda (x) (cons x '&source-keyword)) + '(case-lambda dotimes match-case match-lambda)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-generic define-class + define-macro define-method define-module)) + ;; error + (map (lambda (x) (cons x '&source-error)) + '(error call/cc))))) + *stklos-keys*) + + +(define (stklos-fontifier s) + (fluid-let ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define stklos + (new language + (name "stklos") + (fontifier stklos-fontifier) + (extractor stklos-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SKRIBE +;;;; +;;;; ====================================================================== +(define (skribe-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + ((markup-output (quote ?mk) . ?-) + (and (eq? mk def) exp)) + (else + #f))))) + + +(define (init-skribe-keys) + (unless *skribe-keys* + (init-stklos-keys) + (set! *skribe-keys* (append *stklos-keys* + ;; Markups + (map (lambda (x) (cons x '&source-markup)) + '(bold it emph tt color ref index underline + roman figure center pre flush hrule + linebreak image kbd code var samp + sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font + document chapter section subsection + subsubsection paragraph p handle resolve + processor abstract margin toc + table-of-contents current-document + current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-markup))))) + *skribe-keys*) + + +(define (skribe-fontifier s) + (fluid-let ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;;;; ====================================================================== +;;;; +;;;; BIGLOO +;;;; +;;;; ====================================================================== +(define (bigloo-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) + diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l new file mode 100644 index 0000000..5d9a8d9 --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<> 'eof +<> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + + \ No newline at end of file diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm new file mode 100644 index 0000000..d71e98c --- /dev/null +++ b/src/guile/skribilo/coloring/xml.scm @@ -0,0 +1,53 @@ +;;;; +;;;; xml.stk -- XML Fontification stuff +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 16-Oct-2003 22:33 (eg) +;;;; Last file update: 28-Dec-2003 17:33 (eg) +;;;; + + +;(require "lex-rt") ;; to avoid module problems + + +(define-module (skribilo xml) + :export (xml)) + +(use-modules (skribilo source)) + +(include "xml-lex.stk") ;; SILex generated + +(define (xml-fontifier s) + (let ((lex (xml-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + + +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) + diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in new file mode 100644 index 0000000..6e40e7f --- /dev/null +++ b/src/guile/skribilo/config.scm.in @@ -0,0 +1,21 @@ +;;; -*- Scheme -*- +;;; + +(define-module (skribilo config)) + +(define-public (skribilo-release) "1.3") +(define-public (skribilo-url) "http://www.laas.fr/~lcourtes/") +(define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") +(define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") +(define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@") +(define-public (skribilo-scheme) "guile") + + +;; Compatibility. + +(define-public skribe-release skribilo-release) +(define-public skribe-url skribilo-url) +(define-public skribe-doc-dir skribilo-doc-directory) +(define-public skribe-ext-dir skribilo-extension-directory) +(define-public skribe-default-path skribilo-default-path) +(define-public skribe-scheme skribilo-scheme) diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm new file mode 100644 index 0000000..1a5478e --- /dev/null +++ b/src/guile/skribilo/debug.scm @@ -0,0 +1,161 @@ +;;; +;;; debug.scm -- Debug Facilities (stolen to Manuel Serrano) +;;; +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 10-Aug-2003 20:45 (eg) +;;; Last file update: 28-Oct-2004 13:16 (eg) +;;; + + +(define-module (skribilo debug) + :export (with-debug %with-debug + debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol + no-debug-color)) + + +(define *skribe-debug* 0) +(define *skribe-debug-symbols* '()) +(define *skribe-debug-color* #t) +(define *skribe-debug-item* #f) +(define *debug-port* (current-error-port)) +(define *debug-depth* 0) +(define *debug-margin* "") +(define *skribe-margin-debug-level* 0) + + +(define (set-skribe-debug! val) + (set! *skribe-debug* val)) + +(define (add-skribe-debug-symbol s) + (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*))) + + +(define (no-debug-color) + (set! *skribe-debug-color* #f)) + +(define (skribe-debug) + *skribe-debug*) + +;; +;; debug-port +;; +; (define (debug-port . o) +; (cond +; ((null? o) +; *debug-port*) +; ((output-port? (car o)) +; (set! *debug-port* o) +; o) +; (else +; (error 'debug-port "Illegal debug port" (car o))))) +; + +;;; +;;; debug-color +;;; +(define (debug-color col . o) + (with-output-to-string + (if (and *skribe-debug-color* + (equal? (getenv "TERM") "xterm") + (interactive-port? *debug-port*)) + (lambda () + (format #t "[1;~Am" (+ 31 col)) + (for-each display o) + (display "")) + (lambda () + (for-each display o))))) + +;;; +;;; debug-bold +;;; +(define (debug-bold . o) + (apply debug-color -30 o)) + +;;; +;;; debug-item +;;; +(define (debug-item . args) + (if (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (begin + (display *debug-margin* *debug-port*) + (display (debug-color (- *debug-depth* 1) "- ") *debug-port*) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*)))) + +;;(define-macro (debug-item . args) +;; `()) + +;;; +;;; %with-debug-margin +;;; +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+ *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (- *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;;; +;;; %with-debug +;; +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (begin + (display *debug-margin* *debug-port*) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl)) + *debug-port*) + (newline *debug-port*) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk)) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +(define-macro (with-debug level label . body) + `(%with-debug ,level ,label (lambda () ,@body))) + +;;(define-macro (with-debug level label . body) +;; `(begin ,@body)) + + +; Example: + +; (with-debug 0 'foo1.1 +; (debug-item 'foo2.1) +; (debug-item 'foo2.2) +; (with-debug 0 'foo2.3 +; (debug-item 'foo3.1) +; (with-debug 0 'foo3.2 +; (debug-item 'foo4.1) +; (debug-item 'foo4.2)) +; (debug-item 'foo3.3)) +; (debug-item 'foo2.4)) diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm new file mode 100644 index 0000000..9584f5e --- /dev/null +++ b/src/guile/skribilo/engine.scm @@ -0,0 +1,251 @@ +;;; +;;; engine.scm -- Skribe Engines Stuff +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 24-Jul-2003 20:33 (eg) +;;; Last file update: 28-Oct-2004 21:21 (eg) +;;; + +(define-module (skribilo engine) + :use-module (skribilo debug) +; :use-module (skribilo eval) + :use-module (skribilo writer) + :use-module (skribilo types) + + :use-module (oop goops) + :use-module (ice-9 optargs) + + :export (default-engine default-engine-set! + make-engine copy-engine find-engine lookup-engine + engine-custom engine-custom-set! + engine-format? engine-add-writer! + processor-get-engine + push-default-engine pop-default-engine)) + + + + +;;; Module definition is split here because this file is read by the +;;; documentation Should be changed. +;(select-module SKRIBE-ENGINE-MODULE) + +(define *engines* '()) +(define *default-engine* #f) +(define *default-engines* '()) + + +(define (default-engine) + *default-engine*) + + +(define (default-engine-set! e) + (if (not (engine? e)) + (skribe-error 'default-engine-set! "bad engine ~S" e)) + (set! *default-engine* e) + (set! *default-engines* (cons e *default-engines*)) + e) + + +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + + +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + + +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + ((engine? *skribe-engine*) *skribe-engine*) + (else (find-engine *skribe-engine*))))) + (if (not (engine? e)) + (skribe-error 'engine-format? "No engine" e) + (string=? fmt (engine-format e))))) + +;;; +;;; MAKE-ENGINE +;;; +(define* (make-engine ident #:key (version 'unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (make :ident ident :version version :format format + :filter filter :delegate delegate + :symbol-table symbol-table + :custom custom :info info))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + + +;;; +;;; COPY-ENGINE +;;; +(define* (copy-engine ident e #:key (version 'unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((new (shallow-clone e))) + (slot-set! new 'ident ident) + (slot-set! new 'version version) + (slot-set! new 'filter (or filter (slot-ref e 'filter))) + (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) + (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) + (slot-set! new 'customs (or custom (slot-ref e 'customs))) + + (set! *engines* (cons new *engines*)) + new)) + + +;;; +;;; FIND-ENGINE +;;; +(define (%find-loaded-engine id version) + (let loop ((es *engines*)) + (cond + ((null? es) #f) + ((eq? (slot-ref (car es) 'ident) id) + (cond + ((eq? version 'unspecified) (car es)) + ((eq? version (slot-ref (car es) 'version)) (car es)) + (else (Loop (cdr es))))) + (else (loop (cdr es)))))) + + +(define* (find-engine id #:key (version 'unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + + (or (%find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and c (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (%find-loaded-engine id version)) + #f))))) + +(define lookup-engine find-engine) + + +;;; +;;; ENGINE-CUSTOM +;;; +(define (engine-custom e id) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (cadr c) + 'unspecified))) + + +;;; +;;; ENGINE-CUSTOM-SET! +;;; +(define (engine-custom-set! e id val) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (slot-set! e 'customs (cons (list id val) customs))))) + + +;;; +;;; ENGINE-ADD-WRITER! +;;; +(define (engine-add-writer! e ident pred upred opt before action after class valid) + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (if (not (is-a? e )) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (check-procedure "predicate" pred 2) + + ;; check the correctness of the validation proc + (if valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (slot-set! e 'writers (cons n (slot-ref e 'writers))) + n)) + +;;; ====================================================================== +;;; +;;; I N I T S +;;; +;;; ====================================================================== + +;; A base engine must pre-exist before anything is loaded. In +;; particular, this dummy base engine is used to load the actual +;; definition of base. + +(make-engine 'base :version 'bootstrap) diff --git a/src/guile/skribilo/eval.scm b/src/guile/skribilo/eval.scm new file mode 100644 index 0000000..8bae8ad --- /dev/null +++ b/src/guile/skribilo/eval.scm @@ -0,0 +1,186 @@ +;;; +;;; eval.stk -- Skribe Evaluator +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; + + + +;; FIXME; On peut implémenter maintenant skribe-warning/node + + +(define-module (skribilo eval) + :export (skribe-eval skribe-eval-port skribe-load skribe-load-options + skribe-include + + run-time-module make-run-time-module)) + +(use-modules (skribilo debug) + (skribilo engine) + (skribilo verify) + (skribilo resolve) + (skribilo output) + (ice-9 optargs)) + + +(define *skribe-loaded* '()) ;; List of already loaded files +(define *skribe-load-options* '()) + +(define (%evaluate expr) + (eval expr (current-module))) + + +(define *skribilo-user-module* #f) + +(define *skribilo-user-imports* + '((srfi srfi-1) + (oop goops) + (skribilo module) + (skribilo config) + (skribilo vars) + (skribilo runtime) + (skribilo biblio) + (skribilo lib) + (skribilo resolve))) + + +;;; +;;; MAKE-RUN-TIME-MODULE +;;; +(define (make-run-time-module) + "Return a new module that imports all the necessary bindings required for +execution of Skribilo/Skribe code." + (let ((the-module (make-module))) + (for-each (lambda (iface) + (module-use! the-module (resolve-module iface))) + *skribilo-user-imports*) + (set-module-name! the-module '(skribilo-user)) + the-module)) + +;;; +;;; RUN-TIME-MODULE +;;; +(define (run-time-module) + "Return the default instance of a Skribilo/Skribe run-time module." + (if (not *skribilo-user-module*) + (set! *skribilo-user-module* (make-run-time-module))) + *skribilo-user-module*) + +;;; +;;; SKRIBE-EVAL +;;; +(define* (skribe-eval a e #:key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;;; +;;; SKRIBE-EVAL-PORT +;;; +(define* (skribe-eval-port port engine #:key (env '())) + (with-debug 2 'skribe-eval-port + (debug-item "engine=" engine) + (let ((e (if (symbol? engine) (find-engine engine) engine))) + (debug-item "e=" e) + (if (not (is-a? e )) + (skribe-error 'skribe-eval-port "Cannot find engine" engine) + (let loop ((exp (read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (skribe-eval (%evaluate exp) e :env env) + (loop (read port)))))))) + +;;; +;;; SKRIBE-LOAD +;;; +(define *skribe-load-options* '()) + +(define (skribe-load-options) + *skribe-load-options*) + +(define* (skribe-load file #:key (engine #f) (path #f) #:rest opt) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + + (let* ((ei (cond + ((not engine) *skribe-engine*) + ((engine? engine) engine) + ((not (symbol? engine)) (skribe-error 'skribe-load + "Illegal engine" engine)) + (else engine))) + (path (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else path))) + (filep (find-path file path))) + + (set! *skribe-load-options* opt) + + (unless (and (string? filep) (file-exists? filep)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + *skribe-path*)) + + ;; Load this file if not already done + (unless (member filep *skribe-loaded*) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + ;; Load it + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))) + (set! *skribe-loaded* (cons filep *skribe-loaded*)))))) + +;;; +;;; SKRIBE-INCLUDE +;;; +(define* (skribe-include file #:optional (path (skribe-path))) + (unless (every string? path) + (skribe-error 'skribe-include "Illegal path" path)) + + (let ((path (find-path file path))) + (unless (and (string? path) (file-exists? path)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + path)) + (when (> *skribe-verbose* 0) + (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path + (lambda () + (let Loop ((exp (read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (read (current-input-port)) + (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm new file mode 100644 index 0000000..26b348a --- /dev/null +++ b/src/guile/skribilo/lib.scm @@ -0,0 +1,360 @@ +;;; +;;; lib.stk -- Utilities +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 11-Aug-2003 20:29 (eg) +;;; Last file update: 27-Oct-2004 12:41 (eg) +;;; + +(read-set! keywords 'prefix) + +(define-module (skribilo lib) + :export (skribe-eval-location skribe-ast-error skribe-error + skribe-type-error skribe-line-error + skribe-warning skribe-warning/ast + skribe-message + + skribe-path skribe-path-set! + skribe-image-path skribe-image-path-set! + skribe-bib-path skribe-bib-path-set! + skribe-source-path skribe-source-path-set! + + ;; various utilities for compatiblity + + substring=? + file-suffix file-prefix prefix suffix + directory->list find-file/path + printf fprintf + any? every? + process-input-port process-output-port process-error-port + + make-hashtable hashtable? + hashtable-get hashtable-put! hashtable-update! + hashtable->list + + find-runtime-type) + + :export-syntax (new define-markup define-simple-markup + define-simple-container define-processor-markup + + ;; for compatibility + unwind-protect unless when) + + :use-module (srfi srfi-1) + :use-module (ice-9 optargs)) + + + + +;;; +;;; NEW +;;; +(define-macro (new class . parameters) + `(make ,(string->symbol (format #f "<~a>" class)) + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))) + +;;; +;;; DEFINE-MARKUP +;;; +(define-macro (define-markup bindings . body) + ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL + ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the + ;; `#:rest' argument can only appear last which not what Skribe/DSSSL + ;; expect, hence `fix-rest-arg'. + (define (fix-rest-arg args) + (let loop ((args args) + (result '()) + (rest-arg #f)) + (if (null? args) + (if rest-arg (append (reverse result) rest-arg) (reverse result)) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? (list (car args) (cadr args)) rest-arg)))))) + + (let ((name (car bindings)) + (opts (cdr bindings))) + `(define* ,(cons name (fix-rest-arg opts)) ,@body))) + + +;;; +;;; DEFINE-SIMPLE-MARKUP +;;; +(define-macro (define-simple-markup markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-SIMPLE-CONTAINER +;;; +(define-macro (define-simple-container markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-PROCESSOR-MARKUP +;;; +(define-macro (define-processor-markup proc) + `(define-markup (,proc #:rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + + +;;; +;;; SKRIBE-EVAL-LOCATION ... +;;; +(define (skribe-eval-location) + (format (current-error-port) + "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n") + #f) + +;;; +;;; SKRIBE-ERROR +;;; +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (markup? obj) (markup-markup obj) obj))) + (if (location? l) + (error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape) + (error "~a: ~a ~s " proc msg shape)))) + +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error proc msg obj))) + + +;;; +;;; SKRIBE-TYPE-ERROR +;;; +(define (skribe-type-error proc msg obj etype) + (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f)) + + + +;;; FIXME: Peut-être virée maintenant +(define (skribe-line-error file line proc msg obj) + (error (format "%a:%a: ~a:~a ~S" file line proc msg obj))) + + +;;; +;;; SKRIBE-WARNING & SKRIBE-WARNING/AST +;;; +(define (%skribe-warn level file line lst) + (let ((port (current-error-port))) + (format port "**** WARNING:\n") + (when (and file line) (format port "~a: ~a: " file line)) + (for-each (lambda (x) (format port "~a " x)) lst) + (newline port))) + + +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (%skribe-warn level #f #f obj))) + + +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (ast-loc ast))) + (if (location? l) + (%skribe-warn level (location-file l) (location-pos l) obj) + (%skribe-warn level #f #f obj))))) + +;;; +;;; SKRIBE-MESSAGE +;;; +(define (skribe-message fmt . obj) + (when (> *skribe-verbose* 0) + (apply format (current-error-port) fmt obj))) + +;;; +;;; FILE-PREFIX / FILE-SUFFIX +;;; +(define (file-prefix fn) + (if fn + (let ((match (regexp-match "(.*)\\.([^/]*$)" fn))) + (if match + (cadr match) + fn)) + "./SKRIBE-OUTPUT")) + +(define (file-suffix s) + ;; Not completely correct, but sufficient here + (let* ((basename (regexp-replace "^(.*)/(.*)$" s "\\2")) + (split (string-split basename "."))) + (if (> (length split) 1) + (car (reverse! split)) + ""))) + + +;;; +;;; KEY-GET +;;; +;;; We need to redefine the standard key-get to be more permissive. In +;;; STklos key-get accepts a list which is formed only of keywords. In +;;; Skribe, parameter lists are of the form +;;; (:title "..." :option "...." body1 body2 body3) +;;; So is we find an element which is not a keyword, we skip it (unless it +;;; follows a keyword of course). Since the compiler of extended lambda +;;; uses the function key-get, it will now accept Skribe markups +(define* (key-get lst key #:optional (default #f) default?) + (define (not-found) + (if default? + default + (error 'key-get "value ~S not found in list ~S" key lst))) + (let Loop ((l lst)) + (cond + ((null? l) + (not-found)) + ((not (pair? l)) + (error 'key-get "bad list ~S" lst)) + ((keyword? (car l)) + (if (null? (cdr l)) + (error 'key-get "bad keyword list ~S" lst) + (if (eq? (car l) key) + (cadr l) + (Loop (cddr l))))) + (else + (Loop (cdr l)))))) + + + +;;; ====================================================================== +;;; +;;; A C C E S S O R S +;;; +;;; ====================================================================== + +;; SKRIBE-PATH +(define (skribe-path) *skribe-path*) + +(define (skribe-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;; SKRIBE-IMAGE-PATH +(define (skribe-image-path) *skribe-image-path*) + +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;; SKRIBE-BIB-PATH +(define (skribe-bib-path) *skribe-bib-path*) + +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;; SKRBE-SOURCE-PATH +(define (skribe-source-path) *skribe-source-path*) + +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) + + +;;; ====================================================================== +;;; +;;; Compatibility with Bigloo +;;; +;;; ====================================================================== + +(define (substring=? s1 s2 len) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (let Loop ((i 0)) + (cond + ((= i len) #t) + ((= i l1) #f) + ((= i l2) #f) + ((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1))) + (else #f))))) + +(define (directory->list str) + (map basename (glob (string-append str "/*") (string-append "/.*")))) + +(define-macro (printf . args) `(format #t ,@args)) +(define fprintf format) + + +(define prefix file-prefix) +(define suffix file-suffix) +(define system->string system) ;; FIXME +(define any? any) +(define every? every) +(define find-file/path (lambda (. args) + (format #t "find-file/path: ~a~%" args) + #f)) +(define process-input-port #f) ;process-input) +(define process-output-port #f) ;process-output) +(define process-error-port #f) ;process-error) + + +;;; +;;; h a s h t a b l e s +;;; +(define make-hashtable make-hash-table) +(define hashtable? hash-table?) +(define hashtable-get (lambda (h k) (hash-ref h k #f))) +(define hashtable-put! hash-set!) +(define hashtable-update! hash-set!) +(define hashtable->list (lambda (h) + (map cdr (hash-table->list h)))) + +(define find-runtime-type (lambda (obj) obj)) + +(define-macro (unwind-protect expr1 expr2) + ;; This is no completely correct. + `(dynamic-wind + (lambda () #f) + (lambda () ,expr1) + (lambda () ,expr2))) + +(define-macro (unless expr body) + `(if (not ,expr) ,body)) + +(define-macro (when expr . exprs) + `(if ,expr (begin ,@exprs))) diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm new file mode 100644 index 0000000..4d29f31 --- /dev/null +++ b/src/guile/skribilo/module.scm @@ -0,0 +1,118 @@ +;;; module.scm -- Integration of Skribe code as Guile modules. +;;; +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo module) + :use-module (skribilo reader) + :use-module (skribilo eval) + :use-module (ice-9 optargs)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This (fake) module defines a macro called `define-skribe-module' which +;;; allows to package Skribe code (which uses Skribe built-ins and most +;;; importantly a Skribe syntax) as a Guile module. This module +;;; automatically exports the macro as a core binding so that future +;;; `use-modules' referring to Skribe modules will work as expected. +;;; +;;; Code: + +(define-macro (define-skribe-module name) + `(begin + (define-module ,name) + + ;; Pull all the bindings that Skribe code may expect, plus those needed + ;; to actually create and read the module. + (use-modules (skribilo module) + (skribilo reader) + (skribilo eval) ;; `run-time-module' + + (srfi srfi-1) + (ice-9 optargs) + + (skribilo lib) ;; `define-markup', `unwind-protect', etc. + (skribilo runtime) + (skribilo vars) + (skribilo config)) + + (use-syntax (skribilo lib)) + + ;; The `define' below results in a module-local definition. So the + ;; definition of `read' in the `(guile-user)' module is left untouched. + ;(define read ,(make-reader 'skribe)) + + ;; Everything is exported. + (define-macro (define . things) + (let* ((first (car things)) + (binding (cond ((symbol? first) first) + ((list? first) (car first)) + ((pair? first) (car first)) + (else + (error "define/skribe: bad formals" first))))) + `(begin + (define-public ,@things) + ;; Automatically push it to the run-time user module. +; (module-define! ,(run-time-module) +; (quote ,binding) ,binding) + ))))) + + +;; Make it available to the top-level module. +(module-define! the-root-module + 'define-skribe-module define-skribe-module) + + +(define-public (load-file-with-read file read module) + (with-input-from-file file + (lambda () +; (format #t "load-file-with-read: ~a~%" read) + (let loop ((sexp (read)) + (result #f)) + (if (eof-object? sexp) + result + (begin +; (format #t "preparing to evaluate `~a'~%" sexp) + (loop (read) + (eval sexp module)))))))) + +(define-public (load-skribilo-file file reader-name) + (load-file-with-read file (make-reader reader-name) (current-module))) + +(define-public *skribe-core-modules* + '("utils" "api" "bib" "index" "param" "sui")) + +(define*-public (load-skribe-modules #:optional (debug? #f)) + "Load the core Skribe modules, both in the @code{(skribilo skribe)} +hierarchy and in @code{(run-time-module)}." + (for-each (lambda (mod) + (if debug? + (format #t "loading skribe module `~a'...~%" mod)) + (load-skribilo-file (string-append "skribe/" mod ".scm") + 'skribe)) + *skribe-core-modules*) + (for-each (lambda (mod) + (module-use! (run-time-module) + (resolve-interface (list skribilo skribe + (string->symbol + mod))))) + *skribe-core-modules*)) + +;;; module.scm ends here diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm new file mode 100644 index 0000000..cc690ec --- /dev/null +++ b/src/guile/skribilo/output.scm @@ -0,0 +1,162 @@ +;;;; +;;;; output.stk -- Skribe Output Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 18:42 (eg) +;;;; Last file update: 5-Mar-2004 10:32 (eg) +;;;; + +(define-module (skribilo output) + :export (output)) + +(use-modules (skribilo debug) + (skribilo types) +; (skribe engine) +; (skribe writer) + (oop goops)) + + +(define-generic out) + +(define (%out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" n " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (engine-ident e)) + (debug-item "w=" (writer-ident w)) + + (when (writer? w) + (invoke (slot-ref w 'before) n e) + (invoke (slot-ref w 'action) n e) + (invoke (slot-ref w 'after) n e)))) + + + +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (null? writer) + (out node e) + (cond + ((is-a? (car writer) ) + (%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 ) 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 ) e) + (let ((f (slot-ref e 'filter))) + (if (procedure? f) + (display (f node)) + (display node)))) + + +(define-method (out (node ) e) + (out (number->string node) e)) + + +(define-method (out (n ) 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 ) 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 ) e) + 'unspecified) + + +(define-method (out (n ) e) + (skribe-error 'output "Orphan unresolved" n)) + + +(define-method (out (node ) e) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (%out/writer node e w) + (output (slot-ref node 'body) e)))) diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm new file mode 100644 index 0000000..eb0b3db --- /dev/null +++ b/src/guile/skribilo/prog.scm @@ -0,0 +1,218 @@ +;;;; +;;;; prog.stk -- All the stuff for the prog markup +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 31-Aug-2003 23:42 (eg) +;;;; Last file update: 22-Oct-2003 19:35 (eg) +;;;; + +(define-module SKRIBE-PROG-MODULE + (export make-prog-body resolve-line) + +;;; ====================================================================== +;;; +;;; COMPATIBILITY +;;; +;;; ====================================================================== +(define pregexp-match regexp-match) +(define pregexp-replace regexp-replace) +(define pregexp-quote regexp-quote) + + +(define (node-body-set! b v) + (slot-set! b 'body v)) + +;;; +;;; FIXME: Tout le module peut se factoriser +;;; définir en bigloo node-body-set + + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (number->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (receive (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((node? line) + (receive (m l) + (extract-mark (node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((= r2 l) + (if (= r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+ r2 1) + (+ r2 1) + (if (= r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+ r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (number->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (number->string (+ (if (integer? ldigit) + (max lnum (expt 10 (- ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (receive (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) + diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm new file mode 100644 index 0000000..a149ab1 --- /dev/null +++ b/src/guile/skribilo/reader.scm @@ -0,0 +1,82 @@ +;;; reader.scm -- Skribilo's front-end (aka. reader) interface. +;;; +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo reader) + :use-module (srfi srfi-9) ;; records + :use-module (srfi srfi-17) ;; generalized `set!' + :export (%make-reader lookup-reader make-reader) + :export-syntax (define-reader define-public-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module contains Skribilo's front-end (aka. ``reader'') interface. +;;; Skribilo's default reader is `(skribilo reader skribe)' which provides a +;;; reader for the Skribe syntax. +;;; +;;; Code: + +(define-record-type + (%make-reader name version make) + reader? + (name reader:name reader:set-name!) ;; a symbol + (version reader:version reader:set-version!) ;; a string + (make reader:make reader:set-make!)) ;; a one-argument proc + ;; that returns a reader + ;; proc + +(define-public reader:name + (getter-with-setter reader:name reader:set-name!)) + +(define-public reader:version + (getter-with-setter reader:version reader:set-version!)) + +(define-public reader:make + (getter-with-setter reader:make reader:set-make!)) + +(define-macro (define-reader name version make-proc) + `(define reader-specification + (%make-reader (quote ,name) ,version ,make-proc))) + +(define-macro (define-public-reader name version make-proc) + `(define-reader ,name ,version ,make-proc)) + + + +;;; The mechanism below is inspired by Guile-VM code written by K. Nishida. + +(define (lookup-reader name) + "Look for a reader named @var{name} (a symbol) in the @code{(skribilo +readers)} module hierarchy. If no such reader was found, an error is +raised." + (let ((m (resolve-module `(skribilo reader ,name)))) + (if (module-bound? m 'reader-specification) + (module-ref m 'reader-specification) + (error "no such reader" name)))) + +(define (make-reader name) + "Look for reader @var{name} and instantiate it." + (let* ((spec (lookup-reader name)) + (make (reader:make spec))) + (make))) + + +;;; reader.scm ends here diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm new file mode 100644 index 0000000..673a166 --- /dev/null +++ b/src/guile/skribilo/reader/skribe.scm @@ -0,0 +1,80 @@ +;;; skribe.scm -- A reader for the Skribe syntax. +;;; +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-module (skribilo reader skribe) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + + ;; the Scheme reader composition framework + :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) + + :export (reader-specification + make-skribe-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for the Skribe syntax, i.e. roughly R5RS Scheme plus DSSSL-style +;;; keywords and sk-exps (expressions introduced using a square bracket). +;;; +;;; Code: + + +(define* (make-skribe-reader #:optional (version "1.2d")) + "Return a Skribe reader (a procedure) suitable for version @var{version} of +the Skribe syntax." + (if (string> version "1.2d") + (error "make-skribe-reader: unsupported version" version) + *skribe-reader*)) + + +(define (%make-skribe-reader) + (let* ((dsssl-keyword-reader ;; keywords à la `#!key' + (r:make-token-reader #\! + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (sharp-reader (r:make-reader (cons dsssl-keyword-reader + (map r:standard-token-reader + '(character srfi-4 + number+radix + boolean)))))) + (r:make-reader (cons (r:make-token-reader #\# sharp-reader) + (map r:standard-token-reader + `(whitespace + sexp string number + symbol-lower-case + symbol-upper-case + symbol-misc-chars + quote-quasiquote-unquote + semicolon-comment + keyword ;; keywords à la `:key' + skribe-exp)))))) + +;; We actually cache an instance here. +(define *skribe-reader* (%make-skribe-reader)) + + + +;;; The reader specification. + +(define-reader skribe "1.2d" make-skribe-reader) + +;;; skribe.scm ends here diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm new file mode 100644 index 0000000..2dc5e98 --- /dev/null +++ b/src/guile/skribilo/resolve.scm @@ -0,0 +1,260 @@ +;;;; +;;;; resolve.stk -- Skribe Resolve Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 18:39 (eg) +;;;; Last file update: 17-Feb-2004 14:43 (eg) +;;;; + +(define-module (skribilo resolve) + :use-module (skribilo debug) + :use-module (skribilo runtime) + :use-module (skribilo types) + + :use-module (oop goops) + + :export (resolve! resolve-search-parent resolve-children resolve-children* + find1 resolve-counter resolve-parent resolve-ident)) + + +(define *unresolved* #f) +(define-generic do-resolve!) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE! +;;;; +;;;; This function iterates over an ast until all unresolved references +;;;; are resolved. +;;;; +;;;; ====================================================================== +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + (fluid-let ((*unresolved* #f)) + (let Loop ((ast ast)) + (set! *unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if *unresolved* + (Loop ast) + ast)))))) + +;;;; ====================================================================== +;;;; +;;;; D O - R E S O L V E ! +;;;; +;;;; ====================================================================== + +(define-method (do-resolve! ast engine env) + ast) + + +(define-method (do-resolve! (ast ) 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 ) engine env) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve + (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 ) 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 + (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 ) 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 ) engine env) + (with-debug 5 'do-resolve + (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 ) engine env) + node) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (is-a? n )) + (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 ) p) + ((not p) #f) + (else (resolve-search-parent p e pred)))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-COUNTER +;;;; +;;;; ====================================================================== +;;FIXME: factoriser +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-IDENT +;;;; +;;;; ====================================================================== +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) + diff --git a/src/guile/skribilo/runtime.scm b/src/guile/skribilo/runtime.scm new file mode 100644 index 0000000..af76237 --- /dev/null +++ b/src/guile/skribilo/runtime.scm @@ -0,0 +1,458 @@ +;;; +;;; runtime.stk -- Skribe runtime system +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 13-Aug-2003 18:47 (eg) +;;; Last file update: 15-Nov-2004 14:03 (eg) +;;; + +(define-module (skribilo runtime) + :export (;; Utilities + strip-ref-base ast->file-location string-canonicalize + + ;; Markup functions + markup-option markup-option-add! markup-output + + ;; Container functions + container-env-get + + ;; Images + convert-image + + ;; String writing + make-string-replace + + ;; AST + ast->string)) + +(use-modules (skribilo debug) + (skribilo types) + (skribilo verify) + (skribilo resolve) + (skribilo output) + (skribilo eval) + (oop goops)) + + + +;;; ====================================================================== +;;; +;;; U T I L I T I E S +;;; +;;; ====================================================================== + + +;;FIXME: Remonter cette fonction +(define (strip-ref-base file) + (if (not (string? *skribe-ref-base*)) + file + (let ((l (string-length *skribe-ref-base*))) + (cond + ((not (> (string-length file) (+ l 2))) + file) + ((not (substring=? file *skribe-ref-base* l)) + file) + ((not (char=? (string-ref file l) (file-separator))) + file) + (else + (substring file (+ l 1) (string-length file))))))) + + +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format "~a:~a:" (location-file l) (location-line l)) + ""))) + +;; FIXME: Remonter cette fonction +(define (string-canonicalize old) + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((= r l) + (cond + ((= w 0) + "") + ((char-whitespace? (string-ref new (- w 1))) + (substring new 0 (- w 1))) + ((= w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+ r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+ r 1) (+ w 1) #f)))))) + + +;;; ====================================================================== +;;; +;;; M A R K U P S F U N C T I O N S +;;; +;;; ====================================================================== +;; (define (markup-output markup +;; :optional (engine #f) +;; :key (predicate #f) +;; (options '()) +;; (before #f) +;; (action #f) +;; (after #f)) +;; (let ((e (or engine (use-engine)))) +;; (cond +;; ((not (is-a? e )) +;; (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 """ out)) +;; ((#\&) (display "&" out)) +;; ((#\<) (display "<" out)) +;; ((#\>) (display ">" 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 ">"))) + 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 )) "") +(define-method (ast->string (ast )) ast) +(define-method (ast->string (ast )) (number->string ast)) + +(define-method (ast->string (ast )) + (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 )) + (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-body obj) obj))) +;;NEW (cond +;;NEW ((pair? obj) +;;NEW (apply append (map (lambda (o) (loop o)) obj))) +;;NEW ((is-a? obj ) +;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident)) +;;NEW (if (pred obj) +;;NEW (list (cons obj (loop (container-body obj)))) +;;NEW '())) +;;NEW (else +;;NEW (if (pred obj) +;;NEW (list obj) +;;NEW '())))))) +;;NEW + +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G +;;NEW ;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (the-body opt) +;;NEW ;; Filter out the options +;;NEW (let loop ((opt* opt) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-body "Illegal body" opt)) +;;NEW ((keyword? (car opt*)) +;;NEW (if (null? (cdr opt*)) +;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) +;;NEW (loop (cddr opt*) res))) +;;NEW (else +;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) +;;NEW +;;NEW +;;NEW +;;NEW (define (the-options opt+ . out) +;;NEW ;; Returns an list made of options.The OUT argument contains +;;NEW ;; keywords that are filtered out. +;;NEW (let loop ((opt* opt+) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-options "Illegal options" opt*)) +;;NEW ((keyword? (car opt*)) +;;NEW (cond +;;NEW ((null? (cdr opt*)) +;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) +;;NEW ((memq (car opt*) out) +;;NEW (loop (cdr opt*) res)) +;;NEW (else +;;NEW (loop (cdr opt*) +;;NEW (cons (list (car opt*) (cadr opt*)) res))))) +;;NEW (else +;;NEW (loop (cdr opt*) res))))) +;;NEW diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm new file mode 100644 index 0000000..2828908 --- /dev/null +++ b/src/guile/skribilo/skribe/api.scm @@ -0,0 +1,1260 @@ +;;; api.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe api)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; This module contains all the core markups of Skribe/Skribilo. +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `api.scm' file found in the `common' directory. + +(let ((gensym-orig gensym)) + ;; In Skribe, `gensym' accepts a symbol. Guile's `gensym' accepts only + ;; strings. + (set! gensym + (lambda (obj) + (gensym-orig (cond ((symbol? obj) (symbol->string obj)) + (else obj)))))) + +;*---------------------------------------------------------------------*/ +;* include ... */ +;*---------------------------------------------------------------------*/ +(define-markup (include file) + (if (not (string? file)) + (skribe-error 'include "Illegal file (string expected)" file) + (skribe-include file))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(define-markup (document #!rest + opts + #!key + (ident #f) (class "document") + (title #f) (html-title #f) (author #f) + (ending #f) (env '())) + (new document + (markup 'document) + (ident (or ident + (ast->string title) + (symbol->string (gensym 'document)))) + (class class) + (required-options '(:title :author :ending)) + (options (the-options opts :ident :class :env)) + (body (the-body opts)) + (env (append env + (list (list 'chapter-counter 0) (list 'chapter-env '()) + (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()) + (list 'figure-counter 0) (list 'figure-env '())))))) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(define-markup (author #!rest + opts + #!key + (ident #f) (class "author") + name + (title #f) + (affiliation #f) + (email #f) + (url #f) + (address #f) + (phone #f) + (photo #f) + (align 'center)) + (if (not (memq align '(center left right))) + (skribe-error 'author "Illegal align value" align) + (new container + (markup 'author) + (ident (or ident (symbol->string (gensym 'author)))) + (class class) + (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) + (options `((:name ,name) + (:align ,align) + ,@(the-options opts :ident :class))) + (body #f)))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(define-markup (toc #!rest + opts + #!key + (ident #f) (class "toc") + (chapter #t) (section #t) (subsection #f)) + (let ((body (the-body opts))) + (new container + (markup 'toc) + (ident (or ident (symbol->string (gensym 'toc)))) + (class class) + (required-options '()) + (options `((:chapter ,chapter) + (:section ,section) + (:subsection ,subsection) + ,@(the-options opts :ident :class))) + (body (cond + ((null? body) + (new unresolved + (proc (lambda (n e env) + (handle + (resolve-search-parent n env document?)))))) + ((null? (cdr body)) + (if (handle? (car body)) + (car body) + (skribe-error 'toc + "Illegal argument (handle expected)" + (if (markup? (car body)) + (markup-markup (car body)) + "???")))) + (else + (skribe-error 'toc "Illegal argument" body))))))) + +;*---------------------------------------------------------------------*/ +;* chapter ... ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:chapter@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:chapter@ */ +;*---------------------------------------------------------------------*/ +(define-markup (chapter #!rest + opts + #!key + (ident #f) (class "chapter") + title (html-title #f) (file #f) (toc #t) (number #t)) + (new container + (markup 'chapter) + (ident (or ident (symbol->string (gensym 'chapter)))) + (class class) + (required-options '(:title :file :toc :number)) + (options `((:toc ,toc) + (:number ,(and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n + env + 'chapter + number)))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()))))) + +;*---------------------------------------------------------------------*/ +;* section-number ... */ +;*---------------------------------------------------------------------*/ +(define (section-number number markup) + (and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n env markup number)))))) + +;*---------------------------------------------------------------------*/ +;* section ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:section@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:sectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (section #!rest + opts + #!key + (ident #f) (class "section") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'section) + (ident (or ident (symbol->string (gensym 'section)))) + (class class) + (required-options '(:title :toc :file :toc :number)) + (options `((:number ,(section-number number 'section)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (if file + (list (list 'subsection-counter 0) (list 'subsection-env '()) + (list 'footnote-counter 0) (list 'footnote-env '())) + (list (list 'subsection-counter 0) (list 'subsection-env '())))))) + +;*---------------------------------------------------------------------*/ +;* subsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsection #!rest + opts + #!key + (ident #f) (class "subsection") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'subsection) + (ident (or ident (symbol->string (gensym 'subsection)))) + (class class) + (required-options '(:title :toc :file :number)) + (options `((:number ,(section-number number 'subsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsubsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsubsection #!rest + opts + #!key + (ident #f) (class "subsubsection") + title (file #f) (toc #f) (number #t)) + (new container + (markup 'subsubsection) + (ident (or ident (symbol->string (gensym 'subsubsection)))) + (class class) + (required-options '(:title :toc :number :file)) + (options `((:number ,(section-number number 'subsubsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup paragraph) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(define-markup (footnote #!rest opts + #!key (ident #f) (class "footnote") (label #t)) + ;; The `:label' option used to be called `:number'. + (new container + (markup 'footnote) + (ident (symbol->string (gensym 'footnote))) + (class class) + (required-options '()) + (options `((:label + ,(cond ((string? label) label) + ((number? label) label) + ((not label) label) + (else + (new unresolved + (proc (lambda (n e env) + (resolve-counter n env + 'footnote #t))))) + ,@(the-options opts :ident :class))))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) + (let ((ln (new markup + (ident (or ident (symbol->string (gensym 'linebreak)))) + (class class) + (markup 'linebreak))) + (num (the-body opts))) + (cond + ((null? num) + ln) + ((not (null? (cdr num))) + (skribe-error 'linebreak "Illegal arguments" num)) + ((not (and (integer? (car num)) (positive? (car num)))) + (skribe-error 'linebreak "Illegal argument" (car num))) + (else + (vector->list (make-vector (car num) ln)))))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(define-markup (hrule #!rest + opts + #!key + (ident #f) (class #f) + (width 100.) (height 1)) + (new markup + (markup 'hrule) + (ident (or ident (symbol->string (gensym 'hrule)))) + (class class) + (required-options '()) + (options `((:width ,width) + (:height ,height) + ,@(the-options opts :ident :class))) + (body #f))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(define-markup (color #!rest + opts + #!key + (ident #f) (class "color") + (bg #f) (fg #f) (width #f) (margin #f)) + (new container + (markup 'color) + (ident (or ident (symbol->string (gensym 'color)))) + (class class) + (required-options '(:bg :fg :width)) + (options `((:bg ,(if bg (skribe-use-color! bg) bg)) + (:fg ,(if fg (skribe-use-color! fg) fg)) + ,@(the-options opts :ident :class :bg :fg))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define-markup (frame #!rest + opts + #!key + (ident #f) (class "frame") + (width #f) (margin 2) (border 1)) + (new container + (markup 'frame) + (ident (or ident (symbol->string (gensym 'frame)))) + (class class) + (required-options '(:width :border :margin)) + (options `((:margin ,margin) + (:border ,(cond + ((integer? border) border) + (border 1) + (else #f))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(define-markup (font #!rest + opts + #!key + (ident #f) (class #f) + (size #f) (face #f)) + (new container + (markup 'font) + (ident (or ident (symbol->string (gensym 'font)))) + (class class) + (required-options '(:size)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(define-markup (flush #!rest + opts + #!key + (ident #f) (class #f) + side) + (case side + ((center left right) + (new container + (markup 'flush) + (ident (or ident (symbol->string (gensym 'flush)))) + (class class) + (required-options '(:side)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + (else + (skribe-error 'flush "Illegal side" side)))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container center) + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container pre) + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:prog@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:prog@ */ +;*---------------------------------------------------------------------*/ +(define-markup (prog #!rest + opts + #!key + (ident #f) (class "prog") + (line 1) (linedigit #f) (mark ";!")) + (if (not (or (string? mark) (eq? mark #f))) + (skribe-error 'prog "Illegal mark" mark) + (new container + (markup 'prog) + (ident (or ident (symbol->string (gensym 'prog)))) + (class class) + (required-options '(:line :mark)) + (options (the-options opts :ident :class :linedigit)) + (body (make-prog-body (the-body opts) line linedigit mark))))) + +;*---------------------------------------------------------------------*/ +;* source ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:source@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:source@ */ +;*---------------------------------------------------------------------*/ +(define-markup (source #!rest + opts + #!key + language + (file #f) (start #f) (stop #f) + (definition #f) (tab 8)) + (let ((body (the-body opts))) + (cond + ((and (not (null? body)) (or file start stop definition)) + (skribe-error 'source + "file, start/stop, and definition are exclusive with body" + body)) + ((and start stop definition) + (skribe-error 'source + "start/stop are exclusive with a definition" + body)) + ((and (or start stop definition) (not file)) + (skribe-error 'source + "start/stop and definition require a file specification" + file)) + ((and definition (not language)) + (skribe-error 'source + "definition requires a language specification" + definition)) + ((and file (not (string? file))) + (skribe-error 'source "Illegal file" file)) + ((and start (not (or (integer? start) (string? start)))) + (skribe-error 'source "Illegal start" start)) + ((and stop (not (or (integer? stop) (string? stop)))) + (skribe-error 'source "Illegal start" stop)) + ((and (integer? start) (integer? stop) (> start stop)) + (skribe-error 'source + "start line > stop line" + (format "~a/~a" start stop))) + ((and language (not (language? language))) + (skribe-error 'source "Illegal language" language)) + ((and tab (not (integer? tab))) + (skribe-error 'source "Illegal tab" tab)) + (file + (let ((s (if (not definition) + (source-read-lines file start stop tab) + (source-read-definition file definition tab language)))) + (if language + (source-fontify s language) + s))) + (language + (source-fontify body language)) + (else + body)))) + +;*---------------------------------------------------------------------*/ +;* language ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:language@ */ +;*---------------------------------------------------------------------*/ +(define-markup (language #!key name (fontifier #f) (extractor #f)) + (if (not (string? name)) + (skribe-type-error 'language "Illegal name, " name "string") + (new language + (name name) + (fontifier fontifier) + (extractor extractor)))) + +;*---------------------------------------------------------------------*/ +;* figure ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/figure.skb:figure@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:figure@ */ +;*---------------------------------------------------------------------*/ +(define-markup (figure #!rest + opts + #!key + (ident #f) (class "figure") + (legend #f) (number #t) (multicolumns #f)) + (new container + (markup 'figure) + (ident (or ident + (let ((s (ast->string legend))) + (if (not (string=? s "")) + s + (symbol->string (gensym 'figure)))))) + (class class) + (required-options '(:legend :number :multicolumns)) + (options `((:number + ,(new unresolved + (proc (lambda (n e env) + (resolve-counter n env 'figure number))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* parse-list-of ... */ +;* ------------------------------------------------------------- */ +;* The function table accepts two different prototypes. It */ +;* may receive its N elements in a list of N elements or in */ +;* a list of one element which is a list of N elements. This */ +;* gets rid of APPLY when calling container markup such as ITEMIZE */ +;* or TABLE. */ +;*---------------------------------------------------------------------*/ +(define (parse-list-of for markup lst) + (cond + ((null? lst) + '()) + ((and (pair? lst) + (or (pair? (car lst)) (null? (car lst))) + (null? (cdr lst))) + (parse-list-of for markup (car lst))) + (else + (let loop ((lst lst)) + (cond + ((null? lst) + '()) + ((pair? (car lst)) + (loop (car lst))) + (else + (let ((r (car lst))) + (if (not (is-markup? r markup)) + (skribe-warning 2 + for + (format "Illegal `~a' element, `~a' expected" + (if (markup? r) + (markup-markup r) + (find-runtime-type r)) + markup))) + (cons r (loop (cdr lst)))))))))) + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) + (new container + (markup 'itemize) + (ident (or ident (symbol->string (gensym 'itemize)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'itemize 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) + (new container + (markup 'enumerate) + (ident (or ident (symbol->string (gensym 'enumerate)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'enumerate 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) + (new container + (markup 'description) + (ident (or ident (symbol->string (gensym 'description)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'description 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(define-markup (item #!rest opts #!key (ident #f) (class #f) key) + (if (and key (not (or (string? key) + (number? key) + (markup? key) + (pair? key)))) + (skribe-type-error 'item "Illegal key:" key "node") + (new container + (markup 'item) + (ident (or ident (symbol->string (gensym 'item)))) + (class class) + (required-options '(:key)) + (options `((:key ,key) ,@(the-options opts :ident :class :key))) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* table */ +;*---------------------------------------------------------------------*/ +(define-markup (table #!rest + opts + #!key + (ident #f) (class #f) + (border #f) (width #f) + (frame 'none) (rules 'none) + (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) + (let ((frame (cond + ((string? frame) + (string->symbol frame)) + ((not frame) + #f) + (else + frame))) + (rules (cond + ((string? rules) + (string->symbol rules)) + ((not rules) + #f) + (else + rules))) + (frame-vals '(none above below hsides vsides lhs rhs box border)) + (rules-vals '(none rows cols all header)) + (cells-vals '(collapse separate))) + (cond + ((and frame (not (memq frame frame-vals))) + (skribe-error 'table + (format "frame should be one of \"~a\"" frame-vals) + frame)) + ((and rules (not (memq rules rules-vals))) + (skribe-error 'table + (format "rules should be one of \"~a\"" rules-vals) + rules)) + ((not (or (memq cellstyle cells-vals) + (string? cellstyle) + (number? cellstyle))) + (skribe-error 'table + (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) + cellstyle)) + (else + (new container + (markup 'table) + (ident (or ident (symbol->string (gensym 'table)))) + (class class) + (required-options '(:width :frame :rules)) + (options `((:frame ,frame) + (:rules ,rules) + (:cellstyle ,cellstyle) + ,@(the-options opts :ident :class))) + (body (parse-list-of 'table 'tr (the-body opts)))))))) + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) + (new container + (markup 'tr) + (ident (or ident (symbol->string (gensym 'tr)))) + (class class) + (required-options '()) + (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) + ,@(the-options opts :ident :class :bg))) + (body (parse-list-of 'tr 'tc (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* tc... */ +;*---------------------------------------------------------------------*/ +(define-markup (tc m + #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (let ((align (if (string? align) + (string->symbol align) + align)) + (valign (if (string? valign) + (string->symbol valign) + valign))) + (cond + ((not (integer? colspan)) + (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) + ((not (symbol? align)) + (skribe-type-error 'tc "Illegal align, " align "align")) + ((not (memq align '(#f center left right))) + (skribe-error + 'tc + "align should be one of 'left', `center', or `right'" + align)) + ((not (memq valign '(#f top middle center bottom))) + (skribe-error + 'tc + "valign should be one of 'top', `middle', `center', or `bottom'" + valign)) + (else + (new container + (markup 'tc) + (ident (or ident (symbol->string (gensym 'tc)))) + (class class) + (required-options '(:width :align :valign :colspan)) + (options `((markup ,m) + (:align ,align) + (:valign ,valign) + (:colspan ,colspan) + ,@(if bg + `((:bg ,(if bg (skribe-use-color! bg) bg))) + '()) + ,@(the-options opts :ident :class :bg :align :valign))) + (body (the-body opts))))))) + +;*---------------------------------------------------------------------*/ +;* th ... */ +;*---------------------------------------------------------------------*/ +(define-markup (th #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (apply tc 'th opts)) + +;*---------------------------------------------------------------------*/ +;* td ... */ +;*---------------------------------------------------------------------*/ +(define-markup (td #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (apply tc 'td opts)) + +;*---------------------------------------------------------------------*/ +;* image ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/image.skb:image@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:image@ */ +;* latex: @ref ../../skr/latex.skr:image@ */ +;*---------------------------------------------------------------------*/ +(define-markup (image #!rest + opts + #!key + (ident #f) (class #f) + file (url #f) (width #f) (height #f) (zoom #f)) + (cond + ((not (or (string? file) (string? url))) + (skribe-error 'image "No file or url provided" file)) + ((and (string? file) (string? url)) + (skribe-error 'image "Both file and url provided" (list file url))) + (else + (new markup + (markup 'image) + (ident (or ident (symbol->string (gensym 'image)))) + (class class) + (required-options '(:file :url :width :height)) + (options (the-options opts :ident :class)) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* blockquote */ +;*---------------------------------------------------------------------*/ +(define-simple-markup blockquote) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup roman) +(define-simple-markup bold) +(define-simple-markup underline) +(define-simple-markup strike) +(define-simple-markup emph) +(define-simple-markup kbd) +(define-simple-markup it) +(define-simple-markup tt) +(define-simple-markup code) +(define-simple-markup var) +(define-simple-markup samp) +(define-simple-markup sf) +(define-simple-markup sc) +(define-simple-markup sub) +(define-simple-markup sup) + +;*---------------------------------------------------------------------*/ +;* char ... */ +;*---------------------------------------------------------------------*/ +(define-markup (char char) + (cond + ((char? char) + (string char)) + ((integer? char) + (string (integer->char char))) + ((and (string? char) (= (string-length char) 1)) + char) + (else + (skribe-error 'char "Illegal char" char)))) + +;*---------------------------------------------------------------------*/ +;* symbol ... */ +;*---------------------------------------------------------------------*/ +(define-markup (symbol symbol) + (let ((v (cond + ((symbol? symbol) + (symbol->string symbol)) + ((string? symbol) + symbol) + (else + (skribe-error 'symbol + "Illegal argument (symbol expected)" + symbol))))) + (new markup + (markup 'symbol) + (body v)))) + +;*---------------------------------------------------------------------*/ +;* ! ... */ +;*---------------------------------------------------------------------*/ +(define-markup (! format #!rest node) + (if (not (string? format)) + (skribe-type-error '! "Illegal format:" format "string") + (new command + (fmt format) + (body node)))) + +;*---------------------------------------------------------------------*/ +;* processor ... */ +;*---------------------------------------------------------------------*/ +(define-markup (processor #!rest opts + #!key (combinator #f) (engine #f) (procedure #f)) + (cond + ((and combinator (not (procedure? combinator))) + (skribe-error 'processor "Combinator not a procedure" combinator)) + ((and engine (not (engine? engine))) + (skribe-error 'processor "Illegal engine" engine)) + ((and procedure + (or (not (procedure? procedure)) + (not (correct-arity? procedure 2)))) + (skribe-error 'processor "Illegal procedure" procedure)) + (else + (new processor + (combinator combinator) + (engine engine) + (procedure (or procedure (lambda (n e) n))) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* Processors ... */ +;*---------------------------------------------------------------------*/ +(define-processor-markup html-processor) +(define-processor-markup tex-processor) + +;*---------------------------------------------------------------------*/ +;* handle ... */ +;*---------------------------------------------------------------------*/ +(define-markup (handle #!rest opts + #!key (ident #f) (class "handle") value section) + (let ((body (the-body opts))) + (cond + (section + (error 'handle "Illegal handle `section' option" section) + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident section 'section n env))) + (new handle + (ast s))))))) + ((and (pair? body) + (null? (cdr body)) + (markup? (car body))) + (new handle + (ast (car body)))) + (else + (skribe-error 'handle "Illegal handle" opts))))) + +;*---------------------------------------------------------------------*/ +;* mailto ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mailto@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mailto@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) + (new markup + (markup 'mailto) + (ident (or ident (symbol->string (gensym 'ident)))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* *mark-table* ... */ +;*---------------------------------------------------------------------*/ +(define *mark-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mark@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mark@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) + (let ((bd (the-body opts))) + (cond + ((and (pair? bd) (not (null? (cdr bd)))) + (skribe-error 'mark "Too many argument provided" bd)) + ((null? bd) + (skribe-error 'mark "Missing argument" '())) + ((not (string? (car bd))) + (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) + (ident + (skribe-error 'mark "Illegal `ident:' option" ident)) + (else + (let* ((bs (ast->string bd)) + (n (new markup + (markup 'mark) + (ident bs) + (class class) + (options (the-options opts :ident :class :text)) + (body text)))) + (hashtable-put! *mark-table* bs n) + n))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:ref@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:ref@ */ +;* latex: @ref ../../skr/latex.skr:ref@ */ +;*---------------------------------------------------------------------*/ +(define-markup (ref #!rest + opts + #!key + (class #f) + (ident #f) + (text #f) + (chapter #f) + (section #f) + (subsection #f) + (subsubsection #f) + (bib #f) + (bib-table (default-bib-table)) + (url #f) + (figure #f) + (mark #f) + (handle #f) + (line #f) + (skribe #f) + (page #f)) + (define (unref ast text kind) + (let ((msg (format "Can't find `~a': " kind))) + (if (ast? ast) + (begin + (skribe-warning/ast 1 ast 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string 'unref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body (list text ": " (ast->file-location ast))))) + (begin + (skribe-warning 1 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string 'unref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body text)))))) + (define (skribe-ref skribe) + (let ((path (find-file/path skribe (skribe-path)))) + (if (not path) + (unref #f skribe 'sui-file) + (let* ((sui (load-sui path)) + (os (the-options opts :skribe :class :text)) + (u (sui-ref->url (dirname path) sui ident os))) + (if (not u) + (unref #f os 'sui-ref) + (ref :url u :text text :ident ident :class class)))))) + (define (handle-ref text) + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind handle) ,@(the-options opts :ident :class))) + (body text))) + (define (doref text kind) + (if (not (string? text)) + (skribe-type-error 'ref "Illegal reference" text "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident text kind n env))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,text) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n text (or kind 'ident))))))))) + (define (mark-ref mark) + (if (not (string? mark)) + (skribe-type-error 'mark "Illegal mark, " mark "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (hashtable-get *mark-table* mark))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind mark) + (mark ,mark) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n mark 'mark)))))))) + (define (make-bib-ref v) + (let ((s (resolve-bib bib-table v))) + (if s + (let* ((n (new markup + (markup 'bib-ref) + (ident (symbol->string 'bib-ref)) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (new handle + (ast s))))) + (h (new handle (ast n))) + (o (markup-option s 'used))) + (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) + n) + (unref #f v 'bib)))) + (define (bib-ref text) + (if (pair? text) + (new markup + (markup 'bib-ref+) + (ident (symbol->string 'bib-ref+)) + (class class) + (options (the-options opts :ident :class)) + (body (map make-bib-ref text))) + (make-bib-ref text))) + (define (url-ref) + (new markup + (markup 'url-ref) + (ident (symbol->string 'url-ref)) + (class class) + (required-options '(:url :text)) + (options (the-options opts :ident :class)))) + (define (line-ref line) + (new unresolved + (proc (lambda (n e env) + (let ((l (resolve-line line))) + (if (pair? l) + (new markup + (markup 'line-ref) + (ident (symbol->string 'line-ref)) + (class class) + (options `((:text ,(markup-ident (car l))) + ,@(the-options opts :ident :class))) + (body (new handle + (ast (car l))))) + (unref n line 'line))))))) + (let ((b (the-body opts))) + (if (not (null? b)) + (skribe-warning 1 'ref "Arguments ignored " b)) + (cond + (skribe (skribe-ref skribe)) + (handle (handle-ref handle)) + (ident (doref ident #f)) + (chapter (doref chapter 'chapter)) + (section (doref section 'section)) + (subsection (doref subsection 'subsection)) + (subsubsection (doref subsubsection 'subsubsection)) + (figure (doref figure 'figure)) + (mark (mark-ref mark)) + (bib (bib-ref bib)) + (url (url-ref)) + (line (line-ref line)) + (else (skribe-error 'ref "Illegal reference" opts))))) + +;*---------------------------------------------------------------------*/ +;* resolve ... */ +;*---------------------------------------------------------------------*/ +(define-markup (resolve fun) + (new unresolved + (proc fun))) + +;*---------------------------------------------------------------------*/ +;* bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (bibliography #!rest files + #!key + (command #f) (bib-table (default-bib-table))) + (for-each (lambda (f) + (cond + ((string? f) + (bib-load! bib-table f command)) + ((pair? f) + (bib-add! bib-table f)) + (else + (skribe-error "bibliography" "Illegal entry" f)))) + (the-body files))) + +;*---------------------------------------------------------------------*/ +;* the-bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:the-bibliography@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-bibliography #!rest opts + #!key + pred + (bib-table (default-bib-table)) + (sort bib-sort/authors) + (count 'partial)) + (if (not (memq count '(partial full))) + (skribe-error 'the-bibliography + "Cound must be either `partial' or `full'" + count) + (new unresolved + (proc (lambda (n e env) + (resolve-the-bib bib-table + (new handle (ast n)) + sort + pred + count + (the-options opts))))))) + +;*---------------------------------------------------------------------*/ +;* make-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:make-index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (make-index ident) + (make-index-table ident)) + +;*---------------------------------------------------------------------*/ +;* index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (index #!rest + opts + #!key + (ident #f) (class "index") + (note #f) (index #f) (shape #f) + (url #f)) + (let* ((entry-name (the-body opts)) + (ename (cond + ((string? entry-name) + entry-name) + ((and (pair? entry-name) (every string? entry-name)) + (apply string-append entry-name)) + (else + (skribe-error + 'index + "entry-name must be either a string or a list of strings" + entry-name)))) + (table (cond + ((not index) (default-index)) + ((index? index) index) + (else (skribe-type-error 'index + "Illegal index table, " + index + "index")))) + (m (mark (symbol->string (gensym)))) + (h (new handle (ast m))) + (new (new markup + (markup '&index-entry) + (ident (or ident (symbol->string (gensym 'index)))) + (class class) + (options `((name ,ename) ,@(the-options opts :ident :class))) + (body (if url + (ref :url url :text (or shape ename)) + (ref :handle h :text (or shape ename))))))) + ;; New is bound to a dummy option of the mark in order + ;; to make new options verified. + (markup-option-add! m 'to-verify new) + (hashtable-update! table + ename + (lambda (cur) (cons new cur)) + (list new)) + m)) + +;*---------------------------------------------------------------------*/ +;* the-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:the-index@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-index@ */ +;* html: @ref ../../skr/html.skr:the-index-header@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-index #!rest + opts + #!key + (ident #f) + (class "the-index") + (split #f) + (char-offset 0) + (header-limit 50) + (column 1)) + (let ((bd (the-body opts))) + (cond + ((not (and (integer? char-offset) (>= char-offset 0))) + (skribe-error 'the-index "Illegal char offset" char-offset)) + ((not (integer? column)) + (skribe-error 'the-index "Illegal column number" column)) + ((not (every? index? bd)) + (skribe-error 'the-index + "Illegal indexes" + (filter (lambda (o) (not (index? o))) bd))) + (else + (new unresolved + (proc (lambda (n e env) + (resolve-the-index (ast-loc n) + ident class + bd + split + char-offset + header-limit + column)))))))) diff --git a/src/guile/skribilo/skribe/bib.scm b/src/guile/skribilo/skribe/bib.scm new file mode 100644 index 0000000..f1a32c1 --- /dev/null +++ b/src/guile/skribilo/skribe/bib.scm @@ -0,0 +1,215 @@ +;;; lib.scm +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe bib)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of bibliography-related functions. +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `bib.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* bib-load! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-load! table filename command) + (if (not (bib-table? table)) + (skribe-error 'bib-load "Illegal bibliography table" table) + ;; read the file + (let ((p (skribe-open-bib-file filename command))) + (if (not (input-port? p)) + (skribe-error 'bib-load "Can't open data base" filename) + (unwind-protect + (parse-bib table p) + (close-input-port p)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-bib table ident) + (if (not (bib-table? table)) + (skribe-error 'resolve-bib "Illegal bibliography table" table) + (let* ((i (cond + ((string? ident) ident) + ((symbol? ident) (symbol->string ident)) + (else (skribe-error 'resolve-bib "Illegal ident" ident)))) + (en (hashtable-get table i))) + (if (is-markup? en '&bib-entry) + en + #f)))) + +;*---------------------------------------------------------------------*/ +;* make-bib-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-entry kind ident fields from) + (let* ((m (new markup + (markup '&bib-entry) + (ident ident) + (options `((kind ,kind) (from ,from))))) + (h (new handle + (ast m)))) + (for-each (lambda (f) + (if (and (pair? f) + (pair? (cdr f)) + (null? (cddr f)) + (symbol? (car f))) + (markup-option-add! m + (car f) + (new markup + (markup (symbol-append + '&bib-entry- + (car f))) + (parent h) + (body (cadr f)))) + (bib-parse-error f))) + fields) + m)) + +;*---------------------------------------------------------------------*/ +;* bib-sort/authors ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/authors l) + (define (cmp i1 i2 def) + (cond + ((and (markup? i1) (markup? i2)) + (cmp (markup-body i1) (markup-body i2) def)) + ((markup? i1) + (cmp (markup-body i1) i2 def)) + ((markup? i2) + (cmp i1 (markup-body i2) def)) + ((and (string? i1) (string? i2)) + (if (string=? i1 i2) + (def) + (string (string-length body) 3) + (substring body 0 3) + body)) + (sy (string->symbol (string-downcase body))) + (c (assq sy '((jan . 1) + (feb . 2) + (mar . 3) + (apr . 4) + (may . 5) + (jun . 6) + (jul . 7) + (aug . 8) + (sep . 9) + (oct . 10) + (nov . 11) + (dec . 12))))) + (if (pair? c) (cdr c) 13))))) + (let ((d1 (markup-option p1 'year)) + (d2 (markup-option p2 'year))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((y1 (markup-body d1)) + (y2 (markup-body d2))) + (cond + ((string>? y1 y2) #t) + ((string m1 m2)))))))))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-the-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-bib table n sort pred count opts) + (define (count! entries) + (let loop ((es entries) + (i 1)) + (if (pair? es) + (begin + (markup-option-add! (car es) + :title + (new markup + (markup '&bib-entry-ident) + (parent (car es)) + (options `((number ,i))) + (body (new handle + (ast (car es)))))) + (loop (cdr es) (+ i 1)))))) + (if (not (bib-table? table)) + (skribe-error 'resolve-the-bib "Illegal bibliography table" table) + (let* ((es (sort (hashtable->list table))) + (fes (filter (if (procedure? pred) + (lambda (m) (pred m n)) + (lambda (m) (pair? (markup-option m 'used)))) + es))) + (count! (if (eq? count 'full) es fes)) + (new markup + (markup '&the-bibliography) + (options opts) + (body fes))))) + + +;;; bib.scm ends here diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm new file mode 100644 index 0000000..840a179 --- /dev/null +++ b/src/guile/skribilo/skribe/index.scm @@ -0,0 +1,149 @@ +;;; index.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe index)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of index-related functions. +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `index.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* index? ... */ +;*---------------------------------------------------------------------*/ +(define (index? obj) + (hashtable? obj)) + +;*---------------------------------------------------------------------*/ +;* *index-table* ... */ +;*---------------------------------------------------------------------*/ +(define *index-table* #f) + +;*---------------------------------------------------------------------*/ +;* make-index-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-index-table ident) + (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* default-index ... */ +;*---------------------------------------------------------------------*/ +(define (default-index) + (if (not *index-table*) + (set! *index-table* (make-index-table "default-index"))) + *index-table*) + +;*---------------------------------------------------------------------*/ +;* resolve-the-index ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-index loc i c indexes split char-offset header-limit col) + ;; fetch the descriminating index name letter + (define (index-ref n) + (let ((name (markup-option n 'name))) + (if (>= char-offset (string-length name)) + (skribe-error 'the-index "char-offset out of bound" char-offset) + (string-ref name char-offset)))) + ;; sort a bucket of entries (the entries in a bucket share there name) + (define (sort-entries-bucket ie) + (sort ie + (lambda (i1 i2) + (or (not (markup-option i1 :note)) + (markup-option i2 :note))))) + ;; accumulate all the entries starting with the same letter + (define (letter-references refs) + (let ((letter (index-ref (car (car refs))))) + (let loop ((refs refs) + (acc '())) + (if (or (null? refs) + (not (char-ci=? letter (index-ref (car (car refs)))))) + (values (char-upcase letter) acc refs) + (loop (cdr refs) (cons (car refs) acc)))))) + ;; merge the buckets that comes from different index tables + (define (merge-buckets buckets) + (if (null? buckets) + '() + (let loop ((buckets buckets) + (res '())) + (cond + ((null? (cdr buckets)) + (reverse! (cons (car buckets) res))) + ((string=? (markup-option (car (car buckets)) 'name) + (markup-option (car (cadr buckets)) 'name)) + ;; we merge + (loop (cons (append (car buckets) (cadr buckets)) + (cddr buckets)) + res)) + (else + (loop (cdr buckets) + (cons (car buckets) res))))))) + (let* ((entries (apply append (map hashtable->list indexes))) + (sorted (map sort-entries-bucket + (merge-buckets + (sort entries + (lambda (e1 e2) + (string-cistring (gensym s)) :text s)) + (h (new handle (loc loc) (ast m))) + (r (ref :handle h :text s))) + (ast-loc-set! m loc) + (ast-loc-set! r loc) + (loop next-refs + (cons r lrefs) + (append lr (cons m body))))))))))) + + +;;; index.scm ends here diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm new file mode 100644 index 0000000..8daca62 --- /dev/null +++ b/src/guile/skribilo/skribe/param.scm @@ -0,0 +1,93 @@ +;;; param.scm +;;; +;;; Copyright 2003 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe param)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; Definition of various Skribe run-time parameters. +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `param.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* *skribe-rc-file* ... */ +;* ------------------------------------------------------------- */ +;* The "runtime command" file. */ +;*---------------------------------------------------------------------*/ +(define *skribe-rc-file* "skriberc") + +;*---------------------------------------------------------------------*/ +;* *skribe-auto-mode-alist* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-auto-mode-alist* + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) + +;*---------------------------------------------------------------------*/ +;* *skribe-auto-load-alist* ... */ +;* ------------------------------------------------------------- */ +;* Autoload engines. */ +;*---------------------------------------------------------------------*/ +(define *skribe-auto-load-alist* + '((base . "base.skr") + (html . "html.skr") + (sui . "html.skr") + (latex . "latex.skr") + (context . "context.skr") + (xml . "xml.skr"))) + +;*---------------------------------------------------------------------*/ +;* *skribe-preload* ... */ +;* ------------------------------------------------------------- */ +;* The list of skribe files (e.g. styles) to be loaded at boot-time */ +;*---------------------------------------------------------------------*/ +(define *skribe-preload* + '("skribe.skr")) + +;*---------------------------------------------------------------------*/ +;* *skribe-precustom* ... */ +;* ------------------------------------------------------------- */ +;* The list of pair to be assigned to the default */ +;* engine. */ +;*---------------------------------------------------------------------*/ +(define *skribe-precustom* + '()) + +;*---------------------------------------------------------------------*/ +;* *skribebib-auto-mode-alist* ... */ +;*---------------------------------------------------------------------*/ +(define *skribebib-auto-mode-alist* + '(("bib" . "skribebibtex"))) + +;;; param.scm ends here diff --git a/src/guile/skribilo/skribe/sui.scm b/src/guile/skribilo/skribe/sui.scm new file mode 100644 index 0000000..9baa36a --- /dev/null +++ b/src/guile/skribilo/skribe/sui.scm @@ -0,0 +1,187 @@ +;;; sui.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe sui)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; Library dealing with Skribe URL Indexes (SUI). +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `sui.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* *sui-table* ... */ +;*---------------------------------------------------------------------*/ +(define *sui-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* load-sui ... */ +;* ------------------------------------------------------------- */ +;* Returns a SUI sexp if already loaded. Load it otherwise. */ +;* Raise an error if the file cannot be open. */ +;*---------------------------------------------------------------------*/ +(define (load-sui path) + (let ((sexp (hashtable-get *sui-table* path))) + (or sexp + (begin + (when (> *skribe-verbose* 0) + (fprintf (current-error-port) " [loading sui: ~a]\n" path)) + (let ((p (open-input-file path))) + (if (not (input-port? p)) + (skribe-error 'load-sui + "Can't find `Skribe Url Index' file" + path) + (unwind-protect + (let ((sexp (read p))) + (match-case sexp + ((sui (? string?) . ?-) + (hashtable-put! *sui-table* path sexp)) + (else + (skribe-error 'load-sui + "Illegal `Skribe Url Index' file" + path))) + sexp) + (close-input-port p)))))))) + +;*---------------------------------------------------------------------*/ +;* sui-ref->url ... */ +;*---------------------------------------------------------------------*/ +(define (sui-ref->url dir sui ident opts) + (let ((refs (sui-find-ref sui ident opts))) + (and (pair? refs) + (let ((base (sui-file sui)) + (file (car (car refs))) + (mark (cdr (car refs)))) + (format "~a/~a#~a" dir (or file base) mark))))) + +;*---------------------------------------------------------------------*/ +;* sui-title ... */ +;*---------------------------------------------------------------------*/ +(define (sui-title sexp) + (match-case sexp + ((sui (and ?title (? string?)) . ?-) + title) + (else + (skribe-error 'sui-title "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-file sexp) + (sui-key sexp :file)) + +;*---------------------------------------------------------------------*/ +;* sui-key ... */ +;*---------------------------------------------------------------------*/ +(define (sui-key sexp key) + (match-case sexp + ((sui ?- . ?rest) + (let loop ((rest rest)) + (and (pair? rest) + (if (eq? (car rest) key) + (and (pair? (cdr rest)) + (cadr rest)) + (loop (cdr rest)))))) + (else + (skribe-error 'sui-key "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-find-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-find-ref sui ident opts) + (let ((ident (assq :ident opts)) + (mark (assq :mark opts)) + (class (let ((c (assq :class opts))) + (and (pair? c) (cadr c)))) + (chapter (assq :chapter opts)) + (section (assq :section opts)) + (subsection (assq :subsection opts)) + (subsubsection (assq :subsubsection opts))) + (match-case sui + ((sui (? string?) . ?refs) + (cond + (mark (sui-search-ref 'marks refs (cadr mark) class)) + (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) + (section (sui-search-ref 'sections refs (cadr section) class)) + (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) + (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) + (ident (sui-search-all-refs sui ident class)) + (else '()))) + (else + (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) + +;*---------------------------------------------------------------------*/ +;* sui-search-all-refs ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-all-refs sui id refs) + '()) + +;*---------------------------------------------------------------------*/ +;* sui-search-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-ref kind refs val class) + (define (find-ref refs val class) + (map (lambda (r) + (let ((f (memq :file r)) + (c (memq :mark r))) + (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) + (filter (if class + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val) + (let ((c (memq :class m))) + (and (pair? c) + (eq? (cadr c) class))))) + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val)))) + refs))) + (let loop ((refs refs)) + (if (pair? refs) + (if (and (pair? (car refs)) (eq? (caar refs) kind)) + (find-ref (cdar refs) val class) + (loop (cdr refs))) + '()))) + +;*---------------------------------------------------------------------*/ +;* sui-filter ... */ +;*---------------------------------------------------------------------*/ +(define (sui-filter sui pred1 pred2) + (match-case sui + ((sui (? string?) . ?refs) + (let loop ((refs refs) + (res '())) + (if (pair? refs) + (if (and (pred1 (car refs))) + (loop (cdr refs) + (cons (filter pred2 (cdar refs)) res)) + (loop (cdr refs) res)) + (reverse! res)))) + (else + (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/src/guile/skribilo/skribe/utils.scm b/src/guile/skribilo/skribe/utils.scm new file mode 100644 index 0000000..f963020 --- /dev/null +++ b/src/guile/skribilo/skribe/utils.scm @@ -0,0 +1,259 @@ +;;; utils.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + +(define-skribe-module (skribilo skribe utils)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of various utilities, including AST traversal helper functions. +;;; +;;; Code: + + +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `lib.scm' file found in the `common' directory. + +;*---------------------------------------------------------------------*/ +;* engine-custom-add! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom-add! e id val) + (let ((old (engine-custom e id))) + (if (unspecified? old) + (engine-custom-set! e id (list val)) + (engine-custom-set! e id (cons val old))))) + +;*---------------------------------------------------------------------*/ +;* find-markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define (find-markup-ident ident) + (let ((r (find-markups ident))) + (if (or (pair? r) (null? r)) + r + '()))) + +;*---------------------------------------------------------------------*/ +;* container-search-down ... */ +;*---------------------------------------------------------------------*/ +(define (container-search-down pred obj) + (with-debug 4 'container-search-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((container? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '()))))) + +;*---------------------------------------------------------------------*/ +;* search-down ... */ +;*---------------------------------------------------------------------*/ +(define (search-down pred obj) + (with-debug 4 'search-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '()))))) + +;*---------------------------------------------------------------------*/ +;* find-down ... */ +;*---------------------------------------------------------------------*/ +(define (find-down pred obj) + (with-debug 4 'find-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj obj)) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (debug-item "loop=" (find-runtime-type obj) + " " (markup-ident obj)) + (if (pred obj) + (list (cons obj (loop (markup-body obj)))) + '())) + (else + (if (pred obj) + (list obj) + '())))))) + +;*---------------------------------------------------------------------*/ +;* find1-down ... */ +;*---------------------------------------------------------------------*/ +(define (find1-down pred obj) + (with-debug 4 'find1-down + (let loop ((obj obj) + (stack '())) + (debug-item "obj=" (find-runtime-type obj) + " " (if (markup? obj) (markup-markup obj) "???") + " " (if (markup? obj) (markup-ident obj) "")) + (cond + ((memq obj stack) + (skribe-error 'find1-down "Illegal cyclic object" obj)) + ((pair? obj) + (let liip ((obj obj)) + (cond + ((null? obj) + #f) + (else + (or (loop (car obj) (cons obj stack)) + (liip (cdr obj))))))) + ((pred obj) + obj) + ((markup? obj) + (loop (markup-body obj) (cons obj stack))) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* find-up ... */ +;*---------------------------------------------------------------------*/ +(define (find-up pred obj) + (let loop ((obj obj) + (res '())) + (cond + ((not (ast? obj)) + res) + ((pred obj) + (loop (ast-parent obj) (cons obj res))) + (else + (loop (ast-parent obj) (cons obj res)))))) + +;*---------------------------------------------------------------------*/ +;* find1-up ... */ +;*---------------------------------------------------------------------*/ +(define (find1-up pred obj) + (let loop ((obj obj)) + (cond + ((not (ast? obj)) + #f) + ((pred obj) + obj) + (else + (loop (ast-parent obj)))))) + +;*---------------------------------------------------------------------*/ +;* ast-document ... */ +;*---------------------------------------------------------------------*/ +(define (ast-document m) + (find1-up document? m)) + +;*---------------------------------------------------------------------*/ +;* ast-chapter ... */ +;*---------------------------------------------------------------------*/ +(define (ast-chapter m) + (find1-up (lambda (n) (is-markup? n 'chapter)) m)) + +;*---------------------------------------------------------------------*/ +;* ast-section ... */ +;*---------------------------------------------------------------------*/ +(define (ast-section m) + (find1-up (lambda (n) (is-markup? n 'section)) m)) + +;*---------------------------------------------------------------------*/ +;* the-body ... */ +;* ------------------------------------------------------------- */ +;* Filter out the options */ +;*---------------------------------------------------------------------*/ +(define (the-body opt+) + (let loop ((opt* opt+) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-body "Illegal body" opt*)) + ((keyword? (car opt*)) + (if (null? (cdr opt*)) + (skribe-error 'the-body "Illegal option" (car opt*)) + (loop (cddr opt*) res))) + (else + (loop (cdr opt*) (cons (car opt*) res)))))) + +;*---------------------------------------------------------------------*/ +;* the-options ... */ +;* ------------------------------------------------------------- */ +;* Returns an list made of options. The OUT argument contains */ +;* keywords that are filtered out. */ +;*---------------------------------------------------------------------*/ +(define (the-options opt+ . out) + (let loop ((opt* opt+) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-options "Illegal options" opt*)) + ((keyword? (car opt*)) + (cond + ((null? (cdr opt*)) + (skribe-error 'the-options "Illegal option" (car opt*))) + ((memq (car opt*) out) + (loop (cdr opt*) res)) + (else + (loop (cdr opt*) + (cons (list (car opt*) (cadr opt*)) res))))) + (else + (loop (cdr opt*) res))))) + +;*---------------------------------------------------------------------*/ +;* list-split ... */ +;*---------------------------------------------------------------------*/ +(define (list-split l num . fill) + (let loop ((l l) + (i 0) + (acc '()) + (res '())) + (cond + ((null? l) + (reverse! (cons (if (or (null? fill) (= i num)) + (reverse! acc) + (append! (reverse! acc) + (make-list (- num i) (car fill)))) + res))) + ((= i num) + (loop l + 0 + '() + (cons (reverse! acc) res))) + (else + (loop (cdr l) + (+ i 1) + (cons (car l) acc) + res))))) + +;;; utils.scm ends here diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm new file mode 100644 index 0000000..e56f350 --- /dev/null +++ b/src/guile/skribilo/source.scm @@ -0,0 +1,190 @@ +;;;; +;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 3-Sep-2003 12:22 (eg) +;;;; Last file update: 27-Oct-2004 20:09 (eg) +;;;; + + + +(define-module (skribilo source) + :export (source-read-lines source-read-definition source-fontify)) + + +;; Temporary solution +(define (language-extractor lang) + (slot-ref lang 'extractor)) + +(define (language-fontifier lang) + (slot-ref lang 'fontifier)) + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+ l 1) #t (read-line) r)) + (else + (loop (+ l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((= i len) + (let ((nlen (- col 1))) + (if (= len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((= i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (* (/ (+ col tabl) + tabl) + tabl))) + (liip (+ i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+ i 1) (+ j 1) (+ col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+ i 1) + (* (/ (+ col tabl) tabl) tabl))) + (else + (loop (+ i 1) (+ col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-path file (skribe-source-path)))) + (cond + ((not (language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + (slot-ref lang 'name))) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\Newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) + diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm new file mode 100644 index 0000000..0d51c70 --- /dev/null +++ b/src/guile/skribilo/types.scm @@ -0,0 +1,315 @@ +;;; +;;; types.stk -- Definition of Skribe classes +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. +;;; +;;; Author: Erick Gallesio [eg@essi.fr] +;;; Creation date: 12-Aug-2003 22:18 (eg) +;;; Last file update: 28-Oct-2004 16:18 (eg) +;;; + +(read-set! keywords 'prefix) +(define-module (skribilo types) ;; FIXME: Why should it be a separate module? + :export ( ast? ast-loc ast-loc-set! + command? command-fmt command-body + unresolved? unresolved-proc + handle? handle-ast + node? node-options node-loc + engine? engine-ident engine-format engine-customs + engine-filter engine-symbol-table + writer? write-object + processor? processor-combinator processor-engine + markup? bind-markup! markup-options is-markup? + markup-body find-markups write-object + container? container-options + container-ident container-body + document? document-ident document-body + document-options document-end + language? + 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. + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +;;FIXME: set! location in +(define-class () + (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) + (loc :init-value #f)) + +(define (ast? obj) (is-a? obj )) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (fmt :init-keyword :fmt) + (body :init-keyword :body)) + +(define (command? obj) (is-a? obj )) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (proc :init-keyword :proc)) + +(define (unresolved? obj) (is-a? obj )) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (ast :init-keyword :ast :init-value #f :getter handle-ast)) + +(define (handle? obj) (is-a? obj )) +(define (handle-ast obj) (slot-ref obj 'ast)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (ident :init-keyword :ident :init-value '???) + (format :init-keyword :format :init-value "raw") + (info :init-keyword :info :init-value '()) + (version :init-keyword :version :init-value 'unspecified) + (delegate :init-keyword :delegate :init-value #f) + (writers :init-keyword :writers :init-value '()) + (filter :init-keyword :filter :init-value #f) + (customs :init-keyword :custom :init-value '()) + (symbol-table :init-keyword :symbol-table :init-value '())) + + + + +(define (engine? obj) + (is-a? obj )) + +(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)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (ident :init-keyword :ident :init-value '??? :getter writer-ident) + (class :init-keyword :class :init-value 'unspecified + :getter writer-class) + (pred :init-keyword :pred :init-value 'unspecified) + (upred :init-keyword :upred :init-value 'unspecified) + (options :init-keyword :options :init-value '() :getter writer-options) + (verified? :init-keyword :verified? :init-value #f) + (validate :init-keyword :validate :init-value #f) + (before :init-keyword :before :init-value #f :getter writer-before) + (action :init-keyword :action :init-value #f :getter writer-action) + (after :init-keyword :after :init-value #f :getter writer-after)) + +(define (writer? obj) + (is-a? obj )) + +(define-method (write-object (obj ) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (address-of obj))) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (required-options :init-keyword :required-options :init-value '()) + (options :init-keyword :options :init-value '()) + (body :init-keyword :body :init-value #f + :getter node-body)) + +(define (node? obj) (is-a? obj )) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (combinator :init-keyword :combinator :init-value (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-value 'unspecified) + (procedure :init-keyword :procedure :init-value (lambda (n e) n))) + +(define (processor? obj) (is-a? obj )) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (ident :init-keyword :ident :getter markup-ident :init-value #f) + (class :init-keyword :class :getter markup-class :init-value #f) + (markup :init-keyword :markup :getter markup-markup)) + + +(define (bind-markup! node) + (hash-set! *node-table* + (markup-ident node) + ;(lambda (cur) (cons node cur)) + (list node))) + + +(define-method (initialize (self ) initargs) + (next-method) + (bind-markup! self)) + + +(define (markup? obj) (is-a? obj )) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) + + +(define (is-markup? obj markup) + (and (is-a? obj ) + (eq? (slot-ref obj 'markup) markup))) + + + +(define (find-markups ident) + (hash-ref *node-table* ident #f)) + + +(define-method (write-object (obj ) port) + (format port "#[~A (~A/~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (address-of obj))) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (env :init-keyword :env :init-value '())) + +(define (container? obj) (is-a? obj )) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class ()) + +(define (document? obj) (is-a? obj )) +(define (document-ident obj) (slot-ref obj 'ident)) +(define (document-body obj) (slot-ref obj 'body)) +(define document-options markup-options) +(define document-env container-env) + + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (name :init-keyword :name :init-value #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier) + (extractor :init-keyword :extractor :init-value #f :getter langage-extractor)) + +(define (language? obj) + (is-a? obj )) + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (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 )) + +(define (ast-location obj) + (let ((loc (slot-ref obj 'loc))) + (if (location? loc) + (let* ((fname (location-file loc)) + (line (location-line loc)) + (pwd (getcwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (> lenf len)) + (substring fname len (+ 1 (string-length fname))) + fname))) + (format "~a, line ~a" file line)) + "no source location"))) diff --git a/src/guile/skribilo/vars.scm b/src/guile/skribilo/vars.scm new file mode 100644 index 0000000..51a7ee7 --- /dev/null +++ b/src/guile/skribilo/vars.scm @@ -0,0 +1,65 @@ +;;; +;;; vars.scm -- Skribe Globals +;;; +;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + + +(define-module (skribilo vars)) + +;;; +;;; Switches +;;; +(define-public *skribe-verbose* 0) +(define-public *skribe-warning* 5) +(define-public *load-rc* #t) + +;;; +;;; PATH variables +;;; +(define-public *skribe-path* #f) +(define-public *skribe-bib-path* '(".")) +(define-public *skribe-source-path* '(".")) +(define-public *skribe-image-path* '(".")) + + +(define-public *skribe-rc-directory* + (string-append (getenv "HOME") "/" ".skribilo")) + + +;;; +;;; In and out ports +;;; +(define-public *skribe-src* '()) +(define-public *skribe-dest* #f) + +;;; +;;; Engine +;;; +(define-public *skribe-engine* 'html) ;; Use HTML by default + +;;; +;;; Misc +;;; +(define-public *skribe-chapter-split* '()) +(define-public *skribe-ref-base* #f) +(define-public *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter +(define-public *skribe-variants* '()) + + diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm new file mode 100644 index 0000000..93a1be3 --- /dev/null +++ b/src/guile/skribilo/verify.scm @@ -0,0 +1,161 @@ +;;;; +;;;; verify.stk -- Skribe Verification Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 11:57 (eg) +;;;; Last file update: 27-Oct-2004 16:35 (eg) +;;;; + +(define-module (skribilo verify) + :export (verify)) + +(use-modules (skribilo debug) +; (skribilo engine) +; (skribilo writer) +; (skribilo runtime) + (skribilo types) + (oop goops)) + + + +(define-generic verify) + +;;; +;;; CHECK-REQUIRED-OPTIONS +;;; +(define (check-required-options markup writer engine) + (let ((required-options (slot-ref markup 'required-options)) + (ident (slot-ref writer 'ident)) + (options (slot-ref writer 'options)) + (verified? (slot-ref writer 'verified?))) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (engine-ident engine) + (format "Option unsupported: ~a, supported options: ~a" o options) + markup))) + required-options) + (slot-set! writer 'verified? #t))))) + +;;; +;;; CHECK-OPTIONS +;;; +(define (check-options lopts markup engine) + + ;; Only keywords are checked, symbols are voluntary left unchecked. */ + (with-debug 6 'check-options + (debug-item "markup=" (markup-markup markup)) + (debug-item "options=" (slot-ref markup 'options)) + (debug-item "lopts=" lopts) + (for-each + (lambda (o2) + (for-each + (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o lopts))) + (skribe-warning/ast + 3 + markup + 'verify + (format "Engine ~a does not support markup ~a option `~a' -- ~a" + (engine-ident engine) + (markup-markup markup) + o + (markup-option markup o))))) + o2)) + (slot-ref markup 'options)))) + + +;;; ====================================================================== +;;; +;;; V E R I F Y +;;; +;;; ====================================================================== + +;;; TOP +(define-method (verify (obj ) e) + obj) + +;;; PAIR +(define-method (verify (obj ) e) + (for-each (lambda (x) (verify x e)) obj) + obj) + +;;; PROCESSOR +(define-method (verify (obj ) 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 ) 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 ) e) + (with-debug 5 'verify:: + (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 ) e) + (next-method) + + ;; verify the engine customs + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (slot-ref e 'customs)) + + node) + + diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm new file mode 100644 index 0000000..048dcfb --- /dev/null +++ b/src/guile/skribilo/writer.scm @@ -0,0 +1,217 @@ +;;;; +;;;; writer.stk -- Skribe Writer Stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 15-Sep-2003 22:21 (eg) +;;;; Last file update: 4-Mar-2004 10:48 (eg) +;;;; + + +(define-module (skribilo writer) + :export (invoke markup-writer markup-writer-get markup-writer-get* + lookup-markup-writer copy-markup-writer)) + + +(use-modules (skribilo debug) +; (skribilo engine) + (skribilo output) + + (oop goops) + (ice-9 optargs)) + + +;;;; ====================================================================== +;;;; +;;;; INVOKE +;;;; +;;;; ====================================================================== +(define (invoke proc node e) + (with-debug 5 'invoke + (debug-item "e=" (engine-ident e)) + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))) + + +;;;; ====================================================================== +;;;; +;;;; LOOKUP-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (lookup-markup-writer node e) + (let ((writers (slot-ref e 'writers)) + (delegate (slot-ref e 'delegate))) + (let Loop ((w* writers)) + (cond + ((pair? w*) + (let ((pred (slot-ref (car w*) 'pred))) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;;;; ====================================================================== +;;;; +;;;; MAKE-WRITER-PREDICATE +;;;; +;;;; ====================================================================== +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (eq? (%procedure-arity predicate) 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define* (markup-writer markup #:optional engine + #:key (predicate #f) (class #f) (options '()) + (validate #f) + (before #f) (action 'unspecified) (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action 'unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action 'unspecified) + (lambda (n e) (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET +;;;; +;;;; ====================================================================== +(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer-get "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer-get "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (slot-ref e 'writers))) + (cond + ((pair? w*) + (if (and (eq? (writer-ident (car w*)) markup) + (equal? (writer-class (car w*)) class) + (or (unspecified? pred) + (eq? (slot-ref (car w*) 'upred) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate))) + (else + #f)))))))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET* +;;;; +;;;; ====================================================================== + +;; Finds all writers that matches MARKUP with optional CLASS attribute. + +(define* (markup-writer-get* markup #:optional engine #:key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (slot-ref e 'writers)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (slot-ref (car w*) 'ident) markup) + (equal? (slot-ref (car w*) 'class) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate) res)) + (else + (reverse! res))))))))) + +;;; ====================================================================== +;;;; +;;;; COPY-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define* (copy-markup-writer markup old-engine :optional new-engine + :key (predicate 'unspecified) + (class 'unspecified) + (options 'unspecified) + (validate 'unspecified) + (before 'unspecified) + (action 'unspecified) + (after 'unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate) + :class (if (unspecified? class) (slot-ref old 'class) class) + :options (if (unspecified? options) (slot-ref old 'options) options) + :validate (if (unspecified? validate) (slot-ref old 'validate) validate) + :before (if (unspecified? before) (slot-ref old 'before) before) + :action (if (unspecified? action) (slot-ref old 'action) action) + :after (if (unspecified? after) (slot-ref old 'after) after)))) -- cgit v1.2.3