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