From 409e8a99bf90ddb8e5d40c6dd8559ad1d97b925f Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Jul 2005 17:06:50 +0000 Subject: Cosmetic changes. * src/guile/skribilo/resolve.scm: Minor cosmetic changes. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-6 --- src/guile/skribilo/resolve.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index 14f36b2..a39bb77 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -178,7 +178,7 @@ (cadr c) n))) ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) + (skribe-error 'resolve-parent "orphan node" n)) (else (slot-ref n 'parent))))) @@ -211,7 +211,7 @@ (let ((c (assq (symbol-append cnt '-counter) e))) (if (not (pair? c)) (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "Orphan node" n) + (skribe-error cnt "orphan node" n) (begin (set-cdr! (last-pair e) (list (list (symbol-append cnt '-counter) 0) -- cgit v1.2.3 From e9509518623d016880392237a298d4561a3b6a0b Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 31 Oct 2005 16:03:18 +0000 Subject: Removed useless files, integrated packages. * src/guile/skribilo/packages: New directory and files. * bin: Removed. * skr: Removed (files moved to `src/guile/skribilo/packages'). * skribe: Removed. * doc/skr/env.skr (*courtes-mail*): New. * doc/user/user.skb: Removed postal addresses, added my name. * src/guile/skribilo/engine/lout.scm: Uncommented the slide-related markup writers. * src/guile/skribilo/evaluator.scm (%evaluate): Try weird things with source properties. * src/guile/skribilo/reader/skribe.scm: Comply with the new guile-reader API. * src/guile/skribilo/types.scm: Removed the special `initialize' method for ASTs which was supposed to set their location. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-7 --- README.java | 36 - bin/skribe.bigloo | Bin 412304 -> 0 bytes bin/skribebibtex.bigloo | Bin 36696 -> 0 bytes doc/skr/env.skr | 1 + doc/user/user.skb | 13 +- skr/Makefile | 43 - skr/acmproc.skr | 155 -- skr/french.skr | 19 - skr/jfp.skr | 317 --- skr/letter.skr | 146 -- skr/lncs.skr | 147 -- skr/scribe.skr | 229 --- skr/sigplan.skr | 155 -- skr/skribe.skr | 76 - skr/slide.skr | 664 ------ skr/web-article.skr | 230 --- skr/web-book.skr | 107 - skribe.prj | 332 --- skribe/INSTALL | 110 - skribe/LICENSE | 25 - skribe/Makefile | 131 -- skribe/README | 69 - skribe/README.java | 36 - skribe/configure | 124 -- skribe/doc/Makefile | 233 --- skribe/doc/Makefile.dir | 22 - skribe/doc/dir/dir.skb | 113 -- skribe/doc/img/bsd.gif | Bin 4226 -> 0 bytes skribe/doc/img/lambda.gif | Bin 169 -> 0 bytes skribe/doc/img/linux.gif | Bin 1972 -> 0 bytes skribe/doc/skr/api.skr | 575 ------ skribe/doc/skr/env.skr | 32 - skribe/doc/skr/extension.skr | 95 - skribe/doc/skr/manual.skr | 281 --- skribe/doc/user/bib.skb | 252 --- skribe/doc/user/char.skb | 86 - skribe/doc/user/colframe.skb | 57 - skribe/doc/user/document.skb | 80 - skribe/doc/user/emacs.skb | 58 - skribe/doc/user/engine.skb | 135 -- skribe/doc/user/enumeration.skb | 33 - skribe/doc/user/examples.skb | 34 - skribe/doc/user/figure.skb | 58 - skribe/doc/user/font.skb | 30 - skribe/doc/user/footnote.skb | 28 - skribe/doc/user/htmle.skb | 111 - skribe/doc/user/image.skb | 79 - skribe/doc/user/index.skb | 118 -- skribe/doc/user/justify.skb | 30 - skribe/doc/user/latexe.skb | 60 - skribe/doc/user/lib.skb | 156 -- skribe/doc/user/line.skb | 39 - skribe/doc/user/links.skb | 152 -- skribe/doc/user/markup.skb | 83 - skribe/doc/user/ornament.skb | 25 - skribe/doc/user/package.skb | 139 -- skribe/doc/user/prgm.skb | 121 -- skribe/doc/user/sectioning.skb | 117 -- skribe/doc/user/skribe-config.skb | 44 - skribe/doc/user/skribec.skb | 56 - skribe/doc/user/skribeinfo.skb | 50 - skribe/doc/user/slide.skb | 114 -- skribe/doc/user/src/api1.skb | 5 - skribe/doc/user/src/api10.skb | 12 - skribe/doc/user/src/api11.skb | 22 - skribe/doc/user/src/api12.skb | 1 - skribe/doc/user/src/api13.skb | 10 - skribe/doc/user/src/api14.skb | 9 - skribe/doc/user/src/api15.skb | 25 - skribe/doc/user/src/api16.skb | 5 - skribe/doc/user/src/api17.skb | 9 - skribe/doc/user/src/api18.skb | 2 - skribe/doc/user/src/api19.skb | 3 - skribe/doc/user/src/api2.skb | 5 - skribe/doc/user/src/api20.skb | 2 - skribe/doc/user/src/api3.skb | 8 - skribe/doc/user/src/api4.skb | 2 - skribe/doc/user/src/api5.skb | 2 - skribe/doc/user/src/api6.skb | 1 - skribe/doc/user/src/api7.skb | 3 - skribe/doc/user/src/api8.skb | 15 - skribe/doc/user/src/api9.skb | 5 - skribe/doc/user/src/bib1.sbib | 39 - skribe/doc/user/src/bib2.skb | 7 - skribe/doc/user/src/bib3.skb | 3 - skribe/doc/user/src/bib4.skb | 5 - skribe/doc/user/src/bib5.skb | 24 - skribe/doc/user/src/bib6.skb | 1 - skribe/doc/user/src/index1.skb | 1 - skribe/doc/user/src/index2.skb | 11 - skribe/doc/user/src/index3.skb | 1 - skribe/doc/user/src/links1.skb | 23 - skribe/doc/user/src/links2.skb | 4 - skribe/doc/user/src/prgm1.skb | 15 - skribe/doc/user/src/prgm2.skb | 18 - skribe/doc/user/src/prgm3.skb | 55 - skribe/doc/user/src/slides.skb | 27 - skribe/doc/user/src/start1.skb | 2 - skribe/doc/user/src/start2.skb | 2 - skribe/doc/user/src/start3.skb | 10 - skribe/doc/user/src/start4.skb | 13 - skribe/doc/user/src/start5.skb | 9 - skribe/doc/user/start.skb | 197 -- skribe/doc/user/syntax.skb | 105 - skribe/doc/user/table.skb | 81 - skribe/doc/user/toc.skb | 37 - skribe/doc/user/user.skb | 163 -- skribe/doc/user/xmle.skb | 25 - skribe/emacs/Makefile | 55 - skribe/emacs/skribe.el.in | 841 -------- skribe/etc/ChangeLog | 698 ------- skribe/etc/Makefile | 50 - skribe/etc/bigloo/Makefile | 114 -- skribe/etc/bigloo/Makefile.tpl | 200 -- skribe/etc/bigloo/autoconf/Makefile | 53 - skribe/etc/bigloo/autoconf/bfildir | 36 - skribe/etc/bigloo/autoconf/blibdir | 36 - skribe/etc/bigloo/autoconf/bversion | 42 - skribe/etc/bigloo/autoconf/getbversion | 36 - skribe/etc/bigloo/autoconf/gmaketest | 38 - skribe/etc/bigloo/configure | 552 ----- skribe/etc/skribe-config.in | 64 - skribe/etc/stklos/Makefile.config.in | 5 - skribe/etc/stklos/Makefile.in | 44 - skribe/etc/stklos/Makefile.skb.in | 5 - skribe/etc/stklos/configure | 830 -------- skribe/etc/stklos/configure.in | 57 - skribe/examples/Makefile | 48 - skribe/examples/slide/Makefile | 153 -- skribe/examples/slide/PPRskribe.sty | 67 - skribe/examples/slide/README | 11 - skribe/examples/slide/advi.sty | 416 ---- skribe/examples/slide/ex/skribe.skb | 11 - skribe/examples/slide/ex/syntax.scr | 1 - skribe/examples/slide/skb/slides.skb | 286 --- skribe/examples/slide/skr/local.skr | 73 - skribe/skr/Makefile | 43 - skribe/skr/acmproc.skr | 155 -- skribe/skr/base.skr | 464 ----- skribe/skr/context.skr | 1380 ------------- skribe/skr/french.skr | 19 - skribe/skr/html.skr | 2251 --------------------- skribe/skr/html4.skr | 165 -- skribe/skr/jfp.skr | 317 --- skribe/skr/latex-simple.skr | 101 - skribe/skr/latex.skr | 1780 ---------------- skribe/skr/letter.skr | 146 -- skribe/skr/lncs.skr | 147 -- skribe/skr/scribe.skr | 229 --- skribe/skr/sigplan.skr | 155 -- skribe/skr/skribe.skr | 76 - skribe/skr/slide.skr | 664 ------ skribe/skr/web-article.skr | 230 --- skribe/skr/web-book.skr | 107 - skribe/skr/xml.skr | 111 - skribe/skribe.prj | 332 --- skribe/src/Makefile | 41 - skribe/src/bigloo/Makefile | 271 --- skribe/src/bigloo/api.bgl | 117 -- skribe/src/bigloo/api.sch | 91 - skribe/src/bigloo/asm.scm | 99 - skribe/src/bigloo/bib.bgl | 161 -- skribe/src/bigloo/c.scm | 134 -- skribe/src/bigloo/color.scm | 702 ------- skribe/src/bigloo/configure.bgl | 90 - skribe/src/bigloo/debug.sch | 54 - skribe/src/bigloo/debug.scm | 188 -- skribe/src/bigloo/engine.scm | 262 --- skribe/src/bigloo/eval.scm | 335 --- skribe/src/bigloo/evapi.scm | 39 - skribe/src/bigloo/index.bgl | 32 - skribe/src/bigloo/lib.bgl | 340 ---- skribe/src/bigloo/lisp.scm | 530 ----- skribe/src/bigloo/main.scm | 96 - skribe/src/bigloo/new.sch | 17 - skribe/src/bigloo/output.scm | 167 -- skribe/src/bigloo/param.bgl | 134 -- skribe/src/bigloo/parseargs.scm | 186 -- skribe/src/bigloo/prog.scm | 196 -- skribe/src/bigloo/read.scm | 482 ----- skribe/src/bigloo/resolve.scm | 281 --- skribe/src/bigloo/source.scm | 238 --- skribe/src/bigloo/sui.bgl | 34 - skribe/src/bigloo/types.scm | 685 ------- skribe/src/bigloo/verify.scm | 143 -- skribe/src/bigloo/writer.scm | 232 --- skribe/src/bigloo/xml.scm | 92 - skribe/src/common/api.scm | 1243 ------------ skribe/src/common/bib.scm | 192 -- skribe/src/common/configure.scm.in | 6 - skribe/src/common/index.scm | 126 -- skribe/src/common/lib.scm | 238 --- skribe/src/common/param.scm | 69 - skribe/src/common/sui.scm | 166 -- skribe/src/stklos/Makefile.in | 110 - skribe/src/stklos/biblio.stk | 161 -- skribe/src/stklos/c-lex.l | 67 - skribe/src/stklos/c.stk | 95 - skribe/src/stklos/color.stk | 622 ------ skribe/src/stklos/configure.stk | 90 - skribe/src/stklos/debug.stk | 161 -- skribe/src/stklos/engine.stk | 242 --- skribe/src/stklos/eval.stk | 149 -- skribe/src/stklos/lib.stk | 317 --- skribe/src/stklos/lisp-lex.l | 91 - skribe/src/stklos/lisp.stk | 294 --- skribe/src/stklos/main.stk | 264 --- skribe/src/stklos/output.stk | 158 -- skribe/src/stklos/prog.stk | 219 -- skribe/src/stklos/reader.stk | 136 -- skribe/src/stklos/resolve.stk | 255 --- skribe/src/stklos/runtime.stk | 456 ----- skribe/src/stklos/source.stk | 191 -- skribe/src/stklos/types.stk | 294 --- skribe/src/stklos/vars.stk | 82 - skribe/src/stklos/verify.stk | 157 -- skribe/src/stklos/writer.stk | 211 -- skribe/src/stklos/xml-lex.l | 64 - skribe/src/stklos/xml.stk | 52 - skribe/tools/Makefile | 60 - skribe/tools/skribebibtex/bigloo/Makefile | 70 - skribe/tools/skribebibtex/bigloo/main.scm | 44 - skribe/tools/skribebibtex/bigloo/skribebibtex.scm | 385 ---- skribe/tools/skribebibtex/stklos/Makefile | 62 - skribe/tools/skribebibtex/stklos/bibtex-lex.l | 75 - skribe/tools/skribebibtex/stklos/bibtex-parser.y | 117 -- skribe/tools/skribebibtex/stklos/main.stk | 118 -- src/guile/skribilo/engine/lout.scm | 174 +- src/guile/skribilo/evaluator.scm | 12 +- src/guile/skribilo/packages/acmproc.scm | 155 ++ src/guile/skribilo/packages/french.scm | 21 + src/guile/skribilo/packages/jfp.scm | 319 +++ src/guile/skribilo/packages/letter.scm | 148 ++ src/guile/skribilo/packages/lncs.scm | 149 ++ src/guile/skribilo/packages/scribe.scm | 231 +++ src/guile/skribilo/packages/sigplan.scm | 157 ++ src/guile/skribilo/packages/skribe.scm | 76 + src/guile/skribilo/packages/slide.scm | 667 ++++++ src/guile/skribilo/packages/web-article.scm | 232 +++ src/guile/skribilo/packages/web-book.scm | 107 + src/guile/skribilo/reader/skribe.scm | 36 +- src/guile/skribilo/skribe/param.scm | 19 +- src/guile/skribilo/types.scm | 8 - 243 files changed, 2398 insertions(+), 36070 deletions(-) delete mode 100644 README.java delete mode 100755 bin/skribe.bigloo delete mode 100755 bin/skribebibtex.bigloo delete mode 100644 skr/Makefile delete mode 100644 skr/acmproc.skr delete mode 100644 skr/french.skr delete mode 100644 skr/jfp.skr delete mode 100644 skr/letter.skr delete mode 100644 skr/lncs.skr delete mode 100644 skr/scribe.skr delete mode 100644 skr/sigplan.skr delete mode 100644 skr/skribe.skr delete mode 100644 skr/slide.skr delete mode 100644 skr/web-article.skr delete mode 100644 skr/web-book.skr delete mode 100644 skribe.prj delete mode 100644 skribe/INSTALL delete mode 100644 skribe/LICENSE delete mode 100644 skribe/Makefile delete mode 100644 skribe/README delete mode 100644 skribe/README.java delete mode 100755 skribe/configure delete mode 100644 skribe/doc/Makefile delete mode 100644 skribe/doc/Makefile.dir delete mode 100644 skribe/doc/dir/dir.skb delete mode 100644 skribe/doc/img/bsd.gif delete mode 100644 skribe/doc/img/lambda.gif delete mode 100644 skribe/doc/img/linux.gif delete mode 100644 skribe/doc/skr/api.skr delete mode 100644 skribe/doc/skr/env.skr delete mode 100644 skribe/doc/skr/extension.skr delete mode 100644 skribe/doc/skr/manual.skr delete mode 100644 skribe/doc/user/bib.skb delete mode 100644 skribe/doc/user/char.skb delete mode 100644 skribe/doc/user/colframe.skb delete mode 100644 skribe/doc/user/document.skb delete mode 100644 skribe/doc/user/emacs.skb delete mode 100644 skribe/doc/user/engine.skb delete mode 100644 skribe/doc/user/enumeration.skb delete mode 100644 skribe/doc/user/examples.skb delete mode 100644 skribe/doc/user/figure.skb delete mode 100644 skribe/doc/user/font.skb delete mode 100644 skribe/doc/user/footnote.skb delete mode 100644 skribe/doc/user/htmle.skb delete mode 100644 skribe/doc/user/image.skb delete mode 100644 skribe/doc/user/index.skb delete mode 100644 skribe/doc/user/justify.skb delete mode 100644 skribe/doc/user/latexe.skb delete mode 100644 skribe/doc/user/lib.skb delete mode 100644 skribe/doc/user/line.skb delete mode 100644 skribe/doc/user/links.skb delete mode 100644 skribe/doc/user/markup.skb delete mode 100644 skribe/doc/user/ornament.skb delete mode 100644 skribe/doc/user/package.skb delete mode 100644 skribe/doc/user/prgm.skb delete mode 100644 skribe/doc/user/sectioning.skb delete mode 100644 skribe/doc/user/skribe-config.skb delete mode 100644 skribe/doc/user/skribec.skb delete mode 100644 skribe/doc/user/skribeinfo.skb delete mode 100644 skribe/doc/user/slide.skb delete mode 100644 skribe/doc/user/src/api1.skb delete mode 100644 skribe/doc/user/src/api10.skb delete mode 100644 skribe/doc/user/src/api11.skb delete mode 100644 skribe/doc/user/src/api12.skb delete mode 100644 skribe/doc/user/src/api13.skb delete mode 100644 skribe/doc/user/src/api14.skb delete mode 100644 skribe/doc/user/src/api15.skb delete mode 100644 skribe/doc/user/src/api16.skb delete mode 100644 skribe/doc/user/src/api17.skb delete mode 100644 skribe/doc/user/src/api18.skb delete mode 100644 skribe/doc/user/src/api19.skb delete mode 100644 skribe/doc/user/src/api2.skb delete mode 100644 skribe/doc/user/src/api20.skb delete mode 100644 skribe/doc/user/src/api3.skb delete mode 100644 skribe/doc/user/src/api4.skb delete mode 100644 skribe/doc/user/src/api5.skb delete mode 100644 skribe/doc/user/src/api6.skb delete mode 100644 skribe/doc/user/src/api7.skb delete mode 100644 skribe/doc/user/src/api8.skb delete mode 100644 skribe/doc/user/src/api9.skb delete mode 100644 skribe/doc/user/src/bib1.sbib delete mode 100644 skribe/doc/user/src/bib2.skb delete mode 100644 skribe/doc/user/src/bib3.skb delete mode 100644 skribe/doc/user/src/bib4.skb delete mode 100644 skribe/doc/user/src/bib5.skb delete mode 100644 skribe/doc/user/src/bib6.skb delete mode 100644 skribe/doc/user/src/index1.skb delete mode 100644 skribe/doc/user/src/index2.skb delete mode 100644 skribe/doc/user/src/index3.skb delete mode 100644 skribe/doc/user/src/links1.skb delete mode 100644 skribe/doc/user/src/links2.skb delete mode 100644 skribe/doc/user/src/prgm1.skb delete mode 100644 skribe/doc/user/src/prgm2.skb delete mode 100644 skribe/doc/user/src/prgm3.skb delete mode 100644 skribe/doc/user/src/slides.skb delete mode 100644 skribe/doc/user/src/start1.skb delete mode 100644 skribe/doc/user/src/start2.skb delete mode 100644 skribe/doc/user/src/start3.skb delete mode 100644 skribe/doc/user/src/start4.skb delete mode 100644 skribe/doc/user/src/start5.skb delete mode 100644 skribe/doc/user/start.skb delete mode 100644 skribe/doc/user/syntax.skb delete mode 100644 skribe/doc/user/table.skb delete mode 100644 skribe/doc/user/toc.skb delete mode 100644 skribe/doc/user/user.skb delete mode 100644 skribe/doc/user/xmle.skb delete mode 100644 skribe/emacs/Makefile delete mode 100644 skribe/emacs/skribe.el.in delete mode 100644 skribe/etc/ChangeLog delete mode 100644 skribe/etc/Makefile delete mode 100644 skribe/etc/bigloo/Makefile delete mode 100644 skribe/etc/bigloo/Makefile.tpl delete mode 100644 skribe/etc/bigloo/autoconf/Makefile delete mode 100755 skribe/etc/bigloo/autoconf/bfildir delete mode 100755 skribe/etc/bigloo/autoconf/blibdir delete mode 100755 skribe/etc/bigloo/autoconf/bversion delete mode 100755 skribe/etc/bigloo/autoconf/getbversion delete mode 100755 skribe/etc/bigloo/autoconf/gmaketest delete mode 100755 skribe/etc/bigloo/configure delete mode 100644 skribe/etc/skribe-config.in delete mode 100644 skribe/etc/stklos/Makefile.config.in delete mode 100644 skribe/etc/stklos/Makefile.in delete mode 100644 skribe/etc/stklos/Makefile.skb.in delete mode 100755 skribe/etc/stklos/configure delete mode 100644 skribe/etc/stklos/configure.in delete mode 100644 skribe/examples/Makefile delete mode 100644 skribe/examples/slide/Makefile delete mode 100644 skribe/examples/slide/PPRskribe.sty delete mode 100644 skribe/examples/slide/README delete mode 100644 skribe/examples/slide/advi.sty delete mode 100644 skribe/examples/slide/ex/skribe.skb delete mode 100644 skribe/examples/slide/ex/syntax.scr delete mode 100644 skribe/examples/slide/skb/slides.skb delete mode 100644 skribe/examples/slide/skr/local.skr delete mode 100644 skribe/skr/Makefile delete mode 100644 skribe/skr/acmproc.skr delete mode 100644 skribe/skr/base.skr delete mode 100644 skribe/skr/context.skr delete mode 100644 skribe/skr/french.skr delete mode 100644 skribe/skr/html.skr delete mode 100644 skribe/skr/html4.skr delete mode 100644 skribe/skr/jfp.skr delete mode 100644 skribe/skr/latex-simple.skr delete mode 100644 skribe/skr/latex.skr delete mode 100644 skribe/skr/letter.skr delete mode 100644 skribe/skr/lncs.skr delete mode 100644 skribe/skr/scribe.skr delete mode 100644 skribe/skr/sigplan.skr delete mode 100644 skribe/skr/skribe.skr delete mode 100644 skribe/skr/slide.skr delete mode 100644 skribe/skr/web-article.skr delete mode 100644 skribe/skr/web-book.skr delete mode 100644 skribe/skr/xml.skr delete mode 100644 skribe/skribe.prj delete mode 100644 skribe/src/Makefile delete mode 100644 skribe/src/bigloo/Makefile delete mode 100644 skribe/src/bigloo/api.bgl delete mode 100644 skribe/src/bigloo/api.sch delete mode 100644 skribe/src/bigloo/asm.scm delete mode 100644 skribe/src/bigloo/bib.bgl delete mode 100644 skribe/src/bigloo/c.scm delete mode 100644 skribe/src/bigloo/color.scm delete mode 100644 skribe/src/bigloo/configure.bgl delete mode 100644 skribe/src/bigloo/debug.sch delete mode 100644 skribe/src/bigloo/debug.scm delete mode 100644 skribe/src/bigloo/engine.scm delete mode 100644 skribe/src/bigloo/eval.scm delete mode 100644 skribe/src/bigloo/evapi.scm delete mode 100644 skribe/src/bigloo/index.bgl delete mode 100644 skribe/src/bigloo/lib.bgl delete mode 100644 skribe/src/bigloo/lisp.scm delete mode 100644 skribe/src/bigloo/main.scm delete mode 100644 skribe/src/bigloo/new.sch delete mode 100644 skribe/src/bigloo/output.scm delete mode 100644 skribe/src/bigloo/param.bgl delete mode 100644 skribe/src/bigloo/parseargs.scm delete mode 100644 skribe/src/bigloo/prog.scm delete mode 100644 skribe/src/bigloo/read.scm delete mode 100644 skribe/src/bigloo/resolve.scm delete mode 100644 skribe/src/bigloo/source.scm delete mode 100644 skribe/src/bigloo/sui.bgl delete mode 100644 skribe/src/bigloo/types.scm delete mode 100644 skribe/src/bigloo/verify.scm delete mode 100644 skribe/src/bigloo/writer.scm delete mode 100644 skribe/src/bigloo/xml.scm delete mode 100644 skribe/src/common/api.scm delete mode 100644 skribe/src/common/bib.scm delete mode 100644 skribe/src/common/configure.scm.in delete mode 100644 skribe/src/common/index.scm delete mode 100644 skribe/src/common/lib.scm delete mode 100644 skribe/src/common/param.scm delete mode 100644 skribe/src/common/sui.scm delete mode 100644 skribe/src/stklos/Makefile.in delete mode 100644 skribe/src/stklos/biblio.stk delete mode 100644 skribe/src/stklos/c-lex.l delete mode 100644 skribe/src/stklos/c.stk delete mode 100644 skribe/src/stklos/color.stk delete mode 100644 skribe/src/stklos/configure.stk delete mode 100644 skribe/src/stklos/debug.stk delete mode 100644 skribe/src/stklos/engine.stk delete mode 100644 skribe/src/stklos/eval.stk delete mode 100644 skribe/src/stklos/lib.stk delete mode 100644 skribe/src/stklos/lisp-lex.l delete mode 100644 skribe/src/stklos/lisp.stk delete mode 100644 skribe/src/stklos/main.stk delete mode 100644 skribe/src/stklos/output.stk delete mode 100644 skribe/src/stklos/prog.stk delete mode 100644 skribe/src/stklos/reader.stk delete mode 100644 skribe/src/stklos/resolve.stk delete mode 100644 skribe/src/stklos/runtime.stk delete mode 100644 skribe/src/stklos/source.stk delete mode 100644 skribe/src/stklos/types.stk delete mode 100644 skribe/src/stklos/vars.stk delete mode 100644 skribe/src/stklos/verify.stk delete mode 100644 skribe/src/stklos/writer.stk delete mode 100644 skribe/src/stklos/xml-lex.l delete mode 100644 skribe/src/stklos/xml.stk delete mode 100644 skribe/tools/Makefile delete mode 100644 skribe/tools/skribebibtex/bigloo/Makefile delete mode 100644 skribe/tools/skribebibtex/bigloo/main.scm delete mode 100644 skribe/tools/skribebibtex/bigloo/skribebibtex.scm delete mode 100644 skribe/tools/skribebibtex/stklos/Makefile delete mode 100644 skribe/tools/skribebibtex/stklos/bibtex-lex.l delete mode 100644 skribe/tools/skribebibtex/stklos/bibtex-parser.y delete mode 100644 skribe/tools/skribebibtex/stklos/main.stk create mode 100644 src/guile/skribilo/packages/acmproc.scm create mode 100644 src/guile/skribilo/packages/french.scm create mode 100644 src/guile/skribilo/packages/jfp.scm create mode 100644 src/guile/skribilo/packages/letter.scm create mode 100644 src/guile/skribilo/packages/lncs.scm create mode 100644 src/guile/skribilo/packages/scribe.scm create mode 100644 src/guile/skribilo/packages/sigplan.scm create mode 100644 src/guile/skribilo/packages/skribe.scm create mode 100644 src/guile/skribilo/packages/slide.scm create mode 100644 src/guile/skribilo/packages/web-article.scm create mode 100644 src/guile/skribilo/packages/web-book.scm (limited to 'src') diff --git a/README.java b/README.java deleted file mode 100644 index dcb0457..0000000 --- a/README.java +++ /dev/null @@ -1,36 +0,0 @@ -This README explains how to use the pre-compiled JVM -version of Skribe. This requires JDK 1.3 or higher. - -Installing SKRIBE -***************** - -The pre-compiled version of SKRIBE does not need installation procedure. -It is pre-installed. The documentation is pre-compiled. It is located -in the directory doc/html. - - -Running SKRIBE -************** - -Lets assume that SKRIBEDIR is the shell variable containing -the name of the directory where Skribe has been unzipped: - -1. To compile a Skribe program "prog.skr" uses: - - java -classpath $SKRIBEDIR/bin/skribe.zip:$SKRIBEDIR/lib/bigloo_s.zip -Dbigloo.SKRIBEPATH=$SKRIBEDIR/skr bigloo.skribe.main prog.skr - -2. To convert a Texi file "prog.texi" into Skribe: - - java -classpath $SKRIBEDIR/bin/skribeinfo.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribeinfo.main prog.texi - -3. To convert a BibTex database "db.bib" into Skribe: - - java -classpath $SKRIBEDIR/bin/skribebibtex.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribebibtex.main db.bib - - -Compiling the examples -********************** - -On a Unix platform: - - cd examples; make diff --git a/bin/skribe.bigloo b/bin/skribe.bigloo deleted file mode 100755 index 2122927..0000000 Binary files a/bin/skribe.bigloo and /dev/null differ diff --git a/bin/skribebibtex.bigloo b/bin/skribebibtex.bigloo deleted file mode 100755 index e0ced38..0000000 Binary files a/bin/skribebibtex.bigloo and /dev/null differ diff --git a/doc/skr/env.skr b/doc/skr/env.skr index 09d5146..463b997 100644 --- a/doc/skr/env.skr +++ b/doc/skr/env.skr @@ -11,6 +11,7 @@ (define *serrano-url* "http://www.inria.fr/mimosa/Manuel.Serrano") (define *serrano-mail* "Manuel.Serrano@sophia.inria.fr") +(define *courtes-mail* "ludovic.courtes@laas.fr") (define *html-url* "http://www.w3.org/TR/html4") (define *html-form* "interact/forms.html") (define *emacs-url* "http://www.gnu.org/software/emacs") diff --git a/doc/user/user.skb b/doc/user/user.skb index 3710be9..334dd5c 100644 --- a/doc/user/user.skb +++ b/doc/user/user.skb @@ -40,17 +40,12 @@ :env '((example-counter 0) (example-env ())) :author (list (author :name "Erick Gallesio" :affiliation "Université de Nice - Sophia Antipolis" - :address '("930 route des Colles, BP 145" - "F-06903 Sophia Antipolis, Cedex" - "France") :email (mailto "eg@essi.fr")) (author :name "Manuel Serrano" :affiliation "Inria Sophia-Antipolis" - :address `("2004 route des Lucioles - BP 93" - "F-06902 Sophia Antipolis, Cedex" - "France") - :url (ref :url *serrano-url*) - :email (mailto *serrano-mail*))) + :email (mailto *serrano-mail*)) + (author :name "Ludovic Courtès" + :email (mailto *courtes-mail*))) (linebreak 1) (center (frame (bold (font :size 1. [ @@ -120,7 +115,7 @@ as HTML, Info pages, man pages, Postscript, etc.])))) (include "bib.skb") ;;; Computer programs -(include "prgm.skb") +;;(include "prgm.skb") ;;; Standard Library (include "lib.skb") diff --git a/skr/Makefile b/skr/Makefile deleted file mode 100644 index dcc3e77..0000000 --- a/skr/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/skr/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:21:20 2003 */ -#* Last change : Wed May 18 15:34:21 2005 (serrano) */ -#* Copyright : 2003-05 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Skribe SKR Makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* POPULATION */ -#*---------------------------------------------------------------------*/ -POPULATION= acmproc.skr sigplan.skr jfp.skr \ - slide.skr web-book.skr web-article.skr \ - base.skr latex.skr scribe.skr xml.skr \ - html.skr html4.skr lncs.skr skribe.skr \ - letter.skr french.skr latex-simple.skr context.skr Makefile - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATION:%=skr/%) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_SKRDIR) - cp *.skr $(DESTDIR)$(INSTALL_SKRDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/* - -uninstall: - -$(DESTDIR)$(INSTALL_SKRDIR): - mkdir -p $(DESTDIR)$(INSTALL_SKRDIR) && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR) - diff --git a/skr/acmproc.skr b/skr/acmproc.skr deleted file mode 100644 index 4accc7c..0000000 --- a/skr/acmproc.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/acmproc.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[letterpaper]{acmproc}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\numberofauthors{~a}\n\\author{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "\\alignauthor\n") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\CopyrightYear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\crdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key (class "abstract") postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :class class :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skr/french.skr b/skr/french.skr deleted file mode 100644 index 373d076..0000000 --- a/skr/french.skr +++ /dev/null @@ -1,19 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* French Skribe style */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'usepackage - (string-append (engine-custom le 'usepackage) - "\\usepackage[french]{babel} -\\usepackage{a4}"))) diff --git a/skr/jfp.skr b/skr/jfp.skr deleted file mode 100644 index 60b40f2..0000000 --- a/skr/jfp.skr +++ /dev/null @@ -1,317 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/jfp.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for JFP articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{jfp}") - (engine-custom-set! le 'hyperref #f) - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-subauthor) - (let* ((d (ast-document n)) - (sa (and (is-markup? d 'document) - (markup-option d :head-author)))) - (if sa - (begin - (display "[") - (output sa e) - (display "]"))))) - (define (&latex-author-1 n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output (car n) e) - (for-each (lambda (a) - (display "\\and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (&latex-author-1 body)) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (&latex-author-n body)) - (else - (skribe-error 'author - "Illegal `jfp' author" - body)))))) - ;; title - (markup-writer '&latex-title le - :before (lambda (n e) - (let* ((d (ast-document n)) - (st (and (is-markup? d 'document) - (markup-option d :head-title)))) - (if st - (begin - (display "\\title[") - (output st e) - (display "]{")) - (display "\\title{")))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (aff (markup-option n :affiliation)) - (addr (markup-option n :address)) - (email (markup-option n :email))) - (if name - (begin - (output name e) - (display "\\\\\n"))) - (if aff - (begin - (output aff e) - (display "\\\\\n"))) - (if addr - (begin - (if (pair? addr) - (for-each (lambda (a) - (output a e) - (display "\\\\\n")) - addr) - (begin - (output addr e) - (display "\\\\\n"))))) - (if email - (begin - (display "\\email{") - (output email e) - (display "}\\\\\n"))))))) - ;; bib-ref - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :before "(" - :action (lambda (n e) - (let ((be (handle-ast (markup-body n)))) - (if (is-markup? be '&bib-entry) - (let ((a (markup-option be 'author)) - (y (markup-option be 'year))) - (cond - ((and (is-markup? a '&bib-entry-author) - (is-markup? y '&bib-entry-year)) - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e) - (display ", ") - (output y e))))) - ((is-markup? y '&bib-entry-year) - (skribe-error 'bib-ref - "Missing `name' entry" - (markup-ident be))) - (else - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e))))))) - (skribe-error 'bib-ref - "Illegal bib-ref" - (markup-ident be))))) - :after ")") - ;; bib-ref/text - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :predicate (lambda (n e) - (markup-option n :key)) - :action (lambda (n e) - (output (markup-option n :key) e))) - ;; &the-bibliography - (markup-writer '&the-bibliography le - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - ;; bib-entry - (markup-writer '&bib-entry le - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - ;; %bib-entry-title - (markup-writer '&bib-entry-title le - :action (lambda (n e) - (output (markup-body n) e))) - ;; %bib-entry-body - (markup-writer '&bib-entry-body le - :action (lambda (n e) - (define (output-fields descr) - (display "\\item[") - (let loop ((descr descr) - (pending #f) - (armed #f) - (first #t)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t - #f) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed - #f)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (if first - (display "]")) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed - #f)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author (" (" year ")") " " (or title url) ". " - number ", " institution ", " - address ", " month ", " - ("pp. " pages) ".")) - ((article) - `(author (" (" year ")") " " (or title url) ". " - journal ", " volume ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author (" (" year ")") " " (or title url) ". " - book(or title url) ", " series ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((book) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")) - ((phdthesis) - '(author (" (" year ")") " " (or title url) ". " type ", " - school ", " address - ", " month ".")) - ((misc) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ".")) - (else - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")))))) - ;; abstract - (markup-writer 'jfp-abstract le - :options '(postscript) - :before "\\begin{abstract}\n" - :after "\\end{abstract}\n")) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-jfp-abstract he - :action (lambda (n e) - (let* ((bg (engine-custom e 'abstract-background)) - (exp (p (if bg - (center (color :bg bg :width 90. - (it (markup-body n)))) - (it (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (new markup - (markup 'jfp-abstract) - (body (p (the-body opt)))) - (let ((a (new markup - (markup '&html-jfp-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (section :title "References" :class "references" - :number (not (engine-format? "latex")) - (font :size -1 (the-bibliography))))) - diff --git a/skr/letter.skr b/skr/letter.skr deleted file mode 100644 index 17a0058..0000000 --- a/skr/letter.skr +++ /dev/null @@ -1,146 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for letters */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* document */ -;*---------------------------------------------------------------------*/ -(define %letter-document document) - -(define-markup (document #!rest opt - #!key (ident #f) (class "letter") - where date author - &skribe-eval-location) - (let* ((ubody (the-body opt)) - (body (list (new markup - (markup '&letter-where) - (loc &skribe-eval-location) - (options `((:where ,where) - (:date ,date) - (:author ,author)))) - ubody))) - (apply %letter-document - :author #f :title #f - (append (apply append - (the-options opt :where :date :author :title)) - body)))) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") - (engine-custom-set! le 'maketitle #f) - ;; &letter-where - (markup-writer '&letter-where le - :before "\\begin{raggedright}\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (when hd - (display "\\hfill ") - (output hd e) - (set! hd #f)) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) - -;*---------------------------------------------------------------------*/ -;* HTML configuration */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - ;; &letter-where - (markup-writer '&letter-where he - :before "\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (display "\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "
") - (output n e) - (when hd - (display "") - (output hd e) - (set! hd #f)) - (display "
\n
\n\n")) - - diff --git a/skr/lncs.skr b/skr/lncs.skr deleted file mode 100644 index 4668404..0000000 --- a/skr/lncs.skr +++ /dev/null @@ -1,147 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/lncs.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for LNCS articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{llncs}") - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-inst-body n) - (let ((affiliation (markup-option n :affiliation)) - (address (markup-option n :address))) - (when affiliation (output affiliation e) (display ", ")) - (when address - (for-each (lambda (a) (output a e) (display " ")) - address) - (newline)))) - (define (&latex-inst-n i) - (display "\\institute{\n") - (&latex-inst-body (car i)) - (for-each (lambda (n) - (display "\\and\n") - (&latex-inst-body n)) - (cdr i)) - (display "}\n")) - (define (&latex-author-1 n) - (display "\\author{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author{\n") - (output (car n) e) - (for-each (lambda (a) - (display " and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (markup-option-add! n 'inst 1) - (&latex-author-1 body) - (&latex-inst-n (list body))) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (define (institute=? n1 n2) - (let ((aff1 (markup-option n1 :affiliation)) - (add1 (markup-option n1 :address)) - (aff2 (markup-option n2 :affiliation)) - (add2 (markup-option n2 :address))) - (and (equal? aff1 aff2) (equal? add1 add2)))) - (define (search-institute n i j) - (cond - ((null? i) - #f) - ((institute=? n (car i)) - j) - (else - (search-institute n (cdr i) (- j 1))))) - (if (null? (cdr body)) - (begin - (markup-option-add! (car body) 'inst 1) - (&latex-author-1 (car body)) - (&latex-inst-n body)) - ;; collect the institutes - (let loop ((ns body) - (is '()) - (j 1)) - (if (null? ns) - (begin - (&latex-author-n body) - (&latex-inst-n (reverse! is))) - (let* ((n (car ns)) - (si (search-institute n is (- j 1)))) - (if (integer? si) - (begin - (markup-option-add! n 'inst si) - (loop (cdr ns) is j)) - (begin - (markup-option-add! n 'inst j) - (loop (cdr ns) - (cons n is) - (+ 1 j))))))))) - (else - (skribe-error 'author - "Illegal `lncs' author" - body)))))) - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (inst (markup-option n 'inst))) - (if name (output name e)) - (if title (output title e)) - (if inst (printf "\\inst{~a}\n" inst))))))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-lncs-abstract he - :action (lambda (n e) - (let* ((bg (or (engine-custom e 'abstract-background) - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-lncs-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skr/scribe.skr b/skr/scribe.skr deleted file mode 100644 index d9e3bb8..0000000 --- a/skr/scribe.skr +++ /dev/null @@ -1,229 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/scribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 29 10:07:21 2003 */ -;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Scribe Compatibility kit */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* style ... */ -;*---------------------------------------------------------------------*/ -(define (style . styles) - (define (load-style style) - (let ((name (cond - ((string? style) - style) - ((symbol? style) - (string-append (symbol->string style) ".scr"))))) - (skribe-load name :engine *skribe-engine*))) - (for-each load-style styles)) - -;*---------------------------------------------------------------------*/ -;* chapter ... */ -;*---------------------------------------------------------------------*/ -(define skribe-chapter chapter) - -(define-markup (chapter #!rest opt #!key title subtitle split number toc file) - (apply skribe-chapter - :title (or title subtitle) - :number number - :toc toc - :file file - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* table-of-contents ... */ -;*---------------------------------------------------------------------*/ -(define-markup (table-of-contents #!rest opts #!key chapter section subsection) - (apply toc opts)) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define skribe-frame frame) - -(define-markup (frame #!rest opt #!key width margin) - (apply skribe-frame - :width (if (real? width) (* 100 width) width) - :margin margin - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* copyright ... */ -;*---------------------------------------------------------------------*/ -(define (copyright) - (symbol 'copyright)) - -;*---------------------------------------------------------------------*/ -;* sect ... */ -;*---------------------------------------------------------------------*/ -(define (sect) - (symbol 'section)) - -;*---------------------------------------------------------------------*/ -;* euro ... */ -;*---------------------------------------------------------------------*/ -(define (euro) - (symbol 'euro)) - -;*---------------------------------------------------------------------*/ -;* tab ... */ -;*---------------------------------------------------------------------*/ -(define (tab) - (char #\tab)) - -;*---------------------------------------------------------------------*/ -;* space ... */ -;*---------------------------------------------------------------------*/ -(define (space) - (char #\space)) - -;*---------------------------------------------------------------------*/ -;* print-bibliography ... */ -;*---------------------------------------------------------------------*/ -(define-markup (print-bibliography #!rest opts - #!key all (sort bib-sort/authors)) - (the-bibliography all sort)) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define skribe-linebreak linebreak) - -(define-markup (linebreak . lnum) - (cond - ((null? lnum) - (skribe-linebreak)) - ((string? (car lnum)) - (skribe-linebreak (string->number (car lnum)))) - (else - (skribe-linebreak (car lnum))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define skribe-ref ref) - -(define-markup (ref #!rest opts - #!key scribe url id page figure mark - chapter section subsection subsubsection subsubsection - bib bib+ number) - (let ((bd (the-body opts)) - (args (apply append (the-options opts :id)))) - (if id (set! args (cons* :mark id args))) - (if (pair? bd) (set! args (cons* :text bd args))) - (apply skribe-ref args))) - -;*---------------------------------------------------------------------*/ -;* indexes ... */ -;*---------------------------------------------------------------------*/ -(define *scribe-indexes* - (list (cons "theindex" (make-index "theindex")))) - -(define skribe-index index) -(define skribe-make-index make-index) - -(define-markup (make-index index) - (let ((i (skribe-make-index index))) - (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) - i)) - -(define-markup (index #!rest opts #!key note index shape) - (let ((i (if (not index) - "theindex" - (let ((i (assoc index *scribe-indexes*))) - (if (pair? i) - (cdr i) - (make-index index)))))) - (apply skribe-index :note note :index i :shape shape (the-body opts)))) - -(define-markup (print-index #!rest opts - #!key split (char-offset 0) (header-limit 100)) - (apply the-index - :split split - :char-offset char-offset - :header-limit header-limit - (map (lambda (i) - (let ((c (assoc i *scribe-indexes*))) - (if (pair? c) - (cdr c) - (skribe-error 'the-index "Unknown index" i)))) - (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* format? */ -;*---------------------------------------------------------------------*/ -(define (scribe-format? fmt) #f) - -;*---------------------------------------------------------------------*/ -;* scribe-url ... */ -;*---------------------------------------------------------------------*/ -(define (scribe-url) (skribe-url)) - -;*---------------------------------------------------------------------*/ -;* Various configurations */ -;*---------------------------------------------------------------------*/ -(define *scribe-background* #f) -(define *scribe-foreground* #f) -(define *scribe-tbackground* #f) -(define *scribe-tforeground* #f) -(define *scribe-title-font* #f) -(define *scribe-author-font* #f) -(define *scribe-chapter-numbering* #f) -(define *scribe-footer* #f) -(define *scribe-prgm-color* #f) - -;*---------------------------------------------------------------------*/ -;* prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (prgm #!rest opts - #!key lnum lnumwidth language bg frame (width 1.) - colors (monospace #t)) - (let* ((w (cond - ((real? width) (* width 100.)) - ((number? width) width) - (else 100.))) - (body (if language - (source :language language (the-body opts)) - (the-body opts))) - (body (if monospace - (prog :line lnum body) - body)) - (body (if bg - (color :width 100. :bg bg body) - body))) - (skribe-frame :width w - :border (if frame 1 #f) - body))) - -;*---------------------------------------------------------------------*/ -;* latex configuration */ -;*---------------------------------------------------------------------*/ -(define *scribe-tex-predocument* #f) - -;*---------------------------------------------------------------------*/ -;* latex-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (latex-prelude e) - (if (engine-format? "latex" e) - (begin - (if *scribe-tex-predocument* - (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) - -;*---------------------------------------------------------------------*/ -;* html-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (html-prelude e) - (if (engine-format? "html" e) - (begin - #f))) - -;*---------------------------------------------------------------------*/ -;* prelude */ -;*---------------------------------------------------------------------*/ -(let ((p (user-prelude))) - (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/skr/sigplan.skr b/skr/sigplan.skr deleted file mode 100644 index 9bdb939..0000000 --- a/skr/sigplan.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/sigplan.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Wed May 18 16:00:38 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[twocolumns]{sigplanconf}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\authorinfo{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "}\n\\authorinfo{") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\copyrightyear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\copyrightdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skr/skribe.skr b/skr/skribe.skr deleted file mode 100644 index 86425ac..0000000 --- a/skr/skribe.skr +++ /dev/null @@ -1,76 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/skribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 11 11:23:12 2002 */ -;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The standard Skribe style (always loaded). */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* p ... */ -;*---------------------------------------------------------------------*/ -(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) - (paragraph :ident ident :class class :loc &skribe-eval-location - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* fg ... */ -;*---------------------------------------------------------------------*/ -(define (fg c . body) - (color :fg c body)) - -;*---------------------------------------------------------------------*/ -;* bg ... */ -;*---------------------------------------------------------------------*/ -(define (bg c . body) - (color :bg c body)) - -;*---------------------------------------------------------------------*/ -;* counter ... */ -;* ------------------------------------------------------------- */ -;* This produces a kind of "local enumeration" that is: */ -;* (counting "toto," "tutu," "titi.") */ -;* produces: */ -;* i) toto, ii) tutu, iii) titi. */ -;*---------------------------------------------------------------------*/ -(define-markup (counter #!rest opts #!key (numbering 'roman)) - (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) - (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) - (define (the-roman-number num) - (if (< num (vector-length vroman)) - (list (list "(" (it (vector-ref vroman num)) ") ")) - (skribe-error 'counter - "too many items for roman numbering" - (length items)))) - (define (the-arabic-number num) - (list (list "(" (it (integer->string num)) ") "))) - (define (the-alpha-number num) - (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) - (let ((the-number (case numbering - ((roman) the-roman-number) - ((arabic) the-arabic-number) - ((alpha) the-alpha-number) - (else (skribe-error 'counter - "Illegal numbering" - numbering))))) - (let loop ((num 1) - (items items) - (res '())) - (if (null? items) - (reverse! res) - (loop (+ num 1) - (cdr items) - (cons (list (the-number num) (car items)) res)))))) - -;*---------------------------------------------------------------------*/ -;* q */ -;*---------------------------------------------------------------------*/ -(define-markup (q #!rest opt) - (new markup - (markup 'q) - (options (the-options opt)) - (body (the-body opt)))) - diff --git a/skr/slide.skr b/skr/slide.skr deleted file mode 100644 index f8638ad..0000000 --- a/skr/slide.skr +++ /dev/null @@ -1,664 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/slide.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for slides */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* slide-options */ -;*---------------------------------------------------------------------*/ -(define &slide-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-predocument - "\\special{landscape} - \\slideframe{none} - \\centerslidesfalse - \\raggedslides[0pt] - \\renewcommand{\\slideleftmargin}{0.2in} - \\renewcommand{\\slidetopmargin}{0.3in} - \\newdimen\\slidewidth \\slidewidth 9in") - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-maketitle ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-maketitle - "\\def\\labelitemi{$\\bullet$} - \\def\\labelitemii{$\\circ$} - \\def\\labelitemiii{$\\diamond$} - \\def\\labelitemiv{$\\cdot$} - \\pagestyle{empty} - \\slideframe{none} - \\centerslidestrue - \\begin{slide} - \\date{} - \\maketitle - \\end{slide} - \\slideframe{none} - \\centerslidesfalse") - -;*---------------------------------------------------------------------*/ -;* &slide-prosper-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-prosper-predocument - "\\slideCaption{}\n") - -;*---------------------------------------------------------------------*/ -;* %slide-the-slides ... */ -;*---------------------------------------------------------------------*/ -(define %slide-the-slides '()) -(define %slide-the-counter 0) -(define %slide-initialized #f) -(define %slide-latex-mode 'seminar) - -;*---------------------------------------------------------------------*/ -;* %slide-initialize! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-initialize!) - (unless %slide-initialized - (set! %slide-initialized #t) - (case %slide-latex-mode - ((seminar) - (%slide-seminar-setup!)) - ((advi) - (%slide-advi-setup!)) - ((prosper) - (%slide-prosper-setup!)) - (else - (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) - -;*---------------------------------------------------------------------*/ -;* slide ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide #!rest opt - #!key - (ident #f) (class #f) - (toc #t) - title (number #t) - (vspace #f) (vfill #f) - (transition #f) - (bg #f) (image #f)) - (%slide-initialize!) - (let ((s (new container - (markup 'slide) - (ident (symbol->string (gensym 'slide))) - (class class) - (required-options '(:title :number :toc)) - (options `((:number - ,(cond - ((number? number) - (set! %slide-the-counter number) - number) - (number - (set! %slide-the-counter - (+ 1 %slide-the-counter)) - %slide-the-counter) - (else - #f))) - (:toc ,toc) - ,@(the-options opt :ident :class :vspace :toc))) - (body (if vspace - (list (slide-vspace vspace) (the-body opt)) - (the-body opt)))))) - (set! %slide-the-slides (cons s %slide-the-slides)) - s)) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define %slide-old-ref ref) - -(define-markup (ref #!rest opt #!key (slide #f)) - (if (not slide) - (apply %slide-old-ref opt) - (new unresolved - (proc (lambda (n e env) - (cond - ((eq? slide 'next) - (let ((c (assq n %slide-the-slides))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((eq? slide 'prev) - (let ((c (assq n (reverse %slide-the-slides)))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((number? slide) - (let loop ((s %slide-the-slides)) - (cond - ((null? s) - #f) - ((= slide (markup-option (car s) :number)) - (handle (car s))) - (else - (loop (cdr s)))))) - (else - #f))))))) - -;*---------------------------------------------------------------------*/ -;* slide-pause ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-pause) - (new markup - (markup 'slide-pause))) - -;*---------------------------------------------------------------------*/ -;* slide-vspace ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) - (new markup - (markup 'slide-vspace) - (options `((:unit ,unit) ,@(the-options opt :unit))) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* slide-embed ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-embed #!rest opt - #!key - command - (geometry-opt "-geometry") - (geometry #f) (rgeometry #f) - (transient #f) (transient-opt #f) - (alt #f) - &skribe-eval-location) - (if (not (string? command)) - (skribe-error 'slide-embed - "No command provided" - command) - (new markup - (markup 'slide-embed) - (loc &skribe-eval-location) - (required-options '(:alt)) - (options `((:geometry-opt ,geometry-opt) - (:alt ,alt) - ,@(the-options opt :geometry-opt :alt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-record ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) - (if (not tag) - (skribe-error 'slide-record "Tag missing" tag) - (new markup - (markup 'slide-record) - (ident ident) - (class class) - (options `((:play ,play) ,@(the-options opt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play #!rest opt #!key ident class tag color) - (if (not tag) - (skribe-error 'slide-play "Tag missing" tag) - (new markup - (markup 'slide-play) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - ,@(the-options opt :color))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play* ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play* #!rest opt - #!key ident class color (scolor "#000000")) - (let ((body (the-body opt))) - (for-each (lambda (lbl) - (match-case lbl - ((?id ?col) - (skribe-use-color! col)))) - body) - (new markup - (markup 'slide-play*) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - (:scolor ,(if color (skribe-use-color! scolor) #f)) - ,@(the-options opt :color :scolor))) - (body body)))) - -;*---------------------------------------------------------------------*/ -;* base */ -;*---------------------------------------------------------------------*/ -(let ((be (find-engine 'base))) - (skribe-message "Base slides setup...\n") - ;; slide-pause - (markup-writer 'slide-pause be - :action #f) - ;; slide-vspace - (markup-writer 'slide-vspace be - :options '() - :action #f) - ;; slide-embed - (markup-writer 'slide-embed be - :options '(:alt :geometry-opt) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-record - (markup-writer 'slide-record be - :options '(:tag :play) - :action (lambda (n e) - (output (markup-body n) e))) - ;; slide-play - (markup-writer 'slide-play be - :options '(:tag :color) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-play* - (markup-writer 'slide-play* be - :options '(:tag :color :scolor) - :action (lambda (n e) - (output (markup-option n :alt) e)))) - -;*---------------------------------------------------------------------*/ -;* slide-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (slide-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 95.))) - -;*---------------------------------------------------------------------*/ -;* html-slide-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-slide-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (slide-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "
") - (output title e) - (display ""))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* slide-number ... */ -;*---------------------------------------------------------------------*/ -(define (slide-number) - (length (filter (lambda (n) - (and (is-markup? n 'slide) - (markup-option n :number))) - %slide-the-slides))) - -;*---------------------------------------------------------------------*/ -;* html */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") - ;; &html-page-title - (markup-writer '&html-document-title he - :predicate (lambda (n e) %slide-initialized) - :action html-slide-title) - ;; slide - (markup-writer 'slide he - :options '(:title :number :transition :toc :bg) - :before (lambda (n e) - (printf "" (markup-ident n)) - (display "
\n")) - :action (lambda (n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (skribe-eval - (center - (color :width (slide-body-width e) - :bg (or (markup-option n :bg) "#ffffff") - (table :width 100. - (tr (th :align 'left - (list - (if nb - (format "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) - :after "
") - ;; slide-vspace - (markup-writer 'slide-vspace he - :action (lambda (n e) (display "
")))) - -;*---------------------------------------------------------------------*/ -;* latex */ -;*---------------------------------------------------------------------*/ -(define &latex-slide #f) -(define &latex-pause #f) -(define &latex-embed #f) -(define &latex-record #f) -(define &latex-play #f) -(define &latex-play* #f) - -(let ((le (find-engine 'latex))) - ;; slide-vspace - (markup-writer 'slide-vspace le - :options '(:unit) - :action (lambda (n e) - (display "\n\\vspace{") - (output (markup-body n) e) - (printf " ~a}\n\n" (markup-option n :unit)))) - ;; slide-slide - (markup-writer 'slide le - :options '(:title :number :transition :vfill :toc :vspace :image) - :action (lambda (n e) - (if (procedure? &latex-slide) - (&latex-slide n e)))) - ;; slide-pause - (markup-writer 'slide-pause le - :options '() - :action (lambda (n e) - (if (procedure? &latex-pause) - (&latex-pause n e)))) - ;; slide-embed - (markup-writer 'slide-embed le - :options '(:alt :command :geometry-opt :geometry - :rgeometry :transient :transient-opt) - :action (lambda (n e) - (if (procedure? &latex-embed) - (&latex-embed n e)))) - ;; slide-record - (markup-writer 'slide-record le - :options '(:tag :play) - :action (lambda (n e) - (if (procedure? &latex-record) - (&latex-record n e)))) - ;; slide-play - (markup-writer 'slide-play le - :options '(:tag :color) - :action (lambda (n e) - (if (procedure? &latex-play) - (&latex-play n e)))) - ;; slide-play* - (markup-writer 'slide-play* le - :options '(:tag :color :scolor) - :action (lambda (n e) - (if (procedure? &latex-play*) - (&latex-play* n e))))) - -;*---------------------------------------------------------------------*/ -;* %slide-seminar-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-seminar-setup!) - (skribe-message "Seminar slides setup...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - ;; latex configuration - (define (seminar-slide n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (display "\\begin{slide}\n") - (if nb (printf "~a/~a -- " nb (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n")) - (engine-custom-set! le 'documentclass - "\\documentclass[landscape]{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[setpagesize=false]{hyperref}\n") - ;; slide-slide - (set! &latex-slide seminar-slide))) - -;*---------------------------------------------------------------------*/ -;* %slide-advi-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-advi-setup!) - (skribe-message "Generating `Advi Seminar' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - (define (advi-geometry geo) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) - (if (pair? r) - (let* ((w (cadr r)) - (w' (string->integer w)) - (w'' (number->string (/ w' *skribe-slide-advi-scale*))) - (h (caddr r)) - (h' (string->integer h)) - (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) - (values "" (string-append w "x" h "+!x+!y"))) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) - (if (pair? r) - (let ((w (number->string (/ (string->integer (cadr r)) - *skribe-slide-advi-scale*))) - (h (number->string (/ (string->integer (caddr r)) - *skribe-slide-advi-scale*))) - (x (cadddr r)) - (y (car (cddddr r)))) - (values (string-append "width=" w "cm,height=" h "cm") - "!g")) - (values "" geo)))))) - (define (advi-transition trans) - (cond - ((string? trans) - (printf "\\advitransition{~s}" trans)) - ((and (symbol? trans) - (memq trans '(wipe block slide))) - (printf "\\advitransition{~s}" trans)) - (else - #f))) - ;; latex configuration - (define (advi-slide n e) - (let ((i (markup-option n :image)) - (n (markup-option n :number)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition))) - (if (and i (engine-custom e 'advi)) - (printf "\\advibg[global]{image=~a}\n" - (if (and (pair? i) - (null? (cdr i)) - (string? (car i))) - (car i) - i))) - (display "\\begin{slide}\n") - (advi-transition (or lt gt)) - (if n (printf "~a/~a -- " n (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n\n\n")) - ;; advi record - (define (advi-record n e) - (display "\\advirecord") - (when (markup-option n :play) (display "[play]")) - (printf "{~a}{" (markup-option n :tag)) - (output (markup-body n) e) - (display "}")) - ;; advi play - (define (advi-play n e) - (display "\\adviplay") - (let ((c (markup-option n :color))) - (when c - (display "[") - (display (skribe-get-latex-color c)) - (display "]"))) - (printf "{~a}" (markup-option n :tag))) - ;; advi play* - (define (advi-play* n e) - (let ((c (skribe-get-latex-color (markup-option n :color))) - (d (skribe-get-latex-color (markup-option n :scolor)))) - (let loop ((lbls (markup-body n)) - (last #f)) - (when last - (display "\\adviplay[") - (display d) - (printf "]{~a}" last)) - (when (pair? lbls) - (let ((lbl (car lbls))) - (match-case lbl - ((?id ?col) - (display "\\adviplay[") - (display (skribe-get-latex-color col)) - (printf "]{" ~a "}" id) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) id)) - (else - (display "\\adviplay[") - (display c) - (printf "]{~a}" lbl) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) lbl)))))))) - (engine-custom-set! le 'documentclass - "\\documentclass{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'usepackage - (string-append "\\usepackage{advi}\n" - (engine-custom le 'usepackage))) - ;; slide - (set! &latex-slide advi-slide) - (set! &latex-pause - (lambda (n e) (display "\\adviwait\n"))) - (set! &latex-embed - (lambda (n e) - (let ((geometry-opt (markup-option n :geometry-opt)) - (geometry (markup-option n :geometry)) - (rgeometry (markup-option n :rgeometry)) - (transient (markup-option n :transient)) - (transient-opt (markup-option n :transient-opt)) - (cmd (markup-option n :command))) - (let* ((a (string-append "ephemeral=" - (symbol->string (gensym)))) - (c (cond - (geometry - (string-append cmd " " - geometry-opt " " - geometry)) - (rgeometry - (multiple-value-bind (aopt dopt) - (advi-geometry rgeometry) - (set! a (string-append a "," aopt)) - (string-append cmd " " - geometry-opt " " - dopt))) - (else - cmd))) - (c (if (and transient transient-opt) - (string-append c " " transient-opt " !p") - c))) - (printf "\\adviembed[~a]{~a}\n" a c))))) - (set! &latex-record advi-record) - (set! &latex-play advi-play) - (set! &latex-play* advi-play*))) - -;*---------------------------------------------------------------------*/ -;* %slide-prosper-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-prosper-setup!) - (skribe-message "Generating `Prosper' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base)) - (overlay-count 0)) - ;; transitions - (define (prosper-transition trans) - (cond - ((string? trans) - (printf "[~s]" trans)) - ((eq? trans 'slide) - (printf "[Blinds]")) - ((and (symbol? trans) - (memq trans '(split blinds box wipe dissolve glitter))) - (printf "[~s]" - (string-upcase (symbol->string trans)))) - (else - #f))) - ;; latex configuration - (define (prosper-slide n e) - (let* ((i (markup-option n :image)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition)) - (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) - (lpa (length pa))) - (set! overlay-count 1) - (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) - (display "\\begin{slide}") - (prosper-transition (or lt gt)) - (display "{") - (output t e) - (display "}\n") - (output (markup-body n) e) - (display "\\end{slide}\n") - (if (>= lpa 1) (display "}\n")) - (newline) - (newline))) - (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") - (let* ((cap (engine-custom le 'slide-caption)) - (o (engine-custom le 'predocument)) - (n (if (string? cap) - (format "~a\\slideCaption{~a}\n" - &slide-prosper-predocument - cap) - &slide-prosper-predocument))) - (engine-custom-set! le 'predocument - (if (string? o) (string-append n o) n))) - (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") - ;; writers - (set! &latex-slide prosper-slide) - (set! &latex-pause - (lambda (n e) - (set! overlay-count (+ 1 overlay-count)) - (printf "\\FromSlide{~s}%\n" overlay-count))))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &slide-load-options) - (p (memq :prosper opt))) - (if (and (pair? p) (pair? (cdr p)) (cadr p)) - ;; prosper - (set! %slide-latex-mode 'prosper) - (let ((a (memq :advi opt))) - (if (and (pair? a) (pair? (cdr a)) (cadr a)) - ;; advi - (set! %slide-latex-mode 'advi))))) - diff --git a/skr/web-article.skr b/skr/web-article.skr deleted file mode 100644 index e33328b..0000000 --- a/skr/web-article.skr +++ /dev/null @@ -1,230 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-article.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jan 10 09:09:43 2004 */ -;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* A Skribe style for producing web articles */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* &web-article-load-options ... */ -;*---------------------------------------------------------------------*/ -(define &web-article-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* web-article-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 98.))) - -;*---------------------------------------------------------------------*/ -;* html-document-title-web ... */ -;*---------------------------------------------------------------------*/ -(define (html-document-title-web n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (web-article-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "

") - (output title e) - (display "

"))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-document-title ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-document-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (id (markup-ident n))) - ;; the title - (printf "
\n" - (string-canonicalize id)) - (output title e) - (display "
\n") - ;; the authors - (printf "
\n" - (string-canonicalize id)) - (for-each (lambda (a) (output a e)) - (cond - ((is-markup? authors 'author) - (list authors)) - ((list? authors) - authors) - (else - '()))) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-author ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-author n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (when name - (printf "" - (string-canonicalize (markup-ident n))) - (output name e) - (display "\n")) - (when title - (printf "" - (string-canonicalize (markup-ident n))) - (output title e) - (display "\n")) - (when affiliation - (printf "" - (string-canonicalize (markup-ident n))) - (output affiliation e) - (display "\n")) - (when (pair? address) - (printf "" - (string-canonicalize (markup-ident n))) - (for-each (lambda (a) - (output a e) - (newline)) - address) - (display "\n")) - (when phone - (printf "" - (string-canonicalize (markup-ident n))) - (output phone e) - (display "\n")) - (when email - (printf "" - (string-canonicalize (markup-ident n))) - (output email e) - (display "\n")) - (when url - (printf "" - (string-canonicalize (markup-ident n))) - (output url e) - (display "\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML settings */ -;*---------------------------------------------------------------------*/ -(define (web-article-modern-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :action html-document-title-web) - ;; section - (markup-writer 'section he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background))) - (markup-writer 'section e1 - :options 'all - :action (lambda (n e2) (output n e sec))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg n)) - e1)))) - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background)) - (fg (engine-custom he 'subsection-title-foreground))) - (markup-writer '&html-footnotes e1 - :options 'all - :action (lambda (n e2) - (invoke (writer-action ft) n e))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg :fg fg n)) - e1)))))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-setup ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :before (lambda (n e) - (printf "
\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-document-title - :after "
\n") - ;; author - (markup-writer 'author he - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (printf "\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-author - :after "" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) (output n e sec)) - :after "\n") - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before (lambda (n e) - (printf "
" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) - (output n e ft)) - :after "
\n"))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &web-article-load-options) - (p (memq :style opt)) - (css (memq :css opt)) - (he (find-engine 'html))) - (cond - ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) - (web-article-css-setup he)) - ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) - (engine-custom-set! he 'css (cadr css)) - (web-article-css-setup he)) - (else - (web-article-modern-setup he)))) diff --git a/skr/web-book.skr b/skr/web-book.skr deleted file mode 100644 index f907c8b..0000000 --- a/skr/web-book.skr +++ /dev/null @@ -1,107 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-book.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 10:54:32 2003 */ -;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe web book style. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html customization */ -;*---------------------------------------------------------------------*/ -(define he (find-engine 'html)) -(engine-custom-set! he 'main-browsing-extra #f) -(engine-custom-set! he 'chapter-file #t) - -;*---------------------------------------------------------------------*/ -;* main-browsing ... */ -;*---------------------------------------------------------------------*/ -(define main-browsing - (lambda (n e) - ;; search the document - (let ((p (ast-document n))) - (cond - ((document? p) - ;; got it - (let* ((mt (markup-option p :margin-title)) - (r (ref :handle (handle p) - :text (or mt (markup-option p :title)))) - (fx (engine-custom e 'web-book-main-browsing-extra))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold "main page")))) - (tr :bg (engine-custom e 'background) - (td (apply table :width 100. :border 0 - (tr (td :align 'left - :valign 'top - (bold "top:")) - (td :align 'right - :valign 'top r)) - (if (procedure? fx) - (list (tr (td :width 100. - :colspan 2 - (fx n e)))) - '())))))))) - ((not p) - ;; no document!!! - #f))))) - -;*---------------------------------------------------------------------*/ -;* chapter-browsing ... */ -;*---------------------------------------------------------------------*/ -(define chapter-browsing - (lambda (n e) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (markup-option n :title))))) - (tr :bg (engine-custom e 'background) - (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) - -;*---------------------------------------------------------------------*/ -;* document-browsing ... */ -;*---------------------------------------------------------------------*/ -(define document-browsing - (lambda (n e) - (let ((chap (find1-down (lambda (n) - (is-markup? n 'chapter)) - n))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (if chap "Chapters" "Sections"))))) - (tr :bg (engine-custom e 'background) - (td (if chap - (toc (handle n) :chapter #t :section #f) - (toc (handle n) :section #t :subsection #t))))))))) - -;*---------------------------------------------------------------------*/ -;* left margin ... */ -;*---------------------------------------------------------------------*/ -(engine-custom-set! he 'left-margin-size 20.) - -(engine-custom-set! he 'left-margin - (lambda (n e) - (let ((d (ast-document n)) - (c (ast-chapter n))) - (list (linebreak 1) - (main-browsing n e) - (if (is-markup? c 'chapter) - (list (linebreak 2) - (chapter-browsing c e)) - #f) - (if (document? d) - (list (linebreak 2) - (document-browsing d e)) - #f))))) - diff --git a/skribe.prj b/skribe.prj deleted file mode 100644 index 1539075..0000000 --- a/skribe.prj +++ /dev/null @@ -1,332 +0,0 @@ -;; -*- Prcs -*- -(Created-By-Prcs-Version 1 3 3) -(Project-Description "") -(Project-Version skribe 1.2d 2) -(Parent-Version skribe 1.2d 1) -(Version-Log "") -(New-Version-Log "") -(Checkin-Time "Fri, 03 Jun 2005 16:52:04 +0200") -(Checkin-Login serrano) -(Populate-Ignore ("\\.o$" "\\~$" "\\.log$" "\\.ps$" "\\.aux$" "\\.date_of_backup$" "\\.so$" "\\.a$" "if_not_there$" "if_mach$" "threadlibs$")) -(Project-Keywords) -(Files -;; This is a comment. Fill in files here. -;; For example: (prcs/checkout.cc ()) - -;; Files added by populate at Thu, 18 Dec 2003 10:00:47 +0100, -;; to version 0.0(w), by serrano: - - (tools/Makefile (skribe/10_Makefile 1.3 640)) - (src/stklos/xml.stk (skribe/11_xml.stk 1.2 644)) - (src/stklos/writer.stk (skribe/12_writer.stk 1.3 644)) - (src/stklos/verify.stk (skribe/13_verify.stk 1.4 644)) - (src/stklos/vars.stk (skribe/14_vars.stk 1.3 644)) - (src/stklos/types.stk (skribe/16_types.stk 1.4 644)) - (src/stklos/source.stk (skribe/17_source.stk 1.3 644)) - (src/stklos/runtime.stk (skribe/18_runtime.st 1.4 644)) - (src/stklos/resolve.stk (skribe/19_resolve.st 1.2 644)) - (src/stklos/reader.stk (skribe/20_reader.stk 1.2 644)) - (src/stklos/prog.stk (skribe/21_prog.stk 1.1 644)) - (src/stklos/output.stk (skribe/22_output.stk 1.3 644)) - (src/stklos/main.stk (skribe/23_main.stk 1.3 644)) - (src/stklos/lisp.stk (skribe/24_lisp.stk 1.4 644)) - (src/stklos/lib.stk (skribe/25_lib.stk 1.4 644)) - (src/stklos/eval.stk (skribe/26_eval.stk 1.4 644)) - (src/stklos/engine.stk (skribe/27_engine.stk 1.4 644)) - (src/stklos/debug.stk (skribe/28_debug.stk 1.3 644)) - (src/stklos/color.stk (skribe/29_color.stk 1.2 644)) - (src/stklos/biblio.stk (skribe/30_biblio.stk 1.3 644)) - (src/stklos/Makefile.in (skribe/31_Makefile.i 1.3 644)) - (src/common/param.scm (skribe/32_param.scm 1.2 640)) - (src/common/lib.scm (skribe/33_lib.scm 1.4 640)) - (src/common/index.scm (skribe/34_index.scm 1.2 640)) - (src/common/configure.scm.in (skribe/35_configure. 1.3 640)) - (src/common/bib.scm (skribe/36_bib.scm 1.2 640)) - (src/common/api.scm (skribe/37_api.scm 1.9 640)) - (src/bigloo/xml.scm (skribe/38_xml.scm 1.3 640)) - (src/bigloo/writer.scm (skribe/39_writer.scm 1.3 640)) - (src/bigloo/verify.scm (skribe/40_verify.scm 1.6 640)) - (src/bigloo/types.scm (skribe/42_types.scm 1.6 640)) - (src/bigloo/source.scm (skribe/43_source.scm 1.5 640)) - (src/bigloo/resolve.scm (skribe/44_resolve.sc 1.4 640)) - (src/bigloo/read.scm (skribe/45_read.scm 1.2 640)) - (src/bigloo/prog.scm (skribe/46_prog.scm 1.3 640)) - (src/bigloo/param.bgl (skribe/48_param.bgl 1.4 640)) - (src/bigloo/output.scm (skribe/49_output.scm 1.3 640)) - (src/bigloo/new.sch (skribe/50_new.sch 1.1 640)) - (src/bigloo/main.scm (skribe/51_main.scm 1.4 640)) - (src/bigloo/lisp.scm (skribe/b/0_lisp.scm 1.5 640)) - (src/bigloo/lib.bgl (skribe/b/1_lib.bgl 1.5 640)) - (src/bigloo/index.bgl (skribe/b/2_index.bgl 1.2 640)) - (src/bigloo/evapi.scm (skribe/b/3_evapi.scm 1.6 640)) - (src/bigloo/eval.scm (skribe/b/4_eval.scm 1.7 640)) - (src/bigloo/engine.scm (skribe/b/5_engine.scm 1.4 640)) - (src/bigloo/debug.scm (skribe/b/6_debug.scm 1.2 640)) - (src/bigloo/debug.sch (skribe/b/7_debug.sch 1.2 640)) - (src/bigloo/configure.bgl (skribe/b/8_configure. 1.3 640)) - (src/bigloo/color.scm (skribe/b/9_color.scm 1.2 640)) - (src/bigloo/c.scm (skribe/b/10_c.scm 1.4 640)) - (src/bigloo/bib.bgl (skribe/b/11_bib.bgl 1.4 640)) - (src/bigloo/api.sch (skribe/b/12_api.sch 1.5 640)) - (src/bigloo/api.bgl (skribe/b/13_api.bgl 1.2 640)) - (src/bigloo/Makefile (skribe/b/14_Makefile 1.6 640)) - (src/Makefile (skribe/b/15_Makefile 1.2 640)) - (skr/xml.skr (skribe/b/16_xml.skr 1.2 640)) - (skr/web-book.skr (skribe/b/17_web-book.s 1.5 640)) - (skr/slide.skr (skribe/b/19_slide.skr 1.6 640)) - (skr/skribe.skr (skribe/b/20_skribe.skr 1.4 640)) - (skr/scribe.skr (skribe/b/21_scribe.skr 1.1 640)) - (skr/lncs.skr (skribe/b/22_lncs.skr 1.2 640)) - (skr/letter.skr (skribe/b/23_letter.skr 1.3 640)) - (skr/latex.skr (skribe/b/24_latex.skr 1.6 640)) - (skr/jfp.skr (skribe/b/25_jfp.skr 1.4 640)) - (skr/html.skr (skribe/b/26_html.skr 1.8 640)) - (skr/french.skr (skribe/b/27_french.skr 1.1 640)) - (skr/base.skr (skribe/b/28_base.skr 1.6 640)) - (skr/acmproc.skr (skribe/b/29_acmproc.sk 1.4 640)) - (skr/Makefile (skribe/b/30_Makefile 1.6 640)) - (examples/slide/skr/local.skr (skribe/b/34_local.skr 1.1 640)) - (examples/slide/skb/slides.skb (skribe/b/35_slides.skb 1.1 640)) - (examples/slide/ex/syntax.scr (skribe/b/36_syntax.scr 1.1 640)) - (examples/slide/ex/skribe.skb (skribe/b/37_skribe.skb 1.1 640)) - (examples/slide/advi.sty (skribe/b/38_advi.sty 1.1 640)) - (examples/slide/README (skribe/b/39_README 1.1 640)) - (examples/slide/PPRskribe.sty (skribe/b/40_PPRskribe. 1.1 640)) - (examples/slide/Makefile (skribe/b/41_Makefile 1.1 640)) - (examples/Makefile (skribe/b/42_Makefile 1.2 640)) - (etc/stklos/configure.in (skribe/b/43_configure. 1.2 640)) - (etc/stklos/configure (skribe/b/44_configure 1.2 751)) - (etc/stklos/Makefile.skb.in (skribe/b/45_Makefile.s 1.1 644)) - (etc/stklos/Makefile.in (skribe/b/46_Makefile.i 1.1 640)) - (etc/stklos/Makefile.config.in (skribe/b/47_Makefile.c 1.1 644)) - (etc/skribe-config.in (skribe/b/48_skribe-con 1.2 644)) - (etc/bigloo/configure (skribe/b/49_configure 1.6 740)) - (etc/bigloo/autoconf/gmaketest (skribe/b/50_gmaketest 1.1 750)) - (etc/bigloo/autoconf/getbversion (skribe/b/51_getbversio 1.1 750)) - (etc/bigloo/autoconf/bversion (skribe/c/0_bversion 1.1 750)) - (etc/bigloo/autoconf/blibdir (skribe/c/1_blibdir 1.1 750)) - (etc/bigloo/autoconf/bfildir (skribe/c/2_bfildir 1.1 750)) - (etc/bigloo/autoconf/Makefile (skribe/c/3_Makefile 1.1 640)) - (etc/bigloo/Makefile.tpl (skribe/c/4_Makefile.t 1.3 640)) - (etc/bigloo/Makefile (skribe/c/5_Makefile 1.4 640)) - (etc/Makefile (skribe/c/6_Makefile 1.3 640)) - (emacs/skribe.el.in (skribe/c/7_skribe.el. 1.6 640)) - (emacs/Makefile (skribe/c/8_Makefile 1.2 640)) - (doc/user/user.skb (skribe/c/9_user.skb 1.5 640)) - (doc/user/toc.skb (skribe/c/10_toc.skb 1.1 640)) - (doc/user/table.skb (skribe/c/11_table.skb 1.4 640)) - (doc/user/syntax.skb (skribe/c/12_syntax.skb 1.3 640)) - (doc/user/start.skb (skribe/c/13_start.skb 1.3 640)) - (doc/user/src/start5.skb (skribe/c/14_start5.skb 1.1 644)) - (doc/user/src/start4.skb (skribe/c/15_start4.skb 1.1 640)) - (doc/user/src/start3.skb (skribe/c/16_start3.skb 1.1 640)) - (doc/user/src/start2.skb (skribe/c/17_start2.skb 1.1 640)) - (doc/user/src/start1.skb (skribe/c/18_start1.skb 1.1 640)) - (doc/user/src/prgm3.skb (skribe/c/19_prgm3.skb 1.2 640)) - (doc/user/src/prgm2.skb (skribe/c/20_prgm2.skb 1.2 640)) - (doc/user/src/prgm1.skb (skribe/c/21_prgm1.skb 1.1 640)) - (doc/user/src/links2.skb (skribe/c/22_links2.skb 1.1 640)) - (doc/user/src/links1.skb (skribe/c/23_links1.skb 1.1 640)) - (doc/user/src/index3.skb (skribe/c/24_index3.skb 1.1 640)) - (doc/user/src/index2.skb (skribe/c/25_index2.skb 1.1 640)) - (doc/user/src/index1.skb (skribe/c/26_index1.skb 1.1 640)) - (doc/user/src/bib6.skb (skribe/c/27_bib6.skb 1.1 640)) - (doc/user/src/bib5.skb (skribe/c/28_bib5.skb 1.1 640)) - (doc/user/src/bib4.skb (skribe/c/29_bib4.skb 1.1 640)) - (doc/user/src/bib3.skb (skribe/c/30_bib3.skb 1.1 640)) - (doc/user/src/bib2.skb (skribe/c/31_bib2.skb 1.1 640)) - (doc/user/src/bib1.sbib (skribe/c/32_bib1.sbib 1.1 640)) - (doc/user/src/api9.skb (skribe/c/33_api9.skb 1.1 640)) - (doc/user/src/api8.skb (skribe/c/34_api8.skb 1.1 640)) - (doc/user/src/api7.skb (skribe/c/35_api7.skb 1.1 640)) - (doc/user/src/api6.skb (skribe/c/36_api6.skb 1.1 640)) - (doc/user/src/api5.skb (skribe/c/37_api5.skb 1.1 640)) - (doc/user/src/api4.skb (skribe/c/38_api4.skb 1.1 640)) - (doc/user/src/api3.skb (skribe/c/39_api3.skb 1.1 640)) - (doc/user/src/api20.skb (skribe/c/40_api20.skb 1.3 640)) - (doc/user/src/api2.skb (skribe/c/41_api2.skb 1.1 640)) - (doc/user/src/api19.skb (skribe/c/42_api19.skb 1.1 640)) - (doc/user/src/api18.skb (skribe/c/43_api18.skb 1.1 640)) - (doc/user/src/api17.skb (skribe/c/44_api17.skb 1.2 640)) - (doc/user/src/api16.skb (skribe/c/45_api16.skb 1.1 640)) - (doc/user/src/api15.skb (skribe/c/46_api15.skb 1.1 640)) - (doc/user/src/api14.skb (skribe/c/47_api14.skb 1.1 640)) - (doc/user/src/api13.skb (skribe/c/48_api13.skb 1.3 640)) - (doc/user/src/api12.skb (skribe/c/49_api12.skb 1.1 640)) - (doc/user/src/api11.skb (skribe/c/50_api11.skb 1.1 640)) - (doc/user/src/api10.skb (skribe/c/51_api10.skb 1.2 640)) - (doc/user/src/api1.skb (skribe/d/0_api1.skb 1.1 640)) - (doc/user/skribeinfo.skb (skribe/d/1_skribeinfo 1.1 640)) - (doc/user/skribec.skb (skribe/d/2_skribec.sk 1.3 640)) - (doc/user/sectioning.skb (skribe/d/3_sectioning 1.3 640)) - (doc/user/prgm.skb (skribe/d/4_prgm.skb 1.4 640)) - (doc/user/ornament.skb (skribe/d/5_ornament.s 1.1 640)) - (doc/user/markup.skb (skribe/d/6_markup.skb 1.2 640)) - (doc/user/links.skb (skribe/d/7_links.skb 1.5 640)) - (doc/user/line.skb (skribe/d/8_line.skb 1.1 640)) - (doc/user/lib.skb (skribe/d/9_lib.skb 1.3 644)) - (doc/user/latexe.skb (skribe/d/10_latexe.skb 1.4 640)) - (doc/user/justify.skb (skribe/d/11_justify.sk 1.1 640)) - (doc/user/index.skb (skribe/d/12_index.skb 1.4 640)) - (doc/user/image.skb (skribe/d/13_image.skb 1.3 640)) - (doc/user/htmle.skb (skribe/d/14_htmle.skb 1.6 640)) - (doc/user/footnote.skb (skribe/d/15_footnote.s 1.1 640)) - (doc/user/font.skb (skribe/d/16_font.skb 1.1 640)) - (doc/user/figure.skb (skribe/d/17_figure.skb 1.1 640)) - (doc/user/examples.skb (skribe/d/18_examples.s 1.2 640)) - (doc/user/enumeration.skb (skribe/d/19_enumeratio 1.1 640)) - (doc/user/engine.skb (skribe/d/20_engine.skb 1.4 640)) - (doc/user/emacs.skb (skribe/d/21_emacs.skb 1.3 640)) - (doc/user/document.skb (skribe/d/22_document.s 1.2 640)) - (doc/user/colframe.skb (skribe/d/23_colframe.s 1.3 640)) - (doc/user/char.skb (skribe/d/24_char.skb 1.2 640)) - (doc/user/bib.skb (skribe/d/25_bib.skb 1.5 640)) - (doc/img/linux.gif (skribe/d/29_linux.gif 1.2 640) :no-keywords) - (doc/img/lambda.gif (skribe/d/30_lambda.gif 1.1 640) :no-keywords) - (doc/img/bsd.gif (skribe/d/31_bsd.gif 1.1 640) :no-keywords) - (doc/Makefile (skribe/d/32_Makefile 1.6 640)) - (configure (skribe/d/33_configure 1.5 750)) - (README.java (skribe/d/34_README.jav 1.2 640)) - (README (skribe/d/35_README 1.1 640)) - (LICENSE (skribe/d/36_LICENSE 1.2 640)) - (INSTALL (skribe/d/37_INSTALL 1.2 640)) - (Makefile (skribe/d/38_Makefile 1.5 640)) - -;; Files added by populate at Sat, 17 Jan 2004 08:29:33 +0100, -;; to version 1.0b.1(w), by serrano: - - (src/common/sui.scm (skribe/d/39_sui.scm 1.2 640)) - (src/bigloo/sui.bgl (skribe/d/40_sui.bgl 1.1 640)) - (etc/ChangeLog (skribe/d/41_ChangeLog 1.11 640)) - (doc/user/src/slides.skb (skribe/d/42_slides.skb 1.2 640)) - (doc/user/slide.skb (skribe/d/43_slide.skb 1.4 640)) - (doc/user/skribe-config.skb (skribe/d/44_skribe-con 1.2 640)) - (doc/skr/manual.skr (skribe/d/45_manual.skr 1.3 640)) - (doc/skr/extension.skr (skribe/d/46_extension. 1.1 640)) - (doc/skr/env.skr (skribe/d/47_env.skr 1.2 640)) - (doc/skr/api.skr (skribe/d/48_api.skr 1.5 640)) - (doc/dir/dir.skb (skribe/d/49_dir.skb 1.1 640)) - (doc/Makefile.dir (skribe/d/50_Makefile.d 1.2 640)) - -;; Files added by populate at Sun, 18 Jan 2004 12:46:07 +0100, -;; to version 1.0b.4(w), by serrano: - - (src/bigloo/asm.scm (skribe/d/51_asm.scm 1.2 640)) - -;; Files added by populate at Wed, 18 Feb 2004 21:22:35 +0100, -;; to version 1.0b.5(w), by serrano: - - (src/stklos/xml-lex.l (skribe/e/0_xml-lex.l 1.1 644)) - (src/stklos/configure.stk (skribe/e/1_configure. 1.1 644)) - (doc/user/xmle.skb (skribe/e/2_xmle.skb 1.2 640)) - (contribs/tools/skribeinfo/src/Makefile (skribe/e/3_Makefile 1.2 640)) - (contribs/tools/skribeinfo/skr/skribeinfo.skr (skribe/e/4_skribeinfo 1.1 640)) - (contribs/tools/skribeinfo/doc/pckg/skribeinfo.skb (skribe/e/5_skribeinfo 1.1 640)) - (contribs/tools/skribeinfo/configure (skribe/e/6_configure 1.2 750)) - (contribs/tools/skribeinfo/README (skribe/e/7_README 1.2 640)) - (contribs/tools/skribeinfo/Makefile.in (skribe/e/8_Makefile.i 1.3 640)) - (contribs/tools/Makefile (skribe/e/9_Makefile 1.3 640)) - (contribs/ext/bc-table/src/skribebctable.scm (skribe/e/10_skribebcta 1.2 640)) - (contribs/ext/bc-table/src/example.bc (skribe/e/11_example.bc 1.1 640)) - (contribs/ext/bc-table/src/Makefile (skribe/e/12_Makefile 1.2 640)) - (contribs/ext/bc-table/skr/bc-table.skr (skribe/e/13_bc-table.s 1.4 640)) - (contribs/ext/bc-table/example/example.skb (skribe/e/14_example.sk 1.2 640)) - (contribs/ext/bc-table/doc/pckg/bc-table.skb (skribe/e/15_bc-table.s 1.2 640)) - (contribs/ext/bc-table/configure (skribe/e/16_configure 1.2 750)) - (contribs/ext/bc-table/README (skribe/e/17_README 1.1 640)) - (contribs/ext/bc-table/Makefile.in (skribe/e/18_Makefile.i 1.2 640)) - (contribs/ext/Makefile (skribe/e/19_Makefile 1.3 640)) - (contribs/Makefile (skribe/e/20_Makefile 1.1 640)) - -;; Files added by populate at Wed, 18 Feb 2004 21:24:57 +0100, -;; to version 1.0b.6(w), by serrano: - - (contribs/ext/longtable/skr/longtable.skr (skribe/e/21_longtable. 1.1 640)) - (contribs/ext/longtable/example/example.skb (skribe/e/22_example.sk 1.1 640)) - (contribs/ext/longtable/doc/pckg/longtable.skb (skribe/e/23_longtable. 1.1 640)) - (contribs/ext/longtable/configure (skribe/e/24_configure 1.2 750)) - (contribs/ext/longtable/README (skribe/e/25_README 1.1 640)) - (contribs/ext/longtable/Makefile.in (skribe/e/26_Makefile.i 1.3 640)) - -;; Files added by populate at Sat, 21 Feb 2004 10:39:55 +0100, -;; to version 1.0b.8(w), by serrano: - - (doc/user/package.skb (skribe/e/27_package.sk 1.3 640)) - (contribs/tools/skribeinfo/example/example.skb (skribe/e/28_example.sk 1.2 640)) - (contribs/ext/html-navbar/skr/html-navbar.skr (skribe/e/29_html-navba 1.2 640)) - (contribs/ext/html-navbar/example/example.skb (skribe/e/30_example.sk 1.2 640)) - (contribs/ext/html-navbar/doc/pckg/html-navbar.skb (skribe/e/31_html-navba 1.2 640)) - (contribs/ext/html-navbar/configure (skribe/e/32_configure 1.1 750)) - (contribs/ext/html-navbar/README (skribe/e/33_README 1.1 640)) - (contribs/ext/html-navbar/Makefile.in (skribe/e/34_Makefile.i 1.2 640)) - (contribs/ext/html-gui/skr/html-gui.skr (skribe/e/35_html-gui.s 1.3 640)) - (contribs/ext/html-gui/example/example.skb (skribe/e/36_example.sk 1.2 640)) - (contribs/ext/html-gui/doc/pckg/html-gui.skb (skribe/e/37_html-gui.s 1.2 640)) - (contribs/ext/html-gui/configure (skribe/e/38_configure 1.2 755)) - (contribs/ext/html-gui/README (skribe/e/39_README 1.1 640)) - (contribs/ext/html-gui/Makefile.in (skribe/e/40_Makefile.i 1.2 640)) - -;; Files added by populate at Wed, 19 May 2004 14:41:48 +0200, -;; to version 1.0b.9(w), by serrano: - - (src/stklos/lisp-lex.l (skribe/e/41_lisp-lex.l 1.2 644)) - (src/stklos/c.stk (skribe/e/42_c.stk 1.1 644)) - (src/stklos/c-lex.l (skribe/e/43_c-lex.l 1.1 644)) - (skr/web-article.skr (skribe/e/44_web-articl 1.1 640)) - (skr/html4.skr (skribe/e/45_html4.skr 1.1 644)) - (contribs/tools/skribeinfo/CONTRIB.skb (skribe/e/46_CONTRIB.sk 1.1 640)) - (contribs/tools/skribecolsel/src/skribecolsel.scm (skribe/e/47_skribecols 1.1 640)) - (contribs/tools/skribecolsel/src/Makefile (skribe/e/48_Makefile 1.1 640)) - (contribs/tools/skribecolsel/emacs/skribecolsel.el (skribe/e/49_skribecols 1.1 640)) - (contribs/tools/skribecolsel/configure (skribe/e/50_configure 1.1 750)) - (contribs/tools/skribecolsel/README (skribe/e/51_README 1.1 640)) - (contribs/tools/skribecolsel/Makefile.in (skribe/f/0_Makefile.i 1.1 640)) - (contribs/tools/skribecolsel/CONTRIB.skb (skribe/f/1_CONTRIB.sk 1.1 640)) - (contribs/ext/longtable/CONTRIB.skb (skribe/f/2_CONTRIB.sk 1.1 640)) - (contribs/ext/js-tricks/skr/js-tricks.skr (skribe/f/3_js-tricks. 1.1 640)) - (contribs/ext/js-tricks/example/example.skb (skribe/f/4_example.sk 1.2 640)) - (contribs/ext/js-tricks/doc/pckg/js-tricks.skb (skribe/f/5_js-tricks. 1.1 640)) - (contribs/ext/js-tricks/configure (skribe/f/6_configure 1.1 750)) - (contribs/ext/js-tricks/README (skribe/f/7_README 1.1 640)) - (contribs/ext/js-tricks/Makefile.in (skribe/f/8_Makefile.i 1.1 640)) - (contribs/ext/html-navtabs/skr/html-navtabs.skr (skribe/f/9_html-navta 1.1 640)) - (contribs/ext/html-navtabs/example/example.skb (skribe/f/10_example.sk 1.1 640)) - (contribs/ext/html-navtabs/doc/pckg/html-navtabs.skb (skribe/f/11_html-navta 1.1 640)) - (contribs/ext/html-navtabs/configure (skribe/f/12_configure 1.1 750)) - (contribs/ext/html-navtabs/README (skribe/f/13_README 1.1 640)) - (contribs/ext/html-navtabs/Makefile.in (skribe/f/14_Makefile.i 1.1 640)) - (contribs/ext/html-navtabs/CONTRIB.skb (skribe/f/15_CONTRIB.sk 1.1 640)) - (contribs/ext/html-gui/CONTRIB.skb (skribe/f/16_CONTRIB.sk 1.1 640)) - (contribs/ext/fontsample/skr/fontsample.skr (skribe/f/17_fontsample 1.1 640)) - (contribs/ext/fontsample/example/example.skb (skribe/f/18_example.sk 1.1 640)) - (contribs/ext/fontsample/doc/pckg/fontsample.skb (skribe/f/19_fontsample 1.1 640)) - (contribs/ext/fontsample/configure (skribe/f/20_configure 1.1 750)) - (contribs/ext/fontsample/README (skribe/f/21_README 1.1 640)) - (contribs/ext/fontsample/Makefile.in (skribe/f/22_Makefile.i 1.1 640)) - (contribs/ext/fontsample/CONTRIB.skb (skribe/f/23_CONTRIB.sk 1.1 640)) - -;; Files added by populate at Wed, 22 Sep 2004 02:17:27 +0200, -;; to version 1.1b.2(w), by serrano: - - (src/bigloo/parseargs.scm (skribe/f/24_parseargs. 1.2 640)) - -;; Files added by populate at Wed, 22 Sep 2004 14:53:18 +0200, -;; to version 1.1b.5(w), by serrano: - - (skr/latex-simple.skr (skribe/f/25_latex-simp 1.2 640)) - -;; Files added by populate at Fri, 03 Jun 2005 16:47:11 +0200, -;; to version 1.1b.7(w), by serrano: - - (tools/skribebibtex/stklos/main.stk (skribe/f/26_main.stk 1.1 644)) - (tools/skribebibtex/stklos/bibtex-parser.y (skribe/f/27_bibtex-par 1.1 644)) - (tools/skribebibtex/stklos/bibtex-lex.l (skribe/f/28_bibtex-lex 1.1 644)) - (tools/skribebibtex/stklos/Makefile (skribe/f/29_Makefile 1.1 644)) - (tools/skribebibtex/bigloo/skribebibtex.scm (skribe/f/30_skribebibt 1.1 640)) - (tools/skribebibtex/bigloo/main.scm (skribe/f/31_main.scm 1.1 640)) - (tools/skribebibtex/bigloo/Makefile (skribe/f/32_Makefile 1.1 640)) - (skr/sigplan.skr (skribe/f/33_sigplan.sk 1.1 640)) - (skr/context.skr (skribe/f/34_context.sk 1.1 644)) -) -(Merge-Parents) -(New-Merge-Parents) diff --git a/skribe/INSTALL b/skribe/INSTALL deleted file mode 100644 index 30507e7..0000000 --- a/skribe/INSTALL +++ /dev/null @@ -1,110 +0,0 @@ -Here is the procedure for compiling and installing SKRIBE on a Unix system. - - -Requirements -************ - - - GNU-MAKE is required. - - BIGLOO 2.6b (or later) *or* SKTLOS 0.56 is required. - -Summary of a SKRIBE compilation, test and installation -****************************************************** - - $ ./configure --with-bigloo|--with-stklos - $ make - $ make install - - This procedure will self test SKRIBE because it will compile the various - Skribe documents that implement the Skribe documentation. - - -Configuring SKRIBE -****************** - - Configuring SKRIBE/BIGLOO - ************************* - - 1.a Edit the `./etc/bigloo/configure' file and set the variables defined in the Use - section (e.g. `bindir', `libdir', `mandir' and `docdir'). Note that - if you leave these variable definitions blank the installation procedure - will install Skribe at the same location as Bigloo. - - 1.b Configure Skribe for your machine by invoking: - `./configure --with-bigloo' - or - `./configure --with-bigloo --prefix ' - or - `./configure --with-bigloo --bigloo=' - When the system is ready to be compiled, `configure' prints - the message `configuration done.'. - - The following command: - `./configure --with-bigloo --help' - displays the available options. - - The default configuration uses the C back-end. To produce a JVM version of - SKRIBE, uses: - - `./configure --with-bigloo --jvm' - - Configuring SKRIBE/STKLOS - ************************* - - 1. Configure Skribe for your machine by invoking: - `./configure --with-stklos' - or - `./configure --with-stklos --prefix ' - -Compiling SKRIBE -**************** - - 2. Type: - `make' - - This will compile: - - the Skribe compiler: skribe - - the Texinfo to Skribe translator: skribeinfo (*) - - the BibTex to Skribe translator: skribebibtex (*) - - the Skribe documentation (in manuals/man, manuals/user and - manuals/expert). - - (*) this tools is compiled only when SKRIBE is compiled with BIGLOO. - - -Installing SKRIBE -***************** - - 3. Type: - `make install' - - This install, the Skribe compiler, the Skribeinfo compiler, the - various Skribe back-ends, the variable Skribe style files and - the Skribe documentation. - - This does not install the skribe.el emacs package. - - -Cleaning SKRIBE -*************** - - 4. Once, installed, you can type: - `make clean' - to remove all the useless files. - - -Uninstalling SKRIBE -******************* - - 5. To uninstall Skribe: - `make uninstall' - - -Unconfiguring SKRIBE -******************** - - 6. If you plan to re-install Skribe on a new platform. Before performing - the all installation process (step 1 to 5) you must first remove the - current configuration. For this type: - `make distclean' - - diff --git a/skribe/LICENSE b/skribe/LICENSE deleted file mode 100644 index dbf912f..0000000 --- a/skribe/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ ---------------------------------------------------------------------- - Skribe - - Copyright (c) 2003, 2004 -- Erick Gallesio, Manuel Serrano - - Bug descriptions, use reports, comments or suggestions are - welcome. Send them to - skribe@sophia.inria.fr - http://www.inria.fr/mimosa/fp/Skribe - - 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. ---------------------------------------------------------------------- diff --git a/skribe/Makefile b/skribe/Makefile deleted file mode 100644 index 918e91a..0000000 --- a/skribe/Makefile +++ /dev/null @@ -1,131 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Wed Jul 30 16:23:07 2003 */ -#* Last change : Fri May 21 16:37:53 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The general Skribe makefile */ -#*=====================================================================*/ -include etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* DIRECTORIES */ -#*---------------------------------------------------------------------*/ -DIRECTORIES = skr \ - doc \ - examples \ - src \ - emacs \ - etc \ - tools - -POPULATIONDIRS = $(DIRECTORIES) \ - contribs - -#*---------------------------------------------------------------------*/ -#* all */ -#*---------------------------------------------------------------------*/ -.PHONY: all - -all: - (cd src/$(SYSTEM) && $(MAKE)) - (cd tools && $(MAKE)) - (cd doc && $(MAKE)) - -#*---------------------------------------------------------------------*/ -#* install */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) install) || exit -1; \ - done - -uninstall: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) uninstall) || exit -1; \ - done - -#*---------------------------------------------------------------------*/ -#* revision */ -#*---------------------------------------------------------------------*/ -.PHONY: revision populate skribe.prj - -revision: populate checkin - -populate: skribe.prj - prcs populate skribe `$(MAKE) pop` - -checkin: - prcs checkin -r$(SKRIBERELEASE).@ skribe - -checkout: - @ prcs checkout -r$(SKRIBERELEASE).@ skribe - -skribe.prj: - @ cat skribe.prj | sed -e s,"(Populate-Ignore ())","(Populate-Ignore (\"\\\\\\\\\\.o\\$$\" \"\\\\\\\\\\~$$\" \"\\\\\\\\\\.log\\$$\" \"\\\\\\\\\\.ps\\$$\" \"\\\\\\\\\\.aux\\$$\" \"\\\\\\\\\\.date_of_backup\\$$\" \"\\\\\\\\\\.so\\$$\" \"\\\\\\\\\\.a\\$$\" \"if_not_there\\$$\" \"if_mach\\$$\" \"threadlibs\\$$\"))", > skribe.dprj; $(RM) -f skribe.prj; mv skribe.dprj skribe.prj - -#*---------------------------------------------------------------------*/ -#* population */ -#* ------------------------------------------------------------- */ -#* The list of all files that have to be placed inside the */ -#* repository for revision. */ -#*---------------------------------------------------------------------*/ -.PHONY: subpop popfilelist - -subpop: - @ for d in $(POPULATIONDIRS); do \ - (cd $$d && $(MAKE) -s pop); \ - done - -pop: - @ echo Makefile INSTALL LICENSE README README.java - @ echo configure - @ (for p in `$(MAKE) -s subpop`; do \ - echo $$p; \ - done) | sort - -#*---------------------------------------------------------------------*/ -#* distrib */ -#*---------------------------------------------------------------------*/ -.PHONY: distrib distrib-jvm distrib-src - -distrib: - $(MAKE) distrib -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - (cd www && $(MAKE)) - -distrib-jvm: - $(MAKE) distrib-jvm -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -distrib-src: - $(MAKE) distrib-src -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -#*---------------------------------------------------------------------*/ -#* clean/distclean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - $(RM) -f etc/Makefile.config - -clean: - (cd src && $(MAKE) clean) - (cd doc && $(MAKE) clean) - (cd tools && $(MAKE) clean) - (cd etc && $(MAKE) clean) - -distclean: clean - (cd emacs && $(MAKE) distclean) - (cd etc && $(MAKE) distclean) - -#*---------------------------------------------------------------------*/ -#* devclean/devdistclean */ -#*---------------------------------------------------------------------*/ -.PHONY: devclean devdistclean - -devclean: clean - (cd www && $(MAKE) clean) - -devdistclean: devclean distclean - diff --git a/skribe/README b/skribe/README deleted file mode 100644 index db68b22..0000000 --- a/skribe/README +++ /dev/null @@ -1,69 +0,0 @@ -What is Skribe -************** - -Skribe is programming language design for the production of electronic -documents. With Skribe one can: - - - Produce HTML web pages. - - Produce PS files. - - ... - -One may also: - - - Translate Texinfo files into HTML. - - - re-use BibTex bibliography databases. - - -Obtaining Skribe -**************** - -New versions of Skribe may downloaded from: - - ftp://ftp-sop.inria.fr/mimosa/fp/Skribe - - -Skribe distrubtion -****************** - -The Skribe distribution consists of several directories: - - INSTALL installation instructions. - - Makefile the Makefile to compile Skribe. - - README this document. - - README.java specific information regarding the JVM port of Skribe. - - etc private directory. - - bin the directory where binary files are compiled to. - - lib the directory where Skribe libraries are compiled to. - - configure configuration driver script. - - emacs Skribe emacs mode. - - examples Various example of Skribe texts. - - doc the Skribe sources for Skribe manuals. - - src the Scheme source code for Skribe. - - skr the Skribe source code for the Skribe engines and styles. - - tools the Bigloo source code for the Texi->Skribe and BibTex->Skribe - compilers. - - -Acknowledgements -**************** - -We thank all the people who helped me while writing Skribe. My first -though goes to Frederic Boussinot who's the first pre-alpha-tester of -Skribe always volunteering for new testing new features ;-) I then -thanks all the people that send me fixes, suggestions and -improvements, that is, all the people that appear in the ChangeLog -file. Many thanks to all of you. diff --git a/skribe/README.java b/skribe/README.java deleted file mode 100644 index dcb0457..0000000 --- a/skribe/README.java +++ /dev/null @@ -1,36 +0,0 @@ -This README explains how to use the pre-compiled JVM -version of Skribe. This requires JDK 1.3 or higher. - -Installing SKRIBE -***************** - -The pre-compiled version of SKRIBE does not need installation procedure. -It is pre-installed. The documentation is pre-compiled. It is located -in the directory doc/html. - - -Running SKRIBE -************** - -Lets assume that SKRIBEDIR is the shell variable containing -the name of the directory where Skribe has been unzipped: - -1. To compile a Skribe program "prog.skr" uses: - - java -classpath $SKRIBEDIR/bin/skribe.zip:$SKRIBEDIR/lib/bigloo_s.zip -Dbigloo.SKRIBEPATH=$SKRIBEDIR/skr bigloo.skribe.main prog.skr - -2. To convert a Texi file "prog.texi" into Skribe: - - java -classpath $SKRIBEDIR/bin/skribeinfo.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribeinfo.main prog.texi - -3. To convert a BibTex database "db.bib" into Skribe: - - java -classpath $SKRIBEDIR/bin/skribebibtex.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribebibtex.main db.bib - - -Compiling the examples -********************** - -On a Unix platform: - - cd examples; make diff --git a/skribe/configure b/skribe/configure deleted file mode 100755 index 798d9d2..0000000 --- a/skribe/configure +++ /dev/null @@ -1,124 +0,0 @@ -#!/bin/sh -# -# This file is a simple trampoline to the real configure script which -# depends of the Scheme system used -# -# Known systems so far: -# - Bigloo (use --with-bigloo) -# - STklos (use --with-stklos) -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 29-Jul-2003 13:59 (eg) -# Last file update: 23-Sep-2004 17:14 (eg) - - -use_bigloo=0 -use_stklos=0 - -new_args="" -export new_args -prefix=/usr/local -export prefix - -for i in "$@"; do - case $i in - --with-bigloo) scheme=bigloo; use_bigloo=1;; - --with-stklos) scheme=stklos; use_stklos=1;; - --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; - new_args="$new_args $i";; - *) new_args="$new_args \"$i\"";; - esac -done - -#* for i in $* ;do */ -#* case $i in */ -#* --with-bigloo) scheme=bigloo; use_bigloo=1;; */ -#* --with-stklos) scheme=stklos; use_stklos=1;; */ -#* --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; */ -#* new_args="$new_args $i";; */ -#* *) new_args="$new_args $i";; */ -#* esac */ -#* done */ - - -case `expr $use_bigloo + $use_stklos` in - 0) echo "You must at least specify a Scheme system: "; - echo " --with-bigloo to use Bigloo" - echo " --with-stklos to use STklos" - exit 1;; - 1) ;; - *) echo "You must specify ONLY ONE Scheme system"; exit 1;; -esac - -if test $use_bigloo = 1 ;then - scheme=bigloo -fi - -if test $use_stklos = 1 ;then - scheme=stklos -fi - - - -# Common configuration -release="1.2d" -skribeurl="http://www.inria.fr/mimosa/fp/Skribe" -skribeextdir="$prefix/share/skribe/extensions" -skribedocdir=$prefix/doc/skribe-$release -skribeskrdir="'(\".\" \"$skribeextdir\" \"$prefix/share/skribe/$release/skr\" )" - -# etc/config -rm -f etc/config 2> /dev/null -echo "# Automatically generated file (don't edit)" > etc/config -echo "release=$release" >> etc/config -echo "skribeurl=$skribeurl" >> etc/config -echo "prefix=$prefix" >> etc/config - -# etc/skribe-config -cat etc/skribe-config.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_SKR_DIR@|$prefix/share/skribe/$release/skr|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - > etc/skribe-config -chmod a+x etc/skribe-config - -# emacs/skribe.el -cat emacs/skribe.el.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - | sed "s|@SKRIBE_DOCDIR@|$skribedocdir|" \ - > emacs/skribe.el - -# src/common/configure.scm -rm -f src/common/configure.scm 2> /dev/null -echo ";; Automatically generated file (don't edit)" > src/common/configure.scm -cat src/common/configure.scm.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@SKRIBE_URL@|$skribeurl|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_SKR_PATH@|$skribeskrdir|" \ - | sed "s|@SKRIBE_SCHEME@|$scheme|" \ - >> src/common/configure.scm -echo "" >> src/common/configure.scm - -if test $use_bigloo = 1 ;then - # pass all the arguments to the Bigloo autoconf without the --with-bigloo - echo "Using Bigloo system" - eval "cd etc/bigloo; SKRIBERELEASE=$release ./configure --docdir=$skribedocdir $new_args" - exit 0 -fi - -# If we are here, it means that we use the STklos system -if test $use_stklos = 1 ;then - # pass all the arguments to the STklos autoconf without the --with-stklos - echo "Using STklos system" - eval "cd etc/stklos; ./configure $new_args" - exit 0 -fi - diff --git a/skribe/doc/Makefile b/skribe/doc/Makefile deleted file mode 100644 index 934389e..0000000 --- a/skribe/doc/Makefile +++ /dev/null @@ -1,233 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/doc/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Mon Sep 1 10:29:28 2003 */ -#* Last change : Wed Mar 10 11:16:48 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Skribe documentation. */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compiler and tools */ -#*---------------------------------------------------------------------*/ -BINDIR = ../bin -LIBDIR = ../lib -LATEX = latex -DVIPS = dvips - -SKRIBEVERBOSE = -v1 -SKRIBEWARNING = -w1 -SFLAGS = $(SKRIBEVERBOSE) $(SKRIBEWARNING) \ - -I ../skr \ - -I skr \ - -P img \ - -S .. \ - --custom emit-sui=yes \ - --eval '(define *skribe-bin* "$(SKRIBE)")' \ - --eval '(define *skribebibtex-bin* "$(SKRIBEBIBTEX)")' - -#*---------------------------------------------------------------------*/ -#* Doc skr */ -#*---------------------------------------------------------------------*/ -_SKR = manual.skr env.skr api.skr extension.skr -SKR = $(_SKR:%=skr/%) - -#*---------------------------------------------------------------------*/ -#* Images */ -#*---------------------------------------------------------------------*/ -_IMG = bsd.gif lambda.gif linux.gif -IMG = $(_IMG:%=img/%) - -#*---------------------------------------------------------------------*/ -#* User document */ -#*---------------------------------------------------------------------*/ -_USERMAIN = user.skb -_USEROTHERS = start.skb syntax.skb \ - markup.skb document.skb \ - sectioning.skb toc.skb ornament.skb line.skb font.skb \ - justify.skb enumeration.skb \ - examples.skb colframe.skb figure.skb image.skb table.skb \ - footnote.skb char.skb \ - links.skb index.skb bib.skb prgm.skb \ - engine.skb htmle.skb latexe.skb xmle.skb \ - emacs.skb skribec.skb skribe-config.skb \ - lib.skb slide.skb package.skb -_USERSRC = start1.skb start2.skb start3.skb start4.skb start5.skb \ - api1.skb api2.skb api3.skb api4.skb api5.skb \ - api6.skb api7.skb api8.skb api9.skb api10.skb \ - api11.skb api12.skb api13.skb api14.skb api15.skb \ - api16.skb api17.skb api18.skb api19.skb api20.skb \ - links1.skb links2.skb \ - index1.skb index2.skb index3.skb \ - bib1.sbib bib2.skb bib3.skb bib4.skb bib5.skb bib6.skb \ - prgm1.skb prgm2.skb prgm3.skb slides.skb - -USERMAIN = $(_USERMAIN:%=user/%) -USEROTHERS = $(_USEROTHERS:%=user/%) -USERSRC = $(_USERSRC:%=user/src/%) -USERSKB = $(USERMAIN) $(USEROTHERS) $(USERSRC) - -#*---------------------------------------------------------------------*/ -#* User document */ -#*---------------------------------------------------------------------*/ -_DIRMAIN = dir.skb -_DIROTHERS = -_DIRSRC = - -DIRMAIN = $(_DIRMAIN:%=dir/%) -DIROTHERS = $(_DIROTHERS:%=dir/%) -DIRSRC = $(_DIRSRC:%=dir/src/%) -DIRSKB = $(DIRMAIN) $(DIROTHERS) $(DIRSRC) - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .skb .man .html .sui - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -.PHONY: user dir - -all: user dir -re: re.html re.dir - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo doc/Makefile doc/Makefile.dir - @ echo $(USERSKB:%=doc/%) - @ echo $(DIRSKB:%=doc/%) - @ echo $(SKR:%=doc/%) - @ echo $(IMG:%=doc/%) - -#*---------------------------------------------------------------------*/ -#* user */ -#*---------------------------------------------------------------------*/ -.PHONY: user re.html user.html - -user: user.html user.sui -user.html: html/user.html html/img/lambda.gif html/img/bsd.gif html/img/linux.gif -user.sui: html/user.sui - -user.ps: tex/user.dvi - (cd tex; $(DVIPS) user.dvi -o user.ps) - -user.dvi: tex/user.dvi -tex/user.dvi: tex/user.tex - (cd tex; $(LATEX) user.tex) - -html/user.html html/user.sui: html $(USERSKB) $(SKR) - $(MAKE) re.html - -tex/user.tex: tex $(USERSKB) $(SKR) tex/img/lambda.eps tex/img/bsd.eps tex/img/linux.eps - $(MAKE) re.tex - -# gif -html/img/lambda.gif: html/img img/lambda.gif - cp img/lambda.gif html/img/lambda.gif - -html/img/linux.gif: html/img img/linux.gif - cp img/linux.gif html/img/linux.gif - -html/img/bsd.gif: html/img img/bsd.gif - cp img/bsd.gif html/img/bsd.gif - -# eps image -tex/img/lambda.eps: tex/img img/lambda.gif - convert img/lambda.gif tex/img/lambda.eps - -tex/img/linux.eps: tex/img img/linux.gif - convert img/linux.gif tex/img/linux.eps - -tex/img/bsd.eps: tex/img img/bsd.gif - convert img/bsd.gif tex/img/bsd.eps - -re.html: - $(SKRIBE) $(SFLAGS) $(USERMAIN) \ - --base html -I user -S user \ - -o html/user.html - -re.tex: - $(SKRIBE) $(SFLAGS) $(USERMAIN) \ - --base tex -I user -S user \ - -o tex/user.tex - -#*---------------------------------------------------------------------*/ -#* dir */ -#*---------------------------------------------------------------------*/ -.PHONY: dir re.dir dir.html - -dir: dir.html -dir.html: html/dir.html - -html/dir.html: html $(DIRSKB) $(SKR) - $(MAKE) re.dir - -re.dir: - $(MAKE) -f Makefile.dir SKRIBE="$(SKRIBE)" BASE=html - -#*---------------------------------------------------------------------*/ -#* Misc */ -#*---------------------------------------------------------------------*/ -html: - mkdir -p html - -html/img: - mkdir -p html/img - -tex: - mkdir -p tex - -tex/img: - mkdir -p tex/img - -gethtml: - @ echo "html/user.html" - -#*---------------------------------------------------------------------*/ -#* install/uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_DOCDIR) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr - cp -r html/* $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/* \ - && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR)/img - cp -r skr/* $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc \ - && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr/* - cp Makefile.dir $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/Makefile.dir - cp dir/dir.skb $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/dir.skb - -uninstall: - $(RM) -rf $(DESTDIR)$(INSTALL_DOCDIR) - -$(DESTDIR)$(INSTALL_DOCDIR): - mkdir -p $(DESTDIR)$(INSTALL_DOCDIR) && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR) - - -$(DESTDIR)$(INSTALL_SKRDIR)/doc/skr: - mkdir -p $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod -R a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - $(RM) -rf html - $(RM) -rf tex - $(RM) -f img/bsd.eps img/linux.eps diff --git a/skribe/doc/Makefile.dir b/skribe/doc/Makefile.dir deleted file mode 100644 index e35cf0b..0000000 --- a/skribe/doc/Makefile.dir +++ /dev/null @@ -1,22 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/doc/Makefile.dir */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Thu Jan 1 15:30:39 2004 */ -#* Last change : Wed Feb 4 09:19:03 2004 (serrano) */ -#* Copyright : 2004 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Skribe directory. */ -#*=====================================================================*/ - -SKRIBE = skribe -SFLAGS = -I ../skr -I skr -P img -S .. -w0 -BASE = . -SPATH = - -.PHONY: re.dir - -re.dir: - $(SKRIBE) $(SFLAGS) $(SPATH) dir.skb \ - --base $(BASE) -I dir -S dir \ - -o $(BASE)/dir.html diff --git a/skribe/doc/dir/dir.skb b/skribe/doc/dir/dir.skb deleted file mode 100644 index 8c6d377..0000000 --- a/skribe/doc/dir/dir.skb +++ /dev/null @@ -1,113 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/dir/dir.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Nov 28 10:37:39 2001 */ -;* Last change : Thu Jan 1 17:12:43 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe directory */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The Skribe documentation style */ -;*---------------------------------------------------------------------*/ -(skribe-load "web-book.skr") -(skribe-load "skr/env.skr") -(skribe-load "skr/manual.skr") -(skribe-load "skr/api.skr") - -;*---------------------------------------------------------------------*/ -;* Html configuration */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (engine-custom-set! he 'web-book-main-browsing-extra - (lambda (n e) - (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 - (tr (td :align 'left :valign 'top (bold "Skribe: ")) - (td :align 'right :valign 'top - (ref :url *skribe-user-doc-url* - :text "User Manual"))))))) - -;*---------------------------------------------------------------------*/ -;* The global index */ -;*---------------------------------------------------------------------*/ -(define *sui-index* (make-index "sui")) - -;*---------------------------------------------------------------------*/ -;* index-sui ... */ -;*---------------------------------------------------------------------*/ -(define (index-sui sui dir) - (sui-filter sui - (lambda (s) - (and (pair? s) (eq? (car s) 'marks))) - (lambda (e) - (let ((f (memq :file e)) - (k (memq :mark e)) - (c (memq :class e))) - (when (and (pair? f) - (pair? k) - (pair? c) - (string=? (cadr c) "public-definition")) - (index :index *sui-index* - :url (format "~a/~a#~a" dir (cadr f) (cadr k)) - (cadr k))) - #f)))) - -;*---------------------------------------------------------------------*/ -;* Intern all the sui files */ -;*---------------------------------------------------------------------*/ -(define extensions '()) - -(let loop ((files (directory->list "html"))) - (when (pair? files) - (if (string=? (suffix (car files)) "sui") - (let* ((f (string-append "html/" (car files))) - (sui (load-sui f))) - (if (not (string=? (car files) "user.sui")) - (set! extensions (cons sui extensions))) - (index-sui sui (dirname (car files))))) - (loop (cdr files)))) -(let loop ((files (directory->list "."))) - (when (pair? files) - (if (string=? (suffix (car files)) "sui") - (let* ((f (car files)) - (sui (load-sui f))) - (if (not (string=? (car files) "user.sui")) - (set! extensions (cons sui extensions))) - (index-sui sui (dirname f)))) - (loop (cdr files)))) - -;*---------------------------------------------------------------------*/ -;* The document */ -;*---------------------------------------------------------------------*/ -(document :title "Skribe directory" - :author (list (author :name "Erick Gallesio" - :affiliation "Université de Nice - Sophia Antipolis" - :address '("930 route des Colles, BP 145" - "F-06903 Sophia Antipolis, Cedex" - "France") - :email (mailto "eg@essi.fr")) - (author :name "Manuel Serrano" - :affiliation "Inria Sophia-Antipolis" - :address `("2004 route des Lucioles - BP 93" - "F-06902 Sophia Antipolis, Cedex" - "France") - :url (ref :url *serrano-url*) - :email (mailto *serrano-mail*))) - - (linebreak 1) - -;;; extensions -(if (pair? extensions) - (section :title "Installed extensions" :number #f - (itemize (map (lambda (e) - (item :key (ref :url (sui-file e) :text (sui-title e)) - (let ((d (sui-key e :description))) - (if d (list ": " d) #f)))) - extensions)))) - -;;; global Index -(section :title "Global Markup Index" :number #f - (mark "global index") - (the-index :column 3 *sui-index*))) diff --git a/skribe/doc/img/bsd.gif b/skribe/doc/img/bsd.gif deleted file mode 100644 index e406ba6..0000000 Binary files a/skribe/doc/img/bsd.gif and /dev/null differ diff --git a/skribe/doc/img/lambda.gif b/skribe/doc/img/lambda.gif deleted file mode 100644 index 9c46b7d..0000000 Binary files a/skribe/doc/img/lambda.gif and /dev/null differ diff --git a/skribe/doc/img/linux.gif b/skribe/doc/img/linux.gif deleted file mode 100644 index fa764bd..0000000 Binary files a/skribe/doc/img/linux.gif and /dev/null differ diff --git a/skribe/doc/skr/api.skr b/skribe/doc/skr/api.skr deleted file mode 100644 index a27c3a4..0000000 --- a/skribe/doc/skr/api.skr +++ /dev/null @@ -1,575 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/skr/api.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 07:45:33 2003 */ -;* Last change : Tue Apr 6 06:51:34 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for documenting Lisp APIs. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Html configuration */ -;*---------------------------------------------------------------------*/ -(let* ((he (find-engine 'html)) - (tro (markup-writer-get 'tr he))) - (markup-writer 'tr he - :class 'api-table-header - :options '(:width :bg) - :action (lambda (n e) - (let ((c (engine-custom e 'section-title-background))) - (markup-option-add! n :bg c) - (output n e tro)))) - (markup-writer 'tr he - :class 'api-table-prototype - :options '(:width :bg) - :action (lambda (n e) - (let ((c (engine-custom e 'title-background))) - (markup-option-add! n :bg c) - (output n e tro)))) - (markup-writer 'tr he - :class 'api-symbol-prototype - :options '(:width :bg) - :action (lambda (n e) - (let ((c (engine-custom e 'title-background))) - (markup-option-add! n :bg c) - (output n e tro))))) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let* ((le (find-engine 'latex)) - (tro (markup-writer-get 'tr le))) - (markup-writer 'tr le - :class 'api-table-prototype - :options '(:width :bg) - :action #f) - (markup-writer 'tr le - :class 'api-table-header - :options '(:width :bg) - :action (lambda (n e) - (let ((c (engine-custom e 'section-title-background))) - (markup-option-add! n :bg c) - (output n e tro))))) - -;*---------------------------------------------------------------------*/ -;* api-search-definition ... */ -;* ------------------------------------------------------------- */ -;* Find a definition inside a source file. */ -;*---------------------------------------------------------------------*/ -(define (api-search-definition id file pred) - (let ((f (find-file/path file *skribe-source-path*))) - (if (not (string? f)) - (skribe-error 'api-search-definition - (format "Can't find source file `~a' in path" file) - *skribe-source-path*) - (with-input-from-file f - (lambda () - (let loop ((exp (read))) - (if (eof-object? exp) - (skribe-error 'api-search-definition - (format "Can't find `~a' definition" id) - file) - (or (pred id exp) (loop (read)))))))))) - -;*---------------------------------------------------------------------*/ -;* api-compare-set ... */ -;* ------------------------------------------------------------- */ -;* This function compares two sets. It returns either #t */ -;* is they are equal, or two subsets which contain elements */ -;* not present in the arguments. For instance: */ -;* (api-compare-set '(foo bar) '(bar foo)) ==> #t */ -;* (api-compare-set '(foo gee) '(gee bar)) ==> '((foo) (bar)) */ -;*---------------------------------------------------------------------*/ -(define (api-compare-set s1 s2) - (let ((d1 (filter (lambda (x) (not (memq x s2))) s1)) - (d2 (filter (lambda (x) (not (memq x s1))) s2))) - (or (and (null? d1) (null? d2)) - (list d1 d2)))) - -;*---------------------------------------------------------------------*/ -;* keyword->symbol ... */ -;*---------------------------------------------------------------------*/ -(define (keyword->symbol kwd) - (let ((s (keyword->string kwd))) - (if (char=? #\: (string-ref s 0)) - ;; Bigloo - (string->symbol (substring s 1 (string-length s))) - ;; STklos - (string->symbol s)))) - -;*---------------------------------------------------------------------*/ -;* define-markup? ... */ -;*---------------------------------------------------------------------*/ -(define (define-markup? id o) - (match-case o - (((or define-markup define define-inline) - ((? (lambda (x) (eq? x id))) . (? (lambda (x) (or (pair? x) (null? x))))) . ?-) - o) - ((define-simple-markup (? (lambda (x) (eq? x id)))) - o) - ((define-simple-container (? (lambda (x) (eq? x id)))) - o) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* make-engine? ... */ -;*---------------------------------------------------------------------*/ -(define (make-engine? id o) - (match-case o - (((or make-engine copy-engine) (quote (? (lambda (x) (eq? x id)))) . ?-) - o) - ((quasiquote . ?-) - #f) - ((quote . ?-) - #f) - ((?a . ?d) - (or (make-engine? id a) (make-engine? id d))) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* make-engine-custom ... */ -;*---------------------------------------------------------------------*/ -(define (make-engine-custom def) - (match-case (memq :custom def) - ((:custom (quote ?custom) . ?-) - custom) - ((:custom ?custom . ?-) - (eval custom)) - (else - '()))) - -;*---------------------------------------------------------------------*/ -;* define-markup-formals ... */ -;* ------------------------------------------------------------- */ -;* Returns the formal parameters of a define-markup (not the */ -;* options). */ -;*---------------------------------------------------------------------*/ -(define (define-markup-formals def) - (match-case def - ((?- (?- . ?args) . ?-) - (if (symbol? args) - (list args) - (let loop ((args args) - (res '())) - (cond - ((null? args) - (reverse! res)) - ((symbol? args) - (reverse! (cons args res))) - ((not (symbol? (car args))) - (reverse! res)) - (else - (loop (cdr args) (cons (car args) res))))))) - ((define-simple-markup ?-) - '()) - ((define-simple-container ?-) - '()) - (else - (skribe-error 'define-markup-formals - "Illegal `define-markup' form" - def)))) - -;*---------------------------------------------------------------------*/ -;* define-markup-options ... */ -;* ------------------------------------------------------------- */ -;* Returns the options parameters of a define-markup. */ -;*---------------------------------------------------------------------*/ -(define (define-markup-options def) - (match-case def - ((?- (?- . ?args) . ?-) - (if (not (list? args)) - '() - (let ((keys (memq #!key args))) - (if (pair? keys) - (cdr keys) - '())))) - ((define-simple-markup ?-) - '((ident #f) (class #f))) - ((define-simple-container ?-) - '((ident #f) (class #f))) - (else - (skribe-error 'define-markup-formals - "Illegal `define-markup' form" - def)))) - -;*---------------------------------------------------------------------*/ -;* define-markup-rest ... */ -;* ------------------------------------------------------------- */ -;* Returns the rest parameter of a define-markup. */ -;*---------------------------------------------------------------------*/ -(define (define-markup-rest def) - (match-case def - ((?- (?- . ?args) . ?-) - (if (not (pair? args)) - args - (let ((l (last-pair args))) - (if (symbol? (cdr l)) - (cdr l) - (let ((rest (memq #!rest args))) - (if (pair? rest) - (if (or (not (pair? (cdr rest))) - (not (symbol? (cadr rest)))) - (skribe-error 'define-markup-rest - "Illegal `define-markup' form" - def) - (cadr rest)) - #f)))))) - ((define-simple-markup ?-) - 'node) - ((define-simple-container ?-) - 'node) - (else - (skribe-error 'define-markup-formals - "Illegal `define-markup' form" - def)))) - -;*---------------------------------------------------------------------*/ -;* doc-check-arguments ... */ -;*---------------------------------------------------------------------*/ -(define (doc-check-arguments id args dargs) - (if (not args) - (skribe-error 'doc-check-arguments id args)) - (if (not dargs) - (skribe-error 'doc-check-arguments id dargs)) - (let* ((s1 (map (lambda (x) (if (pair? x) (car x) x)) args)) - (s2 (map (lambda (x) - (let ((i (car x))) - (if (keyword? i) - (keyword->symbol i) - i))) - dargs)) - (d (api-compare-set s1 s2))) - (if (pair? d) - (let ((d1 (car d)) - (d2 (cadr d))) - (if (pair? d1) - (skribe-error 'doc-markup - (format "~a: missing descriptions" id) - d1) - (skribe-error 'doc-markup - (format "~a: extra descriptions" id) - d2)))))) - -;*---------------------------------------------------------------------*/ -;* exp->skribe ... */ -;*---------------------------------------------------------------------*/ -(define (exp->skribe exp) - (cond - ((number? exp) exp) - ((string? exp) (string-append "\"" exp "\"")) - ((eq? exp #f) "#f") - ((eq? exp #t) "#t") - ((symbol? exp) (symbol->string exp)) - ((equal? exp '(quote ())) "'()") - ((ast? exp) - (table :cellpadding 0 :cellspacing 0 - (tr (td :align 'left exp)))) - (else - (match-case exp - ((quote (and ?sym (? symbol?))) - (string-append "'" (symbol->string sym))) - (else - (with-output-to-string (lambda () (write exp)))))))) - -;*---------------------------------------------------------------------*/ -;* doc-markup-proto ... */ -;*---------------------------------------------------------------------*/ -(define (doc-markup-proto id options formals rest) - (define (option opt) - (if (pair? opt) - (if (eq? (cadr opt) #f) - (list " [" (keyword (car opt)) "]") - (list " [" (keyword (car opt)) " " - (code (exp->skribe (cadr opt))) "]")) - (list " " (keyword opt)))) - (define (formal f) - (list " " (param f))) - (code (list (bold "(") (bold :class 'api-proto-ident (format "~a" id))) - (map option (sort options - (lambda (s1 s2) - (cond - ((and (pair? s1) (not (pair? s2))) - #f) - ((and (pair? s2) (not (pair? s1))) - #t) - (else - #t))))) - (if (pair? formals) - (map formal formals)) - (if rest (list " " (param rest))) - (bold ")"))) - -;*---------------------------------------------------------------------*/ -;* doc-markup ... */ -;*---------------------------------------------------------------------*/ -(define-markup (doc-markup id args - #!rest - opts - #!key - (writer-id #f) - (common-args '((:ident "The node identifier.") - (:class "The node class."))) - (ignore-args '(&skribe-eval-location)) - (force-args '()) - (idx *markup-index*) - (idx-note "definition") - (idx-suffix #f) - (source "src/common/api.scm") - (def #f) - (see-also '()) - (others '()) - (force-engines '()) - (engines *api-engines*) - (sui #f) - &skribe-eval-location) - (define (opt-engine-support opt) - ;; find the engines providing a writer for id - (map (lambda (e) - (let* ((id (engine-ident e)) - (s (symbol->string id))) - (if (engine-format? "latex") - (list s " ") - (list (if sui - (ref :skribe sui - :mark (string-append s "-engine") - :text s) - (ref :mark (string-append s "-engine") - :text s)) - " ")))) - (if (pair? force-engines) - force-engines - (filter (lambda (e) - (or (memq opt '(:ident :class)) - (memq opt force-args) - (let ((w (markup-writer-get (or writer-id id) - e))) - (cond - ((not (writer? w)) - #f) - (else - (let ((o (writer-options w))) - (cond - ((eq? o 'all) - #t) - ((not (pair? o)) - #f) - (else - (memq opt o))))))))) - engines)))) - (cond - ((and def source) - (skribe-error 'doc-markup "source and def both specified" id)) - ((and (not def) (not source)) - (skribe-error 'doc-markup "source or def must be specified" id)) - (else - (let* ((d (or def (api-search-definition id source define-markup?))) - (od (map (lambda (o) - (api-search-definition o source define-markup?)) - others)) - (args (append common-args args)) - (formals (define-markup-formals d)) - (fformals (filter (lambda (s) - (let ((c (assq s args))) - (not - (and (pair? c) - (eq? (cadr c) 'ignore))))) - formals)) - (options (filter (lambda (s) - (not (memq s ignore-args))) - (define-markup-options d))) - (dformals (filter (lambda (x) - (symbol? (car x))) - args)) - (doptions (filter (lambda (x) - (and (keyword? (car x)) - ;; useful for STklos only - (not (eq? (car x) #!rest)))) - args)) - (drest (filter (lambda (x) - (eq? #!rest (car x))) - args)) - (dargs (and (pair? drest) (cadr (car drest)))) - (p+ (cons (doc-markup-proto id options fformals dargs) - (map (lambda (id def) - (doc-markup-proto - id - (define-markup-options def) - (define-markup-formals def) - dargs)) - others od)))) - ;; doc table - (define (doc-markup.html) - (let ((df (map (lambda (f) - (tr :bg *prgm-skribe-color* - (td :colspan 2 :width 20. :align 'left - (param (car f)) ) - (td :align 'left :width 80. (cadr f)))) - dformals)) - (dr (and (pair? drest) - (tr :bg *prgm-skribe-color* - (td :align 'left - :valign 'top - :colspan 2 - :width 20. - (param (cadr (car drest)))) - (td :align 'left :width 80. - (caddr (car drest)))))) - (do (map (lambda (f) - (tr :bg *prgm-skribe-color* - (td :align 'left - :valign 'top - :width 10. - (param (car f))) - (td :align 'left - :valign 'top - :width 20. - (opt-engine-support (car f))) - (td :align 'left :width 70. (cadr f)))) - doptions)) - (so (map (lambda (x) - (let ((s (symbol->string x))) - (list - (ref :mark s :text (code s)) - " "))) - see-also))) - (table :border (if (engine-format? "latex") 1 0) - :width (if (engine-format? "latex") #f *prgm-width*) - `(,(tr :class 'api-table-prototype - (th :colspan 3 :align 'left :width *prgm-width* - "prototype")) - ,@(map (lambda (p) - (tr :bg *prgm-skribe-color* - (td :colspan 3 :width *prgm-width* - :align 'left p))) - p+) - ,@(if (pair? do) - `(,(tr :class 'api-table-header - (th :align 'left "option" - :width 10.) - (th :align 'center "engines" - :width 20.) - (th "description")) - ,@do) - '()) - ,@(if (or (pair? df) dr) - `(,(tr :class 'api-table-header - (th :colspan 2 - :align 'left - :width 30. - "argument") - (th "description")) - ,@(if (pair? df) df '()) - ,@(if dr (list dr) '())) - '()) - ,@(if (pair? so) - `(,(tr :class 'api-table-header - (th :colspan 3 :align 'left - (it "See also"))) - ,(tr :bg *prgm-skribe-color* - (td :colspan 3 :align 'left so))) - '()))))) - ;; doc enumerate - (define (doc-markup.latex) - (let ((df (map (lambda (f) - (item :key (param (car f)) (cadr f))) - dformals)) - (dr (if (pair? drest) - (list (item :key (param (cadr (car drest))) - (caddr (car drest)))) - '())) - (do (map (lambda (f) - (item :key (param (car f)) - (list (opt-engine-support (car f)) - (cadr f)))) - doptions)) - (so (map (lambda (x) - (let ((s (symbol->string x))) - (list - (ref :mark s :page #t - :text [,(code s), p.]) - " "))) - see-also))) - (list (center - (frame :margin 5 :border 0 :width *prgm-width* - (color :class 'api-table-prototype - :margin 5 :width 100. :bg "#ccccff" - p+))) - (when (pair? do) - (subsubsection :title "Options" :number #f :toc #f - (description do))) - (when (or (pair? df) (pair? dr)) - (subsubsection :title "Parameters" :number #f :toc #f - (description (append df dr)))) - (when (pair? so) - (subsubsection :title "See also" :number #f :toc #f - (p so) - (! "\\noindent")))))) - ;; check all the descriptions - (doc-check-arguments id formals dformals) - (doc-check-arguments id options doptions) - (if (and (pair? drest) (not (define-markup-rest d))) - (skribe-error 'doc-markup "No rest argument for" id) - options) - (list (mark :class "public-definition" (symbol->string id)) - (map (lambda (i) (mark (symbol->string i))) others) - (map (lambda (i) - (let ((is (symbol->string i))) - (index (if (string? idx-suffix) - (string-append is idx-suffix) - is) - :index idx - :note idx-note))) - (cons id others)) - (cond - ((engine-format? "latex") - (doc-markup.latex)) - (else - (center (doc-markup.html))))))))) - -;*---------------------------------------------------------------------*/ -;* doc-engine ... */ -;*---------------------------------------------------------------------*/ -(define-markup (doc-engine id args - #!rest - opts - #!key - (idx *custom-index*) - source - (def #f)) - (cond - ((and def source) - (skribe-error 'doc-engine "source and def both specified" id)) - ((and (not def) (not source)) - (skribe-error 'doc-engine "source or def must be specified" id)) - (else - (let* ((d (or def (api-search-definition id source make-engine?))) - (c (make-engine-custom d))) - (doc-check-arguments id c args) - (cond - ((engine-format? "latex") - #f) - (else - (center - (apply table - :width *prgm-width* - (tr :class 'api-table-header - (th :align 'left :width 20. "custom") - (th :width 10. "default") - (th "description")) - (map (lambda (r) - (tr :bg *prgm-skribe-color* - (td :align 'left :valign 'top - (list (index (symbol->string (car r)) - :index idx - :note (format "~a custom" id)) - (symbol->string (car r)))) - (let ((def (assq (car r) c))) - (td :valign 'top - (code (exp->skribe (cadr def))))) - (td :align 'left :valign 'top (cadr r)))) - (filter cadr args)))))))))) - diff --git a/skribe/doc/skr/env.skr b/skribe/doc/skr/env.skr deleted file mode 100644 index 09d5146..0000000 --- a/skribe/doc/skr/env.skr +++ /dev/null @@ -1,32 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/skr/env.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 10:22:42 2003 */ -;* Last change : Thu Jan 29 06:48:54 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The environment variables for the documentation. */ -;*=====================================================================*/ - -(define *serrano-url* "http://www.inria.fr/mimosa/Manuel.Serrano") -(define *serrano-mail* "Manuel.Serrano@sophia.inria.fr") -(define *html-url* "http://www.w3.org/TR/html4") -(define *html-form* "interact/forms.html") -(define *emacs-url* "http://www.gnu.org/software/emacs") -(define *xemacs-url* "http://www.xemacs.org") -(define *texinfo-url* "http://www.texinfo.org") -(define *r5rs-url* "http://www.inria.fr/mimosa/fp/Bigloo/doc/r5rs.html") -(define *bigloo-url* "http://www.inria.fr/mimosa/fp/Bigloo") -(define *skribe-user-doc-url* (string-append (skribe-doc-dir) "/user.html")) -(define *skribe-dir-doc-url* (string-append (skribe-doc-dir) "/dir.html")) - -(define *prgm-width* 97.) -(define *prgm-skribe-color* "#ffffcc") -(define *prgm-default-color* "#ffffcc") -(define *prgm-xml-color* "#ffcccc") -(define *prgm-example-color* "#ccccff") -(define *disp-color* "#ccffcc") -(define *header-color* "#cccccc") - -(define *api-engines* (map find-engine '(html latex xml))) diff --git a/skribe/doc/skr/extension.skr b/skribe/doc/skr/extension.skr deleted file mode 100644 index ce10ce7..0000000 --- a/skribe/doc/skr/extension.skr +++ /dev/null @@ -1,95 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/skr/extension.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Dec 23 07:18:36 2003 */ -;* Last change : Fri Jan 2 21:25:49 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe package for documenting extensions */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* extension */ -;*---------------------------------------------------------------------*/ -(define-markup (extension #!rest opt - #!key (ident (symbol->string (gensym 'extension))) - (class "extension") - title html-title ending author description - (env '())) - (new document - (markup 'extension) - (ident ident) - (class class) - (options (the-options opt)) - (body (the-body opt)) - (env (append env - (list (list 'example-counter 0) (list 'example-env '()) - (list 'chapter-counter 0) (list 'chapter-env '()) - (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()) - (list 'figure-counter 0) (list 'figure-env '())))))) - -;*---------------------------------------------------------------------*/ -;* html engine */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (engine-custom-set! he 'web-book-main-browsing-extra - (lambda (n e) - (let ((i (let ((m (find-markup-ident "Index"))) - (and (pair? m) (car m))))) - (if (not i) - (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 - (tr (td :align 'left :valign 'top (bold "Skribe: ")) - (td :align 'right :valign 'top - (ref :url *skribe-dir-doc-url* - :text "Directory"))) - (tr (td) - (td :align 'right :valign 'top - (ref :url *skribe-user-doc-url* - :text "User Manual")))) - (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 - (tr (td :align 'left :valign 'top (bold "index:")) - (td :align 'right (ref :handle (handle i)))) - (tr (td :align 'left :valign 'top (bold "Skribe: ")) - (td :align 'right :valign 'top - (ref :url *skribe-dir-doc-url* - :text "Directory"))) - (tr (td) - (td :align 'right :valign 'top - (ref :url *skribe-user-doc-url* - :text "User Manual")))))))) - (default-engine-set! he)) - -;*---------------------------------------------------------------------*/ -;* extension-sui ... */ -;*---------------------------------------------------------------------*/ -(define (extension-sui n e) - (define (sui) - (display "(sui \"") - (skribe-eval (markup-option n :title) html-title-engine) - (display "\"\n") - (printf " :file ~s\n" (sui-referenced-file n e)) - (printf " :description ~s\n" (markup-option n :description)) - (sui-marks n e) - (display " )\n")) - (if (string? *skribe-dest*) - (let ((f (format "~a.sui" (prefix *skribe-dest*)))) - (with-output-to-file f sui)) - (sui))) - -;*---------------------------------------------------------------------*/ -;* project ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'extension - :options '(:title :html-title :ending :author :description) - :action (lambda (n e) - (output n e (markup-writer-get 'document he))) - :after (lambda (n e) - (if (engine-custom e 'emit-sui) - (extension-sui n e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skribe/doc/skr/manual.skr b/skribe/doc/skr/manual.skr deleted file mode 100644 index 1982237..0000000 --- a/skribe/doc/skr/manual.skr +++ /dev/null @@ -1,281 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/skr/manual.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 11:24:19 2003 */ -;* Last change : Mon Sep 13 19:18:48 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe manuals and documentation pages style */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Base configuration */ -;*---------------------------------------------------------------------*/ -(let ((be (find-engine 'base))) - (markup-writer 'example be - :options '(:legend :number) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (skribe-eval (mark ident) e) - (skribe-eval (center - (markup-body n) - (if number (bold (format "Ex. ~a: " number))) - legend) - e))))) - -;*---------------------------------------------------------------------*/ -;* html-browsing-extra ... */ -;*---------------------------------------------------------------------*/ -(define (html-browsing-extra n e) - (let ((i1 (let ((m (find-markup-ident "Index"))) - (and (pair? m) (car m)))) - (i2 (let ((m (find-markup-ident "markups-index"))) - (and (pair? m) (car m))))) - (cond - ((not i1) - (skribe-error 'left-margin "Can't find section" "Index")) - ((not i2) - (skribe-error 'left-margin "Can't find chapter" "Standard Markups")) - (else - (table :width 100. - :border 0 - :cellspacing 0 :cellpadding 0 - (tr (td :align 'left :valign 'top (bold "index:")) - (td :align 'right (ref :handle (handle i1) :text "Global"))) - (tr (td :align 'left :valign 'top (bold "markups:")) - (td :align 'right (ref :handle (handle i2) :text "Index"))) - (tr (td :align 'left :valign 'top (bold "extensions:")) - (td :align 'right (ref :url *skribe-dir-doc-url* - :text "Directory")))))))) - -;*---------------------------------------------------------------------*/ -;* Html configuration */ -;*---------------------------------------------------------------------*/ -(let* ((he (find-engine 'html)) - (bd (markup-writer-get 'bold he))) - (markup-writer 'bold he - :class 'api-proto-ident - :before "" - :action (lambda (n e) (output n e bd)) - :after "") - (engine-custom-set! he 'web-book-main-browsing-extra html-browsing-extra) - (engine-custom-set! he 'favicon "lambda.gif")) - -;*---------------------------------------------------------------------*/ -;* LaTeX */ -;*---------------------------------------------------------------------*/ -(let* ((le (find-engine 'latex)) - (opckg (engine-custom le 'usepackage)) - (lpckg "\\usepackage{fullpage}\n\\usepackage{eurosym}\n") - (npckg (if (string? opckg) - (string-append lpckg opckg) - lpckg))) - (engine-custom-set! le 'documentclass "\\documentclass{book}") - (engine-custom-set! le 'usepackage npckg)) - -;*---------------------------------------------------------------------*/ -;* prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (prgm #!rest opts #!key (language skribe) (line #f) (file #f) (definition #f)) - (let* ((c (cond - ((eq? language skribe) *prgm-skribe-color*) - ((eq? language xml) *prgm-xml-color*) - (else *prgm-default-color*))) - (sc (cond - ((and file definition) - (source :language language :file file :definition definition)) - (file - (source :language language :file file)) - (else - (source :language language (the-body opts))))) - (pr (cond - (line - (prog :line line sc)) - (else - (pre sc))))) - (center - (frame :margin 5 :border 0 :width *prgm-width* - (color :margin 5 :width 100. :bg c pr))))) - -;*---------------------------------------------------------------------*/ -;* disp ... */ -;*---------------------------------------------------------------------*/ -(define-markup (disp #!rest opts #!key (verb #f) (line #f) (bg *disp-color*)) - (if (engine-format? "latex") - (if verb - (pre (the-body opts)) - (the-body opts)) - (center - (frame :margin 5 :border 0 :width *prgm-width* - (color :margin 5 :width 100. :bg bg - (if verb - (pre (the-body opts)) - (the-body opts))))))) - -;*---------------------------------------------------------------------*/ -;* keyword ... */ -;*---------------------------------------------------------------------*/ -(define-markup (keyword arg) - (new markup - (markup '&source-key) - (body (cond - ((keyword? arg) - (keyword->string arg)) - ((symbol? arg) - (string-append ":" (symbol->string arg))) - (else - arg))))) - -;*---------------------------------------------------------------------*/ -;* param ... */ -;*---------------------------------------------------------------------*/ -(define-markup (param arg) - (cond - ((keyword? arg) - (keyword arg)) - ((symbol? arg) - (code (symbol->string arg))) - (else - arg))) - -;*---------------------------------------------------------------------*/ -;* example ... */ -;*---------------------------------------------------------------------*/ -(define-markup (example #!rest opts #!key legend class) - (new container - (markup 'example) - (ident (symbol->string (gensym 'example))) - (class class) - (required-options '(:legend :number)) - (options `((:number - ,(new unresolved - (proc (lambda (n e env) - (resolve-counter n env 'example #t))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* example-produce ... */ -;*---------------------------------------------------------------------*/ -(define-markup (example-produce example . produce) - (list (it "Example:") - example - (if (pair? produce) - (list (paragraph "Produces:") (car produce))))) - -;*---------------------------------------------------------------------*/ -;* markup-ref ... */ -;*---------------------------------------------------------------------*/ -(define-markup (markup-ref mk) - (ref :mark mk :text (code mk))) - -;*---------------------------------------------------------------------*/ -;* &the-index ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index - :class 'markup-index - :options '(:column) - :before (lambda (n e) - (output (markup-option n 'header) e)) - :action (lambda (n e) - (define (make-mark-entry n fst) - (let ((l (tr :class 'index-mark-entry - (td :colspan 2 :align 'left - (bold (it (sf n))))))) - (if fst - (list l) - (list (tr (td :colspan 2)) l)))) - (define (make-primary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n))) - (when p - (markup-option-add! b :text - (list (markup-option b :text) - ", p.")) - (markup-option-add! b :page #t)) - (tr :class 'index-primary-entry - (td :colspan 2 :valign 'top :align 'left b)))) - (define (make-column ie p) - (let loop ((ie ie) - (f #t)) - (cond - ((null? ie) - '()) - ((not (pair? (car ie))) - (append (make-mark-entry (car ie) f) - (loop (cdr ie) #f))) - (else - (cons (make-primary-entry (caar ie) p) - (loop (cdr ie) #f)))))) - (define (make-sub-tables ie nc p) - (define (split-list l num) - (let loop ((l l) - (i 0) - (acc '()) - (res '())) - (cond - ((null? l) - (reverse! (cons (reverse! acc) res))) - ((= i num) - (loop l - 0 - '() - (cons (reverse! acc) res))) - (else - (loop (cdr l) - (+ i 1) - (cons (car l) acc) - res))))) - (let* ((l (length ie)) - (w (/ 100. nc)) - (iepc (let ((d (/ l nc))) - (if (integer? d) - (inexact->exact d) - (+ 1 (inexact->exact (truncate d)))))) - (split (split-list ie iepc))) - (tr (map (lambda (ies) - (td :valign 'top :width w - (if (pair? ies) - (table :width 100. (make-column ies p)) - ""))) - split)))) - (let* ((ie (markup-body n)) - (nc (markup-option n :column)) - (pref (eq? (engine-custom e 'index-page-ref) #t)) - (loc (ast-loc n)) - (t (cond - ((null? ie) - "") - ((or (not (integer? nc)) (= nc 1)) - (table :width 100. :&skribe-eval-location loc - (make-column ie pref))) - (else - (table :width 100. :&skribe-eval-location loc - (make-sub-tables ie nc pref)))))) - (output (skribe-eval t e) e)))) - -;*---------------------------------------------------------------------*/ -;* compiler-command ... */ -;*---------------------------------------------------------------------*/ -(define-markup (compiler-command bin . opts) - (disp :verb #t - (color :fg "red" (bold bin)) - (map (lambda (o) - (list " [" (it o) "]")) - opts) - "...")) - -;*---------------------------------------------------------------------*/ -;* compiler-options ... */ -;*---------------------------------------------------------------------*/ -(define-markup (compiler-options bin) - (skribe-message " [executing: ~a --options]\n" bin) - (let ((port (open-input-file (format "| ~a --options" bin)))) - (let ((opts (read port))) - (close-input-port port) - (apply description (map (lambda (opt) (item :key (bold (car opt)) - (cadr opt) ".")) - opts))))) diff --git a/skribe/doc/user/bib.skb b/skribe/doc/user/bib.skb deleted file mode 100644 index a006a9b..0000000 --- a/skribe/doc/user/bib.skb +++ /dev/null @@ -1,252 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/bib.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Dec 2 10:02:56 2001 */ -;* Last change : Tue Oct 26 21:41:19 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe index */ -;*=====================================================================*/ - -(bibliography "user/src/bib1.sbib") - -;*---------------------------------------------------------------------*/ -;* Index */ -;*---------------------------------------------------------------------*/ -(chapter :title "Bibliographies" - - (p [ -Skribe supports bibliographies. In order to use bibliography -,(markup-ref "ref") it is needed to:]) - (itemize - (item [ -Use the default pre-existing ,(emph "bibliography table") or create a -custom one.]) - (item [ -Provide a ,(emph "bibliography database").]) - (item [ -Load the database by the mean of the ,(markup-ref "bibliography") -Skribe function call.]) - (item [ -Reference to a bibliography entry, with a ,(markup-ref "ref") Skribe -function call.])) - -;*---------------------------------------------------------------------*/ -;* Bibliography tables */ -;*---------------------------------------------------------------------*/ -(section :title "Bibliography tables" - - (p [ -This section describes the function of using and creating bibliography -tables.]) - - (p [The predicate ,(code "bib-table?") returns ,(code "#t") if and only -if its argument is a bibliography table as returned by -,(markup-ref "make-bib-table") or ,(markup-ref "default-bib-table"). Otherwise -,(code "bib-table?") returns ,(code "#f").]) - - (doc-markup 'bib-table? - '((obj [The value to be tested])) - :see-also '(make-bib-table default-bib-table bibliography the-bibliography) - :force-engines *api-engines* - :common-args '() - :source "../src/bigloo/bib.bgl") - - (p [The function ,(code "default-bib-table") returns a global, pre-existing -bibliography-table:]) - (doc-markup 'default-bib-table - '() - :see-also '(bib-table? make-bib-table bibliography the-bibliography) - :force-engines *api-engines* - :common-args '() - :source "../src/bigloo/bib.bgl") - - (p [The function ,(code "make-bib-table") constructs a new -bibliography-table:]) - (doc-markup 'make-bib-table - '((ident [The name of the bibliography table.])) - :see-also '(bib-table? default-bib-table bibliography the-bibliography) - :force-engines *api-engines* - :common-args '() - :source "../src/bigloo/bib.bgl")) - -;*---------------------------------------------------------------------*/ -;* bibliography ... @label bibliography@ */ -;*---------------------------------------------------------------------*/ -(section :title "Bibliography" - -(p [The function ,(code "bibliography") loads bibliography ,(param 'entries) -into the Skribe memory. An ,(emph "entry") is either a list -representing one entry (such as an article or book reference) or a -string which denotes a file name that contains several -entries. All the entries loaded in memory are available for the function -,(ref :ident "ref" :node "references"). A bibliography database must be loaded -,(emph "before") any reference is introduced. It is advised to place -the ,(code "bibliography") Skribe function call before the call to the -,(markup-ref "document") function call.]) - -(doc-markup 'bibliography - `((:command ,[An external command to be applied when loading - the bibliography entries. The sequence ,(code "~a") is replaced - with the name of the file when the command is invoked.]) - (:bib-table ,[The ,(ref :mark "make-bib-table" :text "table") - where entry is searched.]) - (#!rest entry... ,[If ,(param 'entry) is a string, it denotes - a file containing the entry (see ,(ref :mark "skribe-bib-path" - :text "bibliograph path")). Otherwise, it is a list described - by the ,(ref :subsection "Bibliography syntax" :text "syntax") - below.])) - :see-also '(bib-table? make-bib-table default-bib-table the-bibliography) - :force-engines *api-engines* - :common-args '()) - -(p [The ,(param :command) option can be used to import foreign bibliography. -The following example, shows how to directly use a Bibtex bibliography -using the ,(ref :section "Skribebibtex") translator.]) - -(example-produce - (example :legend "Printing a bibliography" (prgm :file "src/bib6.skb"))) - - -;; bibliography syntax -(subsection :title "Bibliography syntax" - -(p [The Skribe bibliography database uses a format very close to -the Bibtex one. It is a parenthetic version of Bibtex. Here is the -syntax of an entry:]) - -(disp :verb #t :bg *prgm-skribe-color* [ - --> ,(bold "(") +,(bold ")") - --> techreport | article | inproceedings | book - --> | - --> ,(bold "(") ,(bold ")")]) - -(p [Bibtex files cannot be directly loaded in Skribe but the tool -,(ref :section "Skribebibtex" :text (tt "skribebibtex")) can be use to -automatically convert Bibtex format to Skribe bibliography format. -Here is an example of a simple Skribe database.]) - -(prgm :file "src/bib1.sbib"))) - -;*---------------------------------------------------------------------*/ -;* the-bibliography ... @label the-bibliography@ */ -;*---------------------------------------------------------------------*/ -(section :title "Printing a bibliography" - -(p [The function ,(code "the-bibliography") displays the bibliography. ]) - -(doc-markup 'the-bibliography - `((:bib-table [The bibliography - ,(ref :mark "make-bib-table" :text "table") to be displayed.]) - (:pred [A predicate filtering the bibliography entries. It takes - two parameters: the bibliography entry and the - ,(code "the-bibliography") node.]) - (:sort [A function sorting a list of entries.]) - (:count ,[The symbol ,(code "partial") or ,(code "full") - specifies the numbering to be applied. The value - ,(code "partial") tells Skribe to count only the entries - filtered in by ,(param :pred). The value ,(code "full") - tells Skribe to count all entries, event those filtered out - by ,(param :pred).])) - :see-also '(bib-table? make-bib-table default-bib-table bibliography) - :force-engines *api-engines* - :common-args '()) - -(example-produce - (example :legend "Printing a bibliography" (prgm :file "src/bib2.skb")) - (disp (include "src/bib2.skb"))) - -;; filtering bibliography -(subsection :title "Filtering bibliography entries" -(index "the-bibliography" :note "filtering") - -(p [The ,(param :pred) option is bound to a function of one argument -that filters bibliography entries. It is used to control which entries -must appears on a bibliography. The default behavior is to display -only the entries referenced to in the text. For instance, in order to -display ,(emph "all") the entries of a bibliography, is it needed to -print the bibliography with a predicate returning always ,(code "#t").]) - -(example-produce - (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib3.skb")) - (disp (include "src/bib3.skb"))) - -(p [The second example, filters out the entries that are not ,(emph "book") -or that are not referenced to from the document.]) - -(example-produce - (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib4.skb")) - (disp (include "src/bib4.skb"))) - -(p [The last example, illustrates how to change the rendering of a -bibliography. It uses the ,(markup-ref "processor") construction -and it defines two ,(ref :ident "writer" :text "writers") for -displaying ,(code "&bib-entry-ident") and ,(code "&bib-entry-title") -markups. These two markups are introduced by Skribe when it loads a -bibliography. All fields of bibliography entries are represented by -markups whose prefix are ,(code "&bib-entry-"). The parent of all these -markups is the bibliography entry itself. The ,(code "&bib-entry-") markups -are options of there parent.]) - -(example-produce - (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib5.skb")) - (disp (include "src/bib5.skb")))) - -;; sorting bibliography -(subsection :title "Sorting bibliography entries" -(index "the-bibliography" :note "sorting") - -(p [The ,(param :sort) option of the ,(markup-ref "the-bibliography") -markup is used for sorting the bibliography entries. There are three -pre-existing functions for sorting entries:]) - -(doc-markup 'bib-sort/authors - '((l [The list of entries.])) - :force-engines *api-engines* - :source "../src/common/bib.scm" - :others '(bib-sort/idents bib-sort/dates) - :common-args '()) - -(p [The first function sorts the entries according to an alphabetic ordering -on authors. The second sorts according to an alphabetic ordering on -entries identifier. The last one sorts according to entries date.]) - -(example-produce - (example :legend "Sorting bibliography entries" - (prgm :file "src/common/bib.scm" :definition 'bib-sort/idents))))) - -;*---------------------------------------------------------------------*/ -;* skribebibtex */ -;*---------------------------------------------------------------------*/ -(section :title "Skribebibtex" -(index "skribebibtex" :note "manual page") -(index "bibtex") -(p [ -In this section we present the Skribebibtex translator that compiles Bibtex -source files into a Skribe bibliography.]) - -;; Synopsis -(subsection :title "SYNOPSIS" :number #f - (compiler-command *skribebibtex-bin* "options" "input")) - -;; Description -(subsection :title "DESCRIPTION" :number #f [ -This manual page is not meant to be exhaustive. It -documents the ,(tt "skribebibtex"), a tool that translates -,(bold "Bibtex") files into ,(it "Skribe"), bibliography format. These -files can be used by the ,(bold "skribe") compiler to produce -bibliography entries.]) - -;; Suffixes -(subsection :title "SUFFIXES" :number #f [ -The ,(ref :chapter "Skribe compiler" :text "skribe") compiler uses file -suffixes in order to select amongst its possible targets which to choose. -These suffixes are: - -,(description (item :key (it ".bib") [a ,(bold "Bibtex") source file.]))]) - -;; Options -(subsection :title "OPTIONS" :number #f -(compiler-options *skribebibtex-bin*)))) - diff --git a/skribe/doc/user/char.skb b/skribe/doc/user/char.skb deleted file mode 100644 index 85409f0..0000000 --- a/skribe/doc/user/char.skb +++ /dev/null @@ -1,86 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/char.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Sep 6 16:07:08 2003 */ -;* Last change : Mon Feb 2 11:16:57 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Characters, strings and symbols */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Footnote ... */ -;*---------------------------------------------------------------------*/ -(section :title "Characters, Strings and Symbols" :file #t - -;*--- characters ------------------------------------------------------*/ -(subsection :title "Characters" - -(p [The function ,(code "char") introduces a ,(emph "character") in -the produced document. The purpose of this function is to introduce -escape characters or to introduce characters that cannot be typesetted -in the document (for instance because the editors does not support -them). The escapes characters are ,(code (char 91)), ,(code (char 93)) -and ,(code (char 59)).]) - -(doc-markup 'char - '((char [The character to be introduced. Specified value can be -a character, a string or an integer])) - :common-args '()) - -(example-produce - (example :legend "Some characters" (prgm :file "src/api19.skb")) - (disp (include "src/api19.skb")))) - - -;*--- Strings ---------------------------------------------------------*/ -(subsection :title "Strings" - -(p [the function ,(code "!") introduces raw strings in the target. -That is, the strings introduced by ,(code "!") are written ,(emph "as is"), -without any transformation from the engine.]) - -(doc-markup '! - '((format [The format of the command.]) - (#!rest node... "The arguments.")) - :common-args '()) - -(p [The sequences ,(code "$1"), ,(code "$2"), ... in the ,(param 'format) -are replaced with the actual values of the arguments ,(param 'node).]) - -(example-produce - (example :legend "Some characters" (prgm :file "src/api20.skb")) - (disp (include "src/api20.skb")))) - -;*--- Symbols ---------------------------------------------------------*/ -(subsection :title "Symbols" - -(p [The function ,(code "symbol") introduces special symbols in the -produced file. Note that the rendering of symbols is unportable. It depends -of the capacity of the targeted format.]) - -(doc-markup 'symbol - '((symbol [The symbol to introduce.])) - :common-args '()) - -(p [Here is the list of recognized symbols:]) - -(center - (apply table - :width *prgm-width* - (tr :class 'api-symbol-prototype (th "Symbol name") (th "Rendering")) - (map (lambda (s) - (tr :bg *prgm-skribe-color* - (td :align 'left s) - (td :align 'left (symbol s)))) - (sort (let ((t (make-hashtable))) - (for-each (lambda (e) - (for-each (lambda (s) - (hashtable-put! t (car s) (car s))) - (engine-symbol-table e))) - *api-engines*) - (hashtable->list t)) - stringstring "A procedure of one argument for rendering chapter numbers.") - (chapter-file ,[A boolean specifying if chapters are rendered in speparate html file (see ,(markup-ref "chapter") markup).]) - ;; section configuration - (section-title-start "The HTML sequence for starting section title.") - (section-title-stop "The HTML sequence for stopping section title.") - (section-title-background "The background color of section title.") - (section-title-foreground "The foreground color of section title.") - (section-title-number-separator "The section title number separator.") - (section-number->string "A procedure of one argument for rendering section numbers.") - (section-file ,[A boolean specifying if sections are rendered in speparate html file (see ,(markup-ref "section") markup).]) - ;; subsection configuration - (subsection-title-start "The HTML sequence for starting subsection title.") - (subsection-title-stop "The HTML sequence for stopping subsection title.") - (subsection-title-background "The background color of subsection title.") - (subsection-title-foreground "The foreground color of subsection title.") - (subsection-title-number-separator "The subsection title number separator.") - (subsection-number->string "A procedure of one argument for rendering subsection numbers.") - (subsection-file ,[A boolean specifying if subsections are rendered in speparate html file (see ,(markup-ref "subsection") markup).]) - ;; subsubsection configuration - (subsubsection-title-start "The HTML sequence for starting subsubsection title.") - (subsubsection-title-stop "The HTML sequence for stopping subsubsection title.") - (subsubsection-title-background "The background color of subsubsection title.") - (subsubsection-title-foreground "The foreground color of subsubsection title.") - (subsubsection-title-number-separator "The subsubsection title number separator.") - (subsubsection-number->string "A procedure of one argument for rendering subsubsection numbers.") - (subsubsection-file ,[A boolean specifying if subsubsections are rendered in speparate html file (see ,(markup-ref "subsubsection") markup).]) - ;; source fontification - (source-color ,[A boolean enabling/disabling color of source code (see ,(markup-ref "source") markup).]) - (source-comment-color "The source comment color.") - (source-error-color "The source error color.") - (source-define-color "The source define color.") - (source-module-color "The source module color.") - (source-markup-color "The source markup color.") - (source-thread-color "The source thread color.") - (source-string-color "The source string color.") - (source-bracket-color "The source bracket color.") - (source-type-color "The source type color.") - (image-format "The image formats for this engine.")) - :source "skr/html.skr"))) - - diff --git a/skribe/doc/user/image.skb b/skribe/doc/user/image.skb deleted file mode 100644 index d08ad18..0000000 --- a/skribe/doc/user/image.skb +++ /dev/null @@ -1,79 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/image.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Sat Jan 17 18:08:15 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe images */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(section :title "Image" :file #t - -(p [Images are defined by the means of the ,(code "image") function]) - -(doc-markup 'image - `((:file ,[The file where the image is stored on the disk - (see ,(ref :mark "skribe-image-path" - :text "image path")). - The image is converted - (see ,(markup-ref "convert-image")) into a format - supported by the engine. This option is exclusive - with the ,(param :url) option.]) - (:url [The URL of the file. This option is exclusive with the - ,(param :file) option.]) - (:width [The width of the image. It may be an integer for a pixel - size or a floating point number for a percentage.]) - (:height [The height of the image. It may be an integer for a - pixel size or a floating point number for a - percentage.]) - (:zoom [A zoom factor.]) - (#!rest comment [A text describing the image.])) - :see-also '(skribe-image-path convert-image)) - -(example-produce - (example :legend "The image markup" (prgm :file "src/api16.skb")) - (disp (include "src/api16.skb"))) - -;*--- Image format ----------------------------------------------------*/ -(subsection :title "Image formats" - (index "image" :note "conversion") - - (p [ -Images are unfortunately ,(emph "unportable"). The various Skribe output -formats support different image formats. For instance, HTML supports -,(code "gif") and ,(code "jpeg") while the LaTeX back-end only supports -,(code "ps"). Skribe tries, only when needed, to automatically -,(emph "convert") images to a format supported by the target -to be produced. For this, it uses external tools. The default Skribe -translation scheme is:]) -(itemize (item [Do not translate an image that needs no conversion.]) - (item [Uses the ,(code "fig2dev") external tool to translate - ,(code "Xfig") images.]) - (item [Uses the ,(code "convert") external tools to translate all - other formats.])) - - (p [,(ref :chapter "Engines" :text "Engines") support different image -formats. Each engine may specify a converter to be applied to an image. -The engine custom ,(code "image-format") specifies the list of supported -image formats. This list is composed of a suffix such as ,(code "jpeg") or -,(code "gif").]) - - (p [The function ,(code "convert-image") tries to convert an -image according to a list of formats. All the specified formats are -successively tried. On the first success, the function ,(code "convert-image") -returns the name of the new converted image. On failure, it returns -,(code "#f").]) - (doc-markup 'convert-image - `((file [The image file to be converted. The file is -searched in the ,(ref :mark "skribe-image-path" :text "image path").]) - (formats [A list of formats into which images are converted to.])) - :common-args '() - :source "../src/bigloo/lib.bgl" - :see-also '(skribe-image-path) - :idx *function-index*))) - diff --git a/skribe/doc/user/index.skb b/skribe/doc/user/index.skb deleted file mode 100644 index dd5e8fa..0000000 --- a/skribe/doc/user/index.skb +++ /dev/null @@ -1,118 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/index.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Dec 2 10:02:56 2001 */ -;* Last change : Mon Feb 23 18:59:00 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Index */ -;*---------------------------------------------------------------------*/ -(chapter :title "Indexes" (p [ -Skribe support indexes. One may accumulate all entries inside one -unique index or dispatch them amongst user declared indexes. Indexes -may be ,(emph "monolithic") or ,(emph "split"). They only differ in -the way they are rendered by the back-ends. For a split index a sectioning -based on the specific (e.g., "the first one") character of -index entries is deployed.]) - -;*---------------------------------------------------------------------*/ -;* make-index ... @label make-index@ */ -;*---------------------------------------------------------------------*/ -(section :title "Making indexes" - -(p [The function ,(code "make-index") declares a new index.]) - -(doc-markup 'make-index - '((ident "A string, the name the index (currently unused).")) - :common-args '() - :see-also '(default-index index the-index ref mark)) - -(p [For instance, the following Skribe expression declares an index named -,(tt "*index1*"):]) - -(example-produce - (example :legend "Creation of a new index" (prgm :file "src/index1.skb"))) - -(include "src/index1.skb") - -(p [This example produces no output but enables entries to be added to that -index. In general it is convenient to declare indexes ,(emph "before") -the call to the ,(markup-ref "document") function.]) - -(p [The function ,(code "default-index") returns the default index -that pre-exists to all execution.]) - -(doc-markup 'default-index - '() - :common-args '() - :source "src/common/index.scm")) - -;*---------------------------------------------------------------------*/ -;* Index ... @label index@ */ -;*---------------------------------------------------------------------*/ -(section :title "Adding entries to an index" - -(p [The function ,(code "index") adds a new entry into one existing -index and sets a mark in the text where the index will point to. It is -an error to add an entry into an index that is not already declared.]) - -(doc-markup 'index - '((:index [The name of the index whose index entry belongs to. - A value of ,(tt "#f") means that the - ,(markup-ref :mark "default-index") owns this entry.]) - (:note [An optional note added to the index entry. This note - will be displayed in the index printing.]) - (:shape [An optional shape to be used for rendering the entry.]) - (:url [An optional URL that is referenced in the index table - instead of the location of the ,(code "index").]) - (#!rest name [The name of the entry. This must be a string.])) - :see-also '(make-index default-index the-index)) - -(p [The following expressions add entries to the index ,(code "*index1*"):]) - -(example-produce - (example :legend "Adding entries to an index" (prgm :file "src/index2.skb"))) - -(include "src/index2.skb") - -(p [There is no output associated with these expressions.])) - -;*---------------------------------------------------------------------*/ -;* Print-index ... @label the-index@ */ -;*---------------------------------------------------------------------*/ -(section :title "Printing indexes" - - (p [The function ,(code "the-index") displays indexes in the produced -document.]) - - (doc-markup 'the-index - '((:split [If ,(tt "#t"), character based sectioning is deployed. - Otherwise all the index entries are displayed one next to - the other.]) - (:char-offset [The character number to use when split is - required. This option may be useful when printing index whose - items share a common prefix. The ,(param :char-offset) - argument can be used to skip this prefix.]) - (:header-limit [The number of entries from which an index header - is introduced.]) - (:column [The number of columns of the index.]) - (#!rest index... [The indexes to be displayed. If index - is provided, the global index ,(markup-ref "default-index") - is printed.]))) - - (p [If the engine custom -,(ref :chapter "Engines" :text (code "index-page-ref")) is true when a -index is rendered then, page reference framework is used instead of -a direct reference framework.]) - -(example-produce - (example :legend "Printing indexes" (prgm :file "src/index3.skb")) - (disp (include "src/index3.skb"))) - -(p [See the Skribe ,(ref :mark "global index" :text "global index") for -a real life index example.]))) diff --git a/skribe/doc/user/justify.skb b/skribe/doc/user/justify.skb deleted file mode 100644 index 94db7d5..0000000 --- a/skribe/doc/user/justify.skb +++ /dev/null @@ -1,30 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/justify.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Fri Sep 12 15:31:31 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe justification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Justification */ -;*---------------------------------------------------------------------*/ -(section :title "Justification" :file #t - -(p [These functions control the text layout. The default layout is text -justification.]) - -(doc-markup 'flush - '((:side [The possible values for the side justification - are ,(tt "left"), ,(tt "center") or ,(tt "right").]) - (#!rest node... "The nodes of the font.")) - :others '(center pre) - :see-also '(linebreak table prog)) - -(example-produce - (example :legend "The justification markups" (prgm :file "src/api10.skb")) - (disp (include "src/api10.skb")))) - diff --git a/skribe/doc/user/latexe.skb b/skribe/doc/user/latexe.skb deleted file mode 100644 index f53737b..0000000 --- a/skribe/doc/user/latexe.skb +++ /dev/null @@ -1,60 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/latexe.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 11:20:49 2003 */ -;* Last change : Tue Apr 6 06:28:59 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The documentation of the html engine */ -;*=====================================================================*/ -;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ - -;*---------------------------------------------------------------------*/ -;* Document */ -;*---------------------------------------------------------------------*/ -(section :title "LaTeX engine" :file #t - (mark "latex-engine") - (index "LaTeX" :note "Engine") - (p [The LaTeX engine...]) - - - (subsection :title "The LaTeX customization" - - (doc-engine 'latex - `((documentclass ,[A string declaring The LaTeX document class.]) - (usepackage ,[The boolean ,(code "#f") if no package is used or a string declaring The LaTeX packages.]) - (predocument ,[The boolean ,(code "#f") or a string to be written before the \\begin{document} statement.]) - (postdocument ,[The boolean ,(code "#f") or a string to be written after the \\begin{document} statement.]) - (maketitle ,[The boolean ,(code "#f") or a string to be written after the \\begin{document} statement for emitting the document title.]) - (color [Enable/disable colors.]) - (%font-size #f) - ;; source fontification - (source-color ,[A boolean enabling/disabling color of source code (see ,(markup-ref "source") markup).]) - (source-comment-color "The source comment color.") - (source-error-color "The source error color.") - (source-define-color "The source define color.") - (source-module-color "The source module color.") - (source-markup-color "The source markup color.") - (source-thread-color "The source thread color.") - (source-string-color "The source string color.") - (source-bracket-color "The source bracket color.") - (source-type-color "The source type color.") - (color-usepackage "The LaTeX package for coloring.") - (hyperref "Enables/disables hypererrf.") - (hyperref-usepackage "The LaTeX package for hyperref.") - (image-format "The image formats for this engine.") - (index-page-ref "Indexes use page references.")) - :source "skr/latex.skr")) - - (subsection :title "LaTeX documentclass" - - (p [The default setting of the Skribe LaTeX engine is to produce -a document using the ,(code "article") document class. In order to -generate a document using ,(code "chapter") this must be changed because -this LaTeX style does not define any ,(code "\\chapter") function. For -instance, one may use the LaTeX ,(code "book") document class. Changing -this setting can be done with expressions such as: -,(prgm :language skribe [ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\\\documentclass{book}"))])]))) diff --git a/skribe/doc/user/lib.skb b/skribe/doc/user/lib.skb deleted file mode 100644 index 499ca61..0000000 --- a/skribe/doc/user/lib.skb +++ /dev/null @@ -1,156 +0,0 @@ -;;;; -;;;; Standard Library -;;;; -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Nov-2003 07:20 (eg) -;;;; Last file update: 21-Nov-2003 10:17 (eg) - - -(chapter :title "Standard Library" - - (p [This section describes the Skribe standard library]) - -;;; -(section :title "File functions" - - (p [The function ,(code "include") is particularily useful to spread a -long document amongst several files.]) - - (doc-markup 'include - '((file [The file containing the nodes to be included. -These nodes are included in the document in place of the ,(code "include") -call.])) - :common-args '() - :see-also '(skribe-load skribe-path skribe-path-set!) - :idx *function-index*) - - (p [The given file is searched in the current -,(ref :mark "skribe-path" :text "Skribe path")]) - - (p [The function ,(code "skribe-load") is generally used to load in the -Skribe memory, a package or an extension. In general the prelude of a -Skribe document (the expressions placed before the ,(markup-ref "document") -call) contains several ,(code "skribe-load"). The file is search -in the ,(ref :mark "skribe-path" :text "Skribe path").]) - - (doc-markup 'skribe-load - `((file [The file containing the expressions to be loaded.]) - (:engine [The engine used to evaluate the expressions.]) - (:path ,[The optional path where to find the file. The default - path is ,(markup-ref "skribe-path").]) - (#!rest opt... [Additional user options.])) - :source "../src/bigloo/eval.scm" - :common-args '() - :see-also '(skribe-load-options skribe-path skribe-path-set!) - :idx *function-index*) - - (p [Returns the user of options of the last call to -,(markup-ref "skribe-load")]) - (doc-markup 'skribe-load-options - '() - :source "../src/bigloo/eval.scm" - :common-args '() - :see-also '(skribe-load) - :idx *function-index*) - - (p [Skribe provides functions for dealing with paths. These functions -are related to the path that can be specified on the command line, -when the Skribe compiler is invoked (see Chapter -,(ref :chapter "Skribe compiler").)]) - - (doc-markup 'skribe-path - '() - :source "../src/bigloo/eval.scm" - :common-args '() - :others '(skribe-image-path skribe-bib-path skribe-source-path) - :see-also '(include skribe-load image source bibliography skribe-path-set! skribe-image-path-set! skribe-bib-path-set! skribe-source-path-set!) - :idx *function-index*) - - (p [The function ,(code "skribe-path-set!") sets a new path.]) - (doc-markup 'skribe-path-set! - '((path [A list of strings which is the new Skribe search path.])) - :source "../src/bigloo/eval.scm" - :common-args '() - :others '(skribe-image-path-set! skribe-bib-path-set! skribe-source-path-set!) - :see-also '(skribe-path skribe-image-path skribe-bib-path skribe-source-path) - :idx *function-index*)) - -;;; Misc -(section :title "Misc. Functions" - - (p [The function ,(code "skribe-release") returns the Skribe version -as a string]) - (doc-markup 'skribe-release - '() - :common-args '() - :source #f - :def '(define (skribe-release) ...) - :idx *function-index*) - - (p [For instance, the following piece of code:]) - (prgm :language skribe - "[This manual documents the ,(bold (skribe-release)) Skribe release]") - (p [produces the following output]) - (disp [This manual documents the ,(bold (skribe-release)) Skribe release])) - - (p [The function ,(code "skribe-configure") accesses the whole -Skribe configuration. It can be used to ,(emph "get") or ,(emph "check") -the configuration.]) - - (doc-markup 'skribe-configure - '((opt... [Optional arguments.])) - :common-args '() - :source #f - :def '(define (skribe-configure . opt...) ...) - :idx *function-index*) - - (p [The function ,(code "skribe-configure") can be used in three distinct -ways depending on the number of provided arguments:]) - - (enumerate - (item [If no argument is provided, ,(code "skribe-configure") returns -a fresh list of Skribe configuration.]) - (item [If one keyword argument is provided, ,(code "skribe-configure") -returns the value associated with this keyword in the configuration list. -If this value does not exist, it returns the symbol ,(code "void").]) - (item [(code "skribe-configure") is invoked with a list composed -of ,(emph "keyword") ,(emph "value"). The actual configuration is checked -against the provided values. Values are compared with ,(code "equal") except -if the value to check has to be compared with a procedure. In that particular -case the value of the check is the value produces by ,(emph "applying") the -function to the actual value. The result of ,(code "skribe-configure") is a -boolean.])) - - (p [Here are some examples.]) - (prgm :language skribe [ -;; fetch the whole configuration list -(skribe-configure) - -;; fetch the release number -(skribe-configure :release) - -;; test if the release number is 1.0b -(skribe-configure :release "1.0b") - -;; test if the release number is greater or equal than "1.0b" -(skribe-configure :release (lambda (v) (string>=? v "1.0b"))) - -;; test if the release number is greater or equal than "1.0b" -;; and the implementation is bigloo -(skribe-configure :release (lambda (v) (string>=? v "1.0b")) :scheme "bigloo")]) - - (p [The function ,(code "skribe-enforce-configure") checks for the Skribe -configuration. In case of mismatch, it raises an error. The syntax of the -arguments if the same as that of ,(code "skribe-configure") when invoked -with several arguments.]) - - (doc-markup 'skribe-enforce-configure - '((opt... [Optional arguments.])) - :common-args '() - :source #f - :def '(define (skribe-enforce-configure . opt...) ...) - :idx *function-index*)) - - - diff --git a/skribe/doc/user/line.skb b/skribe/doc/user/line.skb deleted file mode 100644 index 85f84dd..0000000 --- a/skribe/doc/user/line.skb +++ /dev/null @@ -1,39 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/line.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 10:08:08 2003 */ -;* Last change : Thu Sep 4 13:29:49 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Line breaks */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Line breaks */ -;*---------------------------------------------------------------------*/ -(section :title "Line breaks" :file #t - -(p [Line breaks and horizontal rules enable text cutting.]) - -;*--- linebreak -------------------------------------------------------*/ -(subsection :title "Linebreak" - -(p [The Skribe function ,(code "linebreak") is unportable. Even if -most engines handle it for their code production, using ,(code "linebreak") -generally produces expected result. For instance, using ,(code "linebreak") -with an engine producing LaTeX code is bound to fail. In consequence, -as much as possible, one should prefer other ways for splitting a text]) - -(doc-markup 'linebreak - '((#!rest num "The number of line breaks.")) - :see-also '(paragraph table))) - -;*--- Horizontal rule -------------------------------------------------*/ -(subsection :title "Horizontal rule" - -(doc-markup 'hrule - `((:width ,[The ,(ref :mark "width") of the horizontal rule.]) - (:height [The thickness of the rule. A positive integer - value stands for a number of pixels.]))))) - diff --git a/skribe/doc/user/links.skb b/skribe/doc/user/links.skb deleted file mode 100644 index b454f28..0000000 --- a/skribe/doc/user/links.skb +++ /dev/null @@ -1,152 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/links.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 11 06:10:44 2003 */ -;* Last change : Thu Feb 26 20:56:48 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe links */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Links and references */ -;*---------------------------------------------------------------------*/ -(chapter :title "References and Hyperlinks" [ -Skribe supports traditional ,(emph "references") (that is, references to some -part of documents) and ,(emph "hyperlinks") (that is visual marks enriching -texts that enable interactive browsing). Hyperlinks may point to - -,(itemize (item [Inner parts of a document, such as a section or a figure.]) - (item [Other documents, such as Web documents.]) - (item [Other Skribe documents.]) - (item [Specific part of other Skribe documents, such as a chapter - of another Skribe document.])) - -,(paragraph [In order to use hyperlinks, Skribe documents must:]) - -,(itemize (item [,(emph "Refer to") marks. This is the role of the ,(tt "ref") - Skribe function.]) - (item [,(emph "Set") marks. This is the role of the ,(tt "mark") - function. However, most Skribe functions that introduce text - structures (e.g., chapters, sections, figures, ...) - automatically introduce marks as well. So, it is - useless to ,(emph "explicitly") introduce a mark at the - beginning of these constructions in order to refer to them - with an hyperlink.]))] - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(section :title "Mark" - -(p [The ,(code "mark") function sets a mark in the produced document -that can be referenced to with the ,(markup-ref "ref") -function. Unless a ,(param :text) option is specified, no visible text -in associated with the mark in the generated document.]) - -(doc-markup 'mark - '((:text "A text associated with the markup.") - (#!rest mark [A string that will be used in a - ,(markup-ref "ref") function call to point to that mark.]))) - -(p [The Skribe functions - ,(map (lambda (x y) - (list (markup-ref x) y)) - '("chapter" "section" "subsection" "subsubsection") - '(", " ", " ", " " ")) -Skribe automatically set a mark whose value is the title of the section. -The Skribe function ,(markup-ref "figure") -automatically sets a mark whose value is the legend of the figure.])) - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(section :title "Reference" - -(p [Skribe proposes only one single function for all the references. -This same ,(code "ref") function is used for introducing references to -section, to bibliographic entries, to source code line number, etc.]) - -(doc-markup 'ref - `((:text [The text that is the visual part the links for - engines that support hyperlinks.]) - (:url [An URL, that is, a location of another file, - such as an HTML file.]) - (:mark [A string that is the name of a mark. That mark has - been introduced by a ,(markup-ref "mark") markup.]) - (:handle [A Skribe node ,(markup-ref "handle").]) - (:ident [A reference to a node who has been specified - an ,(param :ident) value.]) - (:figure [The name of a ,(markup-ref "figure").]) - (:chapter [The name of a ,(markup-ref "chapter").]) - (:section [The name of a ,(markup-ref "section").]) - (:subsection [The name of a ,(markup-ref "subsection").]) - (:subsubsection [The name of a ,(markup-ref "subsubsection").]) - (:page [A boolean enabling/disabling page reference.]) - (:bib ,[A name or a list of names of - ,(ref :chapter "Bibliographies" :text "bibliographic") entry.]) - (:bib-table ,[The - ,(ref :chapter "Bibliographies" :text "bibliography") where - searching the entry.]) - (:line [A reference to a ,(ref :mark "prog" :text "program") - line number.]) - (:skribe [The name of a - ,(ref :section "Skribe Url Index" :text "Skribe Url Index") - ,(var "file") that contains the reference. The - reference can be a ,(tt "chapter"), ,(tt "section"), - ,(tt "subsection"), ,(tt "subsubsection") or even - a ,(tt "mark") located in the Skribe document - described by the ,(var "file") ,(sc "sui").])) - :force-args '(:url :bib :line :skribe) - :see-also '(index)) - - -(example-produce - (example :legend "Some references" (prgm :file "src/links1.skb")) - (disp (include "src/links1.skb")))) - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(section :title "Electronic mails" - -(p [The ,(code "mailto") function is mainly useful for electronic -output formats that are able to run a mailing agent. The function ,(tt "mailto") -introduces mail annotation in a Skribe document.]) - -(doc-markup 'mailto - '((:text [The text that is the visual part the links.]) - (#!rest email [The electronic address.]))) - -(example-produce - (example :legend "Mail address reference" (prgm :file "src/links2.skb")) - (disp (include "src/links2.skb")))) - -;*---------------------------------------------------------------------*/ -;* Skribe Url Index ... */ -;*---------------------------------------------------------------------*/ -(section :title "Skribe Url Index" [ -,(p [A ,(emph "Skribe Url Index") (henceforth ,(sc "Sui")) describes the -marks that are available in a Skribe document. It is to be used to -make Skribe marks available to other Skribe documents. The syntax -of a ,(sc "Sui") file is:]) - -,(disp :verb #t :bg *prgm-skribe-color* [ - --> (skribe-url-index - :file <file-name> - (marks <sui-ref>*) - (chapters <sui-ref>*) - (section <sui-ref>*) - (subsection <sui-ref>*) - (subsubsection <sui-ref>*)) -<sui-ref> --> (<string> :file <file-name> :mark <string>)]) - -,(p [,(sc "Sui") files can be automatically produced by the Skribe compiler. -For instance, in order to produce the ,(sc "Sui") file of this user -manual, one should write:]) - -,(disp :verb #t [ -$ skribe user.skb -o user.sui])])) - -;; LocalWords: Hyperlinks HTML URL url diff --git a/skribe/doc/user/markup.skb b/skribe/doc/user/markup.skb deleted file mode 100644 index 272bfbe..0000000 --- a/skribe/doc/user/markup.skb +++ /dev/null @@ -1,83 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/markup.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 06:09:18 2003 */ -;* Last change : Wed Feb 4 06:11:45 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe standard markups */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* API */ -;*---------------------------------------------------------------------*/ -(chapter :title "Standard Markups" [ - -This chapter describes the forms composing Skribe texts. In XML/HTML -these forms are called ,(emph "markups"). In LaTeX they are called -,(emph "macros"). In Skribe these forms are called ,(emph -"functions"). In this manual, we will say that we ,(emph "call a -function") when a function is used in a form. The values used in a -function call are named the ,(emph "actual parameters") of the -function or ,(emph "parameters") in short. When calling a function -with parameters we say that we are ,(emph "passing") arguments to the -function. - -,(p [ In this documentation function names are typesetted in bold -face. We call a ,(emph "keyword argument"), an argument whose -identifier starts with the ,(tt ":") character. Arguments whose -identifier does not start with this character are called ,(emph "plain -arguments") or ,(emph "arguments") in short. An ,(emph "optional -argument") is represented by a list, starting with the character ,(q -(char 91)) and ending with the character ,(q (char 93)), whose first -element is a keyword argument and the optional second (,(code "#f") -when not specified) element is the default value used if the optional -argument value is not provided on a function call. Arguments that are -not optional are said ,(emph "mandatory"). If a plain argument is -preceeded with a ,(tt ".") character, this argument may be used to -accumulate several values. There are two ways to pass actual arguments -to a function.]) - -,(itemize (item [for keyword arguments: the value of the parameter -must be preceeded by the name of the argument.]) - (item [for plain arguments: a value is provided.])) - -Example: Let us consider the function ,(tt "section") defined as follows: -,(prgm "(section :title [:number #t] [:toc #t] . body)") - -,(p [ -The argument ,(param :title) is a mandatory keyword argument. -The keyword arguments ,(param :number) and ,(param :toc) are -optional. The plain argument ,(param 'body) is preceeded with a -,(tt ".") character so it may receive several values. All the following -calls are legal ,(tt "section") calls:]) - -,(prgm (source :file "src/api1.skb"))] - -;*---------------------------------------------------------------------*/ -;* Markup index ... */ -;*---------------------------------------------------------------------*/ -(section :title "Markup index" :ident "markups-index" :file #f :number #f :toc #t - (the-index :class 'markup-index - :column (if (engine-format? "latex") 2 4) - :split #f - *markup-index*)) - -;*---------------------------------------------------------------------*/ -;* Markups */ -;*---------------------------------------------------------------------*/ -(include "document.skb") -(include "sectioning.skb") -(include "toc.skb") -(include "ornament.skb") -(include "line.skb") -(include "font.skb") -(include "justify.skb") -(include "enumeration.skb") -(include "colframe.skb") -(include "figure.skb") -(include "image.skb") -(include "table.skb") -(include "footnote.skb") -(include "char.skb")) diff --git a/skribe/doc/user/ornament.skb b/skribe/doc/user/ornament.skb deleted file mode 100644 index e65b9d1..0000000 --- a/skribe/doc/user/ornament.skb +++ /dev/null @@ -1,25 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/ornament.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 14:00:52 2003 */ -;* Last change : Fri Sep 12 15:31:19 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The skribe ornaments */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Ornaments */ -;*---------------------------------------------------------------------*/ -(section :title "Ornaments" :file #t - -(p [Skribe supports the standard text ornaments.]) - -(doc-markup 'bold - '((#!rest node... "The nodes of the ornament.")) - :others '(code emph it kbd roman sc sf sub sup tt underline var)) - -(example-produce - (example :legend "The ornament markups" (prgm :file "src/api8.skb")) - (disp (include "src/api8.skb")))) diff --git a/skribe/doc/user/package.skb b/skribe/doc/user/package.skb deleted file mode 100644 index ad989d0..0000000 --- a/skribe/doc/user/package.skb +++ /dev/null @@ -1,139 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/package.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Feb 21 08:26:44 2004 */ -;* Last change : Fri Jun 3 16:51:30 2005 (serrano) */ -;* Copyright : 2004-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Packages */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Standard packages */ -;*---------------------------------------------------------------------*/ -(chapter :title "Standard Packages" - - (p [ -This chapter describes the standard Skribe packages. Additional -packages can be found from the -,(ref :url (skribe-url) :text "Skribe web page"). -This chapter only describes the packages that are contained in the standard -Skribe distribution.]) - - (p [ -In order to use the facilities described in the following sections, the -Skribe source file must contains expressions such as:]) - -(prgm [(skribe-load ,(it "package.skr") ...)]) - -[where ,(it (tt "package.skr")) is the described package.] - -;*---------------------------------------------------------------------*/ -;* jfp */ -;*---------------------------------------------------------------------*/ -(section :title "Articles" - - (subsection :title (tt "acmproc.skr") :ident "acmproc" - (index :index *package-index* "acmproc.skr" :note "package") - (p [ -This package enables producing LaTeX documents conforming to the -,(emph "ACM proceeding") (ACMPROC) style. It introduces the -markup ,(code "abstract"):]) - (doc-markup 'abstract - `((:class "The node class.") - (:postscript [The URL of the PostScript version of the paper.])) - :common-args '() - :idx-note "acmproc" - :idx-suffix " (acmproc)" - :force-engines *api-engines* - :source "../skr/acmproc.skr")) - - (subsection :title (tt "jfp.skr") :ident "jfp" - (index :index *package-index* "jfp.skr" :note "package") - (p [ -This package enables producing LaTeX documents conforming to the -,(emph "Journal of Functional Programming") (JFP) style. It introduces the -markup ,(code "abstract"):]) - (doc-markup 'abstract - `((:postscript [The URL of the PostScript version of the paper.])) - :common-args '() - :idx-note "jfp" - :idx-suffix " (jfp)" - :force-engines *api-engines* - :source "../skr/jfp.skr")) - - (subsection :title (tt "lncs.skr") :ident "lncs" - (index :index *package-index* "lncs.skr" :note "package") - (p [ -This package enables producing LaTeX documents conforming to the -,(emph "Lecture Notes on Computer Science") (LNCS) style. It introduces the -markup ,(code "abstract"):]) - (doc-markup 'abstract - `((:postscript [The URL of the PostScript version of the paper.])) - :common-args '() - :idx-note "lncs" - :idx-suffix " (lncs)" - :force-engines *api-engines* - :source "../skr/lncs.skr"))) - -;*---------------------------------------------------------------------*/ -;* french */ -;*---------------------------------------------------------------------*/ -(section :title "Languages" - (subsection :title (tt "french.skr") - (index :index *package-index* "french.skr" :note "package") - (p [ -Enables French typesetting and typographical rules.]))) - -;*---------------------------------------------------------------------*/ -;* letter */ -;*---------------------------------------------------------------------*/ -(section :title (tt "letter.skr") - (index :index *package-index* "letter.skr" :note "package") - (p [ -This package is to be used to authoring simple letters. It redefines the -,(markup-ref "document") markup.]) - - (doc-markup 'document - `((:where [The location where the letter is posted.]) - (:date [The date of the letter.]) - (:author [The author of the letter.])) - :idx-note "letter" - :idx-suffix " (letter)" - :force-engines *api-engines* - :source "../skr/letter.skr")) - -;*---------------------------------------------------------------------*/ -;* Web */ -;*---------------------------------------------------------------------*/ -(section :title "Web" - - (subsection :title (tt "web-article.skr") - (index :index *package-index* "web-article.skr" :note "package") - (p [ -A convenient mode for rendering articles (i.e., documents made of -sections) in HTML. The Slide package supports two ,(markup-ref "skribe-load") -user options: -,(param :style) and ,(param :css). The ,(param :style) option can either -be ,(code "'traditional") which forces traditional HTML code -emission or ,(code "'css") which forces HTML code emission using CSS -annotations. The CSS style used is specified in the (code "css") -HTML engine ,(ref :subsection "The HTML customization" :text "custom"). -The ,(param :css) is a shorthand for ,(param :style). For instance:]) -(prgm [(skribe-load "web-article.skr" :css "style.css")]) -[is equivalent to:] -(prgm [(skribe-load "web-article.skr" :style 'css) -(engine-custom-set! (find-engine 'html) :css "style.css")])) - - (subsection :title (tt "web-book.skr") - (index :index *package-index* "web-book.skr" :note "package") - (p [ -A convenient mode for rendering books (i.e., documents made of -chapters and sections) in HTML.])))) - -;*---------------------------------------------------------------------*/ -;* Emacs indentation */ -;*---------------------------------------------------------------------*/ -;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@* - diff --git a/skribe/doc/user/prgm.skb b/skribe/doc/user/prgm.skb deleted file mode 100644 index c894614..0000000 --- a/skribe/doc/user/prgm.skb +++ /dev/null @@ -1,121 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/prgm.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Nov 30 09:21:11 2001 */ -;* Last change : Wed Sep 22 02:11:49 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Computer programs */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* fib ... */ -;*---------------------------------------------------------------------*/ -(define (fib x) ;!fib - (if (< x 2) - 1 - (+ (fib (- x 1)) (fib (- x 2))))) - -;*---------------------------------------------------------------------*/ -;* Computer programs */ -;*---------------------------------------------------------------------*/ -(chapter :title "Computer programs" - -(p [It is common that some parts of a Skribe text represent other -texts. For instance, for a document describing a computer programming -language, it is frequent to include excerpt of programs. These -embedded texts are frequently displayed in a specific font and with no -justification but with a precise ,(emph "indentation"). This indentation is -important because it helps in understanding the text,(begin ";") -it is thus desirable to preserve it in the Skribe text. The -,(markup-ref "pre") text layout already enables such a -text formating. This chapter presents two new Skribe functions: -,(markup-ref "prog") and ,(markup-ref "source") that is specially -designed to represent computer programs in Skribe text.]) - -;*---------------------------------------------------------------------*/ -;* Programs ... @label prog@ */ -;*---------------------------------------------------------------------*/ -(section :title "Program" - -(p [A ,(code "prog") function call preserves the indentation of the -program. It may automatically introduce line numbers.]) - -(doc-markup 'prog - `((:line ,[Enables/disables automatic line numbering. An integer - value enables the line number and specifies the number of - the first line of the program. A value of ,(code "#f") disables - the line numbering.]) - (:linedigit ,[The number of digit for representing line - numbers.]) - (:mark ,[A string or the boolean ,(code "#f"). If this option - is a string, that string is the prefix - of line marks. These marks can be used in the - ,(markup-ref "ref") reference. A mark - identifier is defined by the regular expression: - ,(code [,(char "[")_a-zA-Z,(char "]"),(char "[")_a-zA-Z0-9,(char "]")*]). The prefix and the mark are removed from the output program.])) - :force-engines *api-engines* - :see-also '(source pre ref)) - -(example-produce - (example :legend "A program" (prgm :file "src/prgm1.skb")) - (disp (include "src/prgm1.skb")))) - -;*---------------------------------------------------------------------*/ -;* Source code ... @label source@ */ -;*---------------------------------------------------------------------*/ -(section :title "Source code" - -(p [The ,(code "source") function extracts part of the source code and -enables ,(emph "fontification"). That is, some words of the program -can be rendered using different colors or faces.]) - -;!source-start -(doc-markup 'source - `((:language ,[The ,(markup-ref "language") of the source code.]) - (:file ,[The file containing the actual source code. The file - is searched in the ,(markup-ref "skribe-source-path") path.]) - (:start [A start line number or a start marker.]) - (:stop [A stop line number or a stop marker.]) - (:definition [The identifier of the definition to extract.]) - (:tab [The tabulation width.])) - :common-args '() - :force-engines *api-engines* - :see-also '(prog language ref skribe-source-path)) -;!source-stop - -(example-produce - (example :legend "The source markup" (prgm :file "src/prgm2.skb")) - (disp (include "src/prgm2.skb")))) - -;*---------------------------------------------------------------------*/ -;* Language ... @label language@ */ -;*---------------------------------------------------------------------*/ -(section :title "Language" -(index "source" :note "fontification") -(index "fontification") - -(p [The ,(code "language") function builds a language that can be used -in ,(markup-ref "source") function call.]) - -(doc-markup 'language - `((:name [A string which denotes the name of the language.]) - (:fontifier [A function of one argument (a string), that - colorizes a line source code.]) - (:extractor [A function of three arguments: an input port, - an identifier, a tabulation size. This function ,(emph "scans") - in the input port the definition is looks for.])) - :common-args '() - :force-engines *api-engines* - :see-also '(prog source ref)) - -; **** FIXME: -(cond-expand - (bigloo - (example-produce - (example :legend "An ad-hoc fontification" - (prgm :file "src/prgm3.skb")) - (disp (include "src/prgm3.skb")))) - (else - '())))) diff --git a/skribe/doc/user/sectioning.skb b/skribe/doc/user/sectioning.skb deleted file mode 100644 index 48bbc45..0000000 --- a/skribe/doc/user/sectioning.skb +++ /dev/null @@ -1,117 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/sectioning.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 12:27:03 2003 */ -;* Last change : Tue Apr 6 06:45:28 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Sectioning markups */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* dummy-section-output ... */ -;*---------------------------------------------------------------------*/ -(define dummy-section-output - (lambda (n e) - (let* ((t (markup-option n :title)) - (b (markup-body n))) - (skribe-eval (center (bold t)) e) - (output b e)))) - -;*---------------------------------------------------------------------*/ -;* Sectioning */ -;*---------------------------------------------------------------------*/ -(section :title "Sectioning" :file #t - -;*--- chapter ---------------------------------------------------------*/ -(subsection :title "Chapter" - -(p [The function ,(code "chapter") creates new chapters.]) - -(doc-markup 'chapter - `((:title [The title of the chapter.]) - (:html-title "The title of window of the HTML browser.") - (:number [This argument controls the chapter number. -A value of ,(tt "#t") means that the Skribe compiler computes the chapter -number. A value of ,(tt "#f") means that the chapter has no number.]) - (:toc ,[This argument controls if the chapter must -be referenced in the ,(ref :mark "toc" :text "table of contents").]) - (:file [The argument must be a boolean. A value of -,(tt "#t") tells the Skribe compiler to compile that chapter in a separate -file. A value of ,(tt "#f") tells the Skribe compiler to embed the chapter -in the main target file.]) - (#!rest node... [The nodes of the chapter.])) - :see-also '(document section toc)) - -(example-produce - (example :legend "The chapter markup" (prgm :file "src/api4.skb")) - (disp - (processor :combinator - (lambda (e1 e2) - (let ((e (copy-engine 'document-engine e2))) - (markup-writer 'chapter e - :options '(:title :file :number :toc) - :action dummy-section-output) - e)) - (include "src/api4.skb"))))) - -;*--- section ---------------------------------------------------------*/ -(subsection :title "Sections" - -(p [These functions create new sections.]) - -(doc-markup 'section - `((:title [The title of the chapter.]) - (:number [This argument controls the chapter number. -A value of ,(tt "#t") means that the Skribe compiler computes the chapter -number. A value of ,(tt "#f") means that the chapter has no number.]) - (:toc ,[This argument controls if the chapter must -be referenced in the ,(ref :mark "toc" :text "table of contents").]) - (:file [The argument must be a boolean. A value of -,(tt "#t") tells the Skribe compiler to compile that section in a separate -file. A value of ,(tt "#f") tells the Skribe compiler to embed the chapter -in the main target file.]) - (#!rest node... [The nodes of the section.])) - :others '(subsection subsubsection) - :see-also '(document chapter paragraph toc)) - -(example-produce - (example :legend "The chapter markup" (prgm :file "src/api5.skb")) - (disp - (processor :combinator - (lambda (e1 e2) - (let ((e (copy-engine 'document-engine e2))) - (markup-writer 'chapter e - :options '(:title :file :number :toc) - :action dummy-section-output) - e)) - (include "src/api5.skb"))))) - -;*--- paragraph -------------------------------------------------------*/ -(subsection :title "Paragraph" - -(p [The function ,(code "paragraph") (also aliased ,(code "p")) creates -paragraphs.]) - -(doc-markup 'paragraph - '((#!rest node... "The nodes of the paragraph.")) - :see-also '(document chapter section p)) - -(p [The function ,(code "p") is an alias for ,(code "paragraph").]) -(doc-markup 'p - '((#!rest node... "The nodes of the paragraph.")) - :source "../skr/skribe.skr" - :see-also '(document chapter section paragraph))) - -;*--- blockquote -----------------------------------------------------*/ -(subsection :title "Blockquote" - -(p [The function ,(code "blockquote") can be used for text -quotations. A text quotation is generally renderd as an indented block -of text.]) -(doc-markup 'blockquote - '((#!rest node... "The nodes of the quoted text."))))) - - - diff --git a/skribe/doc/user/skribe-config.skb b/skribe/doc/user/skribe-config.skb deleted file mode 100644 index 956af63..0000000 --- a/skribe/doc/user/skribe-config.skb +++ /dev/null @@ -1,44 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/skribe-config.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 2 21:12:24 2004 */ -;* Last change : Thu Sep 23 17:11:53 2004 (eg) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The skribe-config tool */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The skribe-config tool */ -;*---------------------------------------------------------------------*/ -(chapter :title "Getting Skribe configuration information" -(index "skribe-config") - -(p [ -In this chapter we present ,(code "skribe-config") that gives -information about the current Skribe configuration.]) - -;; Synopsis -(section :title "SYNOPSIS" :number #f -(compiler-command "skribe-config" "options")) - -;; Description -(section :title "DESCRIPTION" :number #f [ -The ,(code "skribe-config") gives information about the Skribe configuration. -This information can be the directories used to install Skribe, the Scheme -implementation used for compiling Skribe, etc.]) - -;; Options -(section :title "OPTIONS" :number #f [ -,(pre (let* ((proc (run-process "../etc/skribe-config" "--help" error: pipe:)) - (port (process-error-port proc))) - (let loop ((line (read-line port)) - (lines '())) - (if (eof-object? line) - (reverse! lines) - (begin - (loop (read-line port) (cons* line "\n" lines)))))))])) - - - diff --git a/skribe/doc/user/skribec.skb b/skribe/doc/user/skribec.skb deleted file mode 100644 index 0f00632..0000000 --- a/skribe/doc/user/skribec.skb +++ /dev/null @@ -1,56 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/skribec.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Nov 30 13:43:50 2001 */ -;* Last change : Thu Feb 26 20:58:26 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe compiler */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The Skribe compiler */ -;*---------------------------------------------------------------------*/ -(chapter :title "Skribe compiler" -(index "skribe" :note "manual page") -(p [ -In this chapter we present the Skribe compiler that compiles Skribe -source text into various output formats.]) - -;; Synopsis -(section :title "SYNOPSIS" :number #f -(linebreak 1) -(compiler-command "skribe" "options" "input")) - -;; Description -(section :title "DESCRIPTION" :number #f -(p [ -This manual page is not meant to be exhaustive. The complete documentation -for the programming language ,(bold "Skribe") can be found at the following -,(ref :url (skribe-url) :text "URL"). This manual page only documents -the ,(tt "skribe") -compiler that compiles ,(bold "Skribe") programs into ,(it "HTML"), -,(it "TeX"), ,(it "Info") or ,(it "Nroff") formats.])) - -;; Suffixes -(section :title "SUFFIXES" :number #f [ -The ,(tt "skribe") compiler uses file suffixes in order to select amongst -its possible targets which one to choose. These suffixes are: - -,(description (item :key (it ".skb") [a ,(bold "Skribe") source file.]) - (item :key (it ".html") [an ,(it "HTML") target file.]) - (item :key (it ".tex") [a ,(it "TeX") target file.]) - (item :key (it ".sui") [a ,(it "Skribe url index") file.]))]) - -;; Options -(section :title "OPTIONS" :number #f [ -,(mark "skribe compiler option") -,(compiler-options *skribe-bin*)]) - -;; Environment variables -(section :title "ENVIRONMENT VARIABLES" :number #f [ -Some shell variables control the Skribe search path: -,(description (item :key (it "SKRIBEPATH") - "Search path for source and style files."))])) - diff --git a/skribe/doc/user/skribeinfo.skb b/skribe/doc/user/skribeinfo.skb deleted file mode 100644 index 502cc73..0000000 --- a/skribe/doc/user/skribeinfo.skb +++ /dev/null @@ -1,50 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/skribeinfo.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Nov 30 13:43:50 2001 */ -;* Last change : Mon Dec 15 13:22:08 2003 (serrano) */ -;* Copyright : 2001-03 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribeinfo compiler */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The Skribeinfo compiler */ -;*---------------------------------------------------------------------*/ -(chapter :title "Compiling Texi documents" -(index "skribeinfo" :note "compiler") -(index "texinfo") - -(p [ -In this chapter we present the Skribeinfo compiler that compiles Texinfo -(texi) source files into Skribe source file.]) - -;; Synopsis -(section :title "SYNOPSIS" :number #f -(compiler-command "skribeinfo" "options" "input")) - -;; Description -(section :title "DESCRIPTION" :number #f [ -This manual page is not meant to be exhaustive. The complete documentation -for the programming language ,(bold "Skribe") can be found at the -following ,(ref :url (skribe-url) :text "url"). This manual page only -document the ,(tt "skribeinfo") -compiler that compiles ,(bold "Texinfo") source files into ,(it "Skribe"), -source files. These Skribe files can be compiled by the ,(bold "skribe") -compiler in order to produce ,(it "HTML"), ,(it "TeX"), ,(it "Info") -or ,(it "Nroff") target files.]) - -;; Suffixes -(section :title "SUFFIXES" :number #f [ -The ,(tt "skribe") compiler uses file suffixes in order to select amongst -its possible targets which to choose. These suffixes are: - -,(description (item :key (it ".texi") [a ,(bold "Texinfo") source file.]) - (item :key (it ".skb") [a ,(bold "Skribe") source file.]) - (item :key (it ".sui") [a ,(it "Skribe url index") file.]))]) - -;; Options -(section :title "OPTIONS" :number #f [ -,(compiler-options *skribeinfo-bin*)])) - diff --git a/skribe/doc/user/slide.skb b/skribe/doc/user/slide.skb deleted file mode 100644 index c1111ee..0000000 --- a/skribe/doc/user/slide.skb +++ /dev/null @@ -1,114 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/slide.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 9 06:37:47 2004 */ -;* Last change : Thu Feb 26 21:00:04 2004 (eg) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Slides */ -;*=====================================================================*/ -(skribe-load "slide.skr") - -;*---------------------------------------------------------------------*/ -;* Computer programs */ -;*---------------------------------------------------------------------*/ -(chapter :title "Slide Package" - - (p [ -This chapter describes the facilities Skribe offers authoring slides. -In order to access the functionalities described in this chapter, it -is require to introduce a ,(code [(skribe-load "slides.skr")]) expression -at the beginning of the document. The Slide package supports two -,(markup-ref "skribe-load") user options: ,(param :advi) and ,(param :prosper). -The first one tells Skribe to generate slides for the Advi presenter. The -second one tells Skribe to generate slides for the LaTeX prosper package.]) - -;*---------------------------------------------------------------------*/ -;* slide ... @label slide@ */ -;*---------------------------------------------------------------------*/ -(section :title "Slide" - - (p [A ,(code "slide") function call creates a slide.]) - - (doc-markup 'slide - `((:title [The title of the slide.]) - (:number [The number of the slide (a boolean or an integer).]) - (:toc [This argument controls if the slide must -be referenced in the ,(mark :mark "toc" "table of contents").]) - (:vspace [The boolean ,(code "#f") or an integer representing -the vertical space size between the title and the body of the slide.]) - (:vfill [A boolean that is used to control whether a LaTeX -,(code "\\vfill") is issued at the end of the slide.]) - (:transition [The boolean ,(code "#f") or a symbol in the -list ,(code "(split blinds box wipe dissolve glitter)").]) - (:bg [The background color of the slide.]) - (:image [The background image of the slide.])) - :source "../skr/slide.skr")) - -;*---------------------------------------------------------------------*/ -;* slide-pause */ -;*---------------------------------------------------------------------*/ -(section :title "Pause" - - (p [A ,(code "slide-pause") function call introduces a pause in the slide -projection.]) - - (doc-markup 'slide-pause - '() - :common-args '() - :source "../skr/slide.skr")) - -;*---------------------------------------------------------------------*/ -;* slide-vspace ... */ -;*---------------------------------------------------------------------*/ -(section :title "Slide Vertical Space" - - (p [The ,(code "slide-vspace") introduces a vertical space in the slide.]) - - (doc-markup 'slide-vspace - '((:unit [The unit of the space.]) - (#!rest val [The size of the vertical space.])) - :common-args '() - :source "../skr/slide.skr")) - -;*---------------------------------------------------------------------*/ -;* slide-embed ... */ -;*---------------------------------------------------------------------*/ -(section :title "Slide Embed Applications" - - (p [Embed an application inside a slide.]) - - (doc-markup 'slide-embed - `((:command [The binary file for running the embedded -application.]) - (:geometry-opt [The name of the geometry option to be sent -to the embedded application.]) - (:geometry [The geometry value to be sent.]) - (:rgeometry [A relative geometry to be sent.]) - (:transient-opt [The name of the transient option to be sent -to the embedded application.]) - (:transient [The transient value to be sent.]) - (:alt [An alternative Skribe expression to be used if the -output format does not support embedded application.])) - :common-args '() - :source "../skr/slide.skr")) - -;*---------------------------------------------------------------------*/ -;* Example */ -;*---------------------------------------------------------------------*/ -(section :title "Example" - (p [Here is a complete example of Skribe slides:]) - - (if (and (engine-format? "html") - (not (equal? (engine-custom html-engine 'html-variant) "html4"))) - ;; Show the example and its result - (example-produce - (example :legend "Example of Skribe slides" - (prgm :file "src/slides.skb")) - (disp (include "src/slides.skb"))) - ;; Show only the example (i.e. don't produce a document in a document) - (example :legend "Example of Skribe slides" - (prgm :file "src/slides.skb"))))) - - diff --git a/skribe/doc/user/src/api1.skb b/skribe/doc/user/src/api1.skb deleted file mode 100644 index 80c4389..0000000 --- a/skribe/doc/user/src/api1.skb +++ /dev/null @@ -1,5 +0,0 @@ -(section :title "A title" "This is the body of the section") -(section :title "A title" "This" " is" " the body of the section") -(section :title "A title" :number 3 "This" " is" " the body of the section") -(section :title "A title" :toc #f :number 3 "This" " is" " the body of the section") -(section :title "A title" :number 3 :toc #f "This" " is" " the body of the section") diff --git a/skribe/doc/user/src/api10.skb b/skribe/doc/user/src/api10.skb deleted file mode 100644 index 207d8a7..0000000 --- a/skribe/doc/user/src/api10.skb +++ /dev/null @@ -1,12 +0,0 @@ -(center [A ,(linebreak) multilines ,(linebreak) text]) -(hrule) -(flush :side 'left [A ,(linebreak) multilines ,(linebreak) text]) -(hrule) -(flush :side 'right [A ,(linebreak) multilines ,(linebreak) text]) -(hrule) -(pre [A text layout that - - preserves - linebreaks and spaces ,(it "(into which it is still legal") -,(it "to use Skribe markups)"). -]) diff --git a/skribe/doc/user/src/api11.skb b/skribe/doc/user/src/api11.skb deleted file mode 100644 index 5014e30..0000000 --- a/skribe/doc/user/src/api11.skb +++ /dev/null @@ -1,22 +0,0 @@ -(itemize (item [A first item.]) - (item [A ,(bold "second") one: - ,(itemize (item "One.") - (item "Two.") - (item "Three."))]) - (item [Lists can be nested. For instance that item contains a - ,(tt "description"): - ,(description (item :key (bold "foo") - [is a usual Lisp dummy identifier.]) - (item :key (bold "bar") - [is another one.]) - (item :key (list (bold "foo") (bold "bar")) - [A description entry may contain more than - one keyword.]))]) - (item [The last ,(tt "itemize") entry contains an ,(tt "enumerate"): - ,(enumerate (item "One.") (item "Two.") (item "Three."))])) - -(itemize :symbol "-" - (item "One.") - (item "Two.") - (item "Three.") - (item "Four.")) diff --git a/skribe/doc/user/src/api12.skb b/skribe/doc/user/src/api12.skb deleted file mode 100644 index b0c68da..0000000 --- a/skribe/doc/user/src/api12.skb +++ /dev/null @@ -1 +0,0 @@ -(center (frame :width 10. :margin 10 (p [This is a frame.]))) diff --git a/skribe/doc/user/src/api13.skb b/skribe/doc/user/src/api13.skb deleted file mode 100644 index a9acb04..0000000 --- a/skribe/doc/user/src/api13.skb +++ /dev/null @@ -1,10 +0,0 @@ -(center - (color :bg "#aaaaaa" - :margin 10 - :width 30. - (center - (color :bg "#eeeeee" :fg "blue" :width 100. :margin 10 [This is an -example of color box that uses a color for the -background ,(emph "and") the ,(color :fg "red" "foreground"). It also specifies -a width, that is, an horizontal space, the text should -span to.])))) diff --git a/skribe/doc/user/src/api14.skb b/skribe/doc/user/src/api14.skb deleted file mode 100644 index a3ede40..0000000 --- a/skribe/doc/user/src/api14.skb +++ /dev/null @@ -1,9 +0,0 @@ -(center - (figure :legend "This is a unnumbered figure" - :ident "fig1" - :number #f - (frame [Skribe is a functional programming language.]))) - -(center - (figure :legend "The great Penguin" - (image :file "linux.gif"))) diff --git a/skribe/doc/user/src/api15.skb b/skribe/doc/user/src/api15.skb deleted file mode 100644 index f8f4958..0000000 --- a/skribe/doc/user/src/api15.skb +++ /dev/null @@ -1,25 +0,0 @@ -(resolve (lambda (n e env) - (let* ((d (ast-document n)) - (ex (container-env-get d 'figure-env))) - (table (map (lambda (e) - (tr (td :align 'left - (markup-option e ':number) - " " - (ref :handle (handle e) - :text (markup-option e :legend)) - " (section " - (let ((c (ast-section e))) - (ref :handle (handle c) - :text (markup-option c :title))) - ")"))) - (sort ex - (lambda (e1 e2) - (let ((n1 (markup-option e1 :number)) - (n2 (markup-option e2 :number))) - (cond - ((not (number? n1)) - #t) - ((not (number? n2)) - #f) - (else - (< n1 n2))))))))))) diff --git a/skribe/doc/user/src/api16.skb b/skribe/doc/user/src/api16.skb deleted file mode 100644 index a9d5705..0000000 --- a/skribe/doc/user/src/api16.skb +++ /dev/null @@ -1,5 +0,0 @@ -(image :file "linux.gif" "A first image") -(image :height 50 :file "linux.gif" "A smaller one") -(image :file "bsd.gif" "A second image") -(image :width 50 :file "bsd.gif") -(image :width 200 :height 40 :file "bsd.gif") diff --git a/skribe/doc/user/src/api17.skb b/skribe/doc/user/src/api17.skb deleted file mode 100644 index 42fa54f..0000000 --- a/skribe/doc/user/src/api17.skb +++ /dev/null @@ -1,9 +0,0 @@ -(center - (table :border 1 :width 50. :frame 'hsides :cellstyle 'collapse - (tr :bg "#cccccc" (th :align 'center :colspan 3 "A table")) - (tr (th "Col 1") (th "Col 2") (th "Col 3")) - (tr (td :align 'center "10") (td "-20") (td "30")) - (tr (td :align 'right :rowspan 2 :valign 'center "12") (td "21")) - (tr (td :align 'center :colspan 2 "1234")) - (tr (td :align 'center :colspan 2 "1234") (td :align 'right "5")) - (tr (td :align 'center :colspan 1 "1") (td :colspan 2 "2345")))) diff --git a/skribe/doc/user/src/api18.skb b/skribe/doc/user/src/api18.skb deleted file mode 100644 index 2112dc4..0000000 --- a/skribe/doc/user/src/api18.skb +++ /dev/null @@ -1,2 +0,0 @@ -[Scheme,(footnote [To be pronounced ,(char "[")Skim,(char "]")]) -is a programming language,(footnote [And a great one!]).] diff --git a/skribe/doc/user/src/api19.skb b/skribe/doc/user/src/api19.skb deleted file mode 100644 index cfc11f6..0000000 --- a/skribe/doc/user/src/api19.skb +++ /dev/null @@ -1,3 +0,0 @@ -(itemize (item [The character ,(code "#\\a"): ,(char #\a).]) - (item [The character ,(code "\"a\""): ,(char "a").]) - (item [The character ,(code "97"): ,(char 97).])) diff --git a/skribe/doc/user/src/api2.skb b/skribe/doc/user/src/api2.skb deleted file mode 100644 index 2c20965..0000000 --- a/skribe/doc/user/src/api2.skb +++ /dev/null @@ -1,5 +0,0 @@ -(document :title "This is a Scribe document" - :author (list (author :name "Foo" :email (mailto "foo@nowhere.org")) - (author :name "Bar" :email (mailto "bar@anywhere.org")) - (author :name "Gee" :email (mailto "gee@nowhere.org"))) - "A body...") diff --git a/skribe/doc/user/src/api20.skb b/skribe/doc/user/src/api20.skb deleted file mode 100644 index 686efcb..0000000 --- a/skribe/doc/user/src/api20.skb +++ /dev/null @@ -1,2 +0,0 @@ -[A simple ,(! "string"). A more annoying one ,(! "<strong>string</strong>"). -A last one with arguments ,(! "<u>$1 $2</u>" (bold 1) (it 2)).] diff --git a/skribe/doc/user/src/api3.skb b/skribe/doc/user/src/api3.skb deleted file mode 100644 index ed46eea..0000000 --- a/skribe/doc/user/src/api3.skb +++ /dev/null @@ -1,8 +0,0 @@ -(author :name "Manuel Serrano" - :affiliation "Inria Sophia-Antipolis" - :url (ref :url "http://www.inria.fr/mimosa/Manuel.Serrano") - :email (mailto "Manuel.Serrano@inria.fr") - :address `("2004 route des Lucioles - BP 93" - "F-06902 Sophia Antipolis, Cedex" - "France") - :phone "phone: (+33) 4 92 38 76 41") diff --git a/skribe/doc/user/src/api4.skb b/skribe/doc/user/src/api4.skb deleted file mode 100644 index cfe13f7..0000000 --- a/skribe/doc/user/src/api4.skb +++ /dev/null @@ -1,2 +0,0 @@ -(chapter :title "This is a simple chapter" :number #f :toc #f [ -Its body is just one sentence.]) diff --git a/skribe/doc/user/src/api5.skb b/skribe/doc/user/src/api5.skb deleted file mode 100644 index 01188c1..0000000 --- a/skribe/doc/user/src/api5.skb +++ /dev/null @@ -1,2 +0,0 @@ -(section :title "This is a simple section" :number #f :toc #f [ -Its body is just one sentence.]) diff --git a/skribe/doc/user/src/api6.skb b/skribe/doc/user/src/api6.skb deleted file mode 100644 index 22a1c77..0000000 --- a/skribe/doc/user/src/api6.skb +++ /dev/null @@ -1 +0,0 @@ -(toc :chapter #t :section #f :subsection #f) diff --git a/skribe/doc/user/src/api7.skb b/skribe/doc/user/src/api7.skb deleted file mode 100644 index c6aec8b..0000000 --- a/skribe/doc/user/src/api7.skb +++ /dev/null @@ -1,3 +0,0 @@ -(resolve (lambda (n e env) - (toc :chapter #t :section #t :subsection #t - (handle (ast-chapter n))))) diff --git a/skribe/doc/user/src/api8.skb b/skribe/doc/user/src/api8.skb deleted file mode 100644 index a4403ff..0000000 --- a/skribe/doc/user/src/api8.skb +++ /dev/null @@ -1,15 +0,0 @@ -(itemize (item (roman "a roman text.")) - (item (bold "a bold text.")) - (item (it "an italic text.")) - (item (emph "an emphasized text.")) - (item (underline "an underline text.")) - (item (kbd "a keyboard description.")) - (item (tt "a typewritter text.")) - (item (code "a text representing computer code.")) - (item (var "a computer program variable description.")) - (item (samp "a sample.")) - (item (sc "a smallcaps text.")) - (item (sf "a sans-serif text.")) - (item (sup "a superscripts text.")) - (item (sub "a subscripts text.")) - (item (underline (bold (it "an underline, bold, italic text."))))) diff --git a/skribe/doc/user/src/api9.skb b/skribe/doc/user/src/api9.skb deleted file mode 100644 index 1f6890e..0000000 --- a/skribe/doc/user/src/api9.skb +++ /dev/null @@ -1,5 +0,0 @@ -(itemize - (item (font :size -2 [A smaller font.])) - (item (font :size 6 [An absolute font size.])) - (item (font :size 4. [A larger font.])) - (item (font :face "Helvetica" [An helvetica example.]))) diff --git a/skribe/doc/user/src/bib1.sbib b/skribe/doc/user/src/bib1.sbib deleted file mode 100644 index 3f1c04f..0000000 --- a/skribe/doc/user/src/bib1.sbib +++ /dev/null @@ -1,39 +0,0 @@ -(book queinnec:lisp - (author "Queinnec, C.") - (title "Lisp In Small Pieces") - (publisher "Cambridge University Press") - (year "1996")) - -(book scheme:ieee - (title "IEEE Standard for the Scheme Programming Language") - (author "IEEE Std 1178-1990") - (publisher "Institute of Electrical and Electronic Engineers, Inc.") - (address "New York, NY") - (year "1991")) - -(misc bigloo - (url "http://www.inria.fr/mimosa/fp/Bigloo")) - -(misc scheme:r4rs - (title "The Revised4 Report on the Algorithmic Language Scheme") - (author "Clinger, W. and Rees, J.") - (month "Nov") - (year "1991") - (url "http://www.cs.indiana.edu/scheme-repository/R4RS/r4rs_toc.html")) - -(article scheme:r5rs - (title "The Revised5 Report on the Algorithmic Language Scheme") - (author "Kelsey, R. and Clinger, W. and Rees, J.") - (journal "Higher-Order and Symbolic Computation") - (volume "11") - (number "1") - (month "Sep") - (year "1998") - (url "http://kaolin.unice.fr/Bigloo/doc/r5rs.html")) - -(book as:sicp - (author "Abelson, H. and Sussman, G.") - (title "Structure and Interpretation of Computer Programs") - (year "1985") - (publisher "MIT Press") - (address "Cambridge, Mass., USA")) diff --git a/skribe/doc/user/src/bib2.skb b/skribe/doc/user/src/bib2.skb deleted file mode 100644 index 25417b5..0000000 --- a/skribe/doc/user/src/bib2.skb +++ /dev/null @@ -1,7 +0,0 @@ -[Scheme ,(ref :bib 'scheme:r5rs) is functional programming language. It exists -several books about this language ,(ref :bib '(as:sicp queinnec:lisp)). - -,(linebreak 2) -,(center (bold [-- Bibliography --])) - -,(center (frame :border 1 :margin 2 :width 90. (the-bibliography)))] diff --git a/skribe/doc/user/src/bib3.skb b/skribe/doc/user/src/bib3.skb deleted file mode 100644 index 9cb838e..0000000 --- a/skribe/doc/user/src/bib3.skb +++ /dev/null @@ -1,3 +0,0 @@ -(center - (frame :border 1 :margin 2 :width 90. - (the-bibliography :pred (lambda (m n) #t)))) diff --git a/skribe/doc/user/src/bib4.skb b/skribe/doc/user/src/bib4.skb deleted file mode 100644 index 81ba5df..0000000 --- a/skribe/doc/user/src/bib4.skb +++ /dev/null @@ -1,5 +0,0 @@ -(center - (frame :border 1 :margin 2 :width 90. - (the-bibliography :pred (lambda (m n) - (and (eq? (markup-option m 'kind) 'book) - (pair? (markup-option m 'used))))))) diff --git a/skribe/doc/user/src/bib5.skb b/skribe/doc/user/src/bib5.skb deleted file mode 100644 index a0ee361..0000000 --- a/skribe/doc/user/src/bib5.skb +++ /dev/null @@ -1,24 +0,0 @@ -(center - (frame :border 1 :margin 2 :width 90. - (processor :engine - (make-engine '_ :filter string-upcase) - :combinator - (lambda (e1 e2) - (let ((e (copy-engine '_ e2))) - (markup-writer '&bib-entry-ident e - :action - (lambda (n e) - (let* ((be (ast-parent n)) - (o (markup-option be 'author)) - (y (markup-option be 'year))) - (output (markup-body o) e1) - (display ":") - (output (markup-body y) e)))) - (markup-writer '&bib-entry-title e - :action - (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - e)) - (the-bibliography :pred - (lambda (m n) - (eq? (markup-option m 'kind) 'book)))))) diff --git a/skribe/doc/user/src/bib6.skb b/skribe/doc/user/src/bib6.skb deleted file mode 100644 index 013ca97..0000000 --- a/skribe/doc/user/src/bib6.skb +++ /dev/null @@ -1 +0,0 @@ -(bibliography :command "gzip -d --to-stdout ~a | skribebibtex" "scheme.bib.gz") diff --git a/skribe/doc/user/src/index1.skb b/skribe/doc/user/src/index1.skb deleted file mode 100644 index 199428c..0000000 --- a/skribe/doc/user/src/index1.skb +++ /dev/null @@ -1 +0,0 @@ -(define *index1* (make-index "a new index")) diff --git a/skribe/doc/user/src/index2.skb b/skribe/doc/user/src/index2.skb deleted file mode 100644 index f49cf33..0000000 --- a/skribe/doc/user/src/index2.skb +++ /dev/null @@ -1,11 +0,0 @@ -[The identifier ,(code "Foo"),(index :index *index1* "Foo") is a usually -used as an example. When two identifiers have to used, frequently the -second choice is ,(code "Bar"),(index :index *index1* "Bar" :shape (it "Bar")). -When three are needed, some use ,(code "Baz") -,(index :index *index1* "Baz" :shape (it "Baz")). - -This illustrates how to use identifier -,(index :index *index1* "Foo" :note "How to use Foo") -,(index :index *index1* "Foo" :note "How not to use Foo") -,(index :index *index1* "Fooz") -...] diff --git a/skribe/doc/user/src/index3.skb b/skribe/doc/user/src/index3.skb deleted file mode 100644 index 3d76a90..0000000 --- a/skribe/doc/user/src/index3.skb +++ /dev/null @@ -1 +0,0 @@ -(the-index *index1*) diff --git a/skribe/doc/user/src/links1.skb b/skribe/doc/user/src/links1.skb deleted file mode 100644 index e0ce61c..0000000 --- a/skribe/doc/user/src/links1.skb +++ /dev/null @@ -1,23 +0,0 @@ -[This hyperlink points to the ,(ref :figure "The great Penguin" :text "figure") -of the chapter ,(ref :chapter "Standard Markups") (or also, the -,(ref :ident "Standard Markups" :text "chapter") about markups). -In the second example of reference, no ,(code ":text") option is specified: -,(ref :figure "The great Penguin"). One may use the ,(param ":ident") -field when specified such as: ,(ref :ident "fig1") or ,(ref :figure "fig1"). - -,(linebreak) -That other one points to a well known -,(ref :url "http://slashdot.org/" :text "url"). The same without -,(code ":text"): ,(ref :url "http://slashdot.org/"). - -,(linebreak) -With more complex tricks that are explained in Section -,(ref :section "Resolve"), it is also possible use, for the text of the -reference, a container number such as chapter: -,(resolve (lambda (n e env) - (let ((s (find1-down (lambda (x) - (and (is-markup? x 'chapter) - (string=? (markup-option x :title) - "Standard Markups"))) - (ast-document n)))) - (ref :handle (handle s) :text (markup-option s :number))))).] diff --git a/skribe/doc/user/src/links2.skb b/skribe/doc/user/src/links2.skb deleted file mode 100644 index 7cdee07..0000000 --- a/skribe/doc/user/src/links2.skb +++ /dev/null @@ -1,4 +0,0 @@ -[It is possible to send a mail by -,(mailto "foo@nowhere.com" :text "clicking") that link. That same -reference without ,(code ":text") options: ,(mailto "foo@nowhere.com"). -] diff --git a/skribe/doc/user/src/prgm1.skb b/skribe/doc/user/src/prgm1.skb deleted file mode 100644 index dcdeb88..0000000 --- a/skribe/doc/user/src/prgm1.skb +++ /dev/null @@ -1,15 +0,0 @@ -(frame :width 100. - (prog :line 10 :mark "##" [ -SKRIBE=skribe - -all: demo.html demo.man ##main-goal - -demo.html: demo.skb - $(SKRIBE) demo.skb -o demo.html - -demo.man: demo.skb - $(SKRIBE) demo.skb -o demo.man -])) - -(p [The main goal is specified line ,(ref :line "main-goal").]) - diff --git a/skribe/doc/user/src/prgm2.skb b/skribe/doc/user/src/prgm2.skb deleted file mode 100644 index 5b5644b..0000000 --- a/skribe/doc/user/src/prgm2.skb +++ /dev/null @@ -1,18 +0,0 @@ -(frame :width 100. - (prog (source :language bigloo :file "prgm.skb" :definition 'fib))) - -(p [The Fibonacci function is defined line ,(ref :line "fib").]) - -;!start -(frame :width 100. - (prog :line 11 :mark #f - (source :language skribe :file "prgm.skb" :start 11 :stop 24))) -;!stop - -(p [Here is the source of the frame above:]) - -(frame :width 100. - (prog :line 30 :mark #f - (source :language skribe :file "src/prgm2.skb" - :start ";!start" - :stop ";!stop"))) diff --git a/skribe/doc/user/src/prgm3.skb b/skribe/doc/user/src/prgm3.skb deleted file mode 100644 index 51cb564..0000000 --- a/skribe/doc/user/src/prgm3.skb +++ /dev/null @@ -1,55 +0,0 @@ -(define (makefile-fontifier string) - (with-input-from-string string - (lambda () - (read/rp (regular-grammar () - ((: #\# (+ all)) - ;; makefile comment - (let ((cmt (the-string))) - (cons (it cmt) (ignore)))) - ((bol (: (+ (out " \t\n:")) #\:)) - ;; target - (let ((prompt (the-string))) - (cons (bold prompt) (ignore)))) - ((bol (: (+ alpha) #\=)) - ;; variable definitions - (let* ((len (- (the-length) 1)) - (var (the-substring 0 len))) - (cons (list (color :fg "#bb0000" (bold var)) "=") - (ignore)))) - ((+ (out " \t\n:=$")) - ;; plain strings - (let ((str (the-string))) - (cons str (ignore)))) - ((: #\$ #\( (+ (out " )\n")) #\)) - ;; variable references - (let ((str (the-string)) - (var (the-substring 2 (- (the-length) 1)))) - (cons (underline str) (ignore)))) - ((+ (in " \t\n:")) - ;; separators - (let ((nl (the-string))) - (cons nl (ignore)))) - (else - ;; default - (let ((c (the-failure))) - (if (eof-object? c) - '() - (skribe-error 'makefile "Unexpected char" c))))) - (current-input-port))))) - -(define makefile - (language :name "Makefile" - :fontifier makefile-fontifier)) - -(frame :width 100. - (prog (source :language makefile [ -SKRIBE=skribe - -all: demo.html demo.man - -demo.html: demo.skb - $(SKRIBE) demo.skb -o demo.html - -demo.man: demo.skb - $(SKRIBE) demo.skb -o demo.man -]))) diff --git a/skribe/doc/user/src/slides.skb b/skribe/doc/user/src/slides.skb deleted file mode 100644 index ac584d1..0000000 --- a/skribe/doc/user/src/slides.skb +++ /dev/null @@ -1,27 +0,0 @@ -(skribe-load "slide.skr" :advi #t) - -(document :title (color :fg "red" (sf (font :size +2. "Skribe Slides"))) - :author (author :name (it "Manuel Serrano") - :affiliation [Inria Sophia Antipolis] - :address (ref :url "http://www.inria.fr/mimosa/Manuel.Serrano")) - - (if (engine-format? "html") - (slide :title "Table of contents" :number #f :toc #f - (toc :chapter #f :section #f :subsection #f :subsubsection #f - :slide #t))) - - (slide :title "X11 client" :toc #t :vspace 0.3 - - (itemize - (item "xlock") - (item "xeyes") - (item "xterm"))) - - (slide :title "Xclock" :toc #t :vspace 0.3 - - (center (sf (underline "The Unix xclock client"))) - (slide-vspace 0.3) - - (slide-pause) - (slide-embed :command "xlock" - :alt (frame "Can't run embedded application")))) diff --git a/skribe/doc/user/src/start1.skb b/skribe/doc/user/src/start1.skb deleted file mode 100644 index 4e37dda..0000000 --- a/skribe/doc/user/src/start1.skb +++ /dev/null @@ -1,2 +0,0 @@ -(document :title [Hello World!] [ -This is a very simple text.]) diff --git a/skribe/doc/user/src/start2.skb b/skribe/doc/user/src/start2.skb deleted file mode 100644 index 9fcfdbf..0000000 --- a/skribe/doc/user/src/start2.skb +++ /dev/null @@ -1,2 +0,0 @@ -(document :title [Hello World!] [ -This is a ,(bold [very]) ,(it [simple]) ,(color :fg [red] [text]).]) diff --git a/skribe/doc/user/src/start3.skb b/skribe/doc/user/src/start3.skb deleted file mode 100644 index 0705966..0000000 --- a/skribe/doc/user/src/start3.skb +++ /dev/null @@ -1,10 +0,0 @@ -(document :title [Hello World!] - -(section :title [A first Section] [ - This is a ,(bold [very]) ,(it [simple]) ,(color :fg [red] [text]).]) - -(section :title [A second Section] [ - That section contains an ,(bold itemize) construction: - ,(itemize (item [first item]) - (item [second item]) - (item [third item]))])) diff --git a/skribe/doc/user/src/start4.skb b/skribe/doc/user/src/start4.skb deleted file mode 100644 index 3311925..0000000 --- a/skribe/doc/user/src/start4.skb +++ /dev/null @@ -1,13 +0,0 @@ -(document :title [Various links] [ - -(section :title "A Section" [ -The first link points to an external web page. Here we point to a -,(ref :url [http://slashdot.org/] [Slashdot]) -web page. The second one points to the second -,(ref :section [A second Section] [Section]) -of that document.]) - -(section :title [A second Section] [ -The last links points to the first -,(ref :scribe [user.scr] :figure [A simple web page] [Figure]) -of the Scribe User Manual.])]) diff --git a/skribe/doc/user/src/start5.skb b/skribe/doc/user/src/start5.skb deleted file mode 100644 index 9e6b877..0000000 --- a/skribe/doc/user/src/start5.skb +++ /dev/null @@ -1,9 +0,0 @@ -(resolve (lambda (n e env) - (let* ((current-chapter (ast-chapter n)) - (body (markup-body current-chapter)) - (sects (filter (lambda (x) (is-markup? x 'section)) - body))) - (itemize - (map (lambda (x) - (item (it (markup-option x :title)))) - sects))))) \ No newline at end of file diff --git a/skribe/doc/user/start.skb b/skribe/doc/user/start.skb deleted file mode 100644 index f3c1e28..0000000 --- a/skribe/doc/user/start.skb +++ /dev/null @@ -1,197 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/start.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 11:22:25 2003 */ -;* Last change : Sun Feb 29 16:14:21 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Getting started with Skribe */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Getting started */ -;*---------------------------------------------------------------------*/ -(chapter :title "Getting Started" - -(p [ -In this chapter, the syntax of a Skribe text is presented ,(emph "informally"). -In particular, the Skribe syntax is compared to the HTML syntax. Then, -it is presented how one can use Skribe to make dynamic text -(i.e texts which are generated by the system rather than entered-in by hand. -Finally, It is also -presented how Skribe source files can be processed.]) - -;*--- Hello world -----------------------------------------------------*/ -(section :title "Hello World!" [ -In this section we show how to produce very simple electronic documents -with Skribe. Suppose that we want to produce the following Web document: - -,(disp [,(font :size 2. (bold "Hello World!")) -,(linebreak 2) -This is a very simple text.]) - -The HTML source file for such a page should look like: - -,(prgm :language xml [ -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> -<HTML> -<HEAD> -<TITLE>Hello world Example - - -

Hello World!

- -This is a very simple text. - -]) - -In Skribe, the very same document must be written: - -,(prgm :language skribe :file "src/start1.skb")]) - -;*--- Adding colors and fonts -----------------------------------------*/ -(section :title "Adding colors and fonts" [ -Let us suppose that we want now to colorize and change the face of some -words such as: - -,(disp [,(font :size 2. (bold "Hello World!")) -,(linebreak 2) -This is a ,(bold "very") ,(it "simple") ,(color :fg "red" "text").]) - -The HTML source file for such a document should look like: - -,(prgm :language xml [ - - - -Hello world Example - - -

Hello World!

- -This is a very simple text. - -]) - -In Skribe, the very same document must be written: - -,(prgm :language skribe (source :file "src/start2.skb")) - -As one may notice the Skribe version is much more compact than the HTML one.]) - -;*--- Structured documents --------------------------------------------*/ -(section :title "Structured documents" [ -,(p [For large documents there is an obvious need of structure. Skribe -documents may contain ,(bold "chapters"), ,(bold "sections"), -,(bold "subsections"), ,(bold "itemize"), ... For instance, if we want to -extend our previous example to:]) - -,(disp :verb #t [,(bold (font :size 2. "Hello World!")) - -,(font :size 1. (bold "1. A first Section")) -This is a ,(bold "very") ,(it "simple") ,(color :fg "red" "text"). - -,(font :size 1. (bold "2. A second Section")) -That contains an ,(bold "itemize") construction: - . first item - . second item - . third item]) - -The Skribe source for that text is: - -,(prgm :language skribe (source :file "src/start3.skb"))]) - -;*--- Hyperlinks ------------------------------------------------------*/ -(section :title "Hyperlinks" [ -A Skribe document may contain links to chapters, to sections, to other -Skribe documents or Web pages. The following Skribe source -code illustrates these various kinds of links: - -,(prgm :language skribe (source :file "src/start4.skb"))]) - -;*--- Dynamic documents -----------------------------------------------*/ -(section :title "Dynamic documents" [ -Since Skribe is a programming language, rather than just a markup language, -it is easy to use it to generate some parts of a document. This section -presents here the kind of documents that can be created with Skribe. - -,(subsection :title "Simple computations" [ -In this section we present how to introduce a simple computation into a -document. For instance, the following sentence -,(disp [ -Document creation date: ,(date)]) -is generated with the following piece of code - -,(prgm :language skribe [ -\[Document creation date: \,(date)\] -]) - -Here, we use the Skribe function ,(code "date") to compute the date to -be inserted in the document. In general, any valid Scheme expression -is authorized inside a ,(code ",(...)") construct.,(footnote -[Skribe can be built either with Bigloo or STklos Scheme systems. The Scheme -expressions which are valid inside a ,(code ",(...)") depends of the Scheme system -used at Skribe construction.]). -Another example of -such a computation is given below. -,(prgm :language skribe [ -\[The value of \,(symbol "pi") is \,(* 4 (atan 1))\] -]) -When evaluated, this form produces the following output: -,(disp [ -The value of ,(symbol "pi") is ,(* 4 (atan 1)).]) -]) - -,(subsection :title "Text generation" [ When building a document, one -often need to generate some repetitive text. Skribe programming skills -can be used to ease the construction of such documents as illustrated below. -,(disp -(itemize - (map (lambda (x) (item [The square of ,(bold x) is ,(bold (* x x))])) - '(1 2 3 4 5 6 7 8 9)))) -This text has been generated with the following piece of code -,(prgm :language skribe [ -(itemize - (map (lambda (x) (item \[The square of \,(bold x) is \,(bold (* x x))\])) - '(1 2 3 4 5 6 7 8 9))) -])]) - -,(subsection :title "Introspection" [ -In Skribe, a document is represented by a tree which is available to -the user. So, it is easy to perform introspective tasks on the current -document. For instance the following code displays as an -enumeration the sections titles of the current chapter: - -,(prgm :language skribe :file "src/start5.skb") - -Without entering too much into the details here, the resolve function -is called at the end of the document processing. This function -searches the node representing the chapter to which belongs the -current node and from it finds all its sections. The titles -of these sections are put in italics in an itemize. - -,(p [The execution of this code yield the following text]) - -,(disp (include "src/start5.skb"))]) -]) - - -;*--- Compiling skribe documents --------------------------------------*/ -(section :title "Compiling Skribe documents" [ - -There are several ways to render a Skribe document. It can be statically -compiled by the ,(tt "skribe") compiler to various formats such as HTML, -LaTeX, man and so on. It can be compiled on-demand by the ,(tt "mod_skribe") -,(ref :url "http://www.apache.org/" :text "Apache") Skribe module. In this -section we only present static compilation. - -,(p [Let us suppose a Skribe text located in a file ,(tt "file.skb"). -In order to compile to various formats one must type in:]) - -,(disp :verb #t [ -$ skribe file.skb -o file.html ,(char 35) ,(it "This produces an HTML file.") -$ skribe file.skb -o file.tex ,(char 35) ,(it "This produces a TeX file.") -$ skribe file.skb -o file.man ,(char 35) ,(it "This produces a man page.") -$ skribe file.skb -o file.info ,(char 35) ,(it "This produces an info page.") -$ skribe file.skb -o file.mgp ,(char 35) ,(it "This produces a MagicPoint document")])])) diff --git a/skribe/doc/user/syntax.skb b/skribe/doc/user/syntax.skb deleted file mode 100644 index de60bd9..0000000 --- a/skribe/doc/user/syntax.skb +++ /dev/null @@ -1,105 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/syntax.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Nov 30 11:55:24 2001 */ -;* Last change : Sun Feb 29 16:14:53 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The syntax of Skribe */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The Skribe syntax */ -;*---------------------------------------------------------------------*/ -(chapter :title "Syntax & Values" [ -A Skribe document is composed of Skribe expressions. A Skribe expression -can be: - -,(itemize (item [An atomic expression, such as a string of characters, a number.]) - (item [A list.]) - (item [A text.])) - -Here are several examples of correct Skribe expressions: - -,(center (frame :margin 5 :border 0 :width *prgm-width* - (color :margin 5 :bg *disp-color* :width 100. -(itemize (item [,(color :fg "#009900" (tt "\"foo\"")), a string of characters composed of the -characters `,(color :fg "#009900" "f")', `,(color :fg "#009900" "o")' -and `,(color :fg "#009900" "o")'.]) - (item [,(color :fg "#009900" (tt "123") " " (tt "3.14")), two numbers.]) - (item [,(color :fg "#009900" (tt "#t") " " (tt "#f")), the ,(emph "true") and ,(emph "false") -Skribe value.]) - (item [,(color :fg "#009900" (tt "(bold \"foo bar\")")), a list.]) - (item [,(color :fg "#009900" (tt (char 91)"A text sample"(char 93))), a simple text containing -three words and no escape sequence.]) - (item [,(color :fg "#009900" (tt (char 91)"Another text sample (that is still) simple"(char 93))), -another simple text.]) - (item [,(color :fg "#009900" (tt (char 91)"Another ,(bold \"text\") sample"(char 93))), -a more complex text that contains two words (,(color :fg "#009900" (tt "Another")) and ,(color :fg "#009900" (tt "sample"))) -and an expression ,(color :fg "#009900" (tt "(bold \"text\")")). The escape sequence is introduced -with the `,(color :fg "#009900" (tt ",("))' characters.]))))) - -,(p [ -Expressions are evaluated, thus ,(color :fg "#009900" (tt "(bold \"foo\")")) -has the effect of typesetting the word ,(color :fg "#009900" (tt "foo")) in -bold face to produce ,(color :fg "#009999" (bold "foo")). Escape sequences -enable evaluation of expressions inside the text. Thus the text -,(color :fg "#009900" (tt (char 91)"Another ,(bold \"text\") sample"(char 93))) -produces `,(color :fg "#009999" (tt [Another ,(bold "text") sample]))'. -On the other hand -,(color :fg "#009900" (tt (char 91)"Another (bold \"text\") sample"(char 93))) -produces -`,(color :fg "#009999" (tt [Another (bold "text") sample]))' because it does not contain -the escape sequence `,(color :fg "#009900" (char #\,)(char #\())'.]) -] - -;*---------------------------------------------------------------------*/ -;* Formal syntax */ -;*---------------------------------------------------------------------*/ -(section :title "Skribe syntax" - -(disp :verb #t :bg *prgm-skribe-color* [ - --> - | - | - --> (+) - --> ,(bold (color :fg "red" (char 91))),(it "any sequence but `,(' or a `,"),(it "'"),(bold (color :fg "red" (char 93))) - --> - | - | - | - | - --> ,(tt (char 91))0-9,(tt (char 93))+ - --> ,(tt (char 91))0-9,(tt (char 93))+.,(tt (char 91))0-9,(tt (char 93))* - | ,(tt (char 91))0-9,(tt (char 93))*.,(tt (char 91))0-9,(tt (char 93))+ - --> ,(tt #\")...,(tt #\") - --> - | ,(tt #\")#,(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt #\")])) - -;*---------------------------------------------------------------------*/ -;* Values */ -;*---------------------------------------------------------------------*/ -(section :title "Values" :file #f :toc #t - -;*--- width -----------------------------------------------------------*/ -(subsection :title "Width" (p [ -,(mark "width") -A Skribe ,(emph "width") refers to the horizontal size a construction -occupies on an output document. There are three different ways for -specifying a width:]) - -(description (item :key "An absolute pixel size" - [This is represented by an ,(emph "exact") integer value - (such as ,(code "350")).]) - (item :key "A relative size" - [This is represented by an ,(emph "inexact") integer value - (such as ,(code "50.0")) which ranges in the interval - ,(char 91)-100.0 .. 100.0,(char 93)]) - (item :key "An engine dependent representation" - [This is represented by a string that is directly emitted - in the output document (such as HTML column ,(code "\"0*\"") - specification). Note that this way of specifying width - is strictly unportable.]))))) - - diff --git a/skribe/doc/user/table.skb b/skribe/doc/user/table.skb deleted file mode 100644 index c726d44..0000000 --- a/skribe/doc/user/table.skb +++ /dev/null @@ -1,81 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/table.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Sep 5 13:45:18 2003 */ -;* Last change : Wed Oct 27 12:09:01 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe tables */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Table ... */ -;*---------------------------------------------------------------------*/ -(section :title "Table" :file #t - - (p [Tables are defined by the means of the ,(code "table") function.]) - - (doc-markup 'table - `((:border [The table border thickness.]) - (:width ,[The ,(ref :mark "width") of the table.]) - (:frame ,[Which parts of frame to render. Must be one of - ,(code "none"), ,(code "above"), ,(code "below"), - ,(code "hsides"), ,(code "vsides"), ,(code "lhs"), - ,(code "rhs"), ,(code "box"), ,(code "border").]) - (:rules ,[Rulings between rows and cols, Must be one of - ,(code [none]), ,(code "rows"), ,(code "cols"), ,(code "header"), - ,(code "all").]) - (:cellstyle ,[The style of cells border. Must be either - ,(code "collapse"), ,(code "separate"), or a length representing - the horizontal and vertical space separating the cells.]) - (:cellpadding [A number of pixels around each cell.]) - (:cellspacing [An optional number of pixels used to separate each - cell of the table. A negative uses the target default.]) - (#!rest row... [The rows of the table. Each row must be - constructed by the ,(ref :mark "tr" :text (code "tr")) function.]))) - - (p [,(bold (emph (color :fg "red" "Note:"))) Tables rendering may be only -partially supported by graphical agents. For instance, the ,(code "cellstyle") -attribute is only supported by HTML engines supporting -,(ref :url "http://www.w3.org/TR/REC-CSS2/" :text "CSS2").]) - - -;*--- table rows ------------------------------------------------------*/ -(subsection :title "Table row" - -(p [Table rows are defined by the ,(code "tr") function.]) - -(doc-markup 'tr - '((:bg [The background color of the row.]) - (#!rest cell... [The row cells.])))) - -;*--- Table cell ------------------------------------------------------*/ -(subsection :title "Table cell" - -(p [Two functions define table cells: ,(code "th") for header cells and -,(code "td") for plain cells.]) - -(doc-markup 'th - '((:bg [The background color of the cell.]) - (:width ,[The ,(ref :mark "width") of the table.]) - (:align [The horizontal alignment of the table cell - (,(tt "left"), ,(tt "right"), or ,(tt "center"). Some - engines, such as the HTML engine, also supports a - character for the alignment.)]) - (:valign [The vertical alignment of the cell. The value can - be ,(code "top"), ,(code "center"), ,(code "bottom").]) - (:colspan [The number of columns that the cell expands to.]) - (#!rest node [The value of the cell.])) - :writer-id 'tc - :ignore-args '(m) - :others '(td))) - -;*--- Example ---------------------------------------------------------*/ -(subsection :title "Example" - -(example-produce - (example :legend "A table" (prgm :file "src/api17.skb")) - (disp (include "src/api17.skb"))))) - -;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@* diff --git a/skribe/doc/user/toc.skb b/skribe/doc/user/toc.skb deleted file mode 100644 index aa6c0dc..0000000 --- a/skribe/doc/user/toc.skb +++ /dev/null @@ -1,37 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/toc.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 13:01:03 2003 */ -;* Last change : Fri Sep 12 15:31:14 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Table of contents */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Sectioning */ -;*---------------------------------------------------------------------*/ -(section :title "Table of contents" :file #t - -(p [The production of table of contains.]) - -(doc-markup 'toc - '((:chapter [A boolean. The value ,(code "#t") forces the - inclusion of chapters in the table of contents.]) - (:section [A boolean controlling sections.]) - (:subsection [A boolean controlling subsections.]) - (#!rest handle [An optional handle pointing to the node from - which the table of contents if computed.])) - :see-also '(document chapter section resolve handle)) - -(example-produce - (example :legend "The toc markup" (prgm :file "src/api6.skb")) - (disp (include "src/api6.skb"))) - -(p [The second example only displays the table of contents of the current -chapter.]) - -(example-produce - (example :legend "A restricted table of contents" (prgm :file "src/api7.skb")) - (disp (include "src/api7.skb")))) diff --git a/skribe/doc/user/user.skb b/skribe/doc/user/user.skb deleted file mode 100644 index 07a6e03..0000000 --- a/skribe/doc/user/user.skb +++ /dev/null @@ -1,163 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/user.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Nov 28 10:37:39 2001 */ -;* Last change : Thu Feb 26 21:02:00 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe user manual */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The Skribe documentation style */ -;*---------------------------------------------------------------------*/ -(skribe-load "web-book.skr") -(skribe-load "skr/env.skr") -(skribe-load "skr/manual.skr") -(skribe-load "skr/api.skr") - -;*---------------------------------------------------------------------*/ -;* HTML custom */ -;*---------------------------------------------------------------------*/ -;; since we load slides (for documenting it), we have to use a -;; correct title width -(let ((he (find-engine 'html))) - (engine-custom-set! he 'body-width 100.)) - -;*---------------------------------------------------------------------*/ -;* The various indexes */ -;*---------------------------------------------------------------------*/ -(define *markup-index* (make-index "markup")) -(define *custom-index* (make-index "custom")) -(define *function-index* (make-index "function")) -(define *package-index* (make-index "package")) - -;*---------------------------------------------------------------------*/ -;* The document */ -;*---------------------------------------------------------------------*/ -(document :title "Skribe User Manual" - :env '((example-counter 0) (example-env ())) - :author (list (author :name "Erick Gallesio" - :affiliation "Université de Nice - Sophia Antipolis" - :address '("930 route des Colles, BP 145" - "F-06903 Sophia Antipolis, Cedex" - "France") - :email (mailto "eg@essi.fr")) - (author :name "Manuel Serrano" - :affiliation "Inria Sophia-Antipolis" - :address `("2004 route des Lucioles - BP 93" - "F-06902 Sophia Antipolis, Cedex" - "France") - :url (ref :url *serrano-url*) - :email (mailto *serrano-mail*))) - - (linebreak 1) - (center (frame (bold (font :size 1. [ -This is the documentation for Skribe version -,(color :fg "red" (skribe-release)).])))) - (linebreak 1) - -;;; Introduction -(section :title "Introduction" :number #f :toc #f [ -Skribe is a programming language designed for implementing electronic -documents. It is mainly designed for the writing of technical documents -such as the documentation of computer programs. With Skribe these -documents can be rendered using various tools and technologies. For -instance, a Skribe document can be ,(emph "compiled") to an HTML file -that suits Web browser, it can be compiled to a TeX file in order to -produce a high-quality printed document, and so on.] - - (subsection :title "Who may use Skribe?" :number #f [ -Everyone needing to design web pages, info documents, man pages or -Postscript files can use Skribe. In particular, there is ,(bold "no need") -for programming skills in order to use Skribe. Skribe can be used as -any text description languages such as TeX, LaTeX or HTML.]) - - (subsection :title "Why using Skribe?" :number #f [ -There are three main reasons for using Skribe:] - - (itemize - (item [ -It is easier to type in Skribe texts than other text description formats. -The need for ,(emph "meta keyword"), that is, words used to describe -the structure of the text and not the text itself, is very limited.]) - (item [ -Skribe is highly skilled for computing texts. It is very common that -one needs to automatically produce parts of the text. This can -be very simple such as, for instance, the need to include inside a text, -the date of the last update or the number of the last revision. -Sometimes it may be more complex. For instance, one may be willing to -embed inside a text the result of a complex arithmetic computation. Or -even, you may want to include some statistics about that -text, such as, the number of words, paragraphs, sections, and so on. -Skribe makes these sort of text manipulation easy whereas other -systems rely on the use of text preprocessors.]) - (item [ -The same source file can be compiled to various output formats such -as HTML, Info pages, man pages, Postscript, etc.])))) - -;;; toc -(if (engine-format? "latex") - (toc :chapter #t :section #t :subsection #t)) - -;;; Getting started -(include "start.skb") - -;;; Syntax -(include "syntax.skb") - -;;; Skribe Markup Library -(include "markup.skb") - -;;; Hyperlinks and references -(include "links.skb") - -;;; Indexes -(include "index.skb") - -;;; Bibliography -(include "bib.skb") - -;;; Computer programs -(include "prgm.skb") - -;;; Standard Library -(include "lib.skb") - -;;; Engines -(include "engine.skb") - -;;; Emacs -(include "emacs.skb") - -;;; Skribe -(include "skribec.skb") - -;;; Slides -(include "slide.skb") - -;;; Packages -(include "package.skb") - -;;; skribe-config -(include "skribe-config.skb") - -;;; List of examples -(include "examples.skb") - -;;; table of contents -(if (not (engine-format? "latex")) - (begin - (chapter :title "Table of contents" - (toc :chapter #t :section #t :subsection #t)) - (section :title "Index" :number #f - (mark "global index") - (the-index :column (if (engine-format? "latex") 2 3) - *markup-index* *custom-index* *function-index* *package-index* - (default-index)))) - (chapter :title "Index" - (mark "global index") - (the-index :column (if (engine-format? "latex") 2 3) - *markup-index* *custom-index* *function-index* *package-index* - (default-index))))) diff --git a/skribe/doc/user/xmle.skb b/skribe/doc/user/xmle.skb deleted file mode 100644 index 4a1ee78..0000000 --- a/skribe/doc/user/xmle.skb +++ /dev/null @@ -1,25 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/xmle.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 11:20:49 2003 */ -;* Last change : Tue Apr 6 06:27:51 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The documentation of the XML engine */ -;*=====================================================================*/ -;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ - -;*---------------------------------------------------------------------*/ -;* Document */ -;*---------------------------------------------------------------------*/ -(section :title "Xml engine" :file #t - (mark "xml-engine") - (index "Xml" :note "Engine") - (p [The Xml engine...]) - - (subsection :title "The Xml customization" - - (doc-engine 'xml - `() - :source "skr/xml.skr"))) diff --git a/skribe/emacs/Makefile b/skribe/emacs/Makefile deleted file mode 100644 index 52074cb..0000000 --- a/skribe/emacs/Makefile +++ /dev/null @@ -1,55 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/emacs/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:20:06 2003 */ -#* Last change : Thu Jan 1 16:46:32 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* Skribe emacs Makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo emacs/skribe.el.in emacs/Makefile - -#*---------------------------------------------------------------------*/ -#* install/uninstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - $(MAKE) install-$(SYSTEM) -uninstall: - $(MAKE) uninstall-$(SYSTEM) - -install-bigloo: - if [ "$(EMACSDIR) " != " " ]; then \ - if [ -d $(EMACSDIR) ]; then \ - cp skribe.el $(EMACSDIR) && chmod $(BMASK) $(EMACSDIR)/skribe.el; \ - fi \ - fi -uninstall-bigloo: - if [ "$(EMACSDIR) " != " " ]; then \ - if [ -d $(EMACSDIR) ]; then \ - $(RM) -f $(EMACSDIR)/skribe.el; \ - fi \ - fi - -install-stklos: -uninstall-stklos: - -#*---------------------------------------------------------------------*/ -#* clean/distclean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - -clean: -distclean: clean - $(RM) -f skribe.el diff --git a/skribe/emacs/skribe.el.in b/skribe/emacs/skribe.el.in deleted file mode 100644 index 1b1ae4f..0000000 --- a/skribe/emacs/skribe.el.in +++ /dev/null @@ -1,841 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/emacs/skribe.el.in */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Nov 23 13:16:30 2003 */ -;* Last change : Sun Jul 11 10:38:17 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe minor mode (major mode is supposed to be a */ -;* Scheme-like mode). */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* module */ -;*---------------------------------------------------------------------*/ -(provide 'skribe) -(require 'ude-custom) -(require 'ude-config) -(require 'ude-icon) -(require 'ude-autoload) -(require 'bmacs-config) -(require (if (featurep 'xemacs) 'bmacs-xemacs 'bmacs-gnu-emacs)) - -;*---------------------------------------------------------------------*/ -;* custom */ -;*---------------------------------------------------------------------*/ -;; skribe version -(defconst skribe-version "@SKRIBE_RELEASE@" - "*The Skribe version.") - -;; skribe group -(defgroup skribe nil - "Skribe Emacs Environment." - :tag "Skribe" - :prefix "skribe-" - :group 'processes) - -;; emacs directory -(defcustom skribe-emacs-dir '"@SKRIBE_EMACSDIR@" - "*Directory for Skribe Emacs installation." - :group 'skribe - :type '(string)) - -;; additional directories for online documentation -(defcustom skribe-docdirs '("@SKRIBE_DOCDIR@") - "*Directories for online documentation." - :group 'skribe - :type '(repeat (string))) - -;; Host scheme documentation -(defcustom skribe-host-scheme-docdirs '("@SKRIBE_HOSTSCHEMEDOCDIR@") - "*URL for hosting Scheme system." - :group 'skribe - :type '(string)) - -;; html browser -(defcustom skribe-html-browser "mozilla" - "*The binary file to run for browing HTML files or nil for Emacs mode." - :group 'skribe - :type '(choice string (const nil))) - -;; electric parenthesis -(defcustom skribe-electric-parenthesis t - "*Set his to nil if you don't want electric closing parenthesis." - :type 'boolean) - -;;;###autoload -(defcustom skribe-mode-line-string " Skr" - "*String displayed on the modeline when skribe is active. -Set this to nil if you don't want a modeline indicator." - :group 'skribe - :type '(choice string (const :tag "None" nil))) - -;; fixed indentation -(defcustom skribe-forced-indent-regexp ";;;\\|;[*]" - "*The regexp that marks a forced indentation" - :group 'skribe - :type 'string) - -;; normal indentation -(defcustom skribe-body-indent 3 - "*The Skribe indentation width" - :group 'skribe - :type 'integer) - -;; font lock -(defcustom skribe-font-lock-keywords - (list - (list (concat "\(\\(let\\|let[*]\\|letrec\\|define" - "\\|define-markup\\|set[!]" - "\\|lambda\\|labels" - "\\|let-syntax\\|letrec-syntax" - "\\|regular-grammar\\|lalr-grammar" - "\\|if\\|when\\|unless\\|begin\\|case\\|cond\\|else" - "\\|multiple-value-bind\\|values\\)[ :\n\t]") - 1 - 'font-lock-keyword-face) - - (list "(\\(document\\|chapter\\|section\\|subsection\\|subsubsection\\|paragraph\\|p\\|skribe-load\\|include\\|slide\\)[) \n]" - 1 - 'font-lock-function-name-face) - (list "(\\(toc\\|itemize\\|enumerate\\|description\\|item\\|the-bibliography\\|the-index\\|default-index\\|frame\\|center\\|table\\|tr\\|th\\|td\\|linebreak\\|footnote\\|color\\|author\\|prog\\|source\\|figure\\|image\\)[) \n]" - 1 - 'ude-font-lock-face-2) - (list "(\\(bold\\|code\\|emph\\|it\\|kbd\\|tt\\|roman\\|underline\\|var\\|samp\\|sc\\|sf\\|sup\\|sub\\)[ )]" - 1 - 'ude-font-lock-face-8) - (list "(\\(ref\\|mailto\\|mark\\|new\\)[) \n]" - 1 - 'ude-font-lock-face-3) - (cons "\\(:[^] \n)]+\\|#![a-zA-Z]+\\)" - 'ude-font-lock-face-7) - (cons "[[]\\|]" - 'ude-font-lock-face-3) - (list "(\\(markup-writer\\|make-engine\\|copy-engine\\|default-engine-set!\\|engine-custom\\|engine-custom-set!\\|engine-custom-add!\\|markup-option\\|markup-option-add!\\|markup-body\\)[ \n]" - 1 - 'font-lock-function-name-face) - (list ",(\\([^ \n()]+\\)" - 1 - 'ude-font-lock-face-6)) - "*The Skribe font-lock specification." - :group 'skribe) - -;; tool-bar -(defcustom skribe-toolbar - `(;; the spell button - ("spell.xpm" flyspell-buffer "Buffer spell check") - -- - ;; the compile button - (,ude-compile-icon ude-mode-compile-from-menu "Compile") - ;; the root button - (,ude-root-icon ude-user-set-root-directory "Set new root directory") - -- - ;; the repl button - (,ude-repl-icon ude-repl-other-frame "Start a read-eval-print loop") - -- - --> - -- - ;; online documentation - (,ude-help-icon skribe-doc-ident "Describe markup at point") - (,ude-info-icon skribe-manuals "Skribe online documentations")) - "*The Skribe toolbar" - :group 'skribe) - -;; paragraphs -(defcustom skribe-paragraph-start - "^\\(?:[ \t\n\f]\\|;;\\|[(]\\(?:section\\|sub\\|p\\|slide\\|document\\)\\)" - "*The regexp that marks a paragraph start" - :group 'skribe - :type 'string) - -(defcustom skribe-paragraph-separate - "^[ \t\f%]*$" - "*The regexp that marks a paragraph separation" - :group 'skribe - :type 'string) - -;*---------------------------------------------------------------------*/ -;* Which emacs are we currently running */ -;*---------------------------------------------------------------------*/ -(defvar skribe-emacs - (cond - ((string-match "XEmacs" emacs-version) - 'xemacs) - (t - 'emacs)) - "The type of Emacs we are currently running.") - -;*---------------------------------------------------------------------*/ -;* Autoloading */ -;*---------------------------------------------------------------------*/ -;;;###autoload -(defvar skribe-mode-map (make-sparse-keymap)) - -;;;###autoload -(if (fboundp 'add-minor-mode) - (add-minor-mode 'skribe-mode - 'skribe-mode-line-string - nil - nil - 'skribe-mode) - - (or (assoc 'skribe-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(skribe-mode skribe-mode-line-string) - minor-mode-alist))) - - (or (assoc 'skribe-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'skribe-mode skribe-mode-map) - minor-mode-map-alist)))) - -;*---------------------------------------------------------------------*/ -;* skribe-manuals-menu-entry ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-manuals-menu-entry (s) - (let ((sym (gensym))) - (fset sym `(lambda () - (interactive) - (ude-system skribe-html-browser - (format "file:%s" (expand-file-name ,s))))) - (vector (file-name-nondirectory s) sym t))) - -;*---------------------------------------------------------------------*/ -;* skribe-directory-html-files */ -;*---------------------------------------------------------------------*/ -(defun skribe-directory-html-files (dirs) - (let ((dirs dirs) - (res '())) - (while (consp dirs) - (let ((dir (car dirs))) - (when (file-directory-p dir) - (setq res (append (directory-files dir t "^.+[^0-9][.]html$") res)) - (setq dirs (cdr dirs))))) - res)) - -;*---------------------------------------------------------------------*/ -;* skribe-manuals ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-manuals () - (interactive) - (when (stringp skribe-html-browser) - (let ((res (skribe-directory-html-files skribe-docdirs)) - (host (sort (skribe-directory-html-files skribe-host-scheme-docdirs) - 'string<))) - (if (= (length res) 1) - (ude-system skribe-html-browser - (format "file:%s" (expand-file-name (car res)))) - (let (user dir) - (let ((old res) - (new '())) - (while (consp old) - (let* ((f (car old)) - (b (file-name-nondirectory f))) - (setq old (cdr old)) - (cond - ((string-equal b "user.html") - (setq user f)) - ((string-equal b "dir.html") - (setq dir f)) - (t (setq new (cons f new)))))) - (let* ((rest (mapcar 'skribe-manuals-menu-entry - (sort new - '(lambda (s u) - (string< - (file-name-nondirectory s) - (file-name-nondirectory u)))))) - (smenu (cond - ((and user dir) - (append (list (skribe-manuals-menu-entry user) - (skribe-manuals-menu-entry dir) - "--:shadowEtchedInDash") - rest)) - ((dir) - (cons (skribe-manuals-menu-entry dir) rest)) - ((user) - (cons (skribe-manuals-menu-entry user) rest)) - (t - rest))) - (menu (if (consp host) - (append smenu - (cons "--:shadowEtchedInDash" - (mapcar 'skribe-manuals-menu-entry - host))) - smenu))) - (popup-menu - (cons "Doc" menu))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-scheme-indent-line ... */ -;*---------------------------------------------------------------------*/ -(defvar skribe-scheme-indent-line nil) -(make-variable-buffer-local 'skribe-scheme-indent-line) - -;*---------------------------------------------------------------------*/ -;* skribe-insert-parenthesis ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-insert-parenthesis (char) - ;; find the open parenthesis - (if skribe-electric-parenthesis - (let ((clo nil) - (tag nil)) - (save-excursion - (save-restriction - ;; Scan across one sexp within that range. - ;; Errors or nil mean there is a mismatch. - (insert ?\)) - (condition-case () - (let ((pos (scan-sexps (point) -1))) - (if pos - (progn - (save-excursion - (goto-char pos) - (forward-word 1) - (setq tag (buffer-substring (1+ pos) (point)))) - (setq clo (matching-paren (char-after pos)))) )) - (error nil)))) - (if clo - (progn - (delete-char 1) - (insert clo)) - (forward-char 1))) - (insert char))) - -;*---------------------------------------------------------------------*/ -;* skribe-parenthesis ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-parenthesis (&optional dummy) - "Automatic parenthesis closing of )." - (interactive) - ;; find the open parenthesis - (skribe-insert-parenthesis ?\))) - -;*---------------------------------------------------------------------*/ -;* skribe-bracket ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-bracket (&optional dummy) - "Automatic parenthesis closing of ]." - (interactive) - (skribe-insert-parenthesis ?\])) - -;*---------------------------------------------------------------------*/ -;* skribe-doc-ident ... */ -;* ------------------------------------------------------------- */ -;* On-line document for identifier IDENT. This spawns an */ -;* HTML browser for serving the documentation. */ -;*---------------------------------------------------------------------*/ -(defun skribe-doc-ident (ident) - (interactive (ude-interactive-ident (point) "Identifier: ")) - (and (stringp skribe-html-browser) - (let ((dirs skribe-docdirs)) - (while (consp dirs) - (let* ((dir (car dirs)) - (html-ref (ude-sui-find-ref ident dir))) - (if (stringp html-ref) - (progn - (ude-system skribe-html-browser - (format "file:%s/%s" - (expand-file-name dir) - html-ref)) - (setq dirs '())) - (setq dirs (cdr dirs)))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-mode ... */ -;*---------------------------------------------------------------------*/ -;;;###autoload -(defvar skribe-mode nil) -(make-variable-buffer-local 'skribe-mode) - -;*---------------------------------------------------------------------*/ -;* skribe-major-mode ... */ -;*---------------------------------------------------------------------*/ -;;;###autoload -(defun skribe-major-mode () - "Major mode for editing Skribe code." - (interactive) - (bee-mode) - (skribe-mode t)) - -;*---------------------------------------------------------------------*/ -;* skribe-mode ... */ -;*---------------------------------------------------------------------*/ -;;;###autoload -(defun skribe-mode (&optional arg) - "Minor mode for editing Skribe sources. - -Bindings: -\\[skribe-doc-ident]: on-line document. - -Hooks: -This runs `skribe-mode-hook' after skribe is enterend." - (interactive "P") - (let ((old-skribe-mode skribe-mode)) - ;; Mark the mode as on or off. - (setq skribe-mode (not (or (and (null arg) skribe-mode) - (<= (prefix-numeric-value arg) 0)))) - ;; Do the real work. - (unless (eq skribe-mode old-skribe-mode) - (if skribe-mode (skribe-activate-mode) nil)) - ;; Force modeline redisplay. - (set-buffer-modified-p (buffer-modified-p)))) - -;*---------------------------------------------------------------------*/ -;* skribe-return ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-return (&optional dummy) - "Automatic indentation on RET." - (interactive) - (newline) - (if (>= (point) (point-min)) - (skribe-indent-line))) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-line-toggle ... */ -;*---------------------------------------------------------------------*/ -(defvar skribe-indent-line-toggle nil) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-line ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-line () - (interactive) - (if (eq last-command 'skribe-indent-line) - (if skribe-indent-line-toggle - (skribe-do-indent-line) - (progn - (setq skribe-indent-line-toggle t) - (if skribe-scheme-indent-line - (funcall skribe-scheme-indent-line)))) - (skribe-do-indent-line))) - -;*---------------------------------------------------------------------*/ -;* skribe-do-indent-line ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-do-indent-line () - (setq skribe-indent-line-toggle nil) - (let ((start (point)) beg) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (let* ((pos (- (point-max) start)) - (indent (skribe-calculate-indent start))) - (when indent - (if (listp indent) (setq indent (car indent))) - (let ((shift-amt (- indent (current-column)))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent)))) - ;; If initial point was within line's indentation, - ;; position after the indentation. - ;; Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - -;*---------------------------------------------------------------------*/ -;* skribe-calculate-indent ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-calculate-indent (start &optional parse-start) - "Return appropriate indentation for current line as Skribe code. -In usual case returns an integer: the column to indent to. -Can instead return a list, whose car is the column to indent to. -This means that following lines at the same level of indentation -should not necessarily be indented the same way. -The second element of the list is the buffer position -of the start of the containing expression." - (or (skribe-calculate-forced-indent) - (skribe-calculate-free-indent start parse-start))) - -;*---------------------------------------------------------------------*/ -;* skribe-calculate-forced-indent ... */ -;* ------------------------------------------------------------- */ -;* Returns a column number iff the line indentation is forced */ -;* (i.e. the previous line starts with a "[ \t]*;;;"). Otherwise */ -;* returns f. */ -;*---------------------------------------------------------------------*/ -(defun skribe-calculate-forced-indent () - (save-excursion - (previous-line 1) - (beginning-of-line) - (skip-chars-forward " \t") - (let ((s (current-column))) - (and (looking-at skribe-forced-indent-regexp) s)))) - -;*---------------------------------------------------------------------*/ -;* skribe-calculate-free-indent ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-calculate-free-indent (start &optional parse-start) - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) state paren-depth desired-indent (retry t) - last-sexp containing-sexp first-sexp-list-p skribe-indent) - (if parse-start - (goto-char parse-start) - ;; TOBE IMPROVED - (goto-char (point-min))) -;* (beginning-of-defun)) */ - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - (setq retry nil) - (setq last-sexp (nth 2 state)) - (setq containing-sexp (car (cdr state))) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and last-sexp (> last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp last-sexp indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if (not retry) - ;; Innermost containing sexp found - (progn - (goto-char (1+ containing-sexp)) - (if (not last-sexp) - ;; indent-point immediately follows open paren. - ;; Don't call hook. - (setq desired-indent (current-column)) - ;; Move to first sexp after containing open paren - (parse-partial-sexp (point) last-sexp 0 t) - (setq first-sexp-list-p (looking-at "\\s(")) - (cond - ((> (save-excursion (forward-line 1) (point)) - last-sexp) - ;; Last sexp is on same line as containing sexp. - ;; It's almost certainly a function call. - (parse-partial-sexp (point) last-sexp 0 t) - (if (/= (point) last-sexp) - ;; Indent beneath first argument or, if only one sexp - ;; on line, indent beneath that. - (progn (forward-sexp 1) - (parse-partial-sexp (point) last-sexp 0 t))) - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as last-sexp. - ;; Again, it's almost certainly a function call. - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (backward-prefix-chars))))))) - ;; If looking at a list, don't call hook. - (if first-sexp-list-p - (setq desired-indent (current-column))) - ;; Point is at the point to indent under unless we are inside a string. - ;; Call indentation hook except when overriden by skribe-indent-offset - ;; or if the desired indentation has already skriben computed. - '(message-box (format "start=%s\nfirst-sexp-lisp-p: %s\nstate: %s\ndesired-indent: %s\nintegerp=%s\nchar-after=%s\ncur-char=%s\npoint=%s\nskribe-indent-function-p=%s\n" start first-sexp-list-p state desired-indent - (integerp (car (nthcdr 1 state))) - (char-after (car (nthcdr 1 state))) - (char-after (point)) - (point) - (skribe-indent-method state))) - (cond ((car (nthcdr 3 state)) - ;; Inside a string, don't change indentation. - (goto-char indent-point) - (skip-chars-forward " \t") - (setq desired-indent (current-column))) - ((skribe-indent-bracket-p state) - ;; indenting a bracket - (save-excursion - (goto-char start) - (skip-chars-forward " \t") - (let ((c (car (nthcdr 9 state)))) - (if (and (consp c) (looking-at ",(") nil) - (let ((l (length c))) - (if (< l 2) - (setq desired-indent 0) - (progn - (goto-char (car (nthcdr (- l 2) c))) - (setq desired-indent (current-column))))) - (setq desired-indent 0))))) - ((setq skribe-indent (skribe-indent-method state)) - ;; skribe special form - (setq desired-indent skribe-indent)) - (skribe-scheme-indent-line - ;; scheme form - (goto-char start) - (funcall skribe-scheme-indent-line) - (setq desired-indent nil)) - (t - ;; use default indentation if not computed yet - (setq desired-indent (current-column)))) - desired-indent))) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-bracket-p ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-bracket-p (state) - (or (and (integerp (car (nthcdr 1 state))) - (eq (char-after (car (nthcdr 1 state))) ?[)) - (let ((op (car (nthcdr 9 state)))) - (and (consp op) - (let ((po (reverse op)) - (context 'unknown)) - (save-excursion - (while (and (consp po) (eq context 'unknown)) - (cond - ((eq (char-after (car po)) ?[) - (setq context 'skribe)) - ((and (eq (char-after (car po)) ?\() - (> (car po) (point-min)) - (eq (char-after (1- (car po))) ?,)) - (setq context 'scheme)) - (t - (setq po (cdr po)))))) - (eq context 'skribe)))))) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-method ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-method (state) - (let ((is (car (nthcdr 1 state)))) - (and (integerp is) - (save-excursion - (goto-char is) - (let* ((function (intern-soft - (buffer-substring - (progn (forward-char 1) (point)) - (progn (forward-sexp 1) (point))))) - (method (get function 'skribe-indent))) - (if (functionp method) - (funcall method state) - nil)))))) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-function ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-function (state) - (save-excursion - (goto-char (car (nthcdr 1 state))) - (+ (current-column) skribe-body-indent))) - -;*---------------------------------------------------------------------*/ -;* normal-indent ... */ -;*---------------------------------------------------------------------*/ -(defvar normal-indent 0) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-sexp ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-sexp () - "Indent each line of the list starting just after point." - (interactive) - (let ((indent-stack (list nil)) (next-depth 0) last-depth bol - outer-loop-done inner-loop-done state this-indent) - (save-excursion (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (not outer-loop-done) - (setq last-depth next-depth - inner-loop-done nil) - (while (and (not inner-loop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (car (nthcdr 4 state)) - (progn (skribe-comment-indent) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq inner-loop-done t))) - (if (setq outer-loop-done (<= next-depth 0)) - nil - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - (forward-line 1) - (setq bol (point)) - (skip-chars-forward " \t") - (if (or (eobp) (looking-at ";\\(;;\\|[*]\\)")) - nil - (let ((val (skribe-calculate-indent - (point) - (if (car indent-stack) (- (car indent-stack)))))) - (cond - ((integerp val) - (setcar indent-stack (setq this-indent val))) - ((consp val) - (setcar indent-stack (- (car (cdr val)))) - (setq this-indent (car val))) - (t - (setq this-indent nil)))) - (if (and (integerp this-indent) (/= (current-column) this-indent)) - (progn (delete-region bol (point)) - (indent-to this-indent))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-comment-indent ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-comment-indent (&optional pos) - (save-excursion - (if pos (goto-char pos)) - (cond - ((looking-at ";;;") - (current-column)) - ((looking-at ";*") - 0) - ((looking-at "[ \t]*;;") - (let ((tem (skribe-calculate-indent (point)))) - (if (listp tem) (car tem) tem))) - (t - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column))))) - -;*---------------------------------------------------------------------*/ -;* skribe-custom-indent ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-custom-indent () - (save-excursion - (goto-char (point-min)) - ;; The concat is used to split the regexp so that it is nolonger - ;; to find itself! Without the split, the skribe mode cannot be - ;; used to edit this source file! - (let ((regexp (concat "@ind" "ent:\\([^@]+\\)@"))) - (while (re-search-forward regexp (point-max) t) - (condition-case () - (eval-region (match-beginning 1) (match-end 1) nil) - (error nil)))))) - -;*---------------------------------------------------------------------*/ -;* skribe-indent-load ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-indent-load (file) - (let ((lp (cons skribe-emacs-dir load-path))) - (while (consp lp) - (let ((f (concat (car lp) "/" file))) - (if (file-exists-p f) - (progn - (load f) - (set! lp '())) - (set! lp (cdr lp))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-activate-mode ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-activate-mode () - ;; buffer local global variables - (make-variable-buffer-local 'ude-extra-identifier-chars) - (setq ude-extra-identifier-chars "-") - ;; the keymap - (skribe-activate-keymap skribe-mode-map) - ;; font lock - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(skribe-font-lock-keywords)) - (font-lock-mode nil) - (font-lock-mode t) - ;; paragraph - (make-variable-buffer-local 'paragraph-start) - (setq paragraph-start skribe-paragraph-start) - (make-variable-buffer-local 'paragraph-separate) - (setq paragraph-separate skribe-paragraph-separate) - ;; try to retreive the globa'paragraph-startl indentation binding - (if (not skribe-scheme-indent-line) - (setq skribe-scheme-indent-line (global-key-binding "\t"))) - ;; the toolbar - (use-local-map skribe-mode-map) - (ude-toolbar-set skribe-toolbar) - ;; the custom indentation - (skribe-custom-indent) - ;; we end with the skribe hooks - (run-hooks 'skribe-mode-hook) - t) - -;*---------------------------------------------------------------------*/ -;* skribe-activate-keymap ... */ -;*---------------------------------------------------------------------*/ -(defun skribe-activate-keymap (map) - (define-key map "\C-m" 'skribe-return) - (define-key map "\e\C-m" 'newline) - (define-key map "\t" 'skribe-indent-line) - (define-key map ")" 'skribe-parenthesis) - (define-key map "]" 'skribe-bracket) - (define-key map "\e\C-q" 'skribe-indent-sexp) - (cond - ((eq skribe-emacs 'xemacs) - (define-key map [(control \))] (lambda () (interactive) (insert ")"))) - (define-key map [(control \])] (lambda () (interactive) (insert "]")))) - (t - (define-key map [?\C-\)] (lambda () (interactive) (insert ")"))) - (define-key map [?\C-\]] (lambda () (interactive) (insert "]")))))) - -;*---------------------------------------------------------------------*/ -;* Standard Skribe indent forms */ -;*---------------------------------------------------------------------*/ -(put 'make-engine 'skribe-indent 'skribe-indent-function) -(put 'copy-engine 'skribe-indent 'skribe-indent-function) -(put 'markup-writer 'skribe-indent 'skribe-indent-function) -(put 'engine-custom 'skribe-indent 'skribe-indent-function) -(put 'engine-custom-set! 'skribe-indent 'skribe-indent-function) -(put 'document 'skribe-indent 'skribe-indent-function) -(put 'author 'skribe-indent 'skribe-indent-function) -(put 'chapter 'skribe-indent 'skribe-indent-function) -(put 'section 'skribe-indent 'skribe-indent-function) -(put 'subsection 'skribe-indent 'skribe-indent-function) -(put 'subsubsection 'skribe-indent 'skribe-indent-function) -(put 'paragraph 'skribe-indent 'skribe-indent-function) -(put 'footnote 'skribe-indent 'skribe-indent-function) -(put 'linebreak 'skribe-indent 'skribe-indent-function) -(put 'hrule 'skribe-indent 'skribe-indent-function) -(put 'color 'skribe-indent 'skribe-indent-function) -(put 'frame 'skribe-indent 'skribe-indent-function) -(put 'font 'skribe-indent 'skribe-indent-function) -(put 'flush 'skribe-indent 'skribe-indent-function) -(put 'center 'skribe-indent 'skribe-indent-function) -(put 'pre 'skribe-indent 'skribe-indent-function) -(put 'prog 'skribe-indent 'skribe-indent-function) -(put 'source 'skribe-indent 'skribe-indent-function) -(put 'language 'skribe-indent 'skribe-indent-function) -(put 'itemize 'skribe-indent 'skribe-indent-function) -(put 'enumerate 'skribe-indent 'skribe-indent-function) -(put 'description 'skribe-indent 'skribe-indent-function) -(put 'item 'skribe-indent 'skribe-indent-function) -(put 'figure 'skribe-indent 'skribe-indent-function) -(put 'table 'skribe-indent 'skribe-indent-function) -(put 'tr 'skribe-indent 'skribe-indent-function) -(put 'td 'skribe-indent 'skribe-indent-function) -(put 'th 'skribe-indent 'skribe-indent-function) -(put 'image 'skribe-indent 'skribe-indent-function) -(put 'blockquote 'skribe-indent 'skribe-indent-function) -(put 'roman 'skribe-indent 'skribe-indent-function) -(put 'bold 'skribe-indent 'skribe-indent-function) -(put 'underline 'skribe-indent 'skribe-indent-function) -(put 'strike 'skribe-indent 'skribe-indent-function) -(put 'emph 'skribe-indent 'skribe-indent-function) -(put 'kbdb 'skribe-indent 'skribe-indent-function) -(put 'it 'skribe-indent 'skribe-indent-function) -(put 'tt 'skribe-indent 'skribe-indent-function) -(put 'code 'skribe-indent 'skribe-indent-function) -(put 'var 'skribe-indent 'skribe-indent-function) -(put 'smap 'skribe-indent 'skribe-indent-function) -(put 'sf 'skribe-indent 'skribe-indent-function) -(put 'sc 'skribe-indent 'skribe-indent-function) -(put 'sub 'skribe-indent 'skribe-indent-function) -(put 'sup 'skribe-indent 'skribe-indent-function) -(put 'mailto 'skribe-indent 'skribe-indent-function) -(put 'mark 'skribe-indent 'skribe-indent-function) -(put 'handle 'skribe-indent 'skribe-indent-function) -(put 'ref 'skribe-indent 'skribe-indent-function) -(put 'resolve 'skribe-indent 'skribe-indent-function) -(put 'bibliography 'skribe-indent 'skribe-indent-function) -(put 'the-bibliography 'skribe-indent 'skribe-indent-function) -(put 'make-index 'skribe-indent 'skribe-indent-function) -(put 'index 'skribe-indent 'skribe-indent-function) -(put 'the-index 'skribe-indent 'skribe-indent-function) -(put 'char 'skribe-indent 'skribe-indent-function) -(put 'symbol 'skribe-indent 'skribe-indent-function) -(put '! 'skribe-indent 'skribe-indent-function) -(put 'processor 'skribe-indent 'skribe-indent-function) -(put 'slide 'skribe-indent 'skribe-indent-function) -(put 'counter 'skribe-indent 'skribe-indent-function) diff --git a/skribe/etc/ChangeLog b/skribe/etc/ChangeLog deleted file mode 100644 index 6987245..0000000 --- a/skribe/etc/ChangeLog +++ /dev/null @@ -1,698 +0,0 @@ -Thu Jun 2 10:58:23 CEST 2005 (Manuel Serrano): - - *** Minor changes in acmproc.skr and html.skr in order to improve - HTML div generation of abstracts. - - -Thu May 26 12:59:53 CEST 2005 (Manuel Serrano): - - *** Fix LaTeX author address printing. - - -Sun Apr 10 09:10:31 CEST 2005 (Manuel Serrano): - - * Handles correctly LaTeX \charNUMNUMNUM commands in Skribebibtex. - This enables handling ~ as \char126. - - -Fri Mar 4 08:44:36 CET 2005 (Manuel Serrano): - - *** Fix HTML inner links. If the reference pointed to by a link - is located inside the document, the link doest contain the file name - any longer. This enables the renaming of the HTML file while preserving - the correctness of the HTML links. - - -Wed Nov 17 11:10:53 CET 2004 (Erick Gallesio, Manuel Serrano): - - ********* release 1.2b. - - -Wed Nov 10 11:03:47 CET 2004 (Manuel Serrano): - - * The image conversion process is now coherent. That is, when an - image does not need conversion, it is still copied into the - output directory. - - -Mon Nov 8 11:00:07 CET 2004 (Erick Gallesio) - - * skr/web-book.skr: Added the option :margin-title to web-book - - -Thu Oct 28 21:53:34 CEST 2004 (Erick Gallesio) - - * New back-end using the ConTeXt TeX macro package - - -Tue Oct 26 10:52:05 CEST 2004 (Erick Gallesio): - - * Added the STklos skribebibtex. Makefile and hierearchy changed - accordingly. - - -Thu Oct 21 14:55:04 CEST 2004 (Ludovic Courtès): - - *** Bibliography parsers use SKRIBE-READ instead of READ. - - -Mon Oct 11 15:47:08 CEST 2004 (Manuel Serrano): - - *** Fix TABLE construction in src/common/api.scm. - - -Fri Oct 8 22:14:06 CEST 2004 (Manuel Serrano): - - *** Fix a bug in src/common/api.scm. The subsection environment - was erroneously represented as a shared constant instead of a - freshly allocated list. - - -Thu Sep 23 19:30:13 CEST 2004 (Manuel Serrano): - - *** Fix the definition of the ITEM markup that was erroneously - doubling its :key attribute. - - -Thu Sep 23 17:15:21 CEST 2004 (Erick Gallesio) - - * In the documentation the installed skribe-config script was used, - instead of the one of the distribution. Fixed. - - -Wed Sep 22 14:51:45 CEST 2004 (Damien Ciabrini): - - * New latex-simple.skr Skribe style that let's LaTex handling - references, links, and the enables non-breakable ~ character. - - -Wed Sep 22 14:11:36 CEST 2004 (Manuel Serrano): - - *** Improve error detections. - - -Wed Sep 22 02:13:59 CEST 2004 (Manuel Serrano): - - * Change the start and stop SOURCE markup. These can now be - integer standing for line numbers or then can be marks matched - against the beginning of the lines. - - -Sun Jul 11 10:38:23 CEST 2004 (Manuel Serrano): - - *** Fix SKRIBE.el paragraph delimiters. - - -Wed Jul 7 06:23:49 CEST 2004 (Manuel Serrano): - - *** Switch the execution order of verify and resolve. Resolve now - takes place *before* verify (because verify simply requires the - ast to be already resolved). - - -Wed Jun 23 16:56:57 CEST 2004 (Manuel Serrano): - - *** etc/bigloo/configure, README.java: add JVM visibility over the - environment variable SKRIBEPATH. - - -Tue Jun 22 09:47:37 CEST 2004 (Manuel Serrano): - - * skr/html.skr: Add the inline-css HTML engine custom. - - -Mon May 31 18:51:09 CEST 2004 (Erick Gallesio) - - *** skr/html.skr: Added the charset custom to html - - -Mon May 31 14:35:17 CEST 2004 (Manuel Serrano): - - *** skr/html.skr: fix a small HTML compliance bug in the TD/TH - background color emission. - - -Fri May 21 16:44:53 CEST 2004 (Yann Dirson): - - *** Add DESTDIR to generated Bigloo Makefiles (in order to ease - the Debian package). - - -Fri May 21 16:12:48 CEST 2004 (Stéphane Epardaud): - - *** src/bigloo/engine.scm: Fix a bug in ENGINE-FORMAT? - - -Fri May 21 15:54:46 CEST 2004 (Manuel Serrano): - - *** skr/web-book.skr: Add subsection to navigation tocs. - - -Mon May 17 10:14:25 CEST 2004 (Manuel Serrano): - - *** src/bigloo/xml.scm: Improve XML fontification. - - -Mon May 10 21:00:10 CEST 2004 (Manuel Serrano): - - *** skr/html.skr: Fix an error in negative relative font size handling. - - -Thu Apr 29 05:52:53 CEST 2004 (Manuel Serrano): - - *** skr/html.skr: Add JS custom. - - * src/common/lib.scm: Add ENGINE-CUSTOM-ADD!. - - -Tue Apr 20 13:40:00 CEST 2004 (Manuel Serrano): - - *** skr/html.skr: Add &html-figure-legend to the figure - writer. - - -Tue Apr 20 12:07:36 CEST 2004 (Manuel Serrano): - - *** skr/base.skr: fix a bug in &bib-entry emission. The writer - used to display the label of the entry (&bib-entry-label) was - the writer of the default engine instead of the engine of the - dynamically active engine. - - -Tue Apr 13 10:11:33 CEST 2004 (Manuel Serrano): - - *** skr/html.skr: Fix SUI mark reference generation. - - -Tue Apr 6 06:58:28 CEST 2004 (Manuel Serrano): - - *** doc/user/{engine,latexe}.skb: add document about engines. - - -Thu Apr 1 14:43:47 CEST 2004 (Manuel Serrano): - - *** src/bigloo/evapi.scm: export the SKRIBE-READ function into - the standard api. - - -Fri Mar 26 05:50:10 CET 2004 (Manuel Serrano): - - *** skr/latex.skr, skr/slide.skr: fix PRE and PROG LaTeX tabcolsep. - - -Wed Mar 24 16:37:06 CET 2004 (Manuel Serrano): - - *** skr/latex.skr: add the postdocument custom. - - *** skr/web-article.skr: fix illegal html identifiers (add - calls to STRING-CANONICALIZE). - - -Mon Mar 22 15:53:37 CET 2004 (Erick Gallesio): - - * Fix a bash problem in the configure driver script. - - -Tue Mar 16 09:44:49 CET 2004 (Erick Gallesio, Manuel Serrano): - - ********* release 1.1a. - - -Mon Mar 15 00:00:37 CET 2004 (Erick Gallesio): - - *** skr/html.skr: Changed the generated JavaScript for email - obfuscation to be conform to HTML 4. This is an ugly hack. - - -Thu Mar 11 11:28:17 CET 2004 (Manfred Lotz): - - *** emacs/emacs.el.in: Fix error in font lock declarations. - - *** skr/latex.skr: fix inconsistency in bold face generation. - - -Wed Mar 10 06:06:48 CET 2004 (Manuel Serrano): - - *** src/lib/bigloo.bgl, skr/latex.skr: fix a path bug in - BUILTIN-CONVERT-IMAGE. The generated image was generated in the - source directory but it should be generated in the target directory. - - -Mon Mar 8 11:40:46 CET 2004 (Manuel Serrano): - - * src/common/lib.scm: add an optional filler to LIST-SPLIT. - - -Sat Mar 6 21:17:45 CET 2004 (Manuel Serrano): - - *** skr/html.skr: change the generation of font markup. It now uses - and as much as possible. - - *** skr/html.skr: fix mailto markup. - - -Fri Mar 5 18:45:34 CET 2004 (Manuel Serrano): - - *** src/{bigloo,stklos}/{engine,types,writer}.{scm,stk} rename - inherit in delegate. - - -Sun Feb 29 06:40:53 CET 2004 (Manuel Serrano): - - *** src/bigloo/lib.bgl: change image conversion in order to avoid - new conversion when the target image already exists. - - *** src/bigloo/writer.scm: change MARKUP-WRITER-GET. The optional - argument PRED may now be #unspecified which means that writers - predicate are not checked during the search. - - -Sat Feb 28 10:18:16 CET 2004 (Erick Gallesio): - - *** src/stklos/reader.stk (%read-bracket): Bug correction: ",(" - sequences in strings were interpreted. - - -Thu Feb 26 20:44:50 CET 2004 (Erick Gallesio): - - *** main.stk: Added the --use-variant option - -Thu Feb 26 16:33:49 CET 2004 (Erick Gallesio): - - *** Documentation can now be conform to HTML 4.01, if compiled - using html4.skr - - -Thu Feb 26 10:18:21 CET 2004 (Manuel Serrano): - - * src/common/api.scm, skr/html.skr: ref markups have no default class. - The HTML engine generates a class which is the name of the protocol - of the reference (i.e., ftp, http, file, ...) for url references. - - -Wed Feb 25 06:41:51 CET 2004 (Manuel Serrano): - - *** src/bigloo/engine.scm: add PUSH-DEFAULT-ENGINE and - POP-DEFAULT-ENGINE. - - -Wed Feb 25 01:03:22 CET 2004 (Erick Gallesio): - - *** skr/html4.skr: File that must be preloaded to produce HTML - 4.01 output - - -Mon Feb 23 10:13:57 CET 2004 (Manuel Serrano): - - *** skr/latex.skr: change the output of URL-REF when a text is - provided. - - -Sat Feb 21 10:39:26 CET 2004 (Manuel Serrano): - - * Document standard packages (letter, french, web-book, acmproc, ...). - - -Fri Feb 20 07:36:09 CET 2004 (Manuel Serrano): - - *** skr/html.skr: add the lower case Nu greek symbol. - - -Thu Feb 19 18:28:43 CET 2004 (Manuel Serrano): - - * doc/skr/api.skr: Improve MAKE-ENGINE? predicate in order to - break deeply recursive searches. - -Wed Feb 19 00:48:47 CET 2004 (Erick Gallesio): - *** src/stklos/writer.stk: writers can be cloned with COPY-MARKUP-WRITER - -Wed Feb 18 22:55:20 CET 2004 (Erick Gallesio): - - *** src/stklos/output.stk: added a way to insert a validation phase - before outputting a markup. This should permit, for instance to - verify that a document is conform to certain constraints, as a DTD. - -Wed Feb 18 13:25:47 CET 2004 (Manuel Serrano): - - *** src/bigloo/lib.bgl: change STRING-CANONICALIZE to get rid - of #\# characters that pose problem for both HTML and LaTeX. - - -Wed Feb 18 12:03:11 CET 2004 (Manuel Serrano): - - *** skr/latex.skr: improve error detection of FONT markups. - - -Tue Feb 17 13:26:38 CET 2004 (Manuel Serrano): - - *** src/common/api.scm, skr/html.skr, skr/latex.skr: fix the big - mess about string used by references (string-canonicalize). - - *** src/common/api.scm, skr/html.skr, skr/latex.skr: fix bibliography - references. Bibliography database must be loaded prior to bibliography - entries are referenced. Otherwise, this causes a problem of fix - point iterations between citations and database printing. - - -Tue Feb 17 11:36:19 CET 2004 (Damien Ciabrini): - - *** src/common/sui.scm: fix sui subsection and subsubsection - searches. - - -Tue Feb 17 06:42:44 CET 2004 (Manuel Serrano): - - *** skr/html.skr, skr/latex.skr: add the TABLE rules 'header - option. - - -Mon Feb 16 15:02:19 CET 2004 (Manuel Serrano): - - *** tools/skribebibtex/skribebibtex.scm: add n~ and N~ character - parsing. - - -Thu Feb 12 22:26:31 CET 2004 (Manuel Serrano): - - *** Get rid of the user stage. - - -Thu Feb 12 16:31:41 CET 2004 (Manuel Serrano): - - *** src/common/api.scm: fix table border width handling (option - was ignored). - - -Thu Feb 12 16:13:48 CET 2004 (Manuel Serrano): - - *** src/common/api.scm, skr/html.skr: Improve HTML4.01 compliance. - - -Thu Feb 12 10:42:30 CET 2004 (Manuel Serrano): - - *** src/bigloo/lisp.scm, skr/html.skr, skr/latex.skr: add - &source-error markup. - - -Wed Feb 11 09:48:08 CET 2004 (Manuel Serrano): - - *** src/bigloo/types.scm: The functions LANGUAGE-NAME, - LANGUAGE-FONTIFIER, and LANGUAGE-EXTRACTOR are now exported and - visible from the standard Skribe runtime system. - - *** src/common/api.scm, skr/html.skr: Change the default table - attributes value for BORDER, CELLPADDING, and CELLSPACING in order - to get rid of warning messages when producing LaTeX documents. - - -Mon Feb 9 20:38:28 CET 2004 (Manuel Serrano): - - *** skr/latex.skr: fix tt, code, pre engine that were not using - the correct symbol table. - - -Mon Feb 9 09:44:59 CET 2004 (Manuel Serrano): - - *** src/bigloo/lib/bgl: fix the STRING-CANONICALIZE function - so now it turns #\space into #\_. - - -Mon Feb 9 06:40:33 CET 2004 (Manuel Serrano): - - *** src/bigloo/main.scm: the RC file (.skribe/skriberc) is now loaded - before the command line is parsed. - - -Sat Feb 7 08:23:38 CET 2004 (Manuel Serrano): - - * configure, src/bigloo/configure.bgl, src/common/configure.scm: - Improve the configuration mechanism (enabling dynamic configuration - tests). - - -Fri Feb 6 10:10:31 CET 2004 (Manuel Serrano): - - *** skr/html.skr, skr/slide.skr, skr/web-article.skr: redesign HTML - header generation. - - -Wed Feb 4 14:58:25 CET 2004 (Manuel Serrano): - - *** src/common/index.scm: indexes letter references are now - made unique. - - -Wed Feb 4 05:24:51 CET 2004 (Manuel Serrano): - - *** src/common/api.scm, src/{common,bigloo}/index.scm: improve - error localization for indexes. - - *** skr/base.skr: improve indexed generation. - - -Tue Feb 3 11:58:43 CET 2004 (Manuel Serrano): - - * src/bigloo/param.scm, src/bigloo/parse-args.scm, src/bigloo/eval.scm: - add the -w?level command line option. - - -Tue Feb 3 05:51:41 CET 2004 (Manuel Serrano): - - *** src/common/api.scm, skr/{html.skr,latex.skr}, doc/user/table.skb: - Redesign of tables. - - -Mon Feb 2 09:43:28 CET 2004 (Manuel Serrano): - - *** skr/html.skr: Improve HTML4.01 compliance. - - *** skr/latex.skr: Fix LaTeX symbol table. - - *** src/common/api.scm: Fix color declaration in TC and TR. - - -Sun Feb 1 06:18:08 CET 2004 (Manuel Serrano): - - *** src/bigloo/c.scm, src/bigloo/xml.scm: fix multi-lines - fontification in C and XML mode. Older fontification was producing - ill-formed LaTeX outputs. - - *** src/common/api.scm: fix figure identifier. - - -Wed Jan 28 20:57:11 CET 2004 (Manuel Serrano): - - * WEB-ARTICLE.SKR now supports the :css option that enables CSS - production and sets the CSS to be used. - - -Mon Jan 26 15:25:12 CET 2004 (Manuel Serrano): - - *** skr/html.skr: various HTML4.01 conformity fixes. - - -Sun Jan 25 18:31:19 CET 2004 (Manuel Serrano): - - *** skr/slide.skr: fix a error is the slide numbering. - - -Thu Jan 22 07:28:08 CET 2004 (Manuel Serrano): - - *** src/common/api.scm: fix a bug in multiple bib references. - - -Sun Jan 18 11:55:56 CET 2004 (Manuel Serrano): - - *** skr/html.skr: fix a bug in the HTML class attribute production. - - * src/bigloo/asm.scm: Creation of the assembly fontification (asm). - - -Sat Jan 17 18:26:00 CET 2004 (Manuel Serrano): - - * src/bigloo/api.sch, skr/slide.skr: Change the definition - of DEFINE-MARKUP. This macro now defines a function and a macro. - The macro adds an extra parameters called &SKRIBE-EVAL-LOCATION - that can be used inside the body of the defined function to retrieve - the location of the call. This is extremely useful for function - that defines new nodes. In general, it is desired that the location - associated with these nodes is the user call to the function that - has created the node, instead of the location of the call to - the constructor. - - -Fri Jan 16 06:56:14 CET 2004 (Manuel Serrano): - - * emacs/skribe.el.in: fontification of markups "PROG" and "SOURCE". - - * skr/html.skr, skr/web-article.skr: explicit introduction of two - dummy markups &HTML-DOCUMENT-HEADER and &HTML-DOCUMENT-TITLE for - enabling user fine-grain customizations. - - -Thu Jan 15 17:57:01 CET 2004 (Manuel Serrano): - - *** src/bigloo/eval.scm, src/bigloo/lib.bgl, src/bigloo/resolve.scm, - src/common/api.scm: - Improved location detection for unbound references (such as - unbound (ref :bib ...). - - -Wed Jan 14 08:03:18 CET 2004 (Manuel Serrano): - - * src/common/api.scm, src/common/bib.scm, src/bigloo/bib.bgl, - doc/user/bib.skb, doc/user/links.skb: change the bibliography - table mechanism. Bib tables are now first class citizen. - - -Tue Jan 13 16:22:30 CET 2004 (Manuel Serrano): - - * src/bigloo/eval.scm, src/bigloo/parse-args.scm, src/bigloo/lib.bgl, - src/common/api.scm, src/bigloo/source.scm, doc/user/lib.skb: - Creation of the SKRIBE-{IMAGE,BIB,SOURCE}-PATH and - SKRIBE-{IMAGE,BIB,SOURCE}-PATH-SET! functions. - - * src/common/api.scm, skr/html.skr, skr/latex.skr, doc/usr/image.skb: - Add :URL image option. - - -Tue Jan 13 09:02:18 CET 2004 (Manuel Serrano): - - *** src/bigloo/eval.scm, src/bigloo/parse-args.scm, doc/user/lib.skb: - Remove the SKRIBE-PATH-ADD! function. Only SKRIBE-PATH-SET! lefts. - - -Tue Jan 13 08:59:17 CET 2004 (Todd Dukes): - - *** configure: Fix illegal shell exports. - - -Mon Jan 12 13:50:29 CET 2004 (Manuel Serrano): - - * src/bigloo/eval.scm: Add the functions SKRIBE-PATH, SKRIBE-PATH-SET!, - and SKRIBE-PATH-ADD!. - - -Mon Jan 12 12:02:58 CET 2004 (Manuel Serrano): - - *** skr/latex.skr: fix when color were disabled. - - -Mon Jan 12 09:17:46 CET 2004 (Manuel Serrano): - - *** skr/html.skr: change the default value of css which used to - be '(quote ()) and which is now (). - - -Sat Jan 10 10:00:08 CET 2004 (Manuel Serrano): - - * src/common/api.scm, src/bigloo/types.scm, src/bigloo/output.scm: - Add the PROCEDURE field to PROCESSOR nodes . - - * skr/web-article.skb: Creation of this new package. - - -Fri Jan 9 15:35:03 CET 2004 (Manuel Serrano): - - * The slide.skr package is now documented in the user manual. - - * SKRIBE-LOAD and SKRIBE-LOAD-OPTIONS are now documented. - - -Wed Jan 7 16:37:52 CET 2004 (Manuel Serrano): - - * skr/html.skr, skr/latex.skr: fix &source-type and - &source-bracket markups implementation. - - -Wed Jan 7 11:29:16 CET 2004 (Manuel Serrano): - - * src/bigloo/color.scm: colors are lower case, the search - color search is lower case. - - *** src/bigloo/color.scm: fix a bug in the string search. - - *** skr/latex.skr: The LaTeX engines now uses the "symbol" itemize - option. - - *** skr/latex.skr: The LaTeX engines now uses the "key" item - option. - - -Wed Jan 7 06:12:53 CET 2004 (Manuel Serrano): - - * Add skribe-emacs-dir in emacs/skribe.el.in. - - * Add the skribe-indent-load in emacs/skribe.el.in. - - * Add --emacs-dir in etc/skribe-config. - - -Sat Jan 3 06:59:15 CET 2004 (Manuel Serrano): - - * etc/ChangeLog is now included in the distribution and included - in the Web page. - - * Extensions are now uploaded on the Skribe ftp server. They are - also listed from the Skribe Web page. - - -Fri Jan 2 21:21:52 CET 2004 (Manuel Serrano): - - * Add a chapter for skribe-config in the user documentation. - - * Creation of the directory documentation that gives information - about the installed extensions. - - -Thu Jan 1 06:21:39 CET 2004 (Manuel Serrano): - - * Implement the SUI link mechanisms. - - *** Fix RESOLVE-SEARCH-PARENT whose behavior was incorrect for orphans. - - * Add SKRIBE-DOC-DIR in configure.scm.in. - - -Dec 30 22:09:54 CET 2003 (Manuel Serrano): - - *** Fix FIND-MARKUP-IDENT whose return type was incorrect. - - * Add the :URL option to the INDEX markup. - - -Thu Dec 18 09:12:33 CET 2003 (Erick Gallesio, Manuel Serrano): - - ********* release 1.0a. - - -Wed Dec 17 10:22:27 CET 2003 (Manuel Serrano): - - * Change the processor nodes. The COMBINATOR argument is no longer - required to be a procedure. It can be #f. - - * Export predicates such as COMMAND?, UNRESOLVED? and PROCESSOR?. - Export the accessors associated with these primitive types. - - -Tue Dec 9 16:44:01 CET 2003 (Manuel Serrano): - - * the "q" markup now introduces a new node that is handled by the - engines. - - -Thu Dec 4 09:53:24 CET 2003 (Manuel Serrano): - - * Bib (Bigloo) manager now detects duplicate entries. - - *** Fix LaTeX engine (latex.skr). LaTeX titles (for chapters, - sections, ...) where incorrects. - - *** Various fixes in skribe.el. - - -Mon Nov 24 10:28:15 CET 2003 (Manuel Serrano): - - * Add -c, --custom command line options. - - * Re-design the SUI file generation. diff --git a/skribe/etc/Makefile b/skribe/etc/Makefile deleted file mode 100644 index 349fcf8..0000000 --- a/skribe/etc/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/etc/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:29:30 2003 */ -#* Last change : Sat Jan 3 06:40:19 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Skribe Meta etc Makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo etc/Makefile etc/skribe-config.in etc/ChangeLog - @ (cd bigloo && $(MAKE) pop) - @ (cd stklos && $(MAKE) pop) - -#*---------------------------------------------------------------------*/ -#* Install/Uninstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_EXTDIR) - cp skribe-config $(DESTDIR)$(INSTALL_BINDIR) && \ - chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe-config - -uninstall: - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe-config - -$(DESTDIR)$(INSTALL_EXTDIR): - mkdir -p $(DESTDIR)$(INSTALL_EXTDIR) && chmod a+rx $(DESTDIR)$(INSTALL_EXTDIR) - - -#*---------------------------------------------------------------------*/ -#* clean/distclean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - -clean: - (cd $(SYSTEM) && $(MAKE) clean) - -distclean: clean - (cd $(SYSTEM) && $(MAKE) distclean) - $(RM) -f skribe-config config diff --git a/skribe/etc/bigloo/Makefile b/skribe/etc/bigloo/Makefile deleted file mode 100644 index 82ffceb..0000000 --- a/skribe/etc/bigloo/Makefile +++ /dev/null @@ -1,114 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/etc/bigloo/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Thu Oct 23 08:58:55 2003 */ -#* Last change : Wed Nov 17 10:51:50 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Bigloo etc Makefile */ -#*=====================================================================*/ -include Makefile.skb -include ../Makefile.config - -#*---------------------------------------------------------------------*/ -#* TMPDIR */ -#*---------------------------------------------------------------------*/ -DISTRIBTMPDIR = /tmp -DISTRIBDIR = $$HOME/prgm/distrib - -#*---------------------------------------------------------------------*/ -#* POPULATION */ -#*---------------------------------------------------------------------*/ -POPULATION = configure Makefile Makefile.tpl - -#*---------------------------------------------------------------------*/ -#* distrib */ -#* ------------------------------------------------------------- */ -#* This rule must be executed in the main SKribe directory */ -#* (i.e. ../..). They must be run with a command such as: */ -#* "cd skribe; make -f etc/bigloo/Makefile distrib". */ -#*---------------------------------------------------------------------*/ -.PHONY: distrib distrib-src distrib-jvm - -distrib: distrib-src # distrib-jvm - -#*--- distrib-src -----------------------------------------------------*/ -distrib-src: - @ echo ">>> distrib-src"; \ - (skribedir=`pwd` \ - && /bin/rm -rf $(DISTRIBTMPDIR)/skribe \ - && mkdir -p $(DISTRIBTMPDIR)/skribe \ - && cd $(DISTRIBTMPDIR)/skribe \ - && $(MAKE) -f $$skribedir/Makefile -I $$skribedir checkout \ - && /bin/rm -rf contribs \ - && $(MAKE) -f $$skribedir/etc/bigloo/Makefile -I $$skribedir/etc/bigloo do-distrib-src \ - && $(RM) -rf $(DISTRIBTMPDIR)/skribe$(SKRIBERELEASE)) - -.PHONY: do-distrib-src -do-distrib-src: - (cd .. && \ - mv skribe skribe$(SKRIBERELEASE) && \ - tar cvfz $(DISTRIBDIR)/skribe$(SKRIBERELEASE).tar.gz skribe$(SKRIBERELEASE)) - -#*--- distrib-jvm -----------------------------------------------------*/ -distrib-jvm: - @ echo ">>> distrib-jvm"; \ - (skribedir=`pwd` \ - && /bin/rm -rf $(DISTRIBTMPDIR)/skribe \ - && mkdir -p $(DISTRIBTMPDIR)/skribe \ - && cd $(DISTRIBTMPDIR)/skribe \ - && $(MAKE) -f $$skribedir/Makefile -I $$skribedir checkout \ - && /bin/rm -rf contribs \ - && $(MAKE) -f $$skribedir/etc/bigloo/Makefile -I $$skribedir/etc/bigloo do-distrib-jvm \ - && $(RM) -rf $(DISTRIBTMPDIR)/skribe) - -.PHONY: do-distrib-jvm -do-distrib-jvm: lib bin lib/bigloo_s.zip - $(RM) -f $(DISTRIBDIR)/skribe$(SKRIBERELEASE).zip - (./configure --with-bigloo --jvm \ - && $(MAKE) \ - && cd .. \ - && zip -qr $(ZFLAGS) $(DISTRIBDIR)/skribe$(SKRIBERELEASE).zip \ - skribe \ - -x "*~" \ - -x "*/bin/*-bigloo" \ - -x "*.class" \ - -x "*.o") - -#*--- bigloo_s.zip ----------------------------------------------------*/ -lib/bigloo_s.zip: lib - cp $(FILDIR)/bigloo_s.zip $@ - -#*--- lib -------------------------------------------------------------*/ -lib: - mkdir -p lib - -#*--- bin -------------------------------------------------------------*/ -bin: - mkdir -p bin - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATION:%=etc/bigloo/%) - @ (cd autoconf && $(MAKE) -s pop) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - -clean: - /bin/rm -f ../../lib/bigloo_s.zip - -#*--- distclean -------------------------------------------------------*/ -distclean: - /bin/rm -f Makefile.skb - /bin/rm -f ../../src/common/configure.scm - - - diff --git a/skribe/etc/bigloo/Makefile.tpl b/skribe/etc/bigloo/Makefile.tpl deleted file mode 100644 index 24326c1..0000000 --- a/skribe/etc/bigloo/Makefile.tpl +++ /dev/null @@ -1,200 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/etc/bigloo/Makefile.tpl */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Wed Nov 7 09:20:47 2001 */ -#* Last change : Wed Feb 18 11:23:12 2004 (serrano) */ -#* Copyright : 2001-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* Standard Skribe makefile to build various libraries. */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* Compilers, Tools and Destinations */ -#*---------------------------------------------------------------------*/ -# The heap file -HEAP_FILE = $(LIB)/$(TARGETNAME).heap -HEAPJVM_FILE = $(LIB)/$(TARGETNAME).jheap -# Where to store the library class files -PBASE = bigloo.skribe.$(TARGETNAME) -CLASS_DIR = o/class_s/bigloo/skribe/$(TARGETNAME) -O_DIR = o - -BUNSAFEFLAGS = -unsafe - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .scm .class .o - -#*---------------------------------------------------------------------*/ -#* The implicit rules */ -#*---------------------------------------------------------------------*/ -$(O_DIR)/%.o: %.scm - $(BIGLOO) $(BUNSAFEFLAGS) $(BCFLAGS) $(BCOMMONFLAGS) -c $< -o $@ - -$(CLASS_DIR)/%.class: %.scm - $(BIGLOO) $(BUNSAFEFLAGS) $(BJVMFLAGS) $(BCOMMONFLAGS) -c $< -o $@ - -#*---------------------------------------------------------------------*/ -#* bin */ -#*---------------------------------------------------------------------*/ -.PHONY: bin-c bin-jvm - -#*--- bin-c -----------------------------------------------------------*/ -bin-c: $(TAGS) .afile .etags $(O_DIR) $(SKRIBEBINDIR)/$(TARGETNAME).bigloo - -$(SKRIBEBINDIR)/$(TARGETNAME).bigloo: $(OBJECTS) - $(BIGLOO) $(BUNSAFEFLAGS) $(BLINKFLAGS) $(BCOMMONFLAGS) $(OBJECTS) -o $(SKRIBEBINDIR)/$(TARGETNAME).bigloo - @ echo "$(SKRIBEBINDIR)/$(TARGETNAME).bigloo done..." - @ echo "-------------------------------" - -#*--- bin-jvm ---------------------------------------------------------*/ -bin-jvm: $(TAGS) .afile .etags .jfile $(CLASS_DIR) $(SKRIBEBINDIR)/$(TARGETNAME).zip - -$(SKRIBEBINDIR)/$(TARGETNAME).zip: $(CLASSES) - @ /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).zip - @ (cd $(O_DIR)/class_s; \ - $(ZIP) -q $(ZFLAGS) $(SKRIBEBINDIR)/$(TARGETNAME).zip -r .) - @ echo "$(SKRIBEBINDIR)/$(TARGETNAME).zip done..." - @ echo "-------------------------------" - -#*---------------------------------------------------------------------*/ -#* Directories */ -#*---------------------------------------------------------------------*/ -$(O_DIR): - mkdir -p $(O_DIR) - -$(CLASS_DIR): - mkdir -p $(CLASS_DIR) - -#*---------------------------------------------------------------------*/ -#* The heap construction */ -#*---------------------------------------------------------------------*/ -.PHONY: heap heap-c heap-jvm - -heap-c: $(HEAP_FILE) -heap-jvm: $(HEAPJVM_FILE) - -$(HEAP_FILE): .afile make-lib.scm - @ \rm -f $(HEAP_FILE) - @ $(BIGLOO) $(BHEAPFLAGS) make-lib.scm -addheap $(HEAP_FILE) - @ echo "Heap Done..." - @ echo "-------------------------------" - -$(HEAPJVM_FILE): .jfile .afile make-lib.scm - @ \rm -f $(HEAPJVM_FILE) - @ $(BIGLOO) -jvm $(BHEAPFLAGS) make-lib.scm -addheap $(HEAPJVM_FILE) - @ echo "Heap JVM Done..." - @ echo "-------------------------------" - -#*---------------------------------------------------------------------*/ -#* lib */ -#*---------------------------------------------------------------------*/ -.PHONY: lib-c lib-jvm - -#*--- lib-c -----------------------------------------------------------*/ -lib-c: $(TAGS) .afile lib.$(SHAREDSUFFIX) lib.a - -lib.$(SHAREDSUFFIX): $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) $(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX) -lib.a: $(LIB)/lib$(TARGETNAME)_s.a $(LIB)/lib$(TARGETNAME)_u.a - -$(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX): $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) - cd $(LIB); \ - /bin/rm -f lib$(TARGETNAME)_u.$(SHAREDSUFFIX); \ - ln -s lib$(TARGETNAME)_s.$(SHAREDSUFFIX) lib$(TARGETNAME)_u.$(SHAREDSUFFIX) - -$(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX): .afile $(OBJECTS) - @ /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) - @ $(LD) -o $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) $(OBJECTS) -lm -lc - @ echo "lib$(TARGETNAME)_s.$(SHAREDSUFFIX) Done..." - @ echo "-------------------------------" - -$(LIB)/lib$(TARGETNAME)_u.a: $(LIB)/lib$(TARGETNAME)_s.a - cd $(LIB); \ - /bin/rm -f lib$(TARGETNAME)_u.a; \ - ln -s lib$(TARGETNAME)_s.a lib$(TARGETNAME)_u.a - -$(LIB)/lib$(TARGETNAME)_s.a: .afile $(OBJECTS) - @ /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.a - @ $(AR) $(ARFLAGS) $(LIB)/lib$(TARGETNAME)_s.a $(OBJECTS) - @ $(RANLIB) $(LIB)/lib$(TARGETNAME)_s.a - @ echo "lib$(TARGETNAME)_s.a Done..." - @ echo "-------------------------------" - -#*--- lib-jvm ---------------------------------------------------------*/ -lib-jvm: $(TAGS) $(CLASS_DIR) lib.zip - -lib.zip: .afile .jfile $(CLASSES) - @ /bin/rm -f $(LIB)/$(TARGETNAME).zip - @ (cd $(O_DIR)/class_s; \ - $(ZIP) -q $(ZFLAGS) \ - $(LIB)/$(TARGETNAME)_s.zip \ - $(CLASS_DIR:$(O_DIR)/class_s/%=%)/*.class) - @ echo "lib$(TARGETNAME)_s.zip done..." - @ echo "-------------------------------" - -#*---------------------------------------------------------------------*/ -#* ude */ -#*---------------------------------------------------------------------*/ -.PHONY: ude -ude: - @ $(MAKE) -f Makefile .afile .etags - -.afile: $(SOURCES) - @ $(AFILE) -o .afile $(_BGL_SOURCES) - -.jfile: $(SOURCES) - @ $(JFILE) -o .jfile -pbase $(PBASE) $(SOURCES) - -.etags: $(SOURCES) - @ $(BTAGS) -o .etags $(_BGL_SOURCES) - -#*---------------------------------------------------------------------*/ -#* stdclean */ -#*---------------------------------------------------------------------*/ -stdclean: - /bin/rm -f $(OBJECTS) $(_BGL_OBJECTS:%=%.c) - /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).bigloo - /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).zip - /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) - /bin/rm -f $(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX) - /bin/rm -f .afile .etags .jfile - /bin/rm -rf $(O_DIR) - /bin/rm -f *~ - /bin/rm -f *.mco - -#*---------------------------------------------------------------------*/ -#* install/uninstall */ -#*---------------------------------------------------------------------*/ -install: - $(MAKE) install-$(TARGET) - -uninstall: - $(MAKE) uninstall-$(TARGET) - -install-c: $(DESTDIR)$(INSTALL_BINDIR) - cp $(SKRIBEBINDIR)/$(TARGETNAME).bigloo $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo - /bin/rm -f $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) - ln -s $(TARGETNAME).bigloo $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) - -uninstall-c: - /bin/rm $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo - /bin/rm $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) - -install-jvm: $(DESTDIR)$(INSTALL_FILDIR) - cp $(SKRIBEBINDIR)/$(TARGETNAME).zip $(DESTDIR)$(INSTALL_FILDIR)/$(TARGETNAME).zip - cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) - -uninstall-jvm: - /bin/rm $(DESTDIR)$(INSTALL_FILDIR)/$(TARGETNAME).zip - /bin/rm -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip - -$(DESTDIR)$(INSTALL_BINDIR): - mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) - -$(FILDIR): - mkdir -p $(FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) - diff --git a/skribe/etc/bigloo/autoconf/Makefile b/skribe/etc/bigloo/autoconf/Makefile deleted file mode 100644 index c077107..0000000 --- a/skribe/etc/bigloo/autoconf/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/etc/bigloo/autoconf/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Thu Jun 19 20:48:50 1997 */ -#* Last change : Sat Oct 25 08:34:37 2003 (serrano) */ -#* Copyright : 1997-2003 Manuel Serrano, see LICENSE file */ -#* ------------------------------------------------------------- */ -#* The global autoconf Makefile (mainly for backuping). */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* Flags */ -#*---------------------------------------------------------------------*/ -POPULATION = Makefile bversion getbversion blibdir gmaketest \ - blstlen bfildir - -#*---------------------------------------------------------------------*/ -#* pop ... */ -#*---------------------------------------------------------------------*/ -pop: - @ echo $(POPULATION:%=etc/bigloo/autoconf/%) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean cleanall distclean - -clean: - @ find . \( -name '*[~%]' \ - -o -name '.??*[~%]' \ - -o -name '#*#' \ - -o -name '?*#' \ - -o -name \*core \) \ - -type f -exec rm {} \; - @ echo "cleanup done..." - @ echo "-------------------------------" - -cleanall: clean -distclean: cleanall - -#*---------------------------------------------------------------------*/ -#* distrib */ -#*---------------------------------------------------------------------*/ -distrib: $(POPULATION) - @ if [ `pwd` = $$HOME/prgm/project/bglk/autoconf ]; then \ - echo "*** ERROR:Illegal dir to make a distrib `pwd`"; \ - exit 1; \ - fi - @ $(MAKE) clean - @ chmod a+rx $(POPULATION) - - diff --git a/skribe/etc/bigloo/autoconf/bfildir b/skribe/etc/bigloo/autoconf/bfildir deleted file mode 100755 index 128d5c7..0000000 --- a/skribe/etc/bigloo/autoconf/bfildir +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/scribe/autoconf/bfildir */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Tue Jan 12 14:53:33 1999 */ -#* Last change : Wed Aug 7 21:41:06 2002 (serrano) */ -#* ------------------------------------------------------------- */ -#* Find out the directory where Bigloo is installed */ -#*=====================================================================*/ -bigloo=bigloo - -#*---------------------------------------------------------------------*/ -#* We parse the arguments */ -#*---------------------------------------------------------------------*/ -while : ; do - case $1 in - "") - break;; - --bigloo=*|-bigloo=*) - bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; - - -*) - echo "Unknown option \"$1\", ignored" >&2;; - esac - shift -done - -#*---------------------------------------------------------------------*/ -#* We spawn a bigloo process to check its version number */ -#*---------------------------------------------------------------------*/ -$bigloo -q -eval "(begin (print *default-lib-dir*) (exit 0))" - -exit 0 - - diff --git a/skribe/etc/bigloo/autoconf/blibdir b/skribe/etc/bigloo/autoconf/blibdir deleted file mode 100755 index 603d484..0000000 --- a/skribe/etc/bigloo/autoconf/blibdir +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/scribe/autoconf/blibdir */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Tue Jan 12 14:53:33 1999 */ -#* Last change : Wed Aug 7 21:41:48 2002 (serrano) */ -#* ------------------------------------------------------------- */ -#* Find out the directory where Bigloo library is read. */ -#*=====================================================================*/ -bigloo=bigloo - -#*---------------------------------------------------------------------*/ -#* We parse the arguments */ -#*---------------------------------------------------------------------*/ -while : ; do - case $1 in - "") - break;; - --bigloo=*|-bigloo=*) - bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; - - -*) - echo "Unknown option \"$1\", ignored" >&2;; - esac - shift -done - -#*---------------------------------------------------------------------*/ -#* We spawn a bigloo process to check its version number */ -#*---------------------------------------------------------------------*/ -$bigloo -q -eval "(begin (print *ld-library-dir*) (exit 0))" - -exit 0 - - diff --git a/skribe/etc/bigloo/autoconf/bversion b/skribe/etc/bigloo/autoconf/bversion deleted file mode 100755 index 1f24c86..0000000 --- a/skribe/etc/bigloo/autoconf/bversion +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/scribe/autoconf/bversion */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Tue Jan 12 14:33:21 1999 */ -#* Last change : Sun Jan 13 07:30:21 2002 (serrano) */ -#* ------------------------------------------------------------- */ -#* Check the current bigloo version */ -#*=====================================================================*/ - -bigloo=bigloo -version=2.4b - -#*---------------------------------------------------------------------*/ -#* We parse the arguments */ -#*---------------------------------------------------------------------*/ -while : ; do - case $1 in - "") - break;; - --bigloo=*|-bigloo=*) - bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --version=*|-version=*) - version="`echo $1 | sed 's/^[-a-z]*=//'`";; - - -*) - echo "Unknown option \"$1\", ignored" >&2;; - esac - shift -done - -#*---------------------------------------------------------------------*/ -#* We spawn a bigloo process to check its version number */ -#*---------------------------------------------------------------------*/ -bver=`$bigloo -q -eval "(exit (print *bigloo-version*))"` -echo $bver - -$bigloo -q -eval "(exit (if (string>=? *bigloo-version* \"$version\") 0 1))" - -exit $? diff --git a/skribe/etc/bigloo/autoconf/getbversion b/skribe/etc/bigloo/autoconf/getbversion deleted file mode 100755 index ff83b1c..0000000 --- a/skribe/etc/bigloo/autoconf/getbversion +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/bglk/autoconf/getbversion */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Tue Jan 12 14:33:21 1999 */ -#* Last change : Mon May 22 10:47:46 2000 (serrano) */ -#* ------------------------------------------------------------- */ -#* Get the current bigloo version (with the level) */ -#*=====================================================================*/ - -bigloo=bigloo - -#*---------------------------------------------------------------------*/ -#* We parse the arguments */ -#*---------------------------------------------------------------------*/ -while : ; do - case $1 in - "") - break;; - --bigloo=*|-bigloo=*) - bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --version=*|-version=*) - version="`echo $1 | sed 's/^[-a-z]*=//'`";; - - -*) - echo "Unknown option \"$1\", ignored" >&2;; - esac - shift -done - -#*---------------------------------------------------------------------*/ -#* We spawn a bigloo process to check its version number */ -#*---------------------------------------------------------------------*/ -$bigloo -q -eval "(begin (print *bigloo-version*) (exit 0))" diff --git a/skribe/etc/bigloo/autoconf/gmaketest b/skribe/etc/bigloo/autoconf/gmaketest deleted file mode 100755 index 1bedd72..0000000 --- a/skribe/etc/bigloo/autoconf/gmaketest +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/bigloo/autoconf/gmaketest */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Thu Jan 14 10:31:33 1999 */ -#* Last change : Thu May 18 07:19:28 2000 (serrano) */ -#* ------------------------------------------------------------- */ -#* Checsk that Make is GNU make */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* flags */ -#*---------------------------------------------------------------------*/ -make=make - -#*---------------------------------------------------------------------*/ -#* We parse the arguments */ -#*---------------------------------------------------------------------*/ -while : ; do - case $1 in - "") - break;; - - --make=*) - make="`echo $1 | sed 's/^[-a-z]*=//'`";; - - -*) - echo "Unknown option \"$1\", ignored" >&2;; - esac - shift -done - -# Check the make version number -$make -v --version | grep -i "gnu make" > /dev/null - -# Return the grep result -exit $? diff --git a/skribe/etc/bigloo/configure b/skribe/etc/bigloo/configure deleted file mode 100755 index 9215911..0000000 --- a/skribe/etc/bigloo/configure +++ /dev/null @@ -1,552 +0,0 @@ -#!/bin/sh -#*=====================================================================*/ -#* serrano/prgm/project/skribe/etc/bigloo/configure */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Tue Jan 25 16:05:10 1994 */ -#* Last change : Tue Aug 24 10:31:53 2004 (serrano) */ -#* Copyright : 1994-2004 Manuel Serrano, see LICENSE file */ -#* ------------------------------------------------------------- */ -#* The skribe configuration file */ -#*=====================================================================*/ - -# the name of the current bigloo compiler -bigloo=bigloo -target=c - -# bigloo compilation flags -bcommonflags="-no-hello -fno-reflection" -blinkflags="-no-hello -ld-relative -O3" -boptflags="$bcommonflags -O3" -bsafeflags="$bcommonflags -g" -bflags="$boptflags" -bheapflags="-unsafe -q -mkaddheap -mkaddlib" -bcflags="-copt \"$""(CPICFLAGS)\"" -bjvmflags="-jvm -jvm-purify -saw -jvm-env SKRIBEPATH" -prcs=/usr/bin/prcs - -# the afile, jfile and btags binaries -afile=afile -jfile= -btags=btags -bdepend=bdepend - -# C compilation (left blank for automatic configuration (from Bigloo setup)) -cc= -cflags= -ldopt= - -# path (left blank for automatic configuration (from Bigloo setup)) -bgllibdir= -bglbindir= -bgllddir= -bgldocdir= -skribebindir= -skribelibdir= -skribefildir= -skribeskrdir= -skribeextdir= -skribedocdir= -skribemandir= - -# mask of Skribe intalled files -smask=755 - -#*---------------------------------------------------------------------*/ -#* !!! DON'T EDIT AFTER THIS COMMENT !!! */ -#*---------------------------------------------------------------------*/ -if [ "x$DISTRIBDIR" = "x" ]; then - distribdir=$HOME/prgm/distrib -else - distribdir=$DISTRIBDIR -fi - -if [ "x$SKRIBERELEASE" = "x" ]; then - echo "*** ERROR:configure:release. Aborting" - echo "Variable \"SKRIBERELEASE\" is unset." - exit 1; -else - release=$SKRIBERELEASE -fi - -if [ "x$SKRIBEBETARELEASE" = "x" ]; then - if [ -f $prcs ]; then - beta=`$prcs info skribe 2>&1 /dev/null | tail --lines=1 | awk '{ print $2 }' | sed 's/[0-9]*[.][0-9]*[a-z]*/&-beta/'` - elif [ -f /usr/local/bin/prcs ]; then - beta=`/usr/local/bin/prcs info skribe 2>&1 /dev/null | tail --lines=1 | awk '{ print $2 }' | sed 's/[0-9]*[.][0-9]*[a-z]*/&-beta/'` - else - beta=no - fi -else - beta=$SKRIBEBETARELEASE -fi - -if [ "x$SKRIBEURL" = "x" ]; then - skribeurl="http://www.inria.fr/mimosa/fp/Skribe" -else - skribeurl=$SKRIBEURL -fi - -requiredbigloo=2.6c - -action=all -makefile_config=Makefile.skb -skribe_config=../../src/common/configure.scm -summary=yes - -http="www-sop.inria.fr/mimosa/fp" -autoconfdir=`dirname $0 2> /dev/null`/autoconf -bootconfig=false; - -if [ $? != "0" ]; then - autoconfdir="autoconf" -fi - -# Argument parsing -while : ; do - case $1 in - "") - break;; - - -c) - target=c;; - - -j|--jvm) - target=jvm;; - - -|--dotnet) - target=dotnet;; - - --skribe_config=*) - action="skribe_config"; - skribe_config="`echo $1 | sed 's/^[-a-z_.]*=//'`";; - - --makefile.skb=*) - action="makefile.skb"; - makefile_config="`echo $1 | sed 's/^[-Da-z.]*=//'`";; - - --bglbindir=*) - bglbindir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bgllibdir=*) - bgllibdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bgllddir=*) - bgllddir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bgldocdir=*) - bgldocdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bindir=*) - skribebindir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --libdir=*) - skribelibdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --fildir=*) - skribefildir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --skrdir=*) - skribeskrdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --extdir=*) - skribeextdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --docdir=*) - skribedocdir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --mandir=*) - skribemandir="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bigloo=*) - bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --afile=*) - afile="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --jfile=*) - jfile="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --btags=*) - btags="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --mask=*) - smask="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --cc=*) - cc="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --cflags=*) - cflags="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --ldopt=*) - ldopt="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --backends=*) - backends="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --no-summary) - summary=no;; - - --debug) - bflags="-g -cg $bsafeflags";; - - --debug2) - bflags="-g2 -cg $bsafeflags";; - - --debug3) - bflags="-g3 -cg $bsafeflags";; - - --optimize) - bflags=$boptflags;; - - --bjvmflags=*) - bjvmflags="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --bcflags=*) - bcflags="`echo $1 | sed 's/^[-a-z]*=//'`";; - - --prefix=*) - prefix="`echo $1 | sed 's/^[^=]*=//'`"; - skribebindir=$prefix/bin; - skribeskrdir=$prefix/share/skribe/$release/skr; - skribeextdir=$prefix/share/skribe/extensions; - skribelibdir=$prefix/lib - skribefildir=$skribelibdir/skribe/$release; - skribemandir=$prefix/man/man1; - skribedocdir=$prefix/doc/skribe-$release;; - - --bootconfig) - bootconfig=true;; - - -*) - echo "*** Configure error, unknown option $1" >&2; - echo >&2; - echo "Usage: configure --with-bigloo [options]" >&2; - echo " -c.................... uses the Bigloo C back-end" >&2; - echo " -j|--jvm.............. uses the Bigloo JVM back-end" >&2; - echo " -d|--dotnet........... uses the Bigloo .NET back-end" >&2; - echo " --skribe_config=file.. sets the name of the skribe-config file" >&2; - echo " --makefile.skb=file... sets the name of the Makefile.skb file" >&2; - echo " --prefix=dir.......... prefix to Skribe install" >&2; - echo " --bindir=file......... alternative Skribe bin directory" >&2; - echo " --libdir=file......... alternative Skribe lib directory" >&2; - echo " --fildir=file......... alternative Skribe file directory" >&2; - echo " --skrdir=file......... Skribe skr directory" >&2; - echo " --bglbindir=file...... Bigloo bin directory" >&2; - echo " --bgllibdir=file...... Bigloo lib directory" >&2; - echo " --bglfildir=file...... Bigloo file directory" >&2; - echo " --bgldocdir=file...... Bigloo doc directory" >&2; - echo " --docdir=file......... Documentation directory" >&2; - echo " --mandir=file......... Manual pages directory" >&2; - echo " --bigloo=comp......... The Bigloo compiler" >&2; - echo " --afile=afile......... The Bigloo afile tool" >&2; - echo " --jfile=jfile......... The Bigloo jfile tool" >&2; - echo " --btags=btags......... The Bigloo btags tool" >&2; - echo " --cc=comp............. The C compiler (for C back-end)" >&2; - echo " --cflags=args......... The C compilation options" >&2; - echo " --ldopt=args.......... The C link options" >&2; - echo " --smask=mask.......... The installation mask" >&2; - echo " --no-summary.......... Private option" >&2; - echo " --debug............... Enables Bigloo debug mode" >&2; - echo " --optimize............ Enables Bigloo optimization mode (default)" >&2; - echo " --bootconfig.......... Private option" >&2; - exit -1; - esac - shift -done - -#*---------------------------------------------------------------------*/ -#* First check if bigloo exists and if it is recent enough */ -#*---------------------------------------------------------------------*/ -if [ ! -f $bigloo ]; then - which $bigloo > /dev/null 2> /dev/null - if [ "$?" != "0" ]; then - echo "*** ERROR:configure:bigloo. Aborting" - echo "Can't find bigloo." - exit 1; - fi -fi - -installedbigloo=`$autoconfdir/bversion --bigloo=$bigloo --version=$requiredbigloo` - -if [ $? != "0" ]; then - echo "*** ERROR:configure:bigloo. Aborting" - echo "Your version ($installedbigloo) of Bigloo is too old." - echo "Release $requiredbigloo or more recent is required." - echo "Bigloo may be downloaded from $http" - exit 1; -fi - -#*---------------------------------------------------------------------*/ -#* The binary directory */ -#*---------------------------------------------------------------------*/ -if [ "$bglbindir " = " " ]; then - if [ "$bigloo " = " " ]; then - bgl=`which bigloo`; - else - bgl=`which $bigloo`; - fi - bglbindir=`dirname $bgl` -fi -if [ "$skribebindir " = " " ]; then - skribebindir=$prefix/bin; -fi - -#*---------------------------------------------------------------------*/ -#* The Bigloo library directory */ -#*---------------------------------------------------------------------*/ -if [ "$bgllibdir " = " " ]; then - bgllibdir=`$autoconfdir/blibdir --bigloo="$bigloo"` -fi -if [ "$bglfildir " = " " ]; then - bglfildir=`$autoconfdir/bfildir --bigloo="$bigloo"` -fi - -#*---------------------------------------------------------------------*/ -#* We check the installed Bigloo Makefile.config file */ -#*---------------------------------------------------------------------*/ -if [ ! -f $bglfildir/Makefile.config ]; then - echo "*** ERROR:configure:Can't find Makefile.config file" - echo "Should be $bglfildir/Makefile.config." - exit 1; -fi - -#*---------------------------------------------------------------------*/ -#* jfile */ -#*---------------------------------------------------------------------*/ -if [ "$jfile " = " " ]; then - if [ ! -f $bigloo ]; then - which jfile > /dev/null 2> /dev/null - if [ "$?" != "0" ]; then - jfile=true; - else - jfile=jfile; - fi - fi -fi - -#*---------------------------------------------------------------------*/ -#* We are now able to set the correct value for cc since we know */ -#* what Bigloo is. */ -#*---------------------------------------------------------------------*/ -if [ "$cc " = " " ]; then - cc=`$bigloo -eval '(begin (print *cc*) (exit 0))'` -fi - -if [ "$cflags " = " " ]; then - cflags=`grep '^CFLAGS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` -fi - -ldflags=`grep '^EXTRALIBS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` -cpicflags=`grep '^CPICFLAGS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` - -#*---------------------------------------------------------------------*/ -#* Completing dirs */ -#*---------------------------------------------------------------------*/ -if [ "$skribelibdir " = " " ]; then - skribelibdir=$prefix/lib; -fi -if [ "$skribefildir " = " " ]; then - skribefildir=$skribelibdir/skribe/$release; -fi -if [ "$skribeskrdir " = " " ]; then - skribeskrdir=$prefix/share/skribe/$release/skr; -fi -if [ "$skribeextdir " = " " ]; then - skribeextdir=$prefix/share/skribe/extensions; -fi -if [ "$bgldocdir " = " " ]; then - bgldocdir=`grep '^DOCDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//' | sed 's/[$][(][^)]*[)]//'` -fi -if [ "$skribedocdir " = " " ]; then - skribedocdir=`dirname $bgldocdir`/skribe-$release -fi -if [ "$skribemandir " = " " ]; then - skribemandir=`grep '^MANDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` -fi -if [ "$skribeemacsdir " = " " ]; then - skribeemacsdir=`grep '^EMACSDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` -fi - -#*---------------------------------------------------------------------*/ -#* emacs/skribe.el */ -#*---------------------------------------------------------------------*/ -cat ../../emacs/skribe.el \ - | sed "s|@SKRIBE_EMACSDIR@|$skribeemacsdir|" \ - | sed "s|@SKRIBE_HOSTSCHEMEDOCDIR@|$bgldocdir|" \ - > ../../emacs/skribe.el.aux \ - && mv ../../emacs/skribe.el.aux ../../emacs/skribe.el - -#*---------------------------------------------------------------------*/ -#* etc/skribe-config */ -#*---------------------------------------------------------------------*/ -cat ../skribe-config \ - | sed "s|@SKRIBE_EMACS_DIR@|$skribeemacsdir|" \ - > ../skribe-config.aux \ - && mv ../skribe-config.aux ../skribe-config - -#*---------------------------------------------------------------------*/ -#* makefile.skb */ -#* ------------------------------------------------------------- */ -#* This part of the configure script produces the file */ -#* makefile.skb. This file contains machine dependant */ -#* informations and location where Bigloo is to be installed. */ -#*---------------------------------------------------------------------*/ -if [ $action = "all" -o $action = "makefile.skb" ]; then - - # We create an unexisting temporary file name - name=foo - while( test -f "$name.c" -o -f "$name.o" ); do - name="$name"x; - done - - # We check the C compiler - cat > $name.c </dev/null 2>&1 - then - true - else - echo "***ERROR:configure:$cc:Can't compile c file -- $cc $cflags -c $name.c"; - /bin/rm -f $name.c $name.o $name.a; - exit 1 - fi - /bin/rm -f $name.c $name.o $name.a; - - # We first cleanup the general Makefile config - rm -f ../Makefile.config 2> /dev/null - echo "## Skribe ($release) configure" > ../Makefile.config - echo "## Don't edit, file generated by etc/bigloo/configure" >> ../Makefile.config - echo "SKRIBERELEASE=$release" >> ../Makefile.config - echo "SKRIBEBETARELEASE=$beta" >> ../Makefile.config - echo >> ../Makefile.config - echo "SYSTEM=bigloo" >> ../Makefile.config - case $target in - jvm) - echo 'SKRIBE=java -classpath $(BINDIR)/skribe.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.main' >> ../Makefile.config; - echo 'SKRIBEINFO=java -classpath $(BINDIR)/skribeinfo.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.skribeinfo.main' >> ../Makefile.config; - echo 'SKRIBEBIBTEX=java -classpath $(BINDIR)/skribebibtex.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.skribebibtex.main' >> ../Makefile.config;; - *) - echo 'SKRIBE=$'"(BINDIR)/skribe.bigloo" >> ../Makefile.config; - echo 'SKRIBEINFO=$'"(BINDIR)/skribeinfo.bigloo" >> ../Makefile.config; - echo 'SKRIBEBIBTEX=$'"(BINDIR)/skribebibtex.bigloo" >> ../Makefile.config;; - esac - - # We first cleanup the file - rm -f $makefile_config 2> /dev/null - touch $makefile_config - echo "## Skribe ($release) configure" >> $makefile_config - echo "## Don't edit, file generated by etc/bigloo/configure" >> $makefile_config - echo >> $makefile_config - - # The Bigloo target (c, jvm, dotnet) - echo "TARGET=$target" >> $makefile_config - echo >> $makefile_config - - # The boot directories - echo "SKRIBEDIR=`pwd`/../.." >> $makefile_config - echo 'SKRIBEBINDIR=$'"(SKRIBEDIR)/bin" >> $makefile_config; - echo 'SKRIBELIBDIR=$'"(SKRIBEDIR)/lib" >> $makefile_config; - echo 'SKRIBEFILDIR=$'"(SKRIBEDIR)/lib" >> $makefile_config; - echo >> $makefile_config - - # The distribution directory - echo "DISTRIBDIR=$distribdir" >> $makefile_config - echo >> $makefile_config - - # The installation directories - echo "INSTALL_BINDIR=$skribebindir" >> $makefile_config - echo "INSTALL_LIBDIR=$skribelibdir" >> $makefile_config - echo "INSTALL_FILDIR=$skribefildir" >> $makefile_config - echo "INSTALL_SKRDIR=$skribeskrdir" >> $makefile_config - echo "INSTALL_EXTDIR=$skribeextdir" >> $makefile_config - if [ ! "$skribedocdir " = " " ]; then - echo "INSTALL_DOCDIR=$skribedocdir" >> $makefile_config; - fi - if [ ! "$skribemandir " = " " ]; then - echo "INSTALL_MANDIR=$skribemandir" >> $makefile_config; - fi - echo "INSTALL_HOSTHTTP=$skribehttphost" >> $makefile_config - echo "INSTALL_MASK=$smask" >> $makefile_config - echo >> $makefile_config - - # The bigloo configuration - cat $bglfildir/Makefile.config >> $makefile_config - echo >> $makefile_config - - # The bigloo compiler - echo "BIGLOO=$bigloo" >> $makefile_config - echo "BIGLOO_FILDIR=$bglfildir" >> $makefile_config - echo "BIGLOO_LIBDIR=$bgllibdir" >> $makefile_config - echo >> $makefile_config - - # The bigloo compiler options - echo "BLINKFLAGS=$blinkflags -ldopt '$ldopt'" >> $makefile_config - echo "BSAFEFLAGS=$bsafeflags" >> $makefile_config - echo "BHEAPFLAGS=$bheapflags" >> $makefile_config - echo "BCOMMONFLAGS=$bflags" >> $makefile_config - echo "BCFLAGS=$bcflags" >> $makefile_config - echo "BJVMFLAGS=$bjvmflags" >> $makefile_config - echo >> $makefile_config - - # Bigloo bde - echo "AFILE=$afile" >> $makefile_config - echo "JFILE=$jfile" >> $makefile_config - echo "BTAGS=$btags" >> $makefile_config - echo "BDEPEND=$bdepend" >> $makefile_config - echo "SKRIBEINDENT=bpp" >> $makefile_config - echo >> $makefile_config - - # Misc - echo "RM=/bin/rm" >> $makefile_config - echo >> $makefile_config -fi - -#*---------------------------------------------------------------------*/ -#* Ok, we are done now */ -#*---------------------------------------------------------------------*/ -if [ "$summary" = "yes" ]; then - echo - echo - echo "** Configuration summary **" - echo - echo "Release number:" - echo " Skribe release number................. $release" - echo " Skribe beta number.................... $beta" - echo " Minimum Bigloo version required....... $requiredbigloo" - echo " Installed Bigloo version.............. $installedbigloo" - echo - echo "Compilers:" - echo " Bigloo................................ $bigloo" - echo " Bigloo link flags..................... $blinkflags" - echo " Bigloo compilation flags.............. $bflags" - echo " Bigloo heap flags..................... $bheapflags" - echo " afile................................. $afile" - echo " jfile................................. $jfile" - echo " btags................................. $btags" - echo " cc.................................... $cc" - echo " cc compilation flags.................. $cflags" - echo " link options.......................... $ldopt" - echo - echo "Path:" - echo " Binary directory...................... $skribebindir" - echo " Skr directory......................... $skribeskrdir" - echo " Extensions directory.................. $skribeextdir" - echo " File directory........................ $skribefildir" - echo " Library directory..................... $skribelibdir" - echo " Documentation directory............... $skribedocdir" - echo " Man pages directory................... $skribemandir" - echo " Home page............................. $skribeurl" - echo - echo "Misc configuration:" - echo " mask for installed files.............. $smask" - echo - echo "Emacs:" - echo " Emacs Lisp files directory............ $skribeemacsdir" - echo -fi diff --git a/skribe/etc/skribe-config.in b/skribe/etc/skribe-config.in deleted file mode 100644 index 2a03e26..0000000 --- a/skribe/etc/skribe-config.in +++ /dev/null @@ -1,64 +0,0 @@ -#!/bin/sh -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 19-Nov-2003 21:04 (eg) -# Last file update: 19-Nov-2003 22:29 (eg) - - -function usage() -{ - cat <&2 -fi - -while test $# -gt 0; do - case $1 in - --prefix|-p) - echo @PREFIX@ - ;; - --version|-v) - echo @SKRIBE_RELEASE@ - ;; - --extension-dir|-e) - echo @SKRIBE_EXT_DIR@ - ;; - --skr-dir|-k) - echo @SKRIBE_SKR_DIR@ - ;; - --doc-dir|-d) - echo @SKRIBE_DOC_DIR@ - ;; - --emacs-dir|-m) - echo @SKRIBE_EMACS_DIR@ - ;; - --scheme|-s) - echo @SYSTEM@ - ;; - --help|-h|-\?) - usage 0 1>&2 - ;; - *) - echo "bad option $1" 1>&2 - usage 1 1>&2 - ;; - esac - shift -done -exit 0 - diff --git a/skribe/etc/stklos/Makefile.config.in b/skribe/etc/stklos/Makefile.config.in deleted file mode 100644 index 13a60d8..0000000 --- a/skribe/etc/stklos/Makefile.config.in +++ /dev/null @@ -1,5 +0,0 @@ -SYSTEM=@SYSTEM@ -SKRIBE=@SKRIBE@ -SKRIBEINFO=@SKRIBEINFO@ -SKRIBEBIBTEX=@SKRIBEBIBTEX@ - diff --git a/skribe/etc/stklos/Makefile.in b/skribe/etc/stklos/Makefile.in deleted file mode 100644 index 186fd58..0000000 --- a/skribe/etc/stklos/Makefile.in +++ /dev/null @@ -1,44 +0,0 @@ -# -# Makefile.in -- Skribe Makefile for Stklos -# -# Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI -# -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 10-Aug-2003 17:31 (eg) -# Last file update: 10-Nov-2003 19:48 (eg) -# - -PRCS_FILES=Makefile.config.in Makefile.in Makefile.skb.in configure.in \ -configure - -all: configure - - -configure: configure.in - autoconf - -clean: - /bin/rm -f config.* *~ - -pop: - @echo $(PRCS_FILES:%=etc/stklos/%) - -distclean: clean - (cd ../../src/stklos/; $(MAKE) distclean) - /bin/rm -f Makefile Makefile.skb ../Makefile.config diff --git a/skribe/etc/stklos/Makefile.skb.in b/skribe/etc/stklos/Makefile.skb.in deleted file mode 100644 index 7568474..0000000 --- a/skribe/etc/stklos/Makefile.skb.in +++ /dev/null @@ -1,5 +0,0 @@ -BMASK=0755 -INSTALL_DOCDIR=@PREFIX@/share/doc/skribe-@SKRIBE_RELEASE@ -INSTALL_BINDIR=@PREFIX@/bin -INSTALL_SKRDIR=@PREFIX@/share/skribe/@SKRIBE_RELEASE@/skr -INSTALL_EXTDIR=@PREFIX@/share/skribe/extensions diff --git a/skribe/etc/stklos/configure b/skribe/etc/stklos/configure deleted file mode 100755 index e1d2526..0000000 --- a/skribe/etc/stklos/configure +++ /dev/null @@ -1,830 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.13 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -SHELL=${CONFIG_SHELL-/bin/sh} -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.13" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=../../src/common/api.scm - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -ac_exeext= -ac_objext=o -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - -### AM_INIT_AUTOMAKE(skribe,0.0) -PACKAGE=skribe - -SYSTEM=stklos -SKRIBE='$(BINDIR)/skribe.stklos' -SKRIBEBIBTEX='$(BINDIR)/skribebibtex.stklos' - -## -## Initialize prefix -## -if test "${prefix}" = "NONE" -o "$prefix" = "" ;then - prefix="/usr/local" -fi - -## -## Get information from ../config -## -if test -f ../config ;then - . ../config -else - echo "You must configure Skribe from the ../.. directory" - exit 1 -fi - - -PREFIX=$prefix -SKRIBE_RELEASE=${release} -SKRIBE_URL=${skribeurl} - -## -## Substitutions -## - - - - - - - - - -# -# Outputs -# -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set | grep ac_space) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -cat > conftest.defs <<\EOF -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g -s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g -s%\[%\\&%g -s%\]%\\&%g -s%\$%$$%g -EOF -DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` -rm -f conftest.defs - - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS </dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.13" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir - -trap 'rm -fr `echo "Makefile ../../src/stklos/Makefile Makefile.config Makefile.skb" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@SHELL@%$SHELL%g -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@FFLAGS@%$FFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@PACKAGE@%$PACKAGE%g -s%@PREFIX@%$PREFIX%g -s%@SKRIBE_RELEASE@%$SKRIBE_RELEASE%g -s%@SKRIBE_URL@%$SKRIBE_URL%g -s%@SYSTEM@%$SYSTEM%g -s%@SKRIBE@%$SKRIBE%g -s%@SKRIBEINFO@%$SKRIBEINFO%g -s%@SKRIBEBIBTEX@%$SKRIBEBIBTEX%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -EOF -cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF - -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - - -# Makefile.config must be in the parent directory -mv Makefile.config .. - diff --git a/skribe/etc/stklos/configure.in b/skribe/etc/stklos/configure.in deleted file mode 100644 index 956af77..0000000 --- a/skribe/etc/stklos/configure.in +++ /dev/null @@ -1,57 +0,0 @@ -dnl -dnl Configure.in for Skribe -dnl -dnl Author: Erick Gallesio [eg@essi.fr] -dnl Creation date: 23-Jul-2003 12:04 (eg) -dnl Last file update: 26-Oct-2004 20:24 (eg) - -AC_INIT(../../src/common/api.scm) -### AM_INIT_AUTOMAKE(skribe,0.0) -PACKAGE=skribe - -SYSTEM=stklos -SKRIBE='$(BINDIR)/skribe.stklos' -SKRIBEBIBTEX='$(BINDIR)/skribebibtex.stklos' - -## -## Initialize prefix -## -if test "${prefix}" = "NONE" -o "$prefix" = "" ;then - prefix="/usr/local" -fi - -## -## Get information from ../config -## -if test -f ../config ;then - . ../config -else - echo "You must configure Skribe from the ../.. directory" - exit 1 -fi - - -PREFIX=$prefix -SKRIBE_RELEASE=${release} -SKRIBE_URL=${skribeurl} - -## -## Substitutions -## -AC_SUBST(PACKAGE) -AC_SUBST(PREFIX) -AC_SUBST(SKRIBE_RELEASE) -AC_SUBST(SKRIBE_URL) -AC_SUBST(SYSTEM) -AC_SUBST(SKRIBE) -AC_SUBST(SKRIBEINFO) -AC_SUBST(SKRIBEBIBTEX) - -# -# Outputs -# -AC_OUTPUT(Makefile ../../src/stklos/Makefile Makefile.config Makefile.skb) - -# Makefile.config must be in the parent directory -mv Makefile.config .. - diff --git a/skribe/examples/Makefile b/skribe/examples/Makefile deleted file mode 100644 index 7f47f6e..0000000 --- a/skribe/examples/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/examples/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Fri Oct 24 13:25:43 2003 */ -#* Last change : Wed Feb 18 11:25:20 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The meta Makefile for the examples */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* All the examples */ -#*---------------------------------------------------------------------*/ -EXAMPLES=slide - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ for p in $(EXAMPLES); do \ - (cd $$p && $(MAKE) pop); \ - done - @ echo examples/Makefile - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - -uninstall: - -#*---------------------------------------------------------------------*/ -#* cleaning */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - -clean: - for p in $(EXAMPLES); do \ - (cd $$p && $(MAKE) clean); \ - done - -distclean: clean - diff --git a/skribe/examples/slide/Makefile b/skribe/examples/slide/Makefile deleted file mode 100644 index c9b7a84..0000000 --- a/skribe/examples/slide/Makefile +++ /dev/null @@ -1,153 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/examples/slide/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Fri Jan 11 10:19:46 2002 */ -#* Last change : Thu Dec 18 09:21:41 2003 (serrano) */ -#* Copyright : 2002-03 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Slides example */ -#*=====================================================================*/ -include ../../etc/Makefile.config -include ../../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compiler and tools */ -#*---------------------------------------------------------------------*/ -BINDIR = ../../bin -LIBDIR = ../../lib - -#*---------------------------------------------------------------------*/ -#* Compilers and Tools */ -#*---------------------------------------------------------------------*/ -SFLAGS = -I txt -I skr -I skb -I ../../skr -LATEX = latex -DVIPS = dvips -Ppdf -G0 -TEXHOME = $$HOME/tex -PS2PDF = ps2pdf -dPDFSETTINGS=/prepress -sPAPERSIZE=a4 -MODE = advi - -#*---------------------------------------------------------------------*/ -#* Skribe variables */ -#*---------------------------------------------------------------------*/ -SKRIBEVARS = --eval "(define *mode* '$(MODE))" - -#*---------------------------------------------------------------------*/ -#* Sources */ -#*---------------------------------------------------------------------*/ -MASTER = skb/slides.skb - -INPUTSNAME = -EXNAME = skribe.skb syntax.scr -INPUTS = $(INPUTSNAME:%=skb/%.skb) $(EXNAME:%=ex/%) - -SOURCESNAME = -SOURCES = $(SOURCESNAME:%=scm/%.scm) - -STYLES = local -LSTYLES = $(STYLE:%=skr/%.skr) - -FIGS_SOURCES = -FIGURES = $(FIGS_SOURCES:%=fig/%.eps) $(FIGS_SOURCES:%=fig/%.png) - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .skb .skr .eps .fig .tex .ps .pdf .png .html .dvi - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -all: ps html - -ps: slides.ps -slides.ps: slides.dvi - $(DVIPS) -o slides.ps slides.dvi - -pdf: slides.pdf -slides.pdf: slides.ps - $(PS2PDF) slides.ps slides.pdf - -dvi: slides.dvi -slides.dvi: slides.tex - $(LATEX) slides.tex - -slides.tex: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) - $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -o slides.tex - -html: slides.html -slides.html: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) - $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -o slides.html - -text: slides.text -slides.text: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) - $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -t text -o slides.text - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo examples/slide/Makefile \ - examples/slide/README \ - examples/slide/advi.sty \ - examples/slide/PPRskribe.sty \ - examples/slide/skr/local.skr - @ echo $(MASTER:%=examples/slide/%) - @ echo $(EXNAME:%=examples/slide/ex/%) - -#*---------------------------------------------------------------------*/ -#* binary */ -#*---------------------------------------------------------------------*/ -getbinary: - echo "slides" - -#*---------------------------------------------------------------------*/ -#* re */ -#*---------------------------------------------------------------------*/ -.PHONY: re re.ps re.html - -re: re.ps re.html - -re.ps: - touch -m -d 0 slides.tex - $(MAKE) ps - -re.html: - touch -m -d 0 slides.html - $(MAKE) html - -#*---------------------------------------------------------------------*/ -#* .eps.png */ -#*---------------------------------------------------------------------*/ -.eps.png: - @ echo $*.png: - @ convert $*.eps $*.png - -#*---------------------------------------------------------------------*/ -#* .eps.fig */ -#*---------------------------------------------------------------------*/ -.fig.eps: - @ echo $*.fig: - @ fig2dev -L eps $*.fig > $*.eps - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -clean: - -/bin/rm -f slides.tex 2> /dev/null - -/bin/rm -f slides.dvi 2> /dev/null - -/bin/rm -f *.aux *.log 2> /dev/null - -/bin/rm -f *~ 2> /dev/null - -/bin/rm -f */*~ 2> /dev/null - -/bin/rm -f */*/*~ 2> /dev/null - -/bin/rm -f slides.ps 2> /dev/null - -/bin/rm -f slides.pdf 2> /dev/null - -/bin/rm -f slides*.html 2> /dev/null - -/bin/rm -f slides.text 2> /dev/null - -/bin/rm -f slides.out 2> /dev/null - -/bin/rm -f $(FIGURES) - -cleanall: clean diff --git a/skribe/examples/slide/PPRskribe.sty b/skribe/examples/slide/PPRskribe.sty deleted file mode 100644 index 40b2d08..0000000 --- a/skribe/examples/slide/PPRskribe.sty +++ /dev/null @@ -1,67 +0,0 @@ -%============================================================================== -% Prosper -- (PPRskribe.sty) Style file -% A LaTeX class for creating slides -% Author: Manuel Serrano -% -% Permission is hereby granted, without written agreement and without -% license or royalty fees, to use, copy, modify, and distribute this -% software and its documentation for any purpose, provided that the -% above copyright notice and the following two paragraphs appear in -% all copies of this software. -% -% IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, -% SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF -% THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED -% OF THE POSSIBILITY OF SUCH DAMAGE. -% -% THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, -% INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY -% AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS -% ON AN "AS IS" BASIS, AND THE AUTHOR HAS NO OBLIGATION TO -% PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. -%============================================================================== -\NeedsTeXFormat{LaTeX2e}[1995/12/01] -\ProvidesPackage{PPRskribe}[2003/10/21] -\typeout{`skribe' style for Prosper ---} -\typeout{ } - -\RequirePackage{amssymb} -% Loading packages necessary to define this slide style. -% none - -\FontTitle{% - \usefont{T1}{ptm}{b}{n}\fontsize{13.82pt}{12pt}\selectfont\blue}{% - \usefont{T1}{ptm}{b}{n}\fontsize{13.82pt}{12pt}\selectfont\blue} -\FontText{% - \black\usefont{T1}{phv}{m}{n}\fontsize{9.4pt}{9pt}\selectfont}{% - \black\usefont{T1}{phv}{m}{n}\fontsize{9.4pt}{9pt}\selectfont} - - -% Positionning of the title of a slide. -\newcommand{\slidetitle}[1]{% - \rput[c](5.25,4.4){\fontTitle{#1}} -} - -% Positionning for a logo -% \LogoPosition{-1,-1.1} - -% Definition of this style for slides. - -\newcommand{\BasicFrame}[1]{% - {#1}} - -%\NewSlideStyle[115mm]{t}{5.3,3.2}{BasicFrame} -\NewSlideStyle[125mm]{t}{5.3,3.8}{BasicFrame} -\PDFCroppingBox{10 40 594 800} -\RequirePackage{semhelv} - -\myitem{1}{$\bullet$} -\myitem{2}{$\circ$} -\myitem{3}{$\diamond$} - -\endinput - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: t -%%% End: diff --git a/skribe/examples/slide/README b/skribe/examples/slide/README deleted file mode 100644 index cb9f303..0000000 --- a/skribe/examples/slide/README +++ /dev/null @@ -1,11 +0,0 @@ -This example shows how to program slides with Skribe. Three slide -formats can be produced: - -1. Advi - type `make MODE=advi' - -2. Plain PDF - type `make pdf MODE=pdf' - -3. LaTeX prosper - type `make pdf MODE=prosper' diff --git a/skribe/examples/slide/advi.sty b/skribe/examples/slide/advi.sty deleted file mode 100644 index 9b5e09f..0000000 --- a/skribe/examples/slide/advi.sty +++ /dev/null @@ -1,416 +0,0 @@ -%% -%% This is the original source file advi.sty -%% -%% Package `advi' to use with LaTeX 2e -%% Copyright Roberto Di Cosmo, Jun Furuse, Didier Remy, and Pierre Weis -%% All rights reserved. - -% Which name is ours -\def \ActiveDVI {Active-DVI} - -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{advi} - [2001/29/08 v0.40 Advi Package for advi Previewer] - -%% - -%% Identification -%% Preliminary declarations - -\RequirePackage {keyval} - -%% Options - -\newif \ifadvi@ignore \advi@ignorefalse -\DeclareOption {ignore}{\advi@ignoretrue} - -\ProcessOptions -% \@ifundefined {AdviOptions}{}{\ExecuteOptions {\AdviOptions}} - -%% More declarations - -% Auxilliary macros - - -\def \advi@empty{} -\def \advi@ifempty #1{\def \@test {#1}\ifx \@test \advi@empty - \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} -\def \advi@error #1{\PackageError {Advi}{#1}{Type to proceed.}} -\def \advi@warning #1{\PackageWarning {Advi}{#1}} -\def \advi@undefinedenv {\advi@error {Environment \@currenvir\space undefined. -Maybe you mean \@currenvir ing}} -\def \advi@special@ {\advi@ifadvi{\special}{\advi@ignore}} -\def \advi@special #1{\advi@special@ {advi: #1}} -\def \advi@export #1#2{\@ifdefinable #1{\let #1#2}} -\def \advi@exportenv #1#2{% - \@ifundefined {#1}{\expandafter \let \csname #1\expandafter \endcsname - \csname end#1\endcsname }\relax - \expandafter \@ifdefinable \csname #1\endcsname - {\expandafter \let \csname #1\expandafter \endcsname \csname #2\endcsname - \expandafter \let \csname end#1\expandafter \endcsname - \csname end#2\endcsname}} - -\def \advi@ignore #1{} -\def \advi@id #1{#1} - -\def \advi@ifadvi {\ifadvi@ignore - \expandafter \@secondoftwo \else \expandafter \@firstoftwo \fi} -\advi@export \adviignore \advi@ignoretrue -\advi@export \ifadvi \advi@ifadvi - -%%% Record and play - -\newif \ifadvi@recording -\def \advi@ifrecording {\ifadvi@recording - \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} -\def \advi@ifrecordenv {\ifx \@currenvir \advi@recordenv - \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} - -\def \advi@start {start} -\def \advi@startplay {start play} -\define@key{advi@record}{play}[]{\let \advi@do \advi@startplay} -\def \advi@recordenv {advirecord} - -\newenvironment{advi@recording}[2][]% - {\begingroup - \let \advi@do \advi@start \setkeys{advi@record}{#1}% - \advi@special {proc=#2 record=\advi@do}% - \endgroup} - {\advi@special {proc record=end}} -\newcommand {\advi@record}[3][]{\advi@recording[#1]{#2}#3\endadvi@recording} - -\newcommand {\advi@play}[2][]% - {\begingroup - \advi@ifempty{#1}{}{\color {#1}}{\advi@special {proc=#2 play}}% - \endgroup} - -\advi@exportenv {advirecording}{advi@recording} -\advi@export \advirecord \advi@record -\let \endadvirecord \advi@undefinedenv -\advi@export \adviplay \advi@play - - -%%% Embedded applications - -\def \advi@embed@name{anonymous} -\def \advi@embed@mode{ephemeral} -\def \advi@embed@width{0pt} -\def \advi@embed@height{0pt} -\define@key {advi@embed}{name}{\def \advi@embed@name {#1}} -\define@key {advi@embed}{width}% - {\@tempdima#1\relax \edef \advi@embed@width {\the\@tempdima}} -\define@key {advi@embed}{height}% - {\@tempdima#1\relax \edef \advi@embed@height {\the\@tempdima}} -\def \advi@definemode #1{% - \define@key {advi@embed}{#1}[anonymous]{% - \def \advi@embed@mode {#1}\def\advi@embed@name {##1}% - }} -\advi@definemode{ephemeral} -\advi@definemode{persistent} -\advi@definemode{sticky} - -\def \advi@embed@ #1#2#3#4#5{% - \mbox{\advi@special - {embed name="#1" mode=#2 width=#3 height=#4 command="#5"}% - {\vbox to #4{\hbox to #3{}}}}} -\def \advi@length #1{\@tempdima #1\relax \the\@tempdima} -\newcommand{\advi@embed}[2][]{% - \mbox {\setkeys {advi@embed}{#1}% - \advi@embed@ {\advi@embed@name}{\advi@embed@mode} - {\advi@embed@width}{\advi@embed@height}{#2}}} - -\newcommand{\advi@killembed}[2][]{\advi@special {kill name="#2" signal="#1"}} - -\advi@export \adviembed \advi@embed - -\advi@export \advikillembed \advi@killembed - - -%%% Background colors and images - -\def \do #1{\expandafter \def \csname advi@geom@#1@\endcsname {#1}} -\do {center} -\do {left} -\do {right} -\do {bottom} -\do {top} -\do {topleft} -\do {topright} -\do {bottomleft} -\do {bottomright} -\let \do \relax -\def \advi@ifnine #1#2#3{\@ifundefined {advi@geom@#1@}{#3}{#2}} - -\let \advi@global \relax -\def \advi@global@ {global} -\newif \ifadvi@bgactive - -\def \advi@bg@do - {\do\advi@bgcolor \do\advi@bgimage \do \advi@bgalpha \do\advi@bgblend} -\def \advi@auto@ { fit=auto} -\def \advi@bgreset - {\def \do ##1{\expandafter \advi@global - \expandafter \let \noexpand ##1\advi@empty}\advi@bg@do - \advi@global \let \advi@bgfit \advi@auto@ - \advi@global \advi@bgactivefalse} -\advi@bgreset - -\def \advi@none@ {none} -\def \advi@ifnone #1{\def \@test{#1}\ifx \@test \advi@none@ - \let \@test \advi@empty \fi \ifx \@test \advi@empty - \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} - -\def \advi@setbg #1#2#3{\advi@ifnone {#1} - {\advi@global \expandafter \let \noexpand #1\advi@empty} - {\advi@global \expandafter \def \noexpand #1{ #2=#3}% - \advi@global \advi@bgactivetrue}} -\define@key {advi@bg}{color}[]{\advi@setbg{\advi@bgcolor}{color}{#1}} -\define@key {advi@bg}{image}[]{\advi@setbg{\advi@bgimage}{image}{#1}} -\define@key {advi@bg}{alpha}[]{\advi@setbg{\advi@bgalpha}{alpha}{#1}} -\define@key {advi@bg}{blend}[]{\advi@setbg{\advi@bgblend}{blend}{#1}} -\define@key {advi@bg}{fit}[auto]{\def \advi@bgfit {#1}% - \ifx \advi@bgfit \advi@auto@ \else - \advi@ifnine {\advi@bgfit} - {\advi@global \def \advi@bgfit{ fit=#1}} - {\advi@error {Ill formed background fit=#1}}% - \fi} -\def \advi@bgset #1{\advi@ifnone {#1}{\advi@bgreset}{\setkeys {advi@bg}{#1}}} - -%\define@key {advi@bg}{inherit}[]{\advi@special{setbg inherit}} - -\def \advi@bgemit - {\advi@special - {setbg \advi@bgcolor \advi@bgimage \advi@bgalpha \advi@bgblend - \advi@bgfit - }} -\newif \ifadvi@bglocal - -\newcommand{\advi@bg}[2][]{% - \begingroup - \def \@test {#1}\ifx \@test \advi@global@ \let \advi@global \global - \advi@bgset {#2}\else - \ifx \@test \advi@empty \else \advi@warning - {Optional argument [#1] to \string \advibg ignored}\fi - \global \advi@bglocaltrue - \advi@bgset{#2}\advi@bgemit \fi - \endgroup} -\def \advi@bgpage - {\ifadvi@bgactive \ifadvi@bglocal\else \advi@bgemit \fi\fi - \global \advi@bglocalfalse} - -\advi@export \advibg \advi@bg - -%%% Pausing and waiting - -\def\advi@pause {\advi@special{pause}} -\def\advi@wait#1{\advi@special{wait sec=#1}} - -%% export -\newcommand {\adviwait}[1][]% - {\advi@ifempty {#1}{\advi@pause}{\advi@wait {#1}}} - -%%% Transparency and alpha blending -%%% To be revisited. - -\def\advi@epstransparent - {\advi@special{epstransparent push true}% - \aftergroup \advi@resetepstransparent} -\def\advi@epswhite - {\advi@special{epstransparent push false}% - \aftergroup \advi@resetepstransparent} -\def\advi@setalpha#1% - {\advi@special{alpha push #1}% - \aftergroup \advi@resetalpha} -\def\advi@setblend#1% - {\advi@special{blend push #1}% - \aftergroup\advi@resetblend} -\def\advi@resetepstransparent {\advi@special{epstransparent pop}} -\def\advi@resetalpha {\advi@special{alpha pop}} -\def\advi@resetblend {\advi@special{blend pop}} - -\advi@export \epstransparent \advi@epstransparent -\advi@export \epswhite \advi@epswhite -\advi@export \setalpha \advi@setalpha -\advi@export \setblend \advi@setblend - -%%% Animated transitions - -\def \advi@transfrom{} -\def \advi@transsteps{} -\def \advi@settrans {\advi@global \def} -\define@key {advi@trans}{none} []{\advi@settrans \advi@transmode {none}} -\define@key {advi@trans}{slide}[]{\advi@settrans \advi@transmode {slide}} -\define@key {advi@trans}{block}[]{\advi@settrans \advi@transmode {block}} -\define@key {advi@trans}{wipe} []{\advi@settrans \advi@transmode {wipe}} -\define@key {advi@trans}{from} {\advi@settrans \advi@transfrom { from=#1}} -\define@key {advi@trans}{steps}{\advi@settrans \advi@transsteps { steps=#1}} - -\def \advi@transemit - {\advi@special{trans \advi@transmode \advi@transfrom \advi@transsteps}} -\newif \ifadvi@translocal -\newcommand {\advi@transition}[2][]{% - \begingroup - \def \@test {#1}\ifx \@test \advi@global@ \let \advi@global \global - \setkeys {advi@trans}{#2}\else - \ifx \@test \advi@empty \else \advi@warning - {Optional argument [#1] to \string \advitransition ignored}\fi - \global \advi@translocaltrue - \setkeys {advi@trans}{#2}\advi@transemit \fi - \endgroup} - -\def \advi@transpage - {\@ifundefined {advi@transmode}{} - {\ifadvi@translocal\else \advi@transemit \fi}% - \global \advi@translocalfalse} - -%% Hook \advi@setpagesetyle at \@begindvi that run at every page - -\def \advi@setpagestyle {\advi@bgpage \advi@transpage} -\def \endpage@hook {} -\def \AtEndPage {\g@addto@macro \endpage@hook} -\AtEndPage {\advi@setpagestyle} - -% We must patch \@begindvi to put out hook. -% However, hyperref may patch it as well. So we should do it at begin -% document to have the control (no one after us). -% Howver, one must be careful, because \@begindvi redefines itself at the -% first call to its prerecorded final value. -% So our first patch will be overridden with the value that it was -% meant to have after the first page. -% Hence, we patch it a second time to put our hook to this final value. - -% we can use \g@addto@macro which redefines #1 to so that it procedes as -% before and then execute #2 at the end. - -\def \advi@begindvi@patch - {\g@addto@macro \@begindvi - {\endpage@hook \g@addto@macro \@begindvi {\endpage@hook}}} - -\AtBeginDocument {\advi@begindvi@patch} - -% {\let \advi@begindvi@save \@begindvi %% value at begindocument -% \def \@begindvi %% our new value -% {\advi@begindvi@save %% may redefine \@begindvi -% \global\let \advi@begindvi@save %% so we this new value -% \@begindvi -% \gdef \@begindvi %% now and forever -% {\advi@begindvi@save \endpage@hook}% -% \endpage@hook %% our hook for the -% }} - - - -%% Transitions - -\def\advi@transbox@save#1#2#3{\advi@special - {transbox save width=#1 height=#2 depth=#3}} -\def\advi@transbox@go#1{\advi@special{transbox go #1}} - -\def \advi@transslide {slide} -\def \advi@transbox #1{% - \def \advi@afterbox - {\hbox {\advi@transbox@save{\the\wd0 }{\the\ht0 }{\the\dp0}% - \unhbox0\setkeys {advi@trans}{#1}% - \advi@transbox@go - {\advi@transmode \advi@transfrom \advi@transsteps}}}% - \def \advi@@afterbox {\aftergroup \advi@afterbox} - \afterassignment \advi@@afterbox \setbox0 \hbox } - -\advi@export \advitransition \advi@transition -\advi@export \advitransbox \advi@transbox - -%%% For PS Tricks - -\def \advi@moveto {\advi@special {moveto}} -\def\advi@psput@special#1{% -\hbox{% -\pst@Verb{{ \pst@coor } -dup exec 2 copy moveto advi@Dict begin printpos end -\tx@PutCoor -\tx@PutBegin} -\hbox {\advi@moveto \box#1}% -\pst@Verb{\tx@PutEnd}}} - -\def\advi@ncput@iii{% -\leavevmode -\hbox{% -\pst@Verb{% -\pst@nodedict -/t \psk@npos def -tx@NodeDict /LPutPos known { LPutPos } { CP /Y ED /X ED /NAngle 0 -def } ifelse -LPutCoor -end -\tx@PutBegin -}% -\hbox {\box\pst@hbox}% -\pst@Verb{\tx@PutEnd}}} - -\def \advi@pstricks@patch - {\@ifundefined {psput@special}{} - {\let \psput@special \advi@psput@special - %\@ifundefined {ncput@iii}{}{\let \ncput@iii \advi@ncput@iii}% - \pstheader {advi.pro}}} -\AtBeginDocument {\advi@pstricks@patch} - - -%%% Active DVI - -\def \advi@over@ {over} -\def \advi@click@ {click} -\def \advi@null {\hbox {}} - -\newenvironment {advi@anchoring}[2][over]{% - \begingroup - \def \@test {#1}\ifx \@test \advi@over@ - \advi@special@ {html:
}\else - \ifx \@test \advi@click@ - \advi@special@ {html:}\else - \advi@error {Incorect anchor mode #1}\fi \fi\endgroup} - {\advi@special@ {html:}} -\newcommand {\advi@anchor}[3][over]% - {\advi@anchoring[#1]{#2}#3\endadvi@anchoring} - -\def \advi@endanchor #1{#1\endadvi@anchor \endgroup} -\advi@exportenv {advianchoring}{advi@anchoring} -\advi@export \advianchor \advi@anchor -\let \endadvianchor \advi@undefinedenv - -%%% Partial patch for overlays -- 0 will be shown > 0 will not be shown - -\def \advi@max {0} -\def \advi@overlay #1{% - \advi@ifadvi - {%\advance \c@overlay by 1 - \ifnum \c@overlay>\advi@max \global \xdef \advi@max {\the \c@overlay}\fi - \advi@recording {overlay@#1}\aftergroup \endadvi@recording} - {\latex@overlay {#1}}} - -\def \advi@overlay@loop - {\advi@ifadvi - {\begingroup - \c@overlay=0 - \@whilenum\c@overlay<\advi@max - \do {\advance \c@overlay by 1% - \adviwait \adviplay{overlay@\the\c@overlay}}% - \endgroup - \gdef \advi@max {0}} - {\latex@overlay@loop}} - -\def \advi@end@slide - {\advi@ifadvi {\overlay@loop}{}\latex@end@slide} - -\def \advi@overlay@patch {% - \let \latex@overlay \@overlay - \let \latex@end@slide \end@slide - \let \latex@overlay@loop \overlay@loop - \let \@overlay \advi@overlay - \let \overlay@loop \advi@overlay@loop - \let \end@slide \advi@end@slide - } - -\@ifundefined {overlay}{} - {\AtBeginDocument {\advi@overlay@patch}} - - -\endinput diff --git a/skribe/examples/slide/ex/skribe.skb b/skribe/examples/slide/ex/skribe.skb deleted file mode 100644 index d1a525e..0000000 --- a/skribe/examples/slide/ex/skribe.skb +++ /dev/null @@ -1,11 +0,0 @@ -(slide :title [Skribe] - (st [Skribe:]) - (itemize (item [A functional programming language based on Scheme]) - (item [A markup language ,(emph [à la]) XML]) - (item [A document ,(blue [is]) a program, - a program ,(blue [looks like]) a text with markups])) - - (p [ - ,(st [Example:]) - ,(slide-pause) - ,(skribe-prgm :file "ex/skribe.skb")])) diff --git a/skribe/examples/slide/ex/syntax.scr b/skribe/examples/slide/ex/syntax.scr deleted file mode 100644 index 8590f4a..0000000 --- a/skribe/examples/slide/ex/syntax.scr +++ /dev/null @@ -1 +0,0 @@ -[text goodies: ,(bold "bold") and ,(it "italic").] diff --git a/skribe/examples/slide/skb/slides.skb b/skribe/examples/slide/skb/slides.skb deleted file mode 100644 index c13b102..0000000 --- a/skribe/examples/slide/skb/slides.skb +++ /dev/null @@ -1,286 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/examples/slide/skb/slides.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Oct 8 16:04:59 2003 */ -;* Last change : Fri Oct 24 13:32:37 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe slide example */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Style */ -;*---------------------------------------------------------------------*/ -(case *mode* - ((advi) - (skribe-load "slide.skr" :advi #t)) - ((prosper) - (skribe-load "slide.skr" :prosper #t)) - (else - (skribe-load "slide.skr"))) - -(skribe-load "local.skr") - -;*---------------------------------------------------------------------*/ -;* latex configuration ... */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'transition 'slide) - (engine-custom-set! le 'usepackage - (string-append (engine-custom le 'usepackage) - "\\usepackage{pstricks,pst-node,pst-text,pst-3d}\n"))) - -;*---------------------------------------------------------------------*/ -;* sk-expression ... */ -;*---------------------------------------------------------------------*/ -(define (sk-expression) - (it "sk-expression")) -(define (sk-expressions) - (it "sk-expressions")) - -;*---------------------------------------------------------------------*/ -;* The document */ -;*---------------------------------------------------------------------*/ -(document -:title (red (sf (font :size +2. "This is Skribe!"))) -:author (author :name (it (magenta "Manuel Serrano, Erick Gallesio")) - :affiliation [Inria Sophia Antipolis, University of Nice] - :address (list "" (tt (skribe-url)))) - -;*---------------------------------------------------------------------*/ -;* First slide */ -;*---------------------------------------------------------------------*/ -(include "ex/skribe.skb") - -;* {*---------------------------------------------------------------------*} */ -;* {* Overview *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Skribe overview" */ -;* (center (image :width 90. :file "fig/overview.fig"))) */ - -;* {*---------------------------------------------------------------------*} */ -;* {* Examples *} */ -;* {*---------------------------------------------------------------------*} */ -;* (if (or (skribe-mgp?) (and (skribe-tex?) *skribe-slide-advi*)) */ -;* (slide :title "Skribe examples" */ -;* */ -;* (%embed :geometry *xterm.geo* *xterm*) */ -;* (%embed :geometry *xdvi.geo* *xdvi*) */ -;* */ -;* (st [1 Skribe document, 2 targets:]) */ -;* */ -;* (%vspace 0.0) */ -;* (itemize (item [A ,(sc [Nroff]) target:])) */ -;* (%vspace 3) */ -;* (itemize (item [A ,(sc [Dvi]) target:])))) */ - -;* {*---------------------------------------------------------------------*} */ -;* {* Skribe gallery *} */ -;* {*---------------------------------------------------------------------*} */ -;* {*--- math ------------------------------------------------------------*} */ -;* (slide :title "Gallery (1/2)" */ -;* */ -;* (st [Math skills:]) */ -;* (itemize (item [A ,(LaTeX) math formula in:])) */ -;* (p (font :size -3 */ -;* (color :bg *display-bg* */ -;* (center */ -;* (hook :after */ -;* (lambda () */ -;* (if (skribe-tex?) */ -;* (display "\\(\\sum_{i=1}^{n} x_{i} = \\int_{0}^{1} f\\)") */ -;* (display "∑i=1i=1 = ∫01f")))))))) */ -;* (itemize (item [Denotational semantics:])) */ -;* (p (font :size -3 */ -;* (color :bg *display-bg* */ -;* (prgm :language denotation :monospace (skribe-html?) */ -;* (map (lambda (d) */ -;* (from-file "scm/eval.scm" :definition d)) */ -;* '("ev-lambda1" "ev-funcall1")))))) */ -;* (itemize (item [SOS rule:])) */ -;* (p (font :size -4 */ -;* (color :bg *display-bg* */ -;* (labeled-component */ -;* "Assignment" */ -;* (rule */ -;* (evaluate "exp" "sched, env" "val" "sched', env'") */ -;* (rewrite "var = exp, sched, env" (TERM) "nothing, sched', env'"))))))) */ -;* */ -;* {*--- misc ------------------------------------------------------------*} */ -;* (slide :title "Gallery (2/2)" */ -;* */ -;* (st [Misc:]) */ -;* (itemize (item [A computer program:])) */ -;* (p (font :size -1 (prgm :bg *example-bg* :language c :lnum 1 (from-file "ex/C-code.c")))) */ -;* (itemize (item [Images: */ -;* ,(p (image :width 75 :height 50 :file "img/img.jpg") */ -;* (hook :after (lambda () */ -;* (cond */ -;* ((skribe-tex?) */ -;* (display "\\ \\ \\ \\ ")) */ -;* (else */ -;* (display " "))))) */ -;* (image :width 25 :height 50 :file "img/img.jpg") */ -;* (hook :after (lambda () */ -;* (cond */ -;* ((skribe-tex?) */ -;* (display "\\ \\ \\ \\ ")) */ -;* (else */ -;* (display " "))))) */ -;* (image :width 150 :height 50 :file "img/img.jpg"))]))) */ -;* */ -;*---------------------------------------------------------------------*/ -;* Syntax */ -;*---------------------------------------------------------------------*/ -(slide :title "Skribe Syntax" :vspace 0.3 - -(st [,(sk-expression):]) - -(slide-pause) -(itemize (item [An ,(emph "atom") (a ,(red (it "string")), a ,(red (it "number")), ...)] (slide-pause)) - (item [A ,(emph "list") of ,(!latex "{\\rnode{NA}{$1}}" (sk-expressions))] (slide-pause)) - (item [A ,(emph "text") (,(red (tt [ ,(char "[")... ,(blue [,(char ",")(,(it ""))]) ...,(char "]") ])))] (slide-pause))) - -(slide-vspace 0.3) -(p [,(!latex "{\\rnode{NB}{$1}}" (st [Example:])) - ,(slide-pause) - ,(!latex "{\\nccurve[linecolor=red,angleA=90,angleB=270]{->}{NB}{NA}}") - ,(skribe-prgm :fsize 0 (source :file "ex/syntax.scr"))]) - -(p [is equivalent to: - ,(slide-pause) - ,(skribe-prgm :fsize 0 [(list "text goodies: " (bold "bold") "and" (it "italic") ".")])])) - -;* {*---------------------------------------------------------------------*} */ -;* {* Skribe documents *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Skribe Documents (1/2)" :vspace 0.5 */ -;* */ -;* (st [Skribe Document Structure:]) */ -;* (p (skribe-prgm [,(from-file "ex/skel.scr")]))) */ -;* */ -;* {*--- markup ----------------------------------------------------------*} */ -;* (slide :title "Skribe Documents (2/2)" :vspace 0.5 */ -;* (st [XML markup:]) */ -;* (p (prgm :language xml :bg *example-bg* [ */ -;* */ -;* Some text */ -;* */ -;* for the example */ -;* */ -;* ])) */ -;* (%vspace 0.3) */ -;* (st [Sc-markup:]) */ -;* (p (skribe-prgm [,(from-file "ex/xml.scr")]))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Libraries *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Skribe Libraries" */ -;* */ -;* (st [A set of libraries containing the ,(q "usual") facilities. For instance:]) */ -;* */ -;* (p (skribe-prgm [,(from-file "ex/itemize.scr")])) */ -;* (%vspace 0.1) */ -;* (st [Produces the following output text:]) */ -;* (center (color :bg *display-bg* (font :size -2 (include "ex/itemize.scr"))))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Dynamic texts *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Dynamic texts (1/3)" :vspace 0.2 */ -;* */ -;* (st [Let us assume the factorial table:]) */ -;* (%vspace 0.5) */ -;* */ -;* (center (font :size -1 (color :bg *display-bg* (include "ex/fact.scr"))))) */ -;* */ -;* {*--- dynamic texts: the usual solution -------------------------------*} */ -;* (slide :title "Dynamic texts (2/3)" */ -;* */ -;* (st [The usual solution:]) */ -;* (p (skribe-prgm :fsize -1 (from-file "ex/factb.scr")))) */ -;* */ -;* {*--- dynamic texts: a better solution --------------------------------*} */ -;* (slide :title "Dynamic texts (3/3)" */ -;* */ -;* (st [A better solution:]) */ -;* (p (skribe-prgm (from-file "ex/fact.scr")))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Introspection *} */ -;* {*---------------------------------------------------------------------*} */ -;* {*--- Introspection ---------------------------------------------------*} */ -;* (slide :title "Introspection" */ -;* */ -;* (color :bg *image-bg* */ -;* (center (image :width 1. :file "fig/skribe.fig")))) */ -;* */ -;* {*--- Number of slides ------------------------------------------------*} */ -;* (slide :title "Introspection: an example (1/2)" */ -;* */ -;* (p (color :bg *display-bg* (include "ex/slide.scr")))) */ -;* */ -;* {*--- Number of slides (2/2) ------------------------------------------*} */ -;* (slide :title "Introspection: an example (2/2)" :vspace 0.5 */ -;* */ -;* (st [The previous output is produced with:]) */ -;* (p (skribe-prgm (from-file "ex/slide.scr")))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Conditional evaluation *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Conditional evaluation" :vspace 0.5 */ -;* */ -;* (st [Some features are dependent of the target format:]) */ -;* (itemize (item [Only specific back-ends may support specific features]) */ -;* (item [It is in charge of the back-ends to implement */ -;* ,(emph "reasonable") behaviors for unsupported features. */ -;* Examples: */ -;* ,(itemize (item [Hyper links]) */ -;* (item [Images]) */ -;* (item [...]))]) */ -;* (item [Skribe enables conditional evaluation: */ -;* ,(itemize (item [according to the target format]) */ -;* (item [enabling target format commands]))]))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Extensibility *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Extensibility" */ -;* */ -;* (st [User level:]) */ -;* (itemize (item [New markups can be defined in a document]) */ -;* (item [A markup is a Skribe (Scheme) function]) */ -;* (item [Example: the ,(code "(%pause)") slide facility:])) */ -;* */ -;* (p (skribe-prgm [ */ -;* (define (%pause) */ -;* (cond */ -;* ((skribe-mgp?) (hook :after (lambda () (display "%pause")))) */ -;* ((skribe-advi-tex?) (hook :after (lambda () (print "\\adviwait")))) */ -;* (else (linebreak))))])) */ -;* (%pause) */ -;* */ -;* (st [System level:]) */ -;* (itemize (item [New back-ends can be dynamically added]) */ -;* (item [The ,(sc-ast) can be extended]))) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* Conclusion *} */ -;* {*---------------------------------------------------------------------*} */ -;* (slide :title "Conclusion" :vspace 0.5 */ -;* */ -;* (st [Status:]) */ -;* (itemize (item [Available on-line: ,(ref :url (skribe-url))]) */ -;* (item [Available since a couple of months]) */ -;* (item [Used, by the authors, on a daily basis]) */ -;* (item [,(magenta (bold [Still too young])) ,(symbol '=>) */ -;* ,(itemize (item [Very few styles have been implemented]) */ -;* (item [It is still necessary to be aware of the */ -;* targets idiosyncrasies]) */ -;* (item [Difficult to tame the fix-point */ -;* iteration of the computation model]))])))) */ - -) diff --git a/skribe/examples/slide/skr/local.skr b/skribe/examples/slide/skr/local.skr deleted file mode 100644 index 2802a53..0000000 --- a/skribe/examples/slide/skr/local.skr +++ /dev/null @@ -1,73 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/examples/slide/skr/local.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jun 3 15:32:25 2002 */ -;* Last change : Wed Oct 8 16:22:42 2003 (serrano) */ -;* Copyright : 2002-03 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The local style of the presentation */ -;*=====================================================================*/ - -;* {*---------------------------------------------------------------------*} */ -;* {* fg ... *} */ -;* {*---------------------------------------------------------------------*} */ -;* (define (fg c . body) */ -;* (apply color :fg c body)) */ -;* */ -;* {*---------------------------------------------------------------------*} */ -;* {* bg ... *} */ -;* {*---------------------------------------------------------------------*} */ -;* (define (bg c . body) */ -;* (apply color :bg c body)) */ -;* */ -;*---------------------------------------------------------------------*/ -;* colors ... */ -;*---------------------------------------------------------------------*/ -(define (green body) - (fg "darkgreen" body)) -(define (red body) - (fg "red" body)) -(define (blue body) - (bold (fg "darkblue" body))) -(define (magenta body) - (fg "darkmagenta" body)) -(define (orange body) - (fg "darkorange" body)) - -;*---------------------------------------------------------------------*/ -;* em ... */ -;*---------------------------------------------------------------------*/ -(define (em body) - (bold (magenta body))) - -;*---------------------------------------------------------------------*/ -;* st ... */ -;*---------------------------------------------------------------------*/ -(define (st body) - (sf (red body))) - -;*---------------------------------------------------------------------*/ -;* citem ... */ -;*---------------------------------------------------------------------*/ -(define-markup (citem #!rest opt #!key (color "black") (shape (math 'bullet))) - (item (list (fg color shape) " " (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* skribe-prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (skribe-prgm #!rest opt #!key file definition) - (cond - ((and definition file) - (font :size -4 - (color :bg "#ccffcc" (prog (source :language skribe - :file file - :definition definition))))) - (file - (font :size -4 - (color :bg "#ccffcc" (prog (source :language skribe - :file file))))) - (else - (font :size -4 - (color :bg "#ccffcc" (prog (source :language skribe - (the-body opt)))))))) diff --git a/skribe/skr/Makefile b/skribe/skr/Makefile deleted file mode 100644 index dcc3e77..0000000 --- a/skribe/skr/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/skr/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:21:20 2003 */ -#* Last change : Wed May 18 15:34:21 2005 (serrano) */ -#* Copyright : 2003-05 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Skribe SKR Makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* POPULATION */ -#*---------------------------------------------------------------------*/ -POPULATION= acmproc.skr sigplan.skr jfp.skr \ - slide.skr web-book.skr web-article.skr \ - base.skr latex.skr scribe.skr xml.skr \ - html.skr html4.skr lncs.skr skribe.skr \ - letter.skr french.skr latex-simple.skr context.skr Makefile - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATION:%=skr/%) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_SKRDIR) - cp *.skr $(DESTDIR)$(INSTALL_SKRDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/* - -uninstall: - -$(DESTDIR)$(INSTALL_SKRDIR): - mkdir -p $(DESTDIR)$(INSTALL_SKRDIR) && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR) - diff --git a/skribe/skr/acmproc.skr b/skribe/skr/acmproc.skr deleted file mode 100644 index 4accc7c..0000000 --- a/skribe/skr/acmproc.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/acmproc.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[letterpaper]{acmproc}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\numberofauthors{~a}\n\\author{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "\\alignauthor\n") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\CopyrightYear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\crdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key (class "abstract") postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :class class :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skribe/skr/base.skr b/skribe/skr/base.skr deleted file mode 100644 index ec987ec..0000000 --- a/skribe/skr/base.skr +++ /dev/null @@ -1,464 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/base.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:39:30 2003 */ -;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* BASE Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* base-engine ... */ -;*---------------------------------------------------------------------*/ -(define base-engine - (default-engine-set! - (make-engine 'base - :version 'plain - :symbol-table '(("iexcl" "!") - ("cent" "c") - ("lguillemet" "\"") - ("not" "!") - ("registered" "(r)") - ("degree" "o") - ("plusminus" "+/-") - ("micro" "o") - ("paragraph" "p") - ("middot" ".") - ("rguillemet" "\"") - ("iquestion" "?") - ("Agrave" "À") - ("Aacute" "A") - ("Acircumflex" "Â") - ("Atilde" "A") - ("Amul" "A") - ("Aring" "A") - ("AEligature" "AE") - ("Oeligature" "OE") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "E") - ("Igrave" "I") - ("Iacute" "I") - ("Icircumflex" "Î") - ("Iuml" "I") - ("ETH" "D") - ("Ntilde" "N") - ("Ograve" "O") - ("Oacute" "O") - ("Ocurcumflex" "O") - ("Otilde" "O") - ("Ouml" "O") - ("times" "x") - ("Oslash" "O") - ("Ugrave" "Ù") - ("Uacute" "U") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Y") - ("agrave" "à") - ("aacute" "a") - ("acircumflex" "â") - ("atilde" "a") - ("amul" "a") - ("aring" "a") - ("aeligature" "æ") - ("oeligature" "oe") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "e") - ("igrave" "i") - ("iacute" "i") - ("icircumflex" "î") - ("iuml" "i") - ("ntilde" "n") - ("ograve" "o") - ("oacute" "o") - ("ocurcumflex" "o") - ("otilde" "o") - ("ouml" "o") - ("divide" "/") - ("oslash" "o") - ("ugrave" "ù") - ("uacute" "u") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "y") - ("ymul" "y") - ;; punctuation - ("bullet" ".") - ("ellipsis" "...") - ("<-" "<-") - ("<--" "<--") - ("uparrow" "^;") - ("->" "->") - ("-->" "-->") - ("downarrow" "v") - ("<->" "<->") - ("<-->" "<-->") - ("<+" "<+") - ("<=" "<=;") - ("<==" "<==") - ("Uparrow" "^") - ("=>" "=>") - ("==>" "==>") - ("Downarrow" "v") - ("<=>" "<=>") - ("<==>" "<==>") - ;; Mathematical operators - ("asterisk" "*") - ("angle" "<") - ("and" "^;") - ("or" "v") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "~") - ("mid" "|") - ("langle" "<") - ("rangle" ">") - ;; LaTeX - ("circ" "o") - ("top" "T") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'symbol - :action (lambda (n e) - (let* ((s (markup-body n)) - (c (assoc s (engine-symbol-table e)))) - (if (pair? c) - (display (cadr c)) - (output s e))))) - -;*---------------------------------------------------------------------*/ -;* unref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'unref - :options 'all - :action (lambda (n e) - (let* ((s (markup-option n :skribe)) - (k (markup-option n 'kind)) - (f (cond - (s - (format "?~a@~a " k s)) - (else - (format "?~a " k)))) - (msg (list f (markup-body n))) - (n (list "[" (color :fg "red" (bold msg)) "]"))) - (skribe-eval n e)))) - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-before w) n e)))) - :action (lambda (n e) - (when (pair? (markup-body n)) - (for-each (lambda (i) (output i e)) (markup-body n)))) - :after (lambda (n e) - (let ((w (markup-writer-get 'table e))) - (and (writer? w) (invoke (writer-after w) n e))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :before (lambda (n e) - (invoke (writer-before (markup-writer-get 'tr e)) n e)) - :action (lambda (n e) - (let ((wtc (markup-writer-get 'tc e))) - ;; the label - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'right) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (invoke (writer-after wtc) n e) - ;; the body - (markup-option-add! n :valign 'top) - (markup-option-add! n :align 'left) - (invoke (writer-before wtc) n e) - (output n e (markup-writer-get '&bib-entry-body)) - (invoke (writer-after wtc) n e))) - :after (lambda (n e) - (invoke (writer-after (markup-writer-get 'tr e)) n e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "[" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-body - :action (lambda (n e) - (define (output-fields descr) - (let loop ((descr descr) - (pending #f) - (armed #f)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (loop (cdr descr) #f #t)) - (loop (cdr descr) pending armed)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author " -- " (or title url documenturl) " -- " - number ", " institution ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((article) - `(author " -- " (or title url documenturl) " -- " - journal ", " volume "" ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author " -- " (or title url documenturl) " -- " - booktitle ", " series ", " ("(" number ")") ", " - address ", " month ", " year ", " - ("pp. " pages) ".")) - ((book) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")) - ((phdthesis) - '(author " -- " (or title url documenturl) " -- " type ", " - school ", " address - ", " month ", " year".")) - ((misc) - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year".")) - (else - '(author " -- " (or title url documenturl) " -- " - publisher ", " address - ", " month ", " year ", " ("pp. " pages) ".")))))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-ident ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-ident - :action (lambda (n e) - (output (markup-option n 'number) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-publisher ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-publisher - :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &the-index ... @label the-index@ */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index - :options '(:column) - :before (lambda (n e) - (output (markup-option n 'header) e)) - :action (lambda (n e) - (define (make-mark-entry n fst) - (let ((l (tr :class 'index-mark-entry - (td :colspan 2 :align 'left - (bold (it (sf n))))))) - (if fst - (list l) - (list (tr (td :colspan 2)) l)))) - (define (make-primary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (c (if note - (list b - (it (list " (" note ")"))) - b))) - (when p - (markup-option-add! b :text - (list (markup-option b :text) - ", p.")) - (markup-option-add! b :page #t)) - (tr :class 'index-primary-entry - (td :colspan 2 :valign 'top :align 'left c)))) - (define (make-secondary-entry n p) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (cond - ((not (or bb (is-markup? b 'url-ref))) - (skribe-error 'the-index - "Illegal entry" - b)) - (note - (let ((r (if bb - (it (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p - (list note ", p.") - note))) - (it (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p - (list note ", p.") - note)))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1. " ...") - (td :valign 'top :align 'left r)))) - (else - (let ((r (if bb - (ref :class "the-index-secondary" - :handle bb - :page p - :text (if p " ..., p." " ...")) - (ref :class "the-index-secondary" - :url (markup-option b :url) - :page p - :text (if p " ..., p." " ..."))))) - (tr :class 'index-secondary-entry - (td :valign 'top :align 'right :width 1.) - (td :valign 'top :align 'left r))))))) - (define (make-column ie p) - (let loop ((ie ie) - (f #t)) - (cond - ((null? ie) - '()) - ((not (pair? (car ie))) - (append (make-mark-entry (car ie) f) - (loop (cdr ie) #f))) - (else - (cons (make-primary-entry (caar ie) p) - (append (map (lambda (x) - (make-secondary-entry x p)) - (cdar ie)) - (loop (cdr ie) #f))))))) - (define (make-sub-tables ie nc p) - (let* ((l (length ie)) - (w (/ 100. nc)) - (iepc (let ((d (/ l nc))) - (if (integer? d) - (inexact->exact d) - (+ 1 (inexact->exact (truncate d)))))) - (split (list-split ie iepc))) - (tr (map (lambda (ies) - (td :valign 'top :width w - (if (pair? ies) - (table :width 100. (make-column ies p)) - ""))) - split)))) - (let* ((ie (markup-body n)) - (nc (markup-option n :column)) - (loc (ast-loc n)) - (pref (eq? (engine-custom e 'index-page-ref) #t)) - (t (cond - ((null? ie) - "") - ((or (not (integer? nc)) (= nc 1)) - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-column ie pref))) - (else - (table :width 100. - :&skribe-eval-location loc - :class "index-table" - (make-sub-tables ie nc pref)))))) - (output (skribe-eval t e) e)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;* ------------------------------------------------------------- */ -;* The index header is only useful for targets that support */ -;* hyperlinks such as HTML. */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) #f)) - -;*---------------------------------------------------------------------*/ -;* &prog-line ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&prog-line - :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (n (markup-ident (handle-body (markup-body n))))) - (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) - - - -;;;; A VIRER (mais handle-body n'est pas défini) -(markup-writer 'line-ref - :options '(:offset) - :action #f) diff --git a/skribe/skr/context.skr b/skribe/skr/context.skr deleted file mode 100644 index 5bc5316..0000000 --- a/skribe/skr/context.skr +++ /dev/null @@ -1,1380 +0,0 @@ -;;;; -;;;; context.skr -- ConTeXt mode for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 23-Sep-2004 17:21 (eg) -;;;; Last file update: 3-Nov-2004 12:54 (eg) -;;;; - -;;;; ====================================================================== -;;;; context-customs ... -;;;; ====================================================================== -(define context-customs - '((source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - (index-page-ref #t) - (image-format ("jpg")) - (font-size 11) - (font-type "roman") - (user-style #f) - (document-style "book"))) - -;;;; ====================================================================== -;;;; context-encoding ... -;;;; ====================================================================== -(define context-encoding - '((#\# "\\type{#}") - (#\| "\\type{|}") - (#\{ "$\\{$") - (#\} "$\\}$") - (#\~ "\\type{~}") - (#\& "\\type{&}") - (#\_ "\\type{_}") - (#\^ "\\type{^}") - (#\[ "\\type{[}") - (#\] "\\type{]}") - (#\< "\\type{<}") - (#\> "\\type{>}") - (#\$ "\\type{$}") - (#\% "\\%") - (#\\ "$\\backslash$"))) - -;;;; ====================================================================== -;;;; context-pre-encoding ... -;;;; ====================================================================== -(define context-pre-encoding - (append '((#\space "~") - (#\~ "\\type{~}")) - context-encoding)) - - -;;;; ====================================================================== -;;;; context-symbol-table ... -;;;; ====================================================================== -(define (context-symbol-table math) - `(("iexcl" "!`") - ("cent" "c") - ("pound" "\\pounds") - ("yen" "Y") - ("section" "\\S") - ("mul" ,(math "^-")) - ("copyright" "\\copyright") - ("lguillemet" ,(math "\\ll")) - ("not" ,(math "\\neg")) - ("degree" ,(math "^{\\small{o}}")) - ("plusminus" ,(math "\\pm")) - ("micro" ,(math "\\mu")) - ("paragraph" "\\P") - ("middot" ,(math "\\cdot")) - ("rguillemet" ,(math "\\gg")) - ("1/4" ,(math "\\frac{1}{4}")) - ("1/2" ,(math "\\frac{1}{2}")) - ("3/4" ,(math "\\frac{3}{4}")) - ("iquestion" "?`") - ("Agrave" "\\`{A}") - ("Aacute" "\\'{A}") - ("Acircumflex" "\\^{A}") - ("Atilde" "\\~{A}") - ("Amul" "\\\"{A}") - ("Aring" "{\\AA}") - ("AEligature" "{\\AE}") - ("Oeligature" "{\\OE}") - ("Ccedilla" "{\\c{C}}") - ("Egrave" "{\\`{E}}") - ("Eacute" "{\\'{E}}") - ("Ecircumflex" "{\\^{E}}") - ("Euml" "\\\"{E}") - ("Igrave" "{\\`{I}}") - ("Iacute" "{\\'{I}}") - ("Icircumflex" "{\\^{I}}") - ("Iuml" "\\\"{I}") - ("ETH" "D") - ("Ntilde" "\\~{N}") - ("Ograve" "\\`{O}") - ("Oacute" "\\'{O}") - ("Ocurcumflex" "\\^{O}") - ("Otilde" "\\~{O}") - ("Ouml" "\\\"{O}") - ("times" ,(math "\\times")) - ("Oslash" "\\O") - ("Ugrave" "\\`{U}") - ("Uacute" "\\'{U}") - ("Ucircumflex" "\\^{U}") - ("Uuml" "\\\"{U}") - ("Yacute" "\\'{Y}") - ("szlig" "\\ss") - ("agrave" "\\`{a}") - ("aacute" "\\'{a}") - ("acircumflex" "\\^{a}") - ("atilde" "\\~{a}") - ("amul" "\\\"{a}") - ("aring" "\\aa") - ("aeligature" "\\ae") - ("oeligature" "{\\oe}") - ("ccedilla" "{\\c{c}}") - ("egrave" "{\\`{e}}") - ("eacute" "{\\'{e}}") - ("ecircumflex" "{\\^{e}}") - ("euml" "\\\"{e}") - ("igrave" "{\\`{\\i}}") - ("iacute" "{\\'{\\i}}") - ("icircumflex" "{\\^{\\i}}") - ("iuml" "\\\"{\\i}") - ("ntilde" "\\~{n}") - ("ograve" "\\`{o}") - ("oacute" "\\'{o}") - ("ocurcumflex" "\\^{o}") - ("otilde" "\\~{o}") - ("ouml" "\\\"{o}") - ("divide" ,(math "\\div")) - ("oslash" "\\o") - ("ugrave" "\\`{u}") - ("uacute" "\\'{u}") - ("ucircumflex" "\\^{u}") - ("uuml" "\\\"{u}") - ("yacute" "\\'{y}") - ("ymul" "\\\"{y}") - ;; Greek - ("Alpha" "A") - ("Beta" "B") - ("Gamma" ,(math "\\Gamma")) - ("Delta" ,(math "\\Delta")) - ("Epsilon" "E") - ("Zeta" "Z") - ("Eta" "H") - ("Theta" ,(math "\\Theta")) - ("Iota" "I") - ("Kappa" "K") - ("Lambda" ,(math "\\Lambda")) - ("Mu" "M") - ("Nu" "N") - ("Xi" ,(math "\\Xi")) - ("Omicron" "O") - ("Pi" ,(math "\\Pi")) - ("Rho" "P") - ("Sigma" ,(math "\\Sigma")) - ("Tau" "T") - ("Upsilon" ,(math "\\Upsilon")) - ("Phi" ,(math "\\Phi")) - ("Chi" "X") - ("Psi" ,(math "\\Psi")) - ("Omega" ,(math "\\Omega")) - ("alpha" ,(math "\\alpha")) - ("beta" ,(math "\\beta")) - ("gamma" ,(math "\\gamma")) - ("delta" ,(math "\\delta")) - ("epsilon" ,(math "\\varepsilon")) - ("zeta" ,(math "\\zeta")) - ("eta" ,(math "\\eta")) - ("theta" ,(math "\\theta")) - ("iota" ,(math "\\iota")) - ("kappa" ,(math "\\kappa")) - ("lambda" ,(math "\\lambda")) - ("mu" ,(math "\\mu")) - ("nu" ,(math "\\nu")) - ("xi" ,(math "\\xi")) - ("omicron" ,(math "\\o")) - ("pi" ,(math "\\pi")) - ("rho" ,(math "\\rho")) - ("sigmaf" ,(math "\\varsigma")) - ("sigma" ,(math "\\sigma")) - ("tau" ,(math "\\tau")) - ("upsilon" ,(math "\\upsilon")) - ("phi" ,(math "\\varphi")) - ("chi" ,(math "\\chi")) - ("psi" ,(math "\\psi")) - ("omega" ,(math "\\omega")) - ("thetasym" ,(math "\\vartheta")) - ("piv" ,(math "\\varpi")) - ;; punctuation - ("bullet" ,(math "\\bullet")) - ("ellipsis" ,(math "\\ldots")) - ("weierp" ,(math "\\wp")) - ("image" ,(math "\\Im")) - ("real" ,(math "\\Re")) - ("tm" ,(math "^{\\sc\\tiny{tm}}")) - ("alef" ,(math "\\aleph")) - ("<-" ,(math "\\leftarrow")) - ("<--" ,(math "\\longleftarrow")) - ("uparrow" ,(math "\\uparrow")) - ("->" ,(math "\\rightarrow")) - ("-->" ,(math "\\longrightarrow")) - ("downarrow" ,(math "\\downarrow")) - ("<->" ,(math "\\leftrightarrow")) - ("<-->" ,(math "\\longleftrightarrow")) - ("<+" ,(math "\\hookleftarrow")) - ("<=" ,(math "\\Leftarrow")) - ("<==" ,(math "\\Longleftarrow")) - ("Uparrow" ,(math "\\Uparrow")) - ("=>" ,(math "\\Rightarrow")) - ("==>" ,(math "\\Longrightarrow")) - ("Downarrow" ,(math "\\Downarrow")) - ("<=>" ,(math "\\Leftrightarrow")) - ("<==>" ,(math "\\Longleftrightarrow")) - ;; Mathematical operators - ("forall" ,(math "\\forall")) - ("partial" ,(math "\\partial")) - ("exists" ,(math "\\exists")) - ("emptyset" ,(math "\\emptyset")) - ("infinity" ,(math "\\infty")) - ("nabla" ,(math "\\nabla")) - ("in" ,(math "\\in")) - ("notin" ,(math "\\notin")) - ("ni" ,(math "\\ni")) - ("prod" ,(math "\\Pi")) - ("sum" ,(math "\\Sigma")) - ("asterisk" ,(math "\\ast")) - ("sqrt" ,(math "\\surd")) - ("propto" ,(math "\\propto")) - ("angle" ,(math "\\angle")) - ("and" ,(math "\\wedge")) - ("or" ,(math "\\vee")) - ("cap" ,(math "\\cap")) - ("cup" ,(math "\\cup")) - ("integral" ,(math "\\int")) - ("models" ,(math "\\models")) - ("vdash" ,(math "\\vdash")) - ("dashv" ,(math "\\dashv")) - ("sim" ,(math "\\sim")) - ("cong" ,(math "\\cong")) - ("approx" ,(math "\\approx")) - ("neq" ,(math "\\neq")) - ("equiv" ,(math "\\equiv")) - ("le" ,(math "\\leq")) - ("ge" ,(math "\\geq")) - ("subset" ,(math "\\subset")) - ("supset" ,(math "\\supset")) - ("subseteq" ,(math "\\subseteq")) - ("supseteq" ,(math "\\supseteq")) - ("oplus" ,(math "\\oplus")) - ("otimes" ,(math "\\otimes")) - ("perp" ,(math "\\perp")) - ("mid" ,(math "\\mid")) - ("lceil" ,(math "\\lceil")) - ("rceil" ,(math "\\rceil")) - ("lfloor" ,(math "\\lfloor")) - ("rfloor" ,(math "\\rfloor")) - ("langle" ,(math "\\langle")) - ("rangle" ,(math "\\rangle")) - ;; Misc - ("loz" ,(math "\\diamond")) - ("spades" ,(math "\\spadesuit")) - ("clubs" ,(math "\\clubsuit")) - ("hearts" ,(math "\\heartsuit")) - ("diams" ,(math "\\diamondsuit")) - ("euro" "\\euro{}") - ;; ConTeXt - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;;;; ====================================================================== -;;;; context-width -;;;; ====================================================================== -(define (context-width width) - (cond - ((string? width) - width) - ((and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\textwidth")) - (else - (string-append (number->string width) "pt")))) - -;;;; ====================================================================== -;;;; context-dim -;;;; ====================================================================== -(define (context-dim dimension) - (cond - ((string? dimension) - dimension) - ((number? dimension) - (string-append (number->string (inexact->exact (round dimension))) - "pt")))) - -;;;; ====================================================================== -;;;; context-url -;;;; ====================================================================== -(define(context-url url text e) - (let ((name (gensym 'url)) - (text (or text url))) - (printf "\\useURL[~A][~A][][" name url) - (output text e) - (printf "]\\from[~A]" name))) - -;;;; ====================================================================== -;;;; Color Management ... -;;;; ====================================================================== -(define *skribe-context-color-table* (make-hashtable)) - -(define (skribe-color->context-color spec) - (receive (r g b) - (skribe-color->rgb spec) - (let ((ff (exact->inexact #xff))) - (format "r=~a,g=~a,b=~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))) - - -(define (skribe-declare-used-colors) - (printf "\n%%Colors\n") - (for-each (lambda (spec) - (let ((c (hashtable-get *skribe-context-color-table* spec))) - (unless (string? c) - ;; Color was never used before - (let ((name (symbol->string (gensym 'col)))) - (hashtable-put! *skribe-context-color-table* spec name) - (printf "\\definecolor[~A][~A]\n" - name - (skribe-color->context-color spec)))))) - (skribe-get-used-colors)) - (newline)) - -(define (skribe-declare-standard-colors engine) - (for-each (lambda (x) - (skribe-use-color! (engine-custom engine x))) - '(source-comment-color source-define-color source-module-color - source-markup-color source-thread-color source-string-color - source-bracket-color source-type-color))) - -(define (skribe-get-color spec) - (let ((c (and (hashtable? *skribe-context-color-table*) - (hashtable-get *skribe-context-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'context "Can't find color" spec) - c))) - -;;;; ====================================================================== -;;;; context-engine ... -;;;; ====================================================================== -(define context-engine - (default-engine-set! - (make-engine 'context - :version 1.0 - :format "context" - :delegate (find-engine 'base) - :filter (make-string-replace context-encoding) - :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m))) - :custom context-customs))) - -;;;; ====================================================================== -;;;; document ... -;;;; ====================================================================== -(markup-writer 'document - :options '(:title :subtitle :author :ending :env) - :before (lambda (n e) - ;; Prelude - (printf "% interface=en output=pdftex\n") - (display "%%%% -*- TeX -*-\n") - (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" - (skribe-release) (date)) - ;; Make URLs active - (printf "\\setupinteraction[state=start]\n") - ;; Choose the document font - (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) - (engine-custom e 'font-size)) - ;; Color - (display "\\setupcolors[state=start]\n") - ;; Load Style - (printf "\\input skribe-context-~a.tex\n" - (engine-custom e 'document-style)) - ;; Insert User customization - (let ((s (engine-custom e 'user-style))) - (when s (printf "\\input ~a\n" s))) - ;; Output used colors - (skribe-declare-standard-colors e) - (skribe-declare-used-colors) - - (display "\\starttext\n\\StartTitlePage\n") - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&context-title) - (body t) - (options - `((subtitle ,(markup-option n :subtitle))))) - e - :env `((parent ,n))))) - ;; author(s) - (let ((a (markup-option n :author))) - (when a - (if (list? a) - ;; List of authors. Use multi-columns - (begin - (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) - (display "\\startAuthors\n") - (let Loop ((l a)) - (unless (null? l) - (output (car l) e) - (unless (null? (cdr l)) - (display "\\nextAuthors\n") - (Loop (cdr l))))) - (display "\\stopAuthors\n\n")) - ;; One author, that's easy - (output a e)))) - ;; End of the title - (display "\\StopTitlePage\n")) - :after (lambda (n e) - (display "\n\\stoptext\n"))) - - - -;;;; ====================================================================== -;;;; &context-title ... -;;;; ====================================================================== -(markup-writer '&context-title - :before "{\\DocumentTitle{" - :action (lambda (n e) - (output (markup-body n) e) - (let ((sub (markup-option n 'subtitle))) - (when sub - (display "\\\\\n\\switchtobodyfont[16pt]\\it{") - (output sub e) - (display "}\n")))) - :after "}}") - -;;;; ====================================================================== -;;;; author ... -;;;; ====================================================================== -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (out (lambda (n) - (output n e) - (display "\\\\\n")))) - (display "{\\midaligned{") - (when name (out name)) - (when title (out title)) - (when affiliation (out affiliation)) - (when (pair? address) (for-each out address)) - (when phone (out phone)) - (when email (out email)) - (when url (out url)) - (display "}}\n")))) - - -;;;; ====================================================================== -;;;; toc ... -;;;; ====================================================================== -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\placecontent\n"))) - -;;;; ====================================================================== -;;;; context-block-before ... -;;;; ====================================================================== -(define (context-block-before name name-unnum) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a[~a]{" (if num name name-unnum) - (string-canonicalize (markup-ident n))) - (output (markup-option n :title) e) - (display "}\n")))) - - -;;;; ====================================================================== -;;;; chapter, section, ... -;;;; ====================================================================== -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (context-block-before 'chapter 'title)) - - -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (context-block-before 'section 'subject)) - - -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsection 'subsubject)) - - -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (context-block-before 'subsubsection 'subsubsubject)) - -;;;; ====================================================================== -;;;; paragraph ... -;;;; ====================================================================== -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :after "\\par\n") - -;;;; ====================================================================== -;;;; footnote ... -;;;; ====================================================================== -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;;;; ====================================================================== -;;;; linebreak ... -;;;; ====================================================================== -(markup-writer 'linebreak - :action "\\crlf ") - -;;;; ====================================================================== -;;;; hrule ... -;;;; ====================================================================== -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (printf "\\blackrule[width=~A,height=~A]\n" - (context-width (markup-option n :width)) - (context-dim (markup-option n :height))))) - -;;;; ====================================================================== -;;;; color ... -;;;; ====================================================================== -(markup-writer 'color - :options '(:bg :fg :width :margin :border) - :before (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (if (or bg w m b) - (begin - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (if b (context-width b) "0pt")) - (when m - (printf ",offset=~A" (context-width m))) - (when bg - (printf ",background=color,backgroundcolor=~A" - (skribe-get-color bg))) - (when fg - (printf ",foregroundcolor=~A" - (skribe-get-color fg))) - (when c - (display ",framecorner=round")) - (printf "]\n")) - ;; Probably just a foreground was specified - (when fg - (printf "\\startcolor[~A] " (skribe-get-color fg)))))) - :after (lambda (n e) - (let ((bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (w (markup-option n :width)) - (m (markup-option n :margin)) - (b (markup-option n :border))) - (if (or bg w m b) - (printf "\\stopframedtext ") - (when fg - (printf "\\stopcolor ")))))) -;;;; ====================================================================== -;;;; frame ... -;;;; ====================================================================== -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (b (markup-option n :border)) - (c (markup-option n :round-corner))) - (printf "\\startframedtext[width=~a" (if w - (context-width w) - "fit")) - (printf ",rulethickness=~A" (context-dim b)) - (printf ",offset=~A" (context-width m)) - (when c - (display ",framecorner=round")) - (printf "]\n"))) - :after "\\stopframedtext ") - -;;;; ====================================================================== -;;;; font ... -;;;; ====================================================================== -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (engine-custom e 'font-size)) - (ns (cond - ((and (integer? size) (exact? size)) - (if (> size 0) - size - (+ cs size))) - ((and (number? size) (inexact? size)) - (+ cs (inexact->exact size))) - ((string? size) - (let ((nb (string->number size))) - (if (not (number? nb)) - (skribe-error - 'font - (format "Illegal font size ~s" size) - nb) - (+ cs nb)))))) - (ne (make-engine (gensym 'context) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\switchtobodyfont[~apt]" ns) - (output (markup-body n) ne) - (display "}")))) - - -;;;; ====================================================================== -;;;; flush ... -;;;; ====================================================================== -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n\n\\midaligned{")) - ((left) - (display "\n\n\\leftaligned{")) - ((right) - (display "\n\n\\rightaligned{")))) - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\n\n\\midaligned{" - :after "}\n") - -;;;; ====================================================================== -;;;; pre ... -;;;; ====================================================================== -(markup-writer 'pre - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - -;;;; ====================================================================== -;;;; prog ... -;;;; ====================================================================== -(markup-writer 'prog - :options '(:line :mark) - :before "{\\tt\n\\startlines\n\\fixedspaces\n" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'context) - :delegate e - :filter (make-string-replace context-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after "\n\\stoplines\n}") - - -;;;; ====================================================================== -;;;; itemize, enumerate ... -;;;; ====================================================================== -(define (context-itemization-action n e descr?) - (let ((symbol (markup-option n :symbol))) - (for-each (lambda (item) - (if symbol - (begin - (display "\\sym{") - (output symbol e) - (display "}")) - ;; output a \item iff not a description - (unless descr? - (display " \\item "))) - (output item e) - (newline)) - (markup-body n)))) - -(markup-writer 'itemize - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - - -(markup-writer 'enumerate - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[n][standard]\n" - :action (lambda (n e) (context-itemization-action n e #f)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; description ... -;;;; ====================================================================== -(markup-writer 'description - :options '(:symbol) - :before "\\startnarrower[left]\n\\startitemize[serried]\n" - :action (lambda (n e) (context-itemization-action n e #t)) - :after "\\stopitemize\n\\stopnarrower\n") - -;;;; ====================================================================== -;;;; item ... -;;;; ====================================================================== -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (when k - ;; Output the key(s) - (let Loop ((l (if (pair? k) k (list k)))) - (unless (null? l) - (output (bold (car l)) e) - (unless (null? (cdr l)) - (display "\\crlf\n")) - (Loop (cdr l)))) - (display "\\nowhitespace\\startnarrower[left]\n")) - ;; Output body - (output (markup-body n) e) - ;; Terminate - (when k - (display "\n\\stopnarrower\n"))))) - -;;;; ====================================================================== -;;;; blockquote ... -;;;; ====================================================================== -(markup-writer 'blockquote - :before "\n\\startnarrower[left,right]\n" - :after "\n\\stopnarrower\n") - - -;;;; ====================================================================== -;;;; figure ... -;;;; ====================================================================== -(markup-writer 'figure - :options '(:legend :number :multicolumns) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (unless number - (display "{\\setupcaptions[number=off]\n")) - (display "\\placefigure\n") - (printf " [~a]\n" (string-canonicalize ident)) - (display " {") (output legend e) (display "}\n") - (display " {") (output (markup-body n) e) (display "}") - (unless number - (display "}\n"))))) - -;;;; ====================================================================== -;;;; table ... -;;;; ====================================================================== - ;; width doesn't work -(markup-writer 'table - :options '(:width :border :frame :rules :cellpadding) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (printf "\n{\\bTABLE\n") - (printf "\\setupTABLE[") - (printf "width=~A" (if width (context-width width) "fit")) - (when border - (printf ",rulethickness=~A" (context-dim border))) - (when cp - (printf ",offset=~A" (context-width cp))) - (printf ",frame=off]\n") - - (when rules - (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") - (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n")) - (case rules - ((rows) (display hor)) - ((cols) (display vert)) - ((all) (display hor) (display vert))))) - - (when frame - ;; hsides, vsides, lhs, rhs, box, border - (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n") - (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n") - (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n") - (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n")) - (case frame - ((above) (display top)) - ((below) (display bot)) - ((hsides) (display top) (display bot)) - ((lhs) (display left)) - ((rhs) (display right)) - ((vsides) (display left) (diplay right)) - ((box border) (display top) (display bot) - (display left) (display right))))))) - - :after (lambda (n e) - (printf "\\eTABLE}\n"))) - - -;;;; ====================================================================== -;;;; tr ... -;;;; ====================================================================== -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (display "\\bTR") - (let ((bg (markup-option n :bg))) - (when bg - (printf "[background=color,backgroundcolor=~A]" - (skribe-get-color bg))))) - :after "\\eTR\n") - - -;;;; ====================================================================== -;;;; tc ... -;;;; ====================================================================== -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :before (lambda (n e) - (let ((th? (eq? 'th (markup-option n 'markup))) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (markup-option n :valign)) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "\\bTD[") - (printf "width=~a" (if width (context-width width) "fit")) - (when valign - ;; This is buggy. In fact valign an align can't be both - ;; specified in ConTeXt - (printf ",align=~a" (case valign - ((center) 'lohi) - ((bottom) 'low) - ((top) 'high)))) - (when align - (printf ",align=~a" (case align - ((left) 'right) ; !!!! - ((right) 'left) ; !!!! - (else 'middle)))) - (unless (equal? colspan 1) - (printf ",nx=~a" colspan)) - (display "]") - (when th? - ;; This is a TH, output is bolded - (display "{\\bf{")))) - - :after (lambda (n e) - (when (equal? (markup-option n 'markup) 'th) - ;; This is a TH, output is bolded - (display "}}")) - (display "\\eTD"))) - -;;;; ====================================================================== -;;;; image ... -;;;; ====================================================================== -(markup-writer 'image - :options '(:file :url :width :height :zoom) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (zoom (markup-option n :zoom)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("jpg")))))) - (if (not (string? img)) - (skribe-error 'context "Illegal image" file) - (begin - (printf "\\externalfigure[~A][frame=off" (strip-ref-base img)) - (if zoom (printf ",factor=~a" (inexact->exact zoom))) - (if width (printf ",width=~a" (context-width width))) - (if height (printf ",height=~apt" (context-dim height))) - (display "]")))))) - - -;;;; ====================================================================== -;;;; Ornaments ... -;;;; ====================================================================== -(markup-writer 'roman :before "{\\rm{" :after "}}") -(markup-writer 'bold :before "{\\bf{" :after "}}") -(markup-writer 'underline :before "{\\underbar{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\it{" :after "}}") -(markup-writer 'code :before "{\\tt{" :after "}}") -(markup-writer 'var :before "{\\tt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -;;//(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "{\\low{" :after "}}") -(markup-writer 'sup :before "{\\high{" :after "}}") - - -;;// -;;//(markup-writer 'tt -;;// :before "{\\texttt{" -;;// :action (lambda (n e) -;;// (let ((ne (make-engine -;;// (gensym 'latex) -;;// :delegate e -;;// :filter (make-string-replace latex-tt-encoding) -;;// :custom (engine-customs e) -;;// :symbol-table (engine-symbol-table e)))) -;;// (output (markup-body n) ne))) -;;// :after "}}") - -;;;; ====================================================================== -;;;; q ... -;;;; ====================================================================== -(markup-writer 'q - :before "\\quotation{" - :after "}") - -;;;; ====================================================================== -;;;; mailto ... -;;;; ====================================================================== -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-body n))) - (when (pair? url) - (context-url (format "mailto:~A" (car url)) - (or text - (car url)) - e))))) -;;;; ====================================================================== -;;;; mark ... -;;;; ====================================================================== -(markup-writer 'mark - :before (lambda (n e) - (printf "\\reference[~a]{}\n" - (string-canonicalize (markup-ident n))))) - -;;;; ====================================================================== -;;;; ref ... -;;;; ====================================================================== -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection - :figure :mark :handle :page) - :action (lambda (n e) - (let* ((text (markup-option n :text)) - (page (markup-option n :page)) - (c (handle-ast (markup-body n))) - (id (markup-ident c))) - (cond - (page ;; Output the page only (this is a hack) - (when text (output text e)) - (printf "\\at[~a]" - (string-canonicalize id))) - ((or (markup-option n :chapter) - (markup-option n :section) - (markup-option n :subsection) - (markup-option n :subsubsection)) - (if text - (printf "\\goto{~a}[~a]" (or text id) - (string-canonicalize id)) - (printf "\\in[~a]" (string-canonicalize id)))) - ((markup-option n :mark) - (printf "\\goto{~a}[~a]" - (or text id) - (string-canonicalize id))) - (else ;; Output a little image indicating the direction - (printf "\\in[~a]" (string-canonicalize id))))))) - -;;;; ====================================================================== -;;;; bib-ref ... -;;;; ====================================================================== -(markup-writer 'bib-ref - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) - (let* ((obj (handle-ast (markup-body n))) - (title (markup-option obj :title)) - (ref (markup-option title 'number)) - (ident (markup-ident obj))) - (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) - :after (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; bib-ref+ ... -;;;; ====================================================================== -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (invoke (writer-action (markup-writer-get 'bib-ref e)) - (car rs) - e) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after (lambda (n e) (output "]" e))) - -;;;; ====================================================================== -;;;; url-ref ... -;;;; ====================================================================== -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (context-url (markup-option n :url) (markup-option n :text) e))) - -;;//;*---------------------------------------------------------------------*/ -;;//;* line-ref ... */ -;;//;*---------------------------------------------------------------------*/ -;;//(markup-writer 'line-ref -;;// :options '(:offset) -;;// :before "{\\textit{" -;;// :action (lambda (n e) -;;// (let ((o (markup-option n :offset)) -;;// (v (string->number (markup-option n :text)))) -;;// (cond -;;// ((and (number? o) (number? v)) -;;// (display (+ o v))) -;;// (else -;;// (display v))))) -;;// :after "}}") - - -;;;; ====================================================================== -;;;; &the-bibliography ... -;;;; ====================================================================== -(markup-writer '&the-bibliography - :before "\n% Bibliography\n\n") - - -;;;; ====================================================================== -;;;; &bib-entry ... -;;;; ====================================================================== -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (skribe-eval (mark (markup-ident n)) e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n\n") - -;;;; ====================================================================== -;;;; &bib-entry-label ... -;;;; ====================================================================== -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) (output "[" e)) - :action (lambda (n e) (output (markup-option n :title) e)) - :after (lambda (n e) (output "] "e))) - -;;;; ====================================================================== -;;;; &bib-entry-title ... -;;;; ====================================================================== -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - - -;;//;*---------------------------------------------------------------------*/ -;;//;* &bib-entry-url ... */ -;;//;*---------------------------------------------------------------------*/ -;;//(markup-writer '&bib-entry-url -;;// :action (lambda (n e) -;;// (let* ((en (handle-ast (ast-parent n))) -;;// (url (markup-option en 'url)) -;;// (t (bold (markup-body url)))) -;;// (skribe-eval (ref :url (markup-body url) :text t) e)))) - - -;;;; ====================================================================== -;;;; &the-index ... -;;;; ====================================================================== -(markup-writer '&the-index - :options '(:column) - :action - (lambda (n e) - (define (make-mark-entry n) - (display "\\blank[medium]\n{\\bf\\it\\tfc{") - (skribe-eval (bold n) e) - (display "}}\\crlf\n")) - - (define (make-primary-entry n) - (let ((b (markup-body n))) - (markup-option-add! b :text (list (markup-option b :text) ", ")) - (markup-option-add! b :page #t) - (output n e))) - - (define (make-secondary-entry n) - (let* ((note (markup-option n :note)) - (b (markup-body n)) - (bb (markup-body b))) - (if note - (begin ;; This is another entry - (display "\\crlf\n ... ") - (markup-option-add! b :text (list note ", "))) - (begin ;; another line on an entry - (markup-option-add! b :text ", "))) - (markup-option-add! b :page #t) - (output n e))) - - ;; Writer body starts here - (let ((col (markup-option n :column))) - (when col - (printf "\\startcolumns[n=~a]\n" col)) - (for-each (lambda (item) - ;;(DEBUG "ITEM= ~S" item) - (if (pair? item) - (begin - (make-primary-entry (car item)) - (for-each (lambda (x) (make-secondary-entry x)) - (cdr item))) - (make-mark-entry item)) - (display "\\crlf\n")) - (markup-body n)) - (when col - (printf "\\stopcolumns\n"))))) - -;;;; ====================================================================== -;;;; &source-comment ... -;;;; ====================================================================== -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-line-comment ... -;;;; ====================================================================== -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-keyword ... -;;;; ====================================================================== -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) - -;;;; ====================================================================== -;;;; &source-error ... -;;;; ====================================================================== -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'error-color) cc) - (color :fg cc (it n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-define ... -;;;; ====================================================================== -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-module ... -;;;; ====================================================================== -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-markup ... -;;;; ====================================================================== -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-thread ... -;;;; ====================================================================== -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-string ... -;;;; ====================================================================== -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-bracket ... -;;;; ====================================================================== -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-key ... -;;;; ====================================================================== -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;;;; ====================================================================== -;;;; &source-type ... -;;;; ====================================================================== -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - - - -;;;; ====================================================================== -;;;; Context Only Markups -;;;; ====================================================================== - -;;; -;;; Margin -- put text in the margin -;;; -(define-markup (margin #!rest opts #!key (ident #f) (class "margin") - (side 'right) text) - (new markup - (markup 'margin) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -(markup-writer 'margin - :options '(:text) - :before (lambda (n e) - (display - "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n") - (display "\\inright{") - (output (markup-option n :text) e) - (display "}{")) - :after "}") - -;;; -;;; ConTeXt and TeX -;;; -(define-markup (ConTeXt #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\CONTEXT\\ " "\\CONTEXT")) - "ConTeXt")) - -(define-markup (TeX #!key (space #t)) - (if (engine-format? "context") - (! (if space "\\TEX\\ " "\\TEX")) - "ConTeXt")) - -;;;; ====================================================================== -;;;; Restore the base engine -;;;; ====================================================================== -(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/french.skr b/skribe/skr/french.skr deleted file mode 100644 index 373d076..0000000 --- a/skribe/skr/french.skr +++ /dev/null @@ -1,19 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* French Skribe style */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'usepackage - (string-append (engine-custom le 'usepackage) - "\\usepackage[french]{babel} -\\usepackage{a4}"))) diff --git a/skribe/skr/html.skr b/skribe/skr/html.skr deleted file mode 100644 index ebac5f2..0000000 --- a/skribe/skr/html.skr +++ /dev/null @@ -1,2251 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/html.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 12:28:57 2003 */ -;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* HTML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/htmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-engine - ;; setup the html engine - (default-engine-set! - (make-engine 'html - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@"))) - :custom `(;; the icon associated with the URL - (favicon #f) - ;; charset used - (charset "ISO-8859-1") - ;; enable/disable Javascript - (javascript #f) - ;; user html head - (head #f) - ;; user CSS - (css ()) - ;; user inlined CSS - (inline-css ()) - ;; user JS - (js ()) - ;; emit-sui - (emit-sui #f) - ;; the body - (background "#ffffff") - (foreground #f) - ;; the margins - (margin-padding 3) - (left-margin #f) - (chapter-left-margin #f) - (section-left-margin #f) - (left-margin-font #f) - (left-margin-size 17.) - (left-margin-background "#dedeff") - (left-margin-foreground #f) - (right-margin #f) - (chapter-right-margin #f) - (section-right-margin #f) - (right-margin-font #f) - (right-margin-size 17.) - (right-margin-background "#dedeff") - (right-margin-foreground #f) - ;; author configuration - (author-font #f) - ;; title configuration - (title-font #f) - (title-background "#8381de") - (title-foreground #f) - (file-title-separator " -- ") - ;; index configuration - (index-header-font-size +2.) - ;; chapter configuration - (chapter-number->string number->string) - (chapter-file #f) - ;; section configuration - (section-title-start "

") - (section-title-stop "

") - (section-title-background "#dedeff") - (section-title-foreground "black") - (section-title-number-separator " ") - (section-number->string number->string) - (section-file #f) - ;; subsection configuration - (subsection-title-start "

") - (subsection-title-stop "

") - (subsection-title-background "#ffffff") - (subsection-title-foreground "#8381de") - (subsection-title-number-separator " ") - (subsection-number->string number->string) - (subsection-file #f) - ;; subsubsection configuration - (subsubsection-title-start "

") - (subsubsection-title-stop "

") - (subsubsection-title-background #f) - (subsubsection-title-foreground "#8381de") - (subsubsection-title-number-separator " ") - (subsubsection-number->string number->string) - (subsubsection-file #f) - ;; source fontification - (source-color #t) - (source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - ;; image - (image-format ("png" "gif" "jpg" "jpeg"))) - :symbol-table '(("iexcl" "¡") - ("cent" "¢") - ("pound" "£") - ("currency" "¤") - ("yen" "¥") - ("section" "§") - ("mul" "¨") - ("copyright" "©") - ("female" "ª") - ("lguillemet" "«") - ("not" "¬") - ("registered" "®") - ("degree" "°") - ("plusminus" "±") - ("micro" "µ") - ("paragraph" "¶") - ("middot" "·") - ("male" "¸") - ("rguillemet" "»") - ("1/4" "¼") - ("1/2" "½") - ("3/4" "¾") - ("iquestion" "¿") - ("Agrave" "À") - ("Aacute" "Á") - ("Acircumflex" "Â") - ("Atilde" "Ã") - ("Amul" "Ä") - ("Aring" "Å") - ("AEligature" "Æ") - ("Oeligature" "Œ") - ("Ccedilla" "Ç") - ("Egrave" "È") - ("Eacute" "É") - ("Ecircumflex" "Ê") - ("Euml" "Ë") - ("Igrave" "Ì") - ("Iacute" "Í") - ("Icircumflex" "Î") - ("Iuml" "Ï") - ("ETH" "Ð") - ("Ntilde" "Ñ") - ("Ograve" "Ò") - ("Oacute" "Ó") - ("Ocurcumflex" "Ô") - ("Otilde" "Õ") - ("Ouml" "Ö") - ("times" "×") - ("Oslash" "Ø") - ("Ugrave" "Ù") - ("Uacute" "Ú") - ("Ucircumflex" "Û") - ("Uuml" "Ü") - ("Yacute" "Ý") - ("THORN" "Þ") - ("szlig" "ß") - ("agrave" "à") - ("aacute" "á") - ("acircumflex" "â") - ("atilde" "ã") - ("amul" "ä") - ("aring" "å") - ("aeligature" "æ") - ("oeligature" "œ") - ("ccedilla" "ç") - ("egrave" "è") - ("eacute" "é") - ("ecircumflex" "ê") - ("euml" "ë") - ("igrave" "ì") - ("iacute" "í") - ("icircumflex" "î") - ("iuml" "ï") - ("eth" "ð") - ("ntilde" "ñ") - ("ograve" "ò") - ("oacute" "ó") - ("ocurcumflex" "ô") - ("otilde" "õ") - ("ouml" "ö") - ("divide" "÷") - ("oslash" "ø") - ("ugrave" "ù") - ("uacute" "ú") - ("ucircumflex" "û") - ("uuml" "ü") - ("yacute" "ý") - ("thorn" "þ") - ("ymul" "ÿ") - ;; Greek - ("Alpha" "Α") - ("Beta" "Β") - ("Gamma" "Γ") - ("Delta" "Δ") - ("Epsilon" "Ε") - ("Zeta" "Ζ") - ("Eta" "Η") - ("Theta" "Θ") - ("Iota" "Ι") - ("Kappa" "Κ") - ("Lambda" "Λ") - ("Mu" "Μ") - ("Nu" "Ν") - ("Xi" "Ξ") - ("Omicron" "Ο") - ("Pi" "Π") - ("Rho" "Ρ") - ("Sigma" "Σ") - ("Tau" "Τ") - ("Upsilon" "Υ") - ("Phi" "Φ") - ("Chi" "Χ") - ("Psi" "Ψ") - ("Omega" "Ω") - ("alpha" "α") - ("beta" "β") - ("gamma" "γ") - ("delta" "δ") - ("epsilon" "ε") - ("zeta" "ζ") - ("eta" "η") - ("theta" "θ") - ("iota" "ι") - ("kappa" "κ") - ("lambda" "λ") - ("mu" "μ") - ("nu" "ν") - ("xi" "ξ") - ("omicron" "ο") - ("pi" "π") - ("rho" "ρ") - ("sigmaf" "ς") - ("sigma" "σ") - ("tau" "τ") - ("upsilon" "υ") - ("phi" "φ") - ("chi" "χ") - ("psi" "ψ") - ("omega" "ω") - ("thetasym" "ϑ") - ("piv" "ϖ") - ;; punctuation - ("bullet" "•") - ("ellipsis" "…") - ("weierp" "℘") - ("image" "ℑ") - ("real" "ℜ") - ("tm" "™") - ("alef" "ℵ") - ("<-" "←") - ("<--" "←") - ("uparrow" "↑") - ("->" "→") - ("-->" "→") - ("downarrow" "↓") - ("<->" "↔") - ("<-->" "↔") - ("<+" "↵") - ("<=" "⇐") - ("<==" "⇐") - ("Uparrow" "⇑") - ("=>" "⇒") - ("==>" "⇒") - ("Downarrow" "⇓") - ("<=>" "⇔") - ("<==>" "⇔") - ;; Mathematical operators - ("forall" "∀") - ("partial" "∂") - ("exists" "∃") - ("emptyset" "∅") - ("infinity" "∞") - ("nabla" "∇") - ("in" "∈") - ("notin" "∉") - ("ni" "∋") - ("prod" "∏") - ("sum" "∑") - ("asterisk" "∗") - ("sqrt" "√") - ("propto" "∝") - ("angle" "∠") - ("and" "∧") - ("or" "∨") - ("cap" "∩") - ("cup" "∪") - ("integral" "∫") - ("therefore" "∴") - ("models" "|=") - ("vdash" "|-") - ("dashv" "-|") - ("sim" "∼") - ("cong" "≅") - ("approx" "≈") - ("neq" "≠") - ("equiv" "≡") - ("le" "≤") - ("ge" "≥") - ("subset" "⊂") - ("supset" "⊃") - ("nsupset" "⊃") - ("subseteq" "⊆") - ("supseteq" "⊇") - ("oplus" "⊕") - ("otimes" "⊗") - ("perp" "⊥") - ("mid" "|") - ("lceil" "⌈") - ("rceil" "⌉") - ("lfloor" "⌊") - ("rfloor" "⌋") - ("langle" "〈") - ("rangle" "〉") - ;; Misc - ("loz" "◊") - ("spades" "♠") - ("clubs" "♣") - ("hearts" "♥") - ("diams" "♦") - ("euro" "ℐ") - ;; LaTeX - ("dag" "dag") - ("ddag" "ddag") - ("circ" "o") - ("top" "T") - ("bottom" "⊥") - ("lhd" "<") - ("rhd" ">") - ("parallel" "||"))))) - -;*---------------------------------------------------------------------*/ -;* html-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define html-title-engine - (copy-engine 'html-title base-engine - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """))))) - -;*---------------------------------------------------------------------*/ -;* html-browser-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-browser-title n) - (and (markup? n) - (or (markup-option n :html-title) - (if (document? n) - (markup-option n :title) - (html-browser-title (ast-parent n)))))) - -;*---------------------------------------------------------------------*/ -;* html-file ... */ -;*---------------------------------------------------------------------*/ -(define html-file - (let ((table '()) - (filename (gensym))) - (define (get-file-name base suf) - (let* ((c (assoc base table)) - (n (if (pair? c) - (let ((n (+ 1 (cdr c)))) - (set-cdr! c n) - n) - (begin - (set! table (cons (cons base 1) table)) - 1)))) - (format "~a-~a.~a" base n suf))) - (lambda (node e) - (let ((f (markup-option node filename)) - (file (markup-option node :file))) - (cond - ((string? f) - f) - ((string? file) - file) - ((or file - (and (is-markup? node 'chapter) - (engine-custom e 'chapter-file)) - (and (is-markup? node 'section) - (engine-custom e 'section-file)) - (and (is-markup? node 'subsection) - (engine-custom e 'subsection-file)) - (and (is-markup? node 'subsubsection) - (engine-custom e 'subsubsection-file))) - (let* ((b (or (and (string? *skribe-dest*) - (prefix *skribe-dest*)) - "")) - (s (or (and (string? *skribe-dest*) - (suffix *skribe-dest*)) - "html")) - (nm (get-file-name b s))) - (markup-option-add! node filename nm) - nm)) - ((document? node) - *skribe-dest*) - (else - (let ((p (ast-parent node))) - (if (container? p) - (let ((file (html-file p e))) - (if (string? file) - (begin - (markup-option-add! node filename file) - file) - #f)) - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* html-container-number ... */ -;* ------------------------------------------------------------- */ -;* Returns a string representing the container number */ -;*---------------------------------------------------------------------*/ -(define (html-container-number c e) - (define (html-number n proc) - (cond - ((string? n) - n) - ((number? n) - (if (procedure? proc) - (proc n) - (number->string n))) - (else - ""))) - (define (html-chapter-number c) - (html-number (markup-option c :number) - (engine-custom e 'chapter-number->string))) - (define (html-section-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'section-number->string)))) - (cond - ((is-markup? p 'chapter) - (string-append (html-chapter-number p) "." s)) - (else - (string-append s))))) - (define (html-subsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsection-number->string)))) - (cond - ((is-markup? p 'section) - (string-append (html-section-number p) "." s)) - (else - (string-append "." s))))) - (define (html-subsubsection-number c) - (let ((p (ast-parent c)) - (s (html-number (markup-option c :number) - (engine-custom e 'subsubsection-number->string)))) - (cond - ((is-markup? p 'subsection) - (string-append (html-subsection-number p) "." s)) - (else - (string-append ".." s))))) - (define (inner-html-container-number c) - (html-number (markup-option c :number) #f)) - (let ((n (markup-option c :number))) - (if (not n) - "" - (case (markup-markup c) - ((chapter) - (html-chapter-number c)) - ((section) - (html-section-number c)) - ((subsection) - (html-subsection-number c)) - ((subsubsection) - (html-subsubsection-number c)) - (else - (if (container? c) - (inner-html-container-number c) - (skribe-error 'html-container-number - "Not a container" - (markup-markup c)))))))) - -;*---------------------------------------------------------------------*/ -;* html-counter ... */ -;*---------------------------------------------------------------------*/ -(define (html-counter cnts) - (cond - ((not cnts) - "") - ((null? cnts) - "") - ((not (pair? cnts)) - cnts) - ((null? (cdr cnts)) - (format "~a." (car cnts))) - (else - (let loop ((cnts cnts)) - (if (null? (cdr cnts)) - (format "~a" (car cnts)) - (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) - -;*---------------------------------------------------------------------*/ -;* html-width ... */ -;*---------------------------------------------------------------------*/ -(define (html-width width) - (cond - ((and (integer? width) (exact? width)) - (format "~A" width)) - ((real? width) - (format "~A%" (inexact->exact (round width)))) - ((string? width) - width) - (else - (skribe-error 'html-width "bad width" width)))) - -;*---------------------------------------------------------------------*/ -;* html-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-class m) - (if (markup? m) - (let ((c (markup-class m))) - (if (or (string? c) (symbol? c) (number? c)) - (printf " class=\"~a\"" c))))) - -;*---------------------------------------------------------------------*/ -;* html-markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (html-markup-class m) - (lambda (n e) - (printf "<~a" m) - (html-class n) - (display ">"))) - -;*---------------------------------------------------------------------*/ -;* html-color-spec? ... */ -;*---------------------------------------------------------------------*/ -(define (html-color-spec? v) - (and v - (not (unspecified? v)) - (or (not (string? v)) (> (string-length v) 0)))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :html-title :env) - :action (lambda (n e) - (let* ((id (markup-ident n)) - (title (new markup - (markup '&html-document-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (options `((author ,(markup-option n :author)))) - (body (markup-option n :title))))) - (&html-generic-document n title e))) - :after (lambda (n e) - (if (engine-custom e 'emit-sui) - (document-sui n e)))) - -;*---------------------------------------------------------------------*/ -;* &html-html ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-html - :before " - -\n" - :after "") - -;*---------------------------------------------------------------------*/ -;* &html-head ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-head - :before (lambda (n e) - (printf "\n") - (printf "\n" (engine-custom (find-engine 'html) - 'charset))) - :after "\n\n") - -;*---------------------------------------------------------------------*/ -;* &html-body ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-body - :before (lambda (n e) - (let ((bg (engine-custom e 'background))) - (display "\n"))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* &html-page ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-page - :action (lambda (n e) - (define (html-margin m fn size bg fg cla) - (printf "" bg) - (display ">")) - (printf "
\n" cla) - (cond - ((and (string? fg) (string? fn)) - (printf "" fg fn)) - ((string? fg) - (printf "" fg)) - ((string? fn) - (printf "" fn))) - (if (procedure? m) - (skribe-eval (m n e) e) - (output m e)) - (if (or (string? fg) (string? fn)) - (display "")) - (display "
\n")) - (let ((body (markup-body n)) - (lm (engine-custom e 'left-margin)) - (lmfn (engine-custom e 'left-margin-font)) - (lms (engine-custom e 'left-margin-size)) - (lmbg (engine-custom e 'left-margin-background)) - (lmfg (engine-custom e 'left-margin-foreground)) - (rm (engine-custom e 'right-margin)) - (rmfn (engine-custom e 'right-margin-font)) - (rms (engine-custom e 'right-margin-size)) - (rmbg (engine-custom e 'right-margin-background)) - (rmfg (engine-custom e 'right-margin-foreground))) - (cond - ((and lm rm) - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "
")) - (lm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n" ac)) - (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") - (html-margin body #f #f #f #f "skribe-body") - (display "
")) - (rm - (let* ((ep (engine-custom e 'margin-padding)) - (ac (if (number? ep) ep 0))) - (printf "\n")) - (html-margin body #f #f #f #f "skribe-body") - (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") - (display "
")) - (else - (display "
\n") - (output body e) - (display "
\n")))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-header ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-header n e) - (let* ((ic (engine-custom e 'favicon)) - (id (markup-ident n))) - (unless (string? id) - (skribe-error '&html-generic-header - (format "Illegal identifier `~a'" id) - n)) - ;; title - (output (new markup - (markup '&html-header-title) - (parent n) - (ident (string-append id "-title")) - (class (markup-class n)) - (body (markup-body n))) - e) - ;; favicon - (output (new markup - (markup '&html-header-favicon) - (parent n) - (ident (string-append id "-favicon")) - (body (cond - ((string? ic) - ic) - ((procedure? ic) - (ic d e))))) - e) - ;; style - (output (new markup - (markup '&html-header-style) - (parent n) - (ident (string-append id "-style")) - (class (markup-class n))) - e) - ;; css - (output (new markup - (markup '&html-header-css) - (parent n) - (ident (string-append id "-css")) - (body (let ((c (engine-custom e 'css))) - (if (string? c) - (list c) - c)))) - e) - ;; javascript - (output (new markup - (markup '&html-header-javascript) - (parent n) - (ident (string-append id "-javascript"))) - e))) - -(markup-writer '&html-header-title - :before "" - :action (lambda (n e) - (output (markup-body n) html-title-engine)) - :after "\n") - -(markup-writer '&html-header-favicon - :action (lambda (n e) - (let ((i (markup-body n))) - (when i - (printf " \n" i))))) - -(markup-writer '&html-header-css - :action (lambda (n e) - (let ((css (markup-body n))) - (when (pair? css) - (for-each (lambda (css) - (printf " \n" css)) - css))))) - -(markup-writer '&html-header-style - :before " \n") - -(markup-writer '&html-header-javascript - :action (lambda (n e) - (when (engine-custom e 'javascript) - (display " \n")) - (let* ((ejs (engine-custom e 'js)) - (js (cond - ((string? ejs) - (list ejs)) - ((list? ejs) - ejs) - (else - '())))) - (for-each (lambda (s) - (printf "" s)) - js)))) - - -;*---------------------------------------------------------------------*/ -;* &html-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-header :action &html-generic-header) -(markup-writer '&html-chapter-header :action &html-generic-header) -(markup-writer '&html-section-header :action &html-generic-header) -(markup-writer '&html-subsection-header :action &html-generic-header) -(markup-writer '&html-subsubsection-header :action &html-generic-header) - -;*---------------------------------------------------------------------*/ -;* &html-ending ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-ending - :before "
" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval [ -,(hrule) -,(p :class "ending" (font :size -1 [ -This ,(sc "Html") page has been produced by -,(ref :url (skribe-url) :text "Skribe"). -,(linebreak) -Last update ,(it (date)).]))] e)))) - :after "
\n") - -;*---------------------------------------------------------------------*/ -;* &html-generic-title ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (when title - (display "\n") - (if (html-color-spec? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (when title - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "
") - (output title e) - (display "
")))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n")))) - -;*---------------------------------------------------------------------*/ -;* &html-document-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-document-title :action &html-generic-title) -(markup-writer '&html-chapter-title :action &html-generic-title) -(markup-writer '&html-section-title :action &html-generic-title) -(markup-writer '&html-subsection-title :action &html-generic-title) -(markup-writer '&html-subsubsection-title :action &html-generic-title) - -;*---------------------------------------------------------------------*/ -;* &html-footnotes */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-footnotes - :before (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (display "
") - (display "

\n") - (display "
\n")))) - :action (lambda (n e) - (let ((footnotes (markup-body n))) - (when (pair? footnotes) - (let loop ((fns footnotes)) - (if (pair? fns) - (let ((fn (car fns))) - (printf "" - (string-canonicalize - (container-ident fn))) - (printf "~a: " - (markup-option fn :number)) - (output (markup-body fn) e) - (display "\n
\n") - (loop (cdr fns))))) - (display "
"))))) - -;*---------------------------------------------------------------------*/ -;* html-title-authors ... */ -;*---------------------------------------------------------------------*/ -(define (html-title-authors authors e) - (define (html-authorsN authors cols first) - (define (make-row authors . opt) - (tr (map (lambda (v) - (apply td :align 'center :valign 'top v opt)) - authors))) - (define (make-rows authors) - (let loop ((authors authors) - (rows '()) - (row '()) - (cnum 0)) - (cond - ((null? authors) - (reverse! (cons (make-row (reverse! row)) rows))) - ((= cnum cols) - (loop authors - (cons (make-row (reverse! row)) rows) - '() - 0)) - (else - (loop (cdr authors) - rows - (cons (car authors) row) - (+ cnum 1)))))) - (output (table :cellpadding 10 - (if first - (cons (make-row (list (car authors)) :colspan cols) - (make-rows (cdr authors))) - (make-rows authors))) - e)) - (cond - ((pair? authors) - (display "
\n") - (let ((len (length authors))) - (case len - ((1) - (output (car authors) e)) - ((2 3) - (html-authorsN authors len #f)) - ((4) - (html-authorsN authors 2 #f)) - (else - (html-authorsN authors 3 #t)))) - (display "
\n")) - (else - (html-title-authors (list authors) e)))) - -;*---------------------------------------------------------------------*/ -;* document-sui ... */ -;*---------------------------------------------------------------------*/ -(define (document-sui n e) - (define (sui) - (display "(sui \"") - (skribe-eval (markup-option n :title) html-title-engine) - (display "\"\n") - (printf " :file ~s\n" (sui-referenced-file n e)) - (sui-marks n e) - (sui-blocks 'chapter n e) - (sui-blocks 'section n e) - (sui-blocks 'subsection n e) - (sui-blocks 'subsubsection n e) - (display " )\n")) - (if (string? *skribe-dest*) - (let ((f (format "~a.sui" (prefix *skribe-dest*)))) - (with-output-to-file f sui)) - (sui))) - -;*---------------------------------------------------------------------*/ -;* sui-referenced-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-referenced-file n e) - (let ((file (html-file n e))) - (if (member (suffix file) '("skb" "sui" "skr" "html")) - (string-append (strip-ref-base (prefix file)) ".html") - file))) - -;*---------------------------------------------------------------------*/ -;* sui-marks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-marks n e) - (printf " (marks") - (for-each (lambda (m) - (printf "\n (~s" (markup-ident m)) - (printf " :file ~s" (sui-referenced-file m e)) - (printf " :mark ~s" (markup-ident m)) - (when (markup-class m) - (printf " :class ~s" (markup-class m))) - (display ")")) - (search-down (lambda (n) (is-markup? n 'mark)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* sui-blocks ... */ -;*---------------------------------------------------------------------*/ -(define (sui-blocks kind n e) - (printf " (~as" kind) - (for-each (lambda (chap) - (display "\n (\"") - (skribe-eval (markup-option chap :title) html-title-engine) - (printf "\" :file ~s" (sui-referenced-file chap e)) - (printf " :mark ~s" (markup-ident chap)) - (when (markup-class chap) - (printf " :class ~s" (markup-class chap))) - (display ")")) - (container-search-down (lambda (n) (is-markup? n kind)) n)) - (display ")\n")) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (display "\n")) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (define (row n) - (printf "" align) - (output n e) - (display "")) - ;; name - (printf "" align) - (if nfn - (printf "\n" nfn) - (display "\n")) - (output name e) - (if nfn - (printf "\n") - (display "\n")) - (display "") - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after "") - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :predicate (lambda (n e) (markup-option n :photo)) - :before (lambda (n e) - (display "\n")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (display "") - (output photo e) - (display "") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display ""))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options 'all - :action (lambda (n e) - (define (col n) - (let loop ((i 0)) - (if (< i n) - (begin - (display "") - (loop (+ i 1)))))) - (define (toc-entry fe level) - (let* ((c (car fe)) - (ch (cdr fe)) - (t (markup-option c :title)) - (id (markup-ident c)) - (f (html-file c e))) - (unless (string? id) - (skribe-error 'toc - (format "Illegal identifier `~a'" id) - c)) - (display " ") - ;; blank columns - (col level) - ;; number - (printf "~a" - (html-container-number c e)) - ;; title - (printf "" - (- 4 level)) - (printf "" - (if (string=? f *skribe-dest*) - "" - (strip-ref-base (or f *skribe-dest* ""))) - (string-canonicalize id)) - (output (markup-option c :title) e) - (display "") - (display "\n") - ;; the children - (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) - (define (symbol->keyword s) - (cond-expand - (stklos - (make-keyword s)) - (bigloo - (string->keyword (string-append ":" (symbol->string s)))))) - (let* ((c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection)) - (b (markup-body n)) - (bb (if (handle? b) - (handle-ast b) - b))) - (if (not (container? bb)) - (error 'toc - "Illegal body (container expected)" - (if (markup? bb) - (markup-markup bb) - "???")) - (let ((lst (find-down (lambda (x) - (and (markup? x) - (markup-option x :toc) - (or (and sss (is-markup? x 'subsubsection)) - (and ss (is-markup? x 'subsection)) - (and s (is-markup? x 'section)) - (and c (is-markup? x 'chapter)) - (markup-option n (symbol->keyword - (markup-markup x)))))) - (container-body bb)))) - ;; avoid to produce an empty table - (unless (null? lst) - (display "\n\n") - - (for-each (lambda (n) (toc-entry n 0)) lst) - - (display "\n
\n"))))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-document ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-document n title e) - (let* ((id (markup-ident n)) - (header (new markup - (markup '&html-chapter-header) - (ident (string-append id "-header")) - (class (markup-class n)) - (parent n) - (body (html-browser-title n)))) - (head (new markup - (markup '&html-head) - (ident (string-append id "-head")) - (class (markup-class n)) - (parent n) - (body header))) - (ftnote (new markup - (markup '&html-footnotes) - (ident (string-append id "-footnote")) - (class (markup-class n)) - (parent n) - (body (reverse! - (container-env-get n 'footnote-env))))) - (page (new markup - (markup '&html-page) - (ident (string-append id "-page")) - (class (markup-class n)) - (parent n) - (body (list (markup-body n) ftnote)))) - (ending (new markup - (markup '&html-ending) - (ident (string-append id "-ending")) - (class (markup-class n)) - (parent n) - (body (or (markup-option n :ending) - (let ((p (ast-document n))) - (and p (markup-option p :ending))))))) - (body (new markup - (markup '&html-body) - (ident (string-append id "-body")) - (class (markup-class n)) - (parent n) - (body (list title page ending)))) - (html (new markup - (markup '&html-html) - (ident (string-append id "-html")) - (class (markup-class n)) - (parent n) - (body (list head body))))) - ;; No file must be opened for documents. These files are - ;; directly opened by Skribe - (if (document? n) - (output html e) - (with-output-to-file (html-file n e) - (lambda () - (output html e)))))) - -;*---------------------------------------------------------------------*/ -;* &html-generic-subdocument ... */ -;*---------------------------------------------------------------------*/ -(define (&html-generic-subdocument n e) - (let* ((p (ast-document n)) - (id (markup-ident n)) - (ti (let* ((nb (html-container-number n e)) - (tc (markup-option n :title)) - (ti (if (document? p) - (list (markup-option p :title) - (engine-custom e 'file-title-separator) - tc) - tc)) - (sep (engine-custom - e - (symbol-append (markup-markup n) - '-title-number-separator))) - (nti (and tc - (if (and nb (not (equal? nb ""))) - (list nb - (if (unspecified? sep) ". " sep) - ti) - ti)))) - (new markup - (markup (symbol-append '&html- (markup-markup n) '-title)) - (ident (string-append id "-title")) - (parent n) - (options '((author ()))) - (body nti))))) - (case (markup-markup n) - ((chapter) - (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) - ((section) - (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) - (&html-generic-document n ti e))) - -;*---------------------------------------------------------------------*/ -;* chapter ... @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :before (lambda (n e) - (let ((title (markup-option n :title)) - (ident (markup-ident n))) - (display "\n") - (display "\n") - (display "
") - (output (html-container-number n e) e) - (display " ") - (output (markup-option n :title) e) - (display "
"))) - :after "
") - -;; This writer is invoked only for chapters rendered inside separate files! -(markup-writer 'chapter - :options '(:title :number :file :toc :html-title :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'chapter-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* html-section-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-section-title n e) - (let* ((title (markup-option n :title)) - (number (markup-option n :number)) - (c (markup-class n)) - (ident (markup-ident n)) - (kind (markup-markup n)) - (tbg (engine-custom e (symbol-append kind '-title-background))) - (tfg (engine-custom e (symbol-append kind '-title-foreground))) - (tstart (engine-custom e (symbol-append kind '-title-start))) - (tstop (engine-custom e (symbol-append kind '-title-stop))) - (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) - ;; the section header - (display "\n") - (display "\n") - (if c - (printf "
" c) - (printf "
" (markup-markup n))) - (when (html-color-spec? tbg) - (display "") - (printf "
" tbg)) - (display tstart) - (if tfg (printf "" tfg)) - (if number - (begin - (output (html-container-number n e) e) - (output nsep e))) - (output title e) - (if tfg (display "\n")) - (display tstop) - (when (and (string? tbg) (> (string-length tbg) 0)) - (display "
\n")) - (display "
") - (display "")) - (newline)) - -;*---------------------------------------------------------------------*/ -;* section ... @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :before html-section-title - :after "

\n") - -;; on-file section writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'section-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "
\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :html-title :number :toc :env :file) - :before html-section-title - :after "
\n") - -;; on-file subsection writer -(markup-writer 'section - :options '(:title :html-title :number :toc :file :env) - :predicate (lambda (n e) - (or (markup-option n :file) - (engine-custom e 'subsubsection-file))) - :action &html-generic-subdocument) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "~a" - (ast-location n))) - ((html-markup-class "p") n e)) - :after "

") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :options '(:number) - :action (lambda (n e) - (printf "~a" - (string-canonicalize (container-ident n)) - (markup-option n :number)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :before (lambda (n e) - (display ""))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '(:width :height) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (height (markup-option n :height))) - (display " height 1) - (printf " size=\"~a\"" height)) - (display ">")))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when (html-color-spec? bg) - (display "\n") - (display "\n
")) - (when (html-color-spec? fg) - (display "")))) - :after (lambda (n e) - (when (html-color-spec? (markup-option n :fg)) - (display "")) - (when (html-color-spec? (markup-option n :bg)) - (display "
")))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :margin :border) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (b (markup-option n :border)) - (w (markup-option n :width))) - (display "\n\n
"))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size :face) - :before (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "" "")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s)))) - (when (or (and (number? size) (exact? size)) face) - (display "")))) - :after (lambda (n e) - (let ((size (markup-option n :size)) - (face (markup-option n :face))) - (when (or (and (number? size) (exact? size) (not (= size 0))) - face) - (display "
")) - (when (and (number? size) (inexact? size)) - (let ((s (if (> size 0) "" "")) - (d (if (> size 0) 1 -1))) - (do ((i (inexact->exact size) (- i d))) - ((= i 0)) - (display s))))))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n")) - ((left) - (display "

\n")) - ((right) - (display "
")) - (else - (skribe-error 'flush - "Illegal side" - (markup-option n :side))))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\n")) - ((right) - (display "
\n")) - ((left) - (display "

\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before (html-markup-class "center") - :after "\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre :before (html-markup-class "pre") :after "\n") - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (html-markup-class "pre") - :after "\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before (html-markup-class "ul") - :action (lambda (n e) - (for-each (lambda (item) - (display "") - (output item e) - (display "\n")) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before (html-markup-class "ol") - :action (lambda (n e) - (for-each (lambda (item) - (display "") - (output item e) - (display "\n")) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before (html-markup-class "dl") - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " ") - (output i e) - (display "")) - (if (pair? k) k (list k))) - (display "") - (output (markup-body item) e) - (display "\n"))) - (markup-body n))) - :after "") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "") - (output k e) - (display " ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :options '() - :before (lambda (n e) - (display "
\n")) - :after "\n
\n") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns :legend-width) - :before (html-markup-class "br") - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend))) - (display "\n") - (output (markup-body n) e) - (display "
\n") - (output (new markup - (markup '&html-figure-legend) - (parent n) - (ident (string-append ident "-legend")) - (class (markup-class n)) - (options `((:number ,number))) - (body legend)) - e))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* &html-figure-legend ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-legend - :options '(:number) - :before (lambda (n e) - (display "
") - (let ((number (markup-option n :number)) - (legend (markup-option n :legend))) - (if number - (printf "Fig. ~a: " number) - (printf "Fig. : ")))) - :after "
") - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (border (markup-option n :border)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (cp (markup-option n :cellpadding)) - (cs (markup-option n :cellspacing))) - (display "= cp 0)) - (printf " cellpadding=\"~a\"" cp)) - (if (and (number? cs) (>= cs 0)) - (printf " cellspacing=\"~a\"" cs)) - (cond - ((symbol? cstyle) - (printf " style=\"border-collapse: ~a;\"" cstyle)) - ((string? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) - ((number? cstyle) - (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) - (if frame - (printf " frame=\"~a\"" - (if (eq? frame 'none) "void" frame))) - (if (and rules (not (eq? rules 'header))) - (printf " rules=\"~a\"" rules)) - (display ">\n"))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '(:bg) - :before (lambda (n e) - (let ((bg (markup-option n :bg))) - (display ""))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* tc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(markup :width :align :valign :colspan :rowspan :bg) - :before (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td)) - (width (markup-option n :width)) - (align (markup-option n :align)) - (valign (let ((v (markup-option n :valign))) - (cond - ((or (eq? v 'center) - (equal? v "center")) - "middle") - (else - v)))) - (colspan (markup-option n :colspan)) - (rowspan (markup-option n :rowspan)) - (bg (markup-option n :bg))) - (printf "<~a" markup) - (html-class n) - (if width (printf " width=\"~a\"" (html-width width))) - (if align (printf " align=\"~a\"" align)) - (if valign (printf " valign=\"~a\"" valign)) - (if colspan (printf " colspan=\"~a\"" colspan)) - (if rowspan (printf " rowspan=\"~a\"" rowspan)) - (when (html-color-spec? bg) - (printf " bgcolor=\"~a\"" bg)) - (display ">"))) - :after (lambda (n e) - (let ((markup (or (markup-option n 'markup) 'td))) - (printf "" markup)))) - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("gif" "jpg" "png")))))) - (if (not (string? img)) - (skribe-error 'html "Illegal image" file) - (begin - (printf "\"")")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "") -(markup-writer 'bold :before (html-markup-class "strong") :after "") -(markup-writer 'underline :before (html-markup-class "u") :after "") -(markup-writer 'strike :before (html-markup-class "strike") :after "") -(markup-writer 'emph :before (html-markup-class "em") :after "") -(markup-writer 'kbd :before (html-markup-class "kbd") :after "") -(markup-writer 'it :before (html-markup-class "em") :after "") -(markup-writer 'tt :before (html-markup-class "tt") :after "") -(markup-writer 'code :before (html-markup-class "code") :after "") -(markup-writer 'var :before (html-markup-class "var") :after "
") -(markup-writer 'samp :before (html-markup-class "samp") :after "") -(markup-writer 'sc :before "" :after "") -(markup-writer 'sf :before "" :after "") -(markup-writer 'sub :before (html-markup-class "sub") :after "") -(markup-writer 'sup :before (html-markup-class "sup") :after "") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "\"" - :after "\"") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :action (lambda (n e) - (let ((text (markup-option n :text))) - (display ") - (if text - (output text e) - (skribe-eval (tt (markup-body n)) e)) - (display "")))) - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :predicate (lambda (n e) - (and (engine-custom e 'javascript) - (or (string? (markup-body n)) - (and (pair? (markup-body n)) - (null? (cdr (markup-body n))) - (string? (car (markup-body n))))))) - :action (lambda (n e) - (let* ((body (markup-body n)) - (email (if (string? body) body (car body))) - (split (pregexp-split "@" email)) - (na (car split)) - (do (if (pair? (cdr split)) (cadr split) "")) - (nn (pregexp-replace* "[.]" na " ")) - (dd (pregexp-replace* "[.]" do " ")) - (text (markup-option n :text))) - (display "") - (output text e) - (display "\n")))) - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "")) - :after "") - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) - :before (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c)) - (f (html-file c e)) - (class (if (markup-class n) - (markup-class n) - "inbound"))) - (printf ""))) - :action (lambda (n e) - (let ((t (markup-option n :text)) - (m (markup-option n 'mark)) - (f (markup-option n :figure)) - (c (markup-option n :chapter)) - (s (markup-option n :section)) - (ss (markup-option n :subsection)) - (sss (markup-option n :subsubsection))) - (cond - (t - (output t e)) - (f - (output (new markup - (markup '&html-figure-ref) - (body (markup-body n))) - e)) - ((or c s ss sss) - (output (new markup - (markup '&html-section-ref) - (body (markup-body n))) - e)) - - ((not m) - (output (new markup - (markup '&html-unmark-ref) - (body (markup-body n))) - e)) - (else - (display m))))) - :after "") - -;*---------------------------------------------------------------------*/ -;* &html-figure-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-figure-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (or (not (markup? c)) - (not (is-markup? c 'figure))) - (display "???") - (output (markup-option c :number) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-section-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-section-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (output (markup-option c :title) e))))) - -;*---------------------------------------------------------------------*/ -;* &html-unmark-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&html-unmark-ref - :action (lambda (n e) - (let ((c (handle-ast (markup-body n)))) - (if (not (markup? c)) - (display "???") - (let ((t (markup-option c :title))) - (if t - (output t e) - (let ((l (markup-option c :legend))) - (if l - (output t e) - (display - (string-canonicalize - (markup-ident c))))))))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) (output n e (markup-writer-get 'ref e))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* bib-ref+ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (output (car rs) e (markup-writer-get 'ref e)) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :before (lambda (n e) - (let* ((url (markup-option n :url)) - (class (cond - ((markup-class n) - (markup-class n)) - ((not (string? url)) - #f) - (else - (let ((l (string-length url))) - (let loop ((i 0)) - (cond - ((= i l) - #f) - ((char=? (string-ref url i) #\:) - (substring url 0 i)) - (else - (loop (+ i 1)))))))))) - (display ""))) - :action (lambda (n e) - (let ((v (markup-option n :text))) - (output (or v (markup-option n :url)) e))) - :after "") - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before (html-markup-class "i") - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (if (and (number? o) (number? v)) - (markup-option-add! n :text (+ o v))) - (output n e (markup-writer-get 'ref e)) - (if (and (number? o) (number? v)) - (markup-option-add! n :text v)))) - :after "") - -;*---------------------------------------------------------------------*/ -;* page-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'page-ref - :options '(:mark :handle) - :action (lambda (n e) - (error 'page-ref:html "Not implemented yet" n))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before (lambda (n e) - (printf "")) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label base-engine))) - :after "") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (or (markup-option en 'url) - (markup-option en 'documenturl))) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-url ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-url - :action (lambda (n e) - (let* ((en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (t (bold (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) - -;*---------------------------------------------------------------------*/ -;* &the-index-header ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-index-header - :action (lambda (n e) - (display "") - (for-each (lambda (h) - (let ((f (engine-custom e 'index-header-font-size))) - (if f - (skribe-eval (font :size f (bold (it h))) e) - (output h e)) - (display " "))) - (markup-body n)) - (display "") - (skribe-eval (linebreak 2) e))) - -;*---------------------------------------------------------------------*/ -;* &source-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-line-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-keyword ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &source-error ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-define ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-module ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-markup ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-thread ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-string ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-bracket ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-key ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/html4.skr b/skribe/skr/html4.skr deleted file mode 100644 index acb7068..0000000 --- a/skribe/skr/html4.skr +++ /dev/null @@ -1,165 +0,0 @@ -;;;; -;;;; html4.skr -- HTML 4.01 Engine -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 18-Feb-2004 11:58 (eg) -;;;; Last file update: 26-Feb-2004 21:09 (eg) -;;;; - -(define (find-children node) - (define (flat l) - (cond - ((null? l) l) - ((pair? l) (append (flat (car l)) - (flat (cdr l)))) - (else (list l)))) - - (if (markup? node) - (flat (markup-body node)) - node)) - -;;; ====================================================================== - -(let ((le (find-engine 'html))) - ;;---------------------------------------------------------------------- - ;; Customizations - ;;---------------------------------------------------------------------- - (engine-custom-set! le 'html-variant "html4") - (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") - (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") - - ;;---------------------------------------------------------------------- - ;; &html-html ... - ;;---------------------------------------------------------------------- - (markup-writer '&html-html le - :before " -\n" - :after "") - - ;;---------------------------------------------------------------------- - ;; &html-ending - ;;---------------------------------------------------------------------- - (let* ((img (engine-custom le 'html4-logo)) - (url (engine-custom le 'html4-validator)) - (bottom (list (hrule) - (table :width 100. - (tr - (td :align 'left - (font :size -1 [ - This ,(sc "Html") page has been produced by - ,(ref :url (skribe-url) :text "Skribe"). - ,(linebreak) - Last update ,(it (date)).])) - (td :align 'right :valign 'top - (ref :url url - :text (image :url img :width 88 :height 31)))))))) - (markup-writer '&html-ending le - :before "
" - :action (lambda (n e) - (let ((body (markup-body n))) - (if body - (output body #t) - (skribe-eval bottom e)))) - :after "
\n")) - - ;;---------------------------------------------------------------------- - ;; color ... - ;;---------------------------------------------------------------------- - (markup-writer 'color le - :options '(:bg :fg :width :margin) - :before (lambda (n e) - (let ((m (markup-option n :margin)) - (w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg))) - (when bg - (display "\n") - (display "\n
")) - (when fg - (display "")))) - :after (lambda (n e) - (when (markup-option n :fg) - (display "")) - (when (markup-option n :bg) - (display "
")))) - - ;;---------------------------------------------------------------------- - ;; font ... - ;;---------------------------------------------------------------------- - (markup-writer 'font le - :options '(:size :face) - :before (lambda (n e) - (let ((face (markup-option n :face)) - (size (let ((sz (markup-option n :size))) - (cond - ((or (unspecified? sz) (not sz)) - #f) - ((and (number? sz) (or (inexact? sz) (negative? sz))) - (format "~a%" - (+ 100 - (* 20 (inexact->exact (truncate sz)))))) - ((number? sz) - sz) - (else - (skribe-error 'font - (format "Illegal font size ~s" sz) - n)))))) - (display ""))) - :after "") - - ;;---------------------------------------------------------------------- - ;; paragraph ... - ;;---------------------------------------------------------------------- - (copy-markup-writer 'paragraph le - :validate (lambda (n e) - (let ((pred (lambda (x) - (and (container? x) - (not (memq (markup-markup x) '(font color))))))) - (not (any pred (find-children n)))))) - - ;;---------------------------------------------------------------------- - ;; roman ... - ;;---------------------------------------------------------------------- - (markup-writer 'roman le - :before "" - :after "") - - ;;---------------------------------------------------------------------- - ;; table ... - ;;---------------------------------------------------------------------- - (let ((old-writer (markup-writer-get 'table le))) - (copy-markup-writer 'table le - :validate (lambda (n e) - (not (null? (markup-body n)))))) -) diff --git a/skribe/skr/jfp.skr b/skribe/skr/jfp.skr deleted file mode 100644 index 60b40f2..0000000 --- a/skribe/skr/jfp.skr +++ /dev/null @@ -1,317 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/jfp.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for JFP articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{jfp}") - (engine-custom-set! le 'hyperref #f) - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-subauthor) - (let* ((d (ast-document n)) - (sa (and (is-markup? d 'document) - (markup-option d :head-author)))) - (if sa - (begin - (display "[") - (output sa e) - (display "]"))))) - (define (&latex-author-1 n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output (car n) e) - (for-each (lambda (a) - (display "\\and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (&latex-author-1 body)) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (&latex-author-n body)) - (else - (skribe-error 'author - "Illegal `jfp' author" - body)))))) - ;; title - (markup-writer '&latex-title le - :before (lambda (n e) - (let* ((d (ast-document n)) - (st (and (is-markup? d 'document) - (markup-option d :head-title)))) - (if st - (begin - (display "\\title[") - (output st e) - (display "]{")) - (display "\\title{")))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (aff (markup-option n :affiliation)) - (addr (markup-option n :address)) - (email (markup-option n :email))) - (if name - (begin - (output name e) - (display "\\\\\n"))) - (if aff - (begin - (output aff e) - (display "\\\\\n"))) - (if addr - (begin - (if (pair? addr) - (for-each (lambda (a) - (output a e) - (display "\\\\\n")) - addr) - (begin - (output addr e) - (display "\\\\\n"))))) - (if email - (begin - (display "\\email{") - (output email e) - (display "}\\\\\n"))))))) - ;; bib-ref - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :before "(" - :action (lambda (n e) - (let ((be (handle-ast (markup-body n)))) - (if (is-markup? be '&bib-entry) - (let ((a (markup-option be 'author)) - (y (markup-option be 'year))) - (cond - ((and (is-markup? a '&bib-entry-author) - (is-markup? y '&bib-entry-year)) - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e) - (display ", ") - (output y e))))) - ((is-markup? y '&bib-entry-year) - (skribe-error 'bib-ref - "Missing `name' entry" - (markup-ident be))) - (else - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e))))))) - (skribe-error 'bib-ref - "Illegal bib-ref" - (markup-ident be))))) - :after ")") - ;; bib-ref/text - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :predicate (lambda (n e) - (markup-option n :key)) - :action (lambda (n e) - (output (markup-option n :key) e))) - ;; &the-bibliography - (markup-writer '&the-bibliography le - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - ;; bib-entry - (markup-writer '&bib-entry le - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - ;; %bib-entry-title - (markup-writer '&bib-entry-title le - :action (lambda (n e) - (output (markup-body n) e))) - ;; %bib-entry-body - (markup-writer '&bib-entry-body le - :action (lambda (n e) - (define (output-fields descr) - (display "\\item[") - (let loop ((descr descr) - (pending #f) - (armed #f) - (first #t)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t - #f) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed - #f)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (if first - (display "]")) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed - #f)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author (" (" year ")") " " (or title url) ". " - number ", " institution ", " - address ", " month ", " - ("pp. " pages) ".")) - ((article) - `(author (" (" year ")") " " (or title url) ". " - journal ", " volume ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author (" (" year ")") " " (or title url) ". " - book(or title url) ", " series ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((book) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")) - ((phdthesis) - '(author (" (" year ")") " " (or title url) ". " type ", " - school ", " address - ", " month ".")) - ((misc) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ".")) - (else - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")))))) - ;; abstract - (markup-writer 'jfp-abstract le - :options '(postscript) - :before "\\begin{abstract}\n" - :after "\\end{abstract}\n")) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-jfp-abstract he - :action (lambda (n e) - (let* ((bg (engine-custom e 'abstract-background)) - (exp (p (if bg - (center (color :bg bg :width 90. - (it (markup-body n)))) - (it (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (new markup - (markup 'jfp-abstract) - (body (p (the-body opt)))) - (let ((a (new markup - (markup '&html-jfp-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (section :title "References" :class "references" - :number (not (engine-format? "latex")) - (font :size -1 (the-bibliography))))) - diff --git a/skribe/skr/latex-simple.skr b/skribe/skr/latex-simple.skr deleted file mode 100644 index dd2eccb..0000000 --- a/skribe/skr/latex-simple.skr +++ /dev/null @@ -1,101 +0,0 @@ -;;; -;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER -;;; CE FICHIER (sion simplifie il ne rest plus grand chose) -;;; Erick 27-10-04 -;;; - - -;*=====================================================================*/ -;* scmws04/src/latex-style.skr */ -;* ------------------------------------------------------------- */ -;* Author : Damien Ciabrini */ -;* Creation : Tue Aug 24 19:17:04 2004 */ -;* Last change : Thu Oct 28 21:45:25 2004 (eg) */ -;* Copyright : 2004 Damien Ciabrini, see LICENCE file */ -;* ------------------------------------------------------------- */ -;* Custom style for Latex... */ -;*=====================================================================*/ - -(let* ((le (find-engine 'latex)) - (oa (markup-writer-get 'author le))) - ; latex class & package for the workshop - (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}") - (engine-custom-set! le 'usepackage - "\\usepackage{epsfig} -\\usepackage{workshop} -\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} - {September 22, 2004, Snowbird, Utah, USA.} -\\CopyrightYear{2004} -\\CopyrightHolder{Damien Ciabrini} -\\renewcommand{\\ttdefault}{cmtt} -") - (engine-custom-set! le 'image-format '("eps")) - (engine-custom-set! le 'source-define-color "#000080") - (engine-custom-set! le 'source-thread-color "#8080f0") - (engine-custom-set! le 'source-string-color "#000000") - - ; hyperref options - (engine-custom-set! le 'hyperref #t) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}") - ; nbsp with ~ char - (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding)) - - ; let latex process citations - (markup-writer 'bib-ref le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) (display (markup-option n :bib))) - :after "}") - (markup-writer 'bib-ref+ le - :options '(:text :bib) - :before "\\cite{" - :action (lambda (n e) - (let loop ((bibs (markup-option n :bib))) - (if (pair? bibs) - (begin - (display (car bibs)) - (if (pair? (cdr bibs)) (display ", ")) - (loop (cdr bibs)))))) - :after "}") - (markup-writer '&the-bibliography le - :action (lambda (n e) - (print "\\bibliographystyle{abbrv}") - (display "\\bibliography{biblio}"))) - - ; ACM-style for authors - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (print "\\numberofauthors{" (length body) "}")) - (print "\\author{"))) - :after "}\n") - (markup-writer 'author le - :options (writer-options oa) - :before "" - :action (lambda (n e) - (let ((name (markup-option n :name)) - (affiliation (markup-option n :affiliation)) - (address (markup-option n :address)) - (email (markup-option n :email))) - (define (row pre n post) - (display pre) - (output n e) - (display post) - (display "\\\\\n")) - ;; name - (if name (row "\\alignauthor " name "")) - ;; affiliation - (if affiliation (row "\\affaddr{" affiliation "}")) - ;; address - (if (pair? address) - (for-each (lambda (x) - (row "\\affaddr{" x "}")) address)) - ;; email - (if email (row "\\email{" email "}")))) - :after "") -) - -(define (include-biblio) - (the-bibliography)) diff --git a/skribe/skr/latex.skr b/skribe/skr/latex.skr deleted file mode 100644 index bc20493..0000000 --- a/skribe/skr/latex.skr +++ /dev/null @@ -1,1780 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/latex.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Thu May 26 12:59:47 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* LaTeX Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/latexe.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* latex-verbatim-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-verbatim-encoding - '((#\\ "{\\char92}") - (#\^ "{\\char94}") - (#\{ "\\{") - (#\} "\\}") - (#\& "\\&") - (#\$ "\\$") - (#\# "\\#") - (#\_ "\\_") - (#\% "\\%") - (#\~ "$_{\\mbox{\\char126}}$") - (#\ç "\\c{c}") - (#\Ç "\\c{C}") - (#\â "\\^{a}") - (#\Â "\\^{A}") - (#\à "\\`{a}") - (#\À "\\`{A}") - (#\é "\\'{e}") - (#\É "\\'{E}") - (#\è "\\`{e}") - (#\È "\\`{E}") - (#\ê "\\^{e}") - (#\Ê "\\^{E}") - (#\ù "\\`{u}") - (#\Ù "\\`{U}") - (#\û "\\^{u}") - (#\Û "\\^{U}") - (#\ø "{\\o}") - (#\ô "\\^{o}") - (#\Ô "\\^{O}") - (#\ö "\\\"{o}") - (#\Ö "\\\"{O}") - (#\î "\\^{\\i}") - (#\Î "\\^{I}") - (#\ï "\\\"{\\i}") - (#\Ï "\\\"{I}") - (#\] "{\\char93}") - (#\[ "{\\char91}") - (#\» "\\,{\\tiny{$^{\\gg}$}}") - (#\« "{\\tiny{$^{\\ll}$}}\\,"))) - -;*---------------------------------------------------------------------*/ -;* latex-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-encoding - (append '((#\| "$|$") - (#\< "$<$") - (#\> "$>$") - (#\: "{\\char58}") - (#\# "{\\char35}") - (#\Newline " %\n")) - latex-verbatim-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-tt-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-tt-encoding - (append '((#\. ".\\-") - (#\/ "/\\-")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-pre-encoding ... */ -;*---------------------------------------------------------------------*/ -(define latex-pre-encoding - (append '((#\Space "\\ ") - (#\Newline "\\\\\n")) - latex-encoding)) - -;*---------------------------------------------------------------------*/ -;* latex-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define (latex-symbol-table math) - `(("iexcl" "!`") - ("cent" "c") - ("pound" "\\pounds") - ("yen" "Y") - ("section" "\\S") - ("mul" ,(math "^-")) - ("copyright" "\\copyright") - ("lguillemet" ,(math "\\ll")) - ("not" ,(math "\\neg")) - ("degree" ,(math "^{\\small{o}}")) - ("plusminus" ,(math "\\pm")) - ("micro" ,(math "\\mu")) - ("paragraph" "\\P") - ("middot" ,(math "\\cdot")) - ("rguillemet" ,(math "\\gg")) - ("1/4" ,(math "\\frac{1}{4}")) - ("1/2" ,(math "\\frac{1}{2}")) - ("3/4" ,(math "\\frac{3}{4}")) - ("iquestion" "?`") - ("Agrave" "\\`{A}") - ("Aacute" "\\'{A}") - ("Acircumflex" "\\^{A}") - ("Atilde" "\\~{A}") - ("Amul" "\\\"{A}") - ("Aring" "{\\AA}") - ("AEligature" "{\\AE}") - ("Oeligature" "{\\OE}") - ("Ccedilla" "{\\c{C}}") - ("Egrave" "{\\`{E}}") - ("Eacute" "{\\'{E}}") - ("Ecircumflex" "{\\^{E}}") - ("Euml" "\\\"{E}") - ("Igrave" "{\\`{I}}") - ("Iacute" "{\\'{I}}") - ("Icircumflex" "{\\^{I}}") - ("Iuml" "\\\"{I}") - ("ETH" "D") - ("Ntilde" "\\~{N}") - ("Ograve" "\\`{O}") - ("Oacute" "\\'{O}") - ("Ocurcumflex" "\\^{O}") - ("Otilde" "\\~{O}") - ("Ouml" "\\\"{O}") - ("times" ,(math "\\times")) - ("Oslash" "\\O") - ("Ugrave" "\\`{U}") - ("Uacute" "\\'{U}") - ("Ucircumflex" "\\^{U}") - ("Uuml" "\\\"{U}") - ("Yacute" "\\'{Y}") - ("szlig" "\\ss") - ("agrave" "\\`{a}") - ("aacute" "\\'{a}") - ("acircumflex" "\\^{a}") - ("atilde" "\\~{a}") - ("amul" "\\\"{a}") - ("aring" "\\aa") - ("aeligature" "\\ae") - ("oeligature" "{\\oe}") - ("ccedilla" "{\\c{c}}") - ("egrave" "{\\`{e}}") - ("eacute" "{\\'{e}}") - ("ecircumflex" "{\\^{e}}") - ("euml" "\\\"{e}") - ("igrave" "{\\`{\\i}}") - ("iacute" "{\\'{\\i}}") - ("icircumflex" "{\\^{\\i}}") - ("iuml" "\\\"{\\i}") - ("ntilde" "\\~{n}") - ("ograve" "\\`{o}") - ("oacute" "\\'{o}") - ("ocurcumflex" "\\^{o}") - ("otilde" "\\~{o}") - ("ouml" "\\\"{o}") - ("divide" ,(math "\\div")) - ("oslash" "\\o") - ("ugrave" "\\`{u}") - ("uacute" "\\'{u}") - ("ucircumflex" "\\^{u}") - ("uuml" "\\\"{u}") - ("yacute" "\\'{y}") - ("ymul" "\\\"{y}") - ;; Greek - ("Alpha" "A") - ("Beta" "B") - ("Gamma" ,(math "\\Gamma")) - ("Delta" ,(math "\\Delta")) - ("Epsilon" "E") - ("Zeta" "Z") - ("Eta" "H") - ("Theta" ,(math "\\Theta")) - ("Iota" "I") - ("Kappa" "K") - ("Lambda" ,(math "\\Lambda")) - ("Mu" "M") - ("Nu" "N") - ("Xi" ,(math "\\Xi")) - ("Omicron" "O") - ("Pi" ,(math "\\Pi")) - ("Rho" "P") - ("Sigma" ,(math "\\Sigma")) - ("Tau" "T") - ("Upsilon" ,(math "\\Upsilon")) - ("Phi" ,(math "\\Phi")) - ("Chi" "X") - ("Psi" ,(math "\\Psi")) - ("Omega" ,(math "\\Omega")) - ("alpha" ,(math "\\alpha")) - ("beta" ,(math "\\beta")) - ("gamma" ,(math "\\gamma")) - ("delta" ,(math "\\delta")) - ("epsilon" ,(math "\\varepsilon")) - ("zeta" ,(math "\\zeta")) - ("eta" ,(math "\\eta")) - ("theta" ,(math "\\theta")) - ("iota" ,(math "\\iota")) - ("kappa" ,(math "\\kappa")) - ("lambda" ,(math "\\lambda")) - ("mu" ,(math "\\mu")) - ("nu" ,(math "\\nu")) - ("xi" ,(math "\\xi")) - ("omicron" ,(math "\\o")) - ("pi" ,(math "\\pi")) - ("rho" ,(math "\\rho")) - ("sigmaf" ,(math "\\varsigma")) - ("sigma" ,(math "\\sigma")) - ("tau" ,(math "\\tau")) - ("upsilon" ,(math "\\upsilon")) - ("phi" ,(math "\\varphi")) - ("chi" ,(math "\\chi")) - ("psi" ,(math "\\psi")) - ("omega" ,(math "\\omega")) - ("thetasym" ,(math "\\vartheta")) - ("piv" ,(math "\\varpi")) - ;; punctuation - ("bullet" ,(math "\\bullet")) - ("ellipsis" ,(math "\\ldots")) - ("weierp" ,(math "\\wp")) - ("image" ,(math "\\Im")) - ("real" ,(math "\\Re")) - ("tm" ,(math "^{\\sc\\tiny{tm}}")) - ("alef" ,(math "\\aleph")) - ("<-" ,(math "\\leftarrow")) - ("<--" ,(math "\\longleftarrow")) - ("uparrow" ,(math "\\uparrow")) - ("->" ,(math "\\rightarrow")) - ("-->" ,(math "\\longrightarrow")) - ("downarrow" ,(math "\\downarrow")) - ("<->" ,(math "\\leftrightarrow")) - ("<-->" ,(math "\\longleftrightarrow")) - ("<+" ,(math "\\hookleftarrow")) - ("<=" ,(math "\\Leftarrow")) - ("<==" ,(math "\\Longleftarrow")) - ("Uparrow" ,(math "\\Uparrow")) - ("=>" ,(math "\\Rightarrow")) - ("==>" ,(math "\\Longrightarrow")) - ("Downarrow" ,(math "\\Downarrow")) - ("<=>" ,(math "\\Leftrightarrow")) - ("<==>" ,(math "\\Longleftrightarrow")) - ;; Mathematical operators - ("forall" ,(math "\\forall")) - ("partial" ,(math "\\partial")) - ("exists" ,(math "\\exists")) - ("emptyset" ,(math "\\emptyset")) - ("infinity" ,(math "\\infty")) - ("nabla" ,(math "\\nabla")) - ("in" ,(math "\\in")) - ("notin" ,(math "\\notin")) - ("ni" ,(math "\\ni")) - ("prod" ,(math "\\Pi")) - ("sum" ,(math "\\Sigma")) - ("asterisk" ,(math "\\ast")) - ("sqrt" ,(math "\\surd")) - ("propto" ,(math "\\propto")) - ("angle" ,(math "\\angle")) - ("and" ,(math "\\wedge")) - ("or" ,(math "\\vee")) - ("cap" ,(math "\\cap")) - ("cup" ,(math "\\cup")) - ("integral" ,(math "\\int")) - ("models" ,(math "\\models")) - ("vdash" ,(math "\\vdash")) - ("dashv" ,(math "\\dashv")) - ("sim" ,(math "\\sim")) - ("cong" ,(math "\\cong")) - ("approx" ,(math "\\approx")) - ("neq" ,(math "\\neq")) - ("equiv" ,(math "\\equiv")) - ("le" ,(math "\\leq")) - ("ge" ,(math "\\geq")) - ("subset" ,(math "\\subset")) - ("supset" ,(math "\\supset")) - ("subseteq" ,(math "\\subseteq")) - ("supseteq" ,(math "\\supseteq")) - ("oplus" ,(math "\\oplus")) - ("otimes" ,(math "\\otimes")) - ("perp" ,(math "\\perp")) - ("mid" ,(math "\\mid")) - ("lceil" ,(math "\\lceil")) - ("rceil" ,(math "\\rceil")) - ("lfloor" ,(math "\\lfloor")) - ("rfloor" ,(math "\\rfloor")) - ("langle" ,(math "\\langle")) - ("rangle" ,(math "\\rangle")) - ;; Misc - ("loz" ,(math "\\diamond")) - ("spades" ,(math "\\spadesuit")) - ("clubs" ,(math "\\clubsuit")) - ("hearts" ,(math "\\heartsuit")) - ("diams" ,(math "\\diamondsuit")) - ("euro" "\\euro{}") - ;; LaTeX - ("dag" "\\dag") - ("ddag" "\\ddag") - ("circ" ,(math "\\circ")) - ("top" ,(math "\\top")) - ("bottom" ,(math "\\bot")) - ("lhd" ,(math "\\triangleleft")) - ("rhd" ,(math "\\triangleright")) - ("parallel" ,(math "\\parallel")))) - -;*---------------------------------------------------------------------*/ -;* latex-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-engine - (default-engine-set! - (make-engine 'latex - :version 1.0 - :format "latex" - :delegate (find-engine 'base) - :filter (make-string-replace latex-encoding) - :custom '((documentclass "\\documentclass{article}") - (usepackage "\\usepackage{epsfig}\n") - (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n") - (postdocument #f) - (maketitle "\\date{}\n\\maketitle") - (%font-size 0) - ;; color - (color #t) - (color-usepackage "\\usepackage{color}\n") - ;; hyperref - (hyperref #t) - (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n") - ;; source fontification - (source-color #t) - (source-comment-color "#ffa600") - (source-error-color "red") - (source-define-color "#6959cf") - (source-module-color "#1919af") - (source-markup-color "#1919af") - (source-thread-color "#ad4386") - (source-string-color "red") - (source-bracket-color "red") - (source-type-color "#00cf00") - (image-format ("eps")) - (index-page-ref #t)) - :symbol-table (latex-symbol-table - (lambda (m) - (format "\\begin{math}~a\\end{math}" m)))))) - -;*---------------------------------------------------------------------*/ -;* latex-title-engine ... */ -;*---------------------------------------------------------------------*/ -(define latex-title-engine - (make-engine 'latex-title - :version 1.0 - :format "latex-title" - :delegate latex-engine - :filter (make-string-replace latex-encoding) - :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m))))) - -;*---------------------------------------------------------------------*/ -;* latex-color? ... */ -;*---------------------------------------------------------------------*/ -(define (latex-color? e) - (engine-custom e 'color)) - -;*---------------------------------------------------------------------*/ -;* LaTeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (LaTeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\LaTeX\\ " "\\LaTeX")) - "LaTeX")) - -;*---------------------------------------------------------------------*/ -;* TeX ... */ -;*---------------------------------------------------------------------*/ -(define-markup (TeX #!key (space #t)) - (if (engine-format? "latex") - (! (if space "\\TeX\\ " "\\TeX")) - "TeX")) - -;*---------------------------------------------------------------------*/ -;* latex ... */ -;*---------------------------------------------------------------------*/ -(define-markup (!latex fmt #!rest opt) - (if (engine-format? "latex") - (apply ! fmt opt) - #f)) - -;*---------------------------------------------------------------------*/ -;* latex-width ... */ -;*---------------------------------------------------------------------*/ -(define (latex-width width) - (if (and (number? width) (inexact? width)) - (string-append (number->string (/ width 100.)) "\\linewidth") - (string-append (number->string width) "pt"))) - -;*---------------------------------------------------------------------*/ -;* latex-font-size ... */ -;*---------------------------------------------------------------------*/ -(define (latex-font-size size) - (case size - ((4) "Huge") - ((3) "huge") - ((2) "Large") - ((1) "large") - ((0) "normalsize") - ((-1) "small") - ((-2) "footnotesize") - ((-3) "scriptsize") - ((-4) "tiny") - (else (if (number? size) - (if (< size 0) "tiny" "Huge") - "normalsize")))) - -;*---------------------------------------------------------------------*/ -;* *skribe-latex-color-table* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-latex-color-table* #f) - -;*---------------------------------------------------------------------*/ -;* latex-declare-color ... */ -;*---------------------------------------------------------------------*/ -(define (latex-declare-color name rgb) - (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) - -;*---------------------------------------------------------------------*/ -;* skribe-get-latex-color ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-latex-color spec) - (let ((c (and (hashtable? *skribe-latex-color-table*) - (hashtable-get *skribe-latex-color-table* spec)))) - (if (not (string? c)) - (skribe-error 'latex "Can't find color" spec) - c))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->latex-rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->latex-rgb spec) - (receive (r g b) - (skribe-color->rgb spec) - (cond - ((and (= r 0) (= g 0) (= b 0)) - "0.,0.,0.") - ((and (= r #xff) (= g #xff) (= b #xff)) - "1.,1.,1.") - (else - (let ((ff (exact->inexact #xff))) - (format "~a,~a,~a" - (number->string (/ r ff)) - (number->string (/ g ff)) - (number->string (/ b ff)))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-latex-declare-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-latex-declare-colors colors) - (set! *skribe-latex-color-table* (make-hashtable)) - (for-each (lambda (spec) - (let ((old (hashtable-get *skribe-latex-color-table* spec))) - (if (not (string? old)) - (let ((name (symbol->string (gensym 'c)))) - ;; bind the color - (hashtable-put! *skribe-latex-color-table* spec name) - ;; and emit a latex declaration - (latex-declare-color - name - (skribe-color->latex-rgb spec)))))) - colors)) - -;*---------------------------------------------------------------------*/ -;* &~ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&~ - :before "~" - :action #f) - -;*---------------------------------------------------------------------*/ -;* &latex-table-start */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-start - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (printf "\\begin{tabular*}{~a}" (latex-width width)) - (display "\\begin{tabular}"))))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-stop */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-stop - :options '() - :action (lambda (n e) - (let ((width (markup-option n 'width))) - (if (number? width) - (display "\\end{tabular*}\n") - (display "\\end{tabular}\n"))))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'document - :options '(:title :author :ending :env) - :before (lambda (n e) - ;; documentclass - (let ((dc (engine-custom e 'documentclass))) - (if dc - (begin (display dc) (newline)) - (display "\\documentclass{article}\n"))) - (if (latex-color? e) - (display (engine-custom e 'color-usepackage))) - (if (engine-custom e 'hyperref) - (display (engine-custom e 'hyperref-usepackage))) - ;; usepackage - (let ((pa (engine-custom e 'usepackage))) - (if pa (begin (display pa) (newline)))) - ;; colors - (if (latex-color? e) - (begin - (skribe-use-color! (engine-custom e 'source-comment-color)) - (skribe-use-color! (engine-custom e 'source-define-color)) - (skribe-use-color! (engine-custom e 'source-module-color)) - (skribe-use-color! (engine-custom e 'source-markup-color)) - (skribe-use-color! (engine-custom e 'source-thread-color)) - (skribe-use-color! (engine-custom e 'source-string-color)) - (skribe-use-color! (engine-custom e 'source-bracket-color)) - (skribe-use-color! (engine-custom e 'source-type-color)) - (display "\n%% colors\n") - (skribe-latex-declare-colors (skribe-get-used-colors)) - (display "\n\n"))) - ;; predocument - (let ((pd (engine-custom e 'predocument))) - (when pd (display pd) (newline))) - ;; title - (let ((t (markup-option n :title))) - (when t - (skribe-eval (new markup - (markup '&latex-title) - (body t)) - e - :env `((parent ,n))))) - ;; author - (let ((a (markup-option n :author))) - (when a - (skribe-eval (new markup - (markup '&latex-author) - (body a)) - e - :env `((parent ,n))))) - ;; document - (display "\\begin{document}\n") - ;; postdocument - (let ((pd (engine-custom e 'postdocument))) - (if pd (begin (display pd) (newline)))) - ;; maketitle - (let ((mt (engine-custom e 'maketitle))) - (if mt (begin (display mt) (newline))))) - :action (lambda (n e) - (output (markup-body n) e)) - :after (lambda (n e) - (display "\n\\end{document}\n"))) - -;*---------------------------------------------------------------------*/ -;* &latex-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-title - :before "\\title{" - :after "}\n") - -;*---------------------------------------------------------------------*/ -;* &latex-author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-author - :before "\\author{\\centerline{\n" - :action (lambda (n e) - (let ((body (markup-body n))) - (if (pair? body) - (begin - (output (new markup - (markup '&latex-table-start) - (class "&latex-author-table")) - e) - (printf "{~a}\n" (make-string (length body) #\c)) - (let loop ((as body)) - (output (car as) e) - (if (pair? (cdr as)) - (begin - (display " & ") - (loop (cdr as))))) - (display "\\\\\n") - (output (new markup - (markup '&latex-table-stop) - (class "&latex-author-table")) - e)) - (output body e)))) - :after "}}\n") - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{~a}\n" - (case (markup-option n :align) - ((left) "l") - ((right) "r") - (else "c")))) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (cond - ((pair? address) - (for-each row address)) - ((string? address) - (row address))) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url)))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'author - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :predicate (lambda (n e) (markup-option n :photo)) - :before (lambda (n e) - (output (new markup - (markup '&latex-table-start) - (class "author")) - e) - (printf "{cc}\n")) - :action (lambda (n e) - (let ((photo (markup-option n :photo))) - (output photo e) - (display " & ") - (markup-option-add! n :photo #f) - (output n e) - (markup-option-add! n :photo photo) - (display "\\\\\n"))) - :after (lambda (n e) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'toc - :options '() - :action (lambda (n e) (display "\\tableofcontents\n"))) - -;*---------------------------------------------------------------------*/ -;* latex-block-before ... */ -;*---------------------------------------------------------------------*/ -(define (latex-block-before m) - (lambda (n e) - (let ((num (markup-option n :number))) - (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) - (printf "\\~a~a{" m (if (not num) "*" "")) - (output (markup-option n :title) latex-title-engine) - (display "}\n") - (when num - (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) - -;*---------------------------------------------------------------------*/ -;* section ... .. @label chapter@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'chapter - :options '(:title :number :toc :file :env) - :before (latex-block-before 'chapter)) - -;*---------------------------------------------------------------------*/ -;* section ... . @label section@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'section - :options '(:title :number :toc :file :env) - :before (latex-block-before 'section)) - -;*---------------------------------------------------------------------*/ -;* subsection ... @label subsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsection)) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... @label subsubsection@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'subsubsection - :options '(:title :number :toc :file :env) - :before (latex-block-before 'subsubsection)) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'paragraph - :options '(:title :number :toc :env) - :before (lambda (n e) - (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) - (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" - (ast-location n))) - (display "\\noindent ")) - :after "\\par\n") - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'footnote - :before "\\footnote{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'linebreak - :action (lambda (n e) - (display "\\makebox[\\linewidth]{}"))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'hrule - :options '() - :before "\\hrulefill" - :action #f) - -;*---------------------------------------------------------------------*/ -;* latex-color-counter */ -;*---------------------------------------------------------------------*/ -(define latex-color-counter 1) - -;*---------------------------------------------------------------------*/ -;* latex-color ... */ -;*---------------------------------------------------------------------*/ -(define latex-color - (lambda (bg fg n e) - (if (not (latex-color? e)) - (output n e) - (begin - (if bg - (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) - (set! latex-color-counter (+ latex-color-counter 1)) - (if fg - (begin - (printf "\\textcolor{~a}{" (skribe-get-latex-color fg)) - (output n e) - (display "}")) - (output n e)) - (set! latex-color-counter (- latex-color-counter 1)) - (if bg - (printf "\\egroup\\colorbox{~a}{\\box~a}%\n" - (skribe-get-latex-color bg) latex-color-counter)))))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'color - :options '(:bg :fg :width) - :action (lambda (n e) - (let* ((w (markup-option n :width)) - (bg (markup-option n :bg)) - (fg (markup-option n :fg)) - (m (markup-option n :margin)) - (tw (cond - ((not w) - #f) - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (when bg - (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" - (latex-width m))) - (output (new markup - (markup '&latex-table-start) - (class "color")) - e) - (if tw - (printf "{p{~a}}\n" tw) - (printf "{l}\n"))) - (latex-color bg fg (markup-body n) e) - (when bg - (output (new markup - (markup '&latex-table-stop) - (class "color")) - e) - (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n"))))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'frame - :options '(:width :border :margin) - :before (lambda (n e) - (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") - (let ((m (markup-option n :margin))) - (when m - (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) - (newline)) - :action (lambda (n e) - (let* ((b (markup-option n :border)) - (w (markup-option n :width)) - (tw (cond - ((not w) - ".96\\linewidth") - ((and (integer? w) (exact? w)) - w) - ((real? w) - (latex-width w))))) - (output (new markup - (markup '&latex-table-start) - (class "frame")) - e) - (if (and (integer? b) (> b 0)) - (begin - (printf "{|p{~a}|}\\hline\n" tw) - (output (markup-body n) e) - (display "\\\\\\hline\n")) - (begin - (printf "{p{~a}}\n" tw) - (output (markup-body n) e))) - (output (new markup - (markup '&latex-table-stop) - (class "author")) - e))) - :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n") - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'font - :options '(:size) - :action (lambda (n e) - (let* ((size (markup-option n :size)) - (cs (let ((n (engine-custom e '%font-size))) - (if (number? n) - n - 0))) - (ns (cond - ((and (integer? size) (exact? size)) - (if (> size 0) - size - (+ cs size))) - ((and (number? size) (inexact? size)) - (+ cs (inexact->exact size))) - ((string? size) - (let ((nb (string->number size))) - (if (not (number? nb)) - (skribe-error - 'font - (format "Illegal font size ~s" size) - nb) - (+ cs nb)))))) - (ne (make-engine (gensym 'latex) - :delegate e - :filter (engine-filter e) - :symbol-table (engine-symbol-table e) - :custom `((%font-size ,ns) - ,@(engine-customs e))))) - (printf "{\\~a{" (latex-font-size ns)) - (output (markup-body n) ne) - (display "}}")))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'flush - :options '(:side) - :before (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\begin{center}\n")) - ((left) - (display "\\begin{flushleft}")) - ((right) - (display "\\begin{flushright}")))) - :after (lambda (n e) - (case (markup-option n :side) - ((center) - (display "\\end{center}\n")) - ((left) - (display "\\end{flushleft}\n")) - ((right) - (display "\\end{flushright}\n"))))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'center - :before "\\begin{center}\n" - :after "\\end{center}\n") - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'pre - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "pre")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'prog - :options '(:line :mark) - :before (lambda (n e) - (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{" - latex-color-counter) - (output (new markup - (markup '&latex-table-start) - (class "pre")) - e) - (display "{l}\n") - (set! latex-color-counter (+ latex-color-counter 1))) - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-pre-encoding) - :symbol-table (engine-symbol-table e) - :custom (engine-customs e)))) - (output (markup-body n) ne))) - :after (lambda (n e) - (set! latex-color-counter (- latex-color-counter 1)) - (output (new markup - (markup '&latex-table-stop) - (class "prog")) - e) - (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) - -;*---------------------------------------------------------------------*/ -;* &prog-line ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&prog-line - :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) - :after "\\\\\n") - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'itemize - :options '(:symbol) - :before "\\begin{itemize}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{itemize} ") - -(markup-writer 'itemize - :predicate (lambda (n e) (markup-option n :symbol)) - :options '(:symbol) - :before (lambda (n e) - (display "\\begin{list}{") - (output (markup-option n :symbol) e) - (display "}{}") - (newline)) - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{list}\n") - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'enumerate - :options '(:symbol) - :before "\\begin{enumerate}\n" - :action (lambda (n e) - (for-each (lambda (item) - (display " \\item ") - (output item e) - (newline)) - (markup-body n))) - :after "\\end{enumerate}\n") - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'description - :options '(:symbol) - :before "\\begin{description}\n" - :action (lambda (n e) - (for-each (lambda (item) - (let ((k (markup-option item :key))) - (for-each (lambda (i) - (display " \\item[") - (output i e) - (display "]\n")) - (if (pair? k) k (list k))) - (output (markup-body item) e))) - (markup-body n))) - :after "\\end{description}\n") - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'item - :options '(:key) - :action (lambda (n e) - (let ((k (markup-option n :key))) - (if k - (begin - (display "[") - (output k e) - (display "] ")))) - (output (markup-body n) e))) - -;*---------------------------------------------------------------------*/ -;* blockquote ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'blockquote - :before "\n\\begin{quote}\n" - :after "\n\\end{quote}") - -;*---------------------------------------------------------------------*/ -;* figure ... @label figure@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'figure - :options '(:legend :number :multicolumns) - :action (lambda (n e) - (let ((ident (markup-ident n)) - (number (markup-option n :number)) - (legend (markup-option n :legend)) - (mc (markup-option n :multicolumns))) - (display (if mc - "\\begin{figure*}[!th]\n" - "\\begin{figure}[ht]\n")) - (output (markup-body n) e) - (printf "\\caption{\\label{~a}" (string-canonicalize ident)) - (output legend e) - (display (if mc - "}\\end{figure*}\n" - "}\\end{figure}\n"))))) - -;*---------------------------------------------------------------------*/ -;* table-column-number ... */ -;* ------------------------------------------------------------- */ -;* Computes how many columns are contained in a table. */ -;*---------------------------------------------------------------------*/ -(define (table-column-number t) - (define (row-columns row) - (let luup ((cells (markup-body row)) - (nbcols 0)) - (cond - ((null? cells) - nbcols) - ((pair? cells) - (luup (cdr cells) - (+ nbcols (markup-option (car cells) :colspan)))) - (else - (skribe-type-error 'tr "Illegal tr body, " row "pair"))))) - (let loop ((rows (markup-body t)) - (nbcols 0)) - (if (null? rows) - nbcols - (loop (cdr rows) - (max (row-columns (car rows)) nbcols))))) - -;*---------------------------------------------------------------------*/ -;* table ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'table - :options '(:width :frame :rules :cellstyle) - :before (lambda (n e) - (let ((width (markup-option n :width)) - (frame (markup-option n :frame)) - (rules (markup-option n :rules)) - (cstyle (markup-option n :cellstyle)) - (nbcols (table-column-number n)) - (id (markup-ident n)) - (cla (markup-class n)) - (rows (markup-body n))) - ;; the table header - (output (new markup - (markup '&latex-table-start) - (class "table") - (options `((width ,width)))) - e) - ;; store the actual number of columns - (markup-option-add! n '&nbcols nbcols) - ;; compute the table header - (let ((cols (cond - ((= nbcols 0) - (skribe-error 'table - "Illegal empty table" - n)) - ((or (not width) (= nbcols 1)) - (make-string nbcols #\c)) - (else - (let ((v (make-vector - (- nbcols 1) - "@{\\extracolsep{\\fill}}c"))) - (apply string-append - (cons "c" (vector->list v)))))))) - (case frame - ((none) - (printf "{~a}\n" cols)) - ((border box) - (printf "{|~a|}" cols) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((above hsides) - (printf "{~a}" cols) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-above" id)) - (class "table-line-above")) - e)) - ((vsides) - (markup-option-add! n '&lhs #t) - (markup-option-add! n '&rhs #t) - (printf "{|~a|}\n" cols)) - ((lhs) - (markup-option-add! n '&lhs #t) - (printf "{|~a}\n" cols)) - ((rhs) - (markup-option-add! n '&rhs #t) - (printf "{~a|}\n" cols)) - (else - (printf "{~a}\n" cols))) - ;; mark each row with appropriate '&tl (top-line) - ;; and &bl (bottom-line) options - (when (pair? rows) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&tl #t)))) - (if (eq? rules 'header) - (let ((frow (car rows))) - (if (is-markup? frow 'tr) - (markup-option-add! frow '&bl #t)))) - (when (and (pair? (cdr rows)) - (memq rules '(rows all))) - (for-each (lambda (row) - (if (is-markup? row 'tr) - (markup-option-add! row '&bl #t))) - rows) - (markup-option-add! (car (last-pair rows)) '&bl #f)) - (if (and (memq rules '(rows all)) - (or (not (eq? cstyle 'collapse)) - (not (memq frame '(border box above hsides))))) - (let ((lrow (car (last-pair rows)))) - (if (is-markup? lrow 'tr) - (markup-option-add! lrow '&bl #t)))))))) - :after (lambda (n e) - (case (markup-option n :frame) - ((hsides below box border) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (format "~a-below" (markup-ident n))) - (class "table-hline-below")) - e))) - (output (new markup - (markup '&latex-table-stop) - (class "table") - (options `((width ,(markup-option n :width))))) - e))) - -;*---------------------------------------------------------------------*/ -;* &latex-table-hline */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-table-hline - :action "\\hline\n") - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tr - :options '() - :action (lambda (n e) - (let* ((parent (ast-parent n)) - (_ (if (not (is-markup? parent 'table)) - (skribe-type-error 'tr "Illegal parent, " parent - "#"))) - (nbcols (markup-option parent '&nbcols)) - (lhs (markup-option parent '&lhs)) - (rhs (markup-option parent '&rhs)) - (rules (markup-option parent :rules)) - (collapse (eq? (markup-option parent :cellstyle) - 'collapse)) - (vrules (memq rules '(cols all))) - (cells (markup-body n))) - (if (markup-option n '&tl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e)) - (if (> nbcols 0) - (let laap ((nbc nbcols) - (cs cells)) - (if (null? cs) - (when (> nbc 1) - (display " & ") - (laap (- nbc 1) cs)) - (let* ((c (car cs)) - (nc (- nbc (markup-option c :colspan)))) - (when (= nbcols nbc) - (cond - ((and lhs vrules (not collapse)) - (markup-option-add! c '&lhs "||")) - ((or lhs vrules) - (markup-option-add! c '&lhs #\|)))) - (when (= nc 0) - (cond - ((and rhs vrules (not collapse)) - (markup-option-add! c '&rhs "||")) - ((or rhs vrules) - (markup-option-add! c '&rhs #\|)))) - (when (and vrules (> nc 0) (< nc nbcols)) - (markup-option-add! c '&rhs #\|)) - (output c e) - (when (> nc 0) - (display " & ") - (laap nc (cdr cs))))))))) - :after (lambda (n e) - (display "\\\\") - (if (markup-option n '&bl) - (output (new markup - (markup '&latex-table-hline) - (parent n) - (ident (markup-ident n)) - (class (markup-class n))) - e) - (newline)))) - -;*---------------------------------------------------------------------*/ -;* tc */ -;*---------------------------------------------------------------------*/ -(markup-writer 'tc - :options '(:width :align :valign :colspan) - :action (lambda (n e) - (let ((id (markup-ident n)) - (cla (markup-class n))) - (let* ((o0 (markup-body n)) - (o1 (if (eq? (markup-option n 'markup) 'th) - (new markup - (markup '&latex-th) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o0)) - o0)) - (o2 (if (markup-option n :width) - (new markup - (markup '&latex-tc-parbox) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o1)) - o1)) - (o3 (if (or (> (markup-option n :colspan) 1) - (not (eq? (markup-option n :align) - 'center)) - (markup-option n '&lhs) - (markup-option n '&rhs)) - (new markup - (markup '&latex-tc-multicolumn) - (parent n) - (ident id) - (class cla) - (options (markup-options n)) - (body o2)) - o2))) - (output o3 e))))) - -;*---------------------------------------------------------------------*/ -;* &latex-th ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-th - :before "\\textsf{" - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-parbox ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-parbox - :before (lambda (n e) - (let ((width (markup-option n :width)) - (valign (markup-option n :valign))) - (printf "\\parbox{~a}{" (latex-width width)))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* &latex-tc-multicolumn ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&latex-tc-multicolumn - :before (lambda (n e) - (let ((colspan (markup-option n :colspan)) - (lhs (or (markup-option n '&lhs) "")) - (rhs (or (markup-option n '&rhs) "")) - (align (case (markup-option n :align) - ((left) #\l) - ((center) #\c) - ((right) #\r) - (else #\c)))) - (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) - :after "}") - -;*---------------------------------------------------------------------*/ -;* image ... @label image@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'image - :options '(:file :url :width :height :zoom) - :action (lambda (n e) - (let* ((file (markup-option n :file)) - (url (markup-option n :url)) - (width (markup-option n :width)) - (height (markup-option n :height)) - (zoom (markup-option n :zoom)) - (body (markup-body n)) - (efmt (engine-custom e 'image-format)) - (img (or url (convert-image file - (if (list? efmt) - efmt - '("eps")))))) - (if (not (string? img)) - (skribe-error 'latex "Illegal image" file) - (begin - (printf "\\epsfig{file=~a" (strip-ref-base img)) - (if width (printf ", width=~a" (latex-width width))) - (if height (printf ", height=~apt" height)) - (if zoom (printf ", zoom=\"~a\"" zoom)) - (display "}")))))) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'roman :before "{\\textrm{" :after "}}") -(markup-writer 'bold :before "{\\textbf{" :after "}}") -(markup-writer 'underline :before "{\\underline{" :after "}}") -(markup-writer 'emph :before "{\\em{" :after "}}") -(markup-writer 'it :before "{\\textit{" :after "}}") -(markup-writer 'code :before "{\\texttt{" :after "}}") -(markup-writer 'var :before "{\\texttt{" :after "}}") -(markup-writer 'sc :before "{\\sc{" :after "}}") -(markup-writer 'sf :before "{\\sf{" :after "}}") -(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}") -(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}") - -(markup-writer 'tt - :before "{\\texttt{" - :action (lambda (n e) - (let ((ne (make-engine - (gensym 'latex) - :delegate e - :filter (make-string-replace latex-tt-encoding) - :custom (engine-customs e) - :symbol-table (engine-symbol-table e)))) - (output (markup-body n) ne))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* q ... @label q@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'q - :before "``" - :after "''") - -;*---------------------------------------------------------------------*/ -;* mailto ... @label mailto@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mailto - :options '(:text) - :before "{\\texttt{" - :action (lambda (n e) - (let ((text (markup-option n :text))) - (output (or text (markup-body n)) e))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* mark ... @label mark@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'mark - :before (lambda (n e) - (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... @label ref@ */ -;*---------------------------------------------------------------------*/ -(markup-writer 'ref - :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) - :action (lambda (n e) - (let ((t (markup-option n :text))) - (if t - (begin - (output t e) - (output "~" e (markup-writer-get '&~ e)))))) - :after (lambda (n e) - (let* ((c (handle-ast (markup-body n))) - (id (markup-ident c))) - (if (markup-option n :page) - (printf "\\begin{math}{\\pageref{~a}}\\end{math}" - (string-canonicalize id)) - (printf "\\ref{~a}" - (string-canonicalize id)))))) - -;*---------------------------------------------------------------------*/ -;* bib-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (output (markup-option (handle-ast (markup-body n)) :title) e)) - :after "]") - -;*---------------------------------------------------------------------*/ -;* bib-ref+ ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'bib-ref+ - :options '(:text :bib) - :before "[" - :action (lambda (n e) - (let loop ((rs (markup-body n))) - (cond - ((null? rs) - #f) - (else - (if (is-markup? (car rs) 'bib-ref) - (invoke (writer-action (markup-writer-get 'bib-ref e)) - (car rs) - e) - (output (car rs) e)) - (if (pair? (cdr rs)) - (begin - (display ",") - (loop (cdr rs)))))))) - :after "]") - -;*---------------------------------------------------------------------*/ -;* url-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :action (lambda (n e) - (let ((text (markup-option n :text)) - (url (markup-option n :url))) - (if (not text) - (output url e) - (output text e))))) - -;*---------------------------------------------------------------------*/ -;* url-ref hyperref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'url-ref - :options '(:url :text) - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let ((body (markup-option n :text)) - (url (markup-option n :url))) - (if (and body (not (equal? body url))) - (begin - (display "\\href{") - (display url) - (display "}{") - (output body e) - (display "}")) - (begin - (display "\\href{") - (display url) - (printf "}{~a}" url)))))) - -;*---------------------------------------------------------------------*/ -;* line-ref ... */ -;*---------------------------------------------------------------------*/ -(markup-writer 'line-ref - :options '(:offset) - :before "{\\textit{" - :action (lambda (n e) - (let ((o (markup-option n :offset)) - (v (string->number (markup-option n :text)))) - (cond - ((and (number? o) (number? v)) - (display (+ o v))) - (else - (display v))))) - :after "}}") - -;*---------------------------------------------------------------------*/ -;* &the-bibliography ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&the-bibliography - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[21]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - \\itemsep 0pt - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-label e)) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-title ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-title - :predicate (lambda (n e) - (engine-custom e 'hyperref)) - :action (lambda (n e) - (let* ((t (bold (markup-body n))) - (en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (ht (if url (ref :url (markup-body url) :text t) t))) - (skribe-eval ht e)))) - -;*---------------------------------------------------------------------*/ -;* &bib-entry-label ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-label - :options '(:title) - :before "\\item[{\\char91}" - :action (lambda (n e) (output (markup-option n :title) e)) - :after "{\\char93}] ") - -;*---------------------------------------------------------------------*/ -;* &bib-entry-url ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&bib-entry-url - :action (lambda (n e) - (let* ((en (handle-ast (ast-parent n))) - (url (markup-option en 'url)) - (t (bold (markup-body url)))) - (skribe-eval (ref :url (markup-body url) :text t) e)))) - -;*---------------------------------------------------------------------*/ -;* &source-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (it (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-line-comment ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-line-comment - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-comment-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-keyword ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-keyword - :action (lambda (n e) - (skribe-eval (underline (markup-body n)) e))) - -;*---------------------------------------------------------------------*/ -;* &source-error ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-error - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-error-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'error-color) cc) - (color :fg cc (underline n1)) - (underline n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-define ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-define - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-define-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-module ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-module - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-module-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-markup ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-markup - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-markup-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-thread ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-thread - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-thread-color)) - (n1 (bold (markup-body n))) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-string ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-string - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-string-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - n1))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-bracket ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-bracket - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-bracket-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc n1) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-key ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-key - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg cc (bold n1)) - (it n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* &source-type ... */ -;*---------------------------------------------------------------------*/ -(markup-writer '&source-type - :action (lambda (n e) - (let* ((cc (engine-custom e 'source-type-color)) - (n1 (markup-body n)) - (n2 (if (and (engine-custom e 'source-color) cc) - (color :fg "red" (bold n1)) - (bold n1)))) - (skribe-eval n2 e)))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/letter.skr b/skribe/skr/letter.skr deleted file mode 100644 index 17a0058..0000000 --- a/skribe/skr/letter.skr +++ /dev/null @@ -1,146 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for letters */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* document */ -;*---------------------------------------------------------------------*/ -(define %letter-document document) - -(define-markup (document #!rest opt - #!key (ident #f) (class "letter") - where date author - &skribe-eval-location) - (let* ((ubody (the-body opt)) - (body (list (new markup - (markup '&letter-where) - (loc &skribe-eval-location) - (options `((:where ,where) - (:date ,date) - (:author ,author)))) - ubody))) - (apply %letter-document - :author #f :title #f - (append (apply append - (the-options opt :where :date :author :title)) - body)))) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") - (engine-custom-set! le 'maketitle #f) - ;; &letter-where - (markup-writer '&letter-where le - :before "\\begin{raggedright}\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (when hd - (display "\\hfill ") - (output hd e) - (set! hd #f)) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) - -;*---------------------------------------------------------------------*/ -;* HTML configuration */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - ;; &letter-where - (markup-writer '&letter-where he - :before "
\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (display "\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "
") - (output n e) - (when hd - (display "") - (output hd e) - (set! hd #f)) - (display "
\n
\n\n")) - - diff --git a/skribe/skr/lncs.skr b/skribe/skr/lncs.skr deleted file mode 100644 index 4668404..0000000 --- a/skribe/skr/lncs.skr +++ /dev/null @@ -1,147 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/lncs.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for LNCS articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{llncs}") - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-inst-body n) - (let ((affiliation (markup-option n :affiliation)) - (address (markup-option n :address))) - (when affiliation (output affiliation e) (display ", ")) - (when address - (for-each (lambda (a) (output a e) (display " ")) - address) - (newline)))) - (define (&latex-inst-n i) - (display "\\institute{\n") - (&latex-inst-body (car i)) - (for-each (lambda (n) - (display "\\and\n") - (&latex-inst-body n)) - (cdr i)) - (display "}\n")) - (define (&latex-author-1 n) - (display "\\author{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author{\n") - (output (car n) e) - (for-each (lambda (a) - (display " and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (markup-option-add! n 'inst 1) - (&latex-author-1 body) - (&latex-inst-n (list body))) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (define (institute=? n1 n2) - (let ((aff1 (markup-option n1 :affiliation)) - (add1 (markup-option n1 :address)) - (aff2 (markup-option n2 :affiliation)) - (add2 (markup-option n2 :address))) - (and (equal? aff1 aff2) (equal? add1 add2)))) - (define (search-institute n i j) - (cond - ((null? i) - #f) - ((institute=? n (car i)) - j) - (else - (search-institute n (cdr i) (- j 1))))) - (if (null? (cdr body)) - (begin - (markup-option-add! (car body) 'inst 1) - (&latex-author-1 (car body)) - (&latex-inst-n body)) - ;; collect the institutes - (let loop ((ns body) - (is '()) - (j 1)) - (if (null? ns) - (begin - (&latex-author-n body) - (&latex-inst-n (reverse! is))) - (let* ((n (car ns)) - (si (search-institute n is (- j 1)))) - (if (integer? si) - (begin - (markup-option-add! n 'inst si) - (loop (cdr ns) is j)) - (begin - (markup-option-add! n 'inst j) - (loop (cdr ns) - (cons n is) - (+ 1 j))))))))) - (else - (skribe-error 'author - "Illegal `lncs' author" - body)))))) - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (inst (markup-option n 'inst))) - (if name (output name e)) - (if title (output title e)) - (if inst (printf "\\inst{~a}\n" inst))))))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-lncs-abstract he - :action (lambda (n e) - (let* ((bg (or (engine-custom e 'abstract-background) - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-lncs-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skribe/skr/scribe.skr b/skribe/skr/scribe.skr deleted file mode 100644 index d9e3bb8..0000000 --- a/skribe/skr/scribe.skr +++ /dev/null @@ -1,229 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/scribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 29 10:07:21 2003 */ -;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Scribe Compatibility kit */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* style ... */ -;*---------------------------------------------------------------------*/ -(define (style . styles) - (define (load-style style) - (let ((name (cond - ((string? style) - style) - ((symbol? style) - (string-append (symbol->string style) ".scr"))))) - (skribe-load name :engine *skribe-engine*))) - (for-each load-style styles)) - -;*---------------------------------------------------------------------*/ -;* chapter ... */ -;*---------------------------------------------------------------------*/ -(define skribe-chapter chapter) - -(define-markup (chapter #!rest opt #!key title subtitle split number toc file) - (apply skribe-chapter - :title (or title subtitle) - :number number - :toc toc - :file file - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* table-of-contents ... */ -;*---------------------------------------------------------------------*/ -(define-markup (table-of-contents #!rest opts #!key chapter section subsection) - (apply toc opts)) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define skribe-frame frame) - -(define-markup (frame #!rest opt #!key width margin) - (apply skribe-frame - :width (if (real? width) (* 100 width) width) - :margin margin - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* copyright ... */ -;*---------------------------------------------------------------------*/ -(define (copyright) - (symbol 'copyright)) - -;*---------------------------------------------------------------------*/ -;* sect ... */ -;*---------------------------------------------------------------------*/ -(define (sect) - (symbol 'section)) - -;*---------------------------------------------------------------------*/ -;* euro ... */ -;*---------------------------------------------------------------------*/ -(define (euro) - (symbol 'euro)) - -;*---------------------------------------------------------------------*/ -;* tab ... */ -;*---------------------------------------------------------------------*/ -(define (tab) - (char #\tab)) - -;*---------------------------------------------------------------------*/ -;* space ... */ -;*---------------------------------------------------------------------*/ -(define (space) - (char #\space)) - -;*---------------------------------------------------------------------*/ -;* print-bibliography ... */ -;*---------------------------------------------------------------------*/ -(define-markup (print-bibliography #!rest opts - #!key all (sort bib-sort/authors)) - (the-bibliography all sort)) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define skribe-linebreak linebreak) - -(define-markup (linebreak . lnum) - (cond - ((null? lnum) - (skribe-linebreak)) - ((string? (car lnum)) - (skribe-linebreak (string->number (car lnum)))) - (else - (skribe-linebreak (car lnum))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define skribe-ref ref) - -(define-markup (ref #!rest opts - #!key scribe url id page figure mark - chapter section subsection subsubsection subsubsection - bib bib+ number) - (let ((bd (the-body opts)) - (args (apply append (the-options opts :id)))) - (if id (set! args (cons* :mark id args))) - (if (pair? bd) (set! args (cons* :text bd args))) - (apply skribe-ref args))) - -;*---------------------------------------------------------------------*/ -;* indexes ... */ -;*---------------------------------------------------------------------*/ -(define *scribe-indexes* - (list (cons "theindex" (make-index "theindex")))) - -(define skribe-index index) -(define skribe-make-index make-index) - -(define-markup (make-index index) - (let ((i (skribe-make-index index))) - (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) - i)) - -(define-markup (index #!rest opts #!key note index shape) - (let ((i (if (not index) - "theindex" - (let ((i (assoc index *scribe-indexes*))) - (if (pair? i) - (cdr i) - (make-index index)))))) - (apply skribe-index :note note :index i :shape shape (the-body opts)))) - -(define-markup (print-index #!rest opts - #!key split (char-offset 0) (header-limit 100)) - (apply the-index - :split split - :char-offset char-offset - :header-limit header-limit - (map (lambda (i) - (let ((c (assoc i *scribe-indexes*))) - (if (pair? c) - (cdr c) - (skribe-error 'the-index "Unknown index" i)))) - (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* format? */ -;*---------------------------------------------------------------------*/ -(define (scribe-format? fmt) #f) - -;*---------------------------------------------------------------------*/ -;* scribe-url ... */ -;*---------------------------------------------------------------------*/ -(define (scribe-url) (skribe-url)) - -;*---------------------------------------------------------------------*/ -;* Various configurations */ -;*---------------------------------------------------------------------*/ -(define *scribe-background* #f) -(define *scribe-foreground* #f) -(define *scribe-tbackground* #f) -(define *scribe-tforeground* #f) -(define *scribe-title-font* #f) -(define *scribe-author-font* #f) -(define *scribe-chapter-numbering* #f) -(define *scribe-footer* #f) -(define *scribe-prgm-color* #f) - -;*---------------------------------------------------------------------*/ -;* prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (prgm #!rest opts - #!key lnum lnumwidth language bg frame (width 1.) - colors (monospace #t)) - (let* ((w (cond - ((real? width) (* width 100.)) - ((number? width) width) - (else 100.))) - (body (if language - (source :language language (the-body opts)) - (the-body opts))) - (body (if monospace - (prog :line lnum body) - body)) - (body (if bg - (color :width 100. :bg bg body) - body))) - (skribe-frame :width w - :border (if frame 1 #f) - body))) - -;*---------------------------------------------------------------------*/ -;* latex configuration */ -;*---------------------------------------------------------------------*/ -(define *scribe-tex-predocument* #f) - -;*---------------------------------------------------------------------*/ -;* latex-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (latex-prelude e) - (if (engine-format? "latex" e) - (begin - (if *scribe-tex-predocument* - (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) - -;*---------------------------------------------------------------------*/ -;* html-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (html-prelude e) - (if (engine-format? "html" e) - (begin - #f))) - -;*---------------------------------------------------------------------*/ -;* prelude */ -;*---------------------------------------------------------------------*/ -(let ((p (user-prelude))) - (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/skribe/skr/sigplan.skr b/skribe/skr/sigplan.skr deleted file mode 100644 index 9bdb939..0000000 --- a/skribe/skr/sigplan.skr +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/sigplan.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Wed May 18 16:00:38 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[twocolumns]{sigplanconf}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\authorinfo{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "}\n\\authorinfo{") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\copyrightyear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\copyrightdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/skribe/skr/skribe.skr b/skribe/skr/skribe.skr deleted file mode 100644 index 86425ac..0000000 --- a/skribe/skr/skribe.skr +++ /dev/null @@ -1,76 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/skribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 11 11:23:12 2002 */ -;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The standard Skribe style (always loaded). */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* p ... */ -;*---------------------------------------------------------------------*/ -(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) - (paragraph :ident ident :class class :loc &skribe-eval-location - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* fg ... */ -;*---------------------------------------------------------------------*/ -(define (fg c . body) - (color :fg c body)) - -;*---------------------------------------------------------------------*/ -;* bg ... */ -;*---------------------------------------------------------------------*/ -(define (bg c . body) - (color :bg c body)) - -;*---------------------------------------------------------------------*/ -;* counter ... */ -;* ------------------------------------------------------------- */ -;* This produces a kind of "local enumeration" that is: */ -;* (counting "toto," "tutu," "titi.") */ -;* produces: */ -;* i) toto, ii) tutu, iii) titi. */ -;*---------------------------------------------------------------------*/ -(define-markup (counter #!rest opts #!key (numbering 'roman)) - (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) - (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) - (define (the-roman-number num) - (if (< num (vector-length vroman)) - (list (list "(" (it (vector-ref vroman num)) ") ")) - (skribe-error 'counter - "too many items for roman numbering" - (length items)))) - (define (the-arabic-number num) - (list (list "(" (it (integer->string num)) ") "))) - (define (the-alpha-number num) - (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) - (let ((the-number (case numbering - ((roman) the-roman-number) - ((arabic) the-arabic-number) - ((alpha) the-alpha-number) - (else (skribe-error 'counter - "Illegal numbering" - numbering))))) - (let loop ((num 1) - (items items) - (res '())) - (if (null? items) - (reverse! res) - (loop (+ num 1) - (cdr items) - (cons (list (the-number num) (car items)) res)))))) - -;*---------------------------------------------------------------------*/ -;* q */ -;*---------------------------------------------------------------------*/ -(define-markup (q #!rest opt) - (new markup - (markup 'q) - (options (the-options opt)) - (body (the-body opt)))) - diff --git a/skribe/skr/slide.skr b/skribe/skr/slide.skr deleted file mode 100644 index f8638ad..0000000 --- a/skribe/skr/slide.skr +++ /dev/null @@ -1,664 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/slide.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for slides */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* slide-options */ -;*---------------------------------------------------------------------*/ -(define &slide-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-predocument - "\\special{landscape} - \\slideframe{none} - \\centerslidesfalse - \\raggedslides[0pt] - \\renewcommand{\\slideleftmargin}{0.2in} - \\renewcommand{\\slidetopmargin}{0.3in} - \\newdimen\\slidewidth \\slidewidth 9in") - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-maketitle ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-maketitle - "\\def\\labelitemi{$\\bullet$} - \\def\\labelitemii{$\\circ$} - \\def\\labelitemiii{$\\diamond$} - \\def\\labelitemiv{$\\cdot$} - \\pagestyle{empty} - \\slideframe{none} - \\centerslidestrue - \\begin{slide} - \\date{} - \\maketitle - \\end{slide} - \\slideframe{none} - \\centerslidesfalse") - -;*---------------------------------------------------------------------*/ -;* &slide-prosper-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-prosper-predocument - "\\slideCaption{}\n") - -;*---------------------------------------------------------------------*/ -;* %slide-the-slides ... */ -;*---------------------------------------------------------------------*/ -(define %slide-the-slides '()) -(define %slide-the-counter 0) -(define %slide-initialized #f) -(define %slide-latex-mode 'seminar) - -;*---------------------------------------------------------------------*/ -;* %slide-initialize! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-initialize!) - (unless %slide-initialized - (set! %slide-initialized #t) - (case %slide-latex-mode - ((seminar) - (%slide-seminar-setup!)) - ((advi) - (%slide-advi-setup!)) - ((prosper) - (%slide-prosper-setup!)) - (else - (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) - -;*---------------------------------------------------------------------*/ -;* slide ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide #!rest opt - #!key - (ident #f) (class #f) - (toc #t) - title (number #t) - (vspace #f) (vfill #f) - (transition #f) - (bg #f) (image #f)) - (%slide-initialize!) - (let ((s (new container - (markup 'slide) - (ident (symbol->string (gensym 'slide))) - (class class) - (required-options '(:title :number :toc)) - (options `((:number - ,(cond - ((number? number) - (set! %slide-the-counter number) - number) - (number - (set! %slide-the-counter - (+ 1 %slide-the-counter)) - %slide-the-counter) - (else - #f))) - (:toc ,toc) - ,@(the-options opt :ident :class :vspace :toc))) - (body (if vspace - (list (slide-vspace vspace) (the-body opt)) - (the-body opt)))))) - (set! %slide-the-slides (cons s %slide-the-slides)) - s)) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define %slide-old-ref ref) - -(define-markup (ref #!rest opt #!key (slide #f)) - (if (not slide) - (apply %slide-old-ref opt) - (new unresolved - (proc (lambda (n e env) - (cond - ((eq? slide 'next) - (let ((c (assq n %slide-the-slides))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((eq? slide 'prev) - (let ((c (assq n (reverse %slide-the-slides)))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((number? slide) - (let loop ((s %slide-the-slides)) - (cond - ((null? s) - #f) - ((= slide (markup-option (car s) :number)) - (handle (car s))) - (else - (loop (cdr s)))))) - (else - #f))))))) - -;*---------------------------------------------------------------------*/ -;* slide-pause ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-pause) - (new markup - (markup 'slide-pause))) - -;*---------------------------------------------------------------------*/ -;* slide-vspace ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) - (new markup - (markup 'slide-vspace) - (options `((:unit ,unit) ,@(the-options opt :unit))) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* slide-embed ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-embed #!rest opt - #!key - command - (geometry-opt "-geometry") - (geometry #f) (rgeometry #f) - (transient #f) (transient-opt #f) - (alt #f) - &skribe-eval-location) - (if (not (string? command)) - (skribe-error 'slide-embed - "No command provided" - command) - (new markup - (markup 'slide-embed) - (loc &skribe-eval-location) - (required-options '(:alt)) - (options `((:geometry-opt ,geometry-opt) - (:alt ,alt) - ,@(the-options opt :geometry-opt :alt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-record ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) - (if (not tag) - (skribe-error 'slide-record "Tag missing" tag) - (new markup - (markup 'slide-record) - (ident ident) - (class class) - (options `((:play ,play) ,@(the-options opt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play #!rest opt #!key ident class tag color) - (if (not tag) - (skribe-error 'slide-play "Tag missing" tag) - (new markup - (markup 'slide-play) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - ,@(the-options opt :color))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play* ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play* #!rest opt - #!key ident class color (scolor "#000000")) - (let ((body (the-body opt))) - (for-each (lambda (lbl) - (match-case lbl - ((?id ?col) - (skribe-use-color! col)))) - body) - (new markup - (markup 'slide-play*) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - (:scolor ,(if color (skribe-use-color! scolor) #f)) - ,@(the-options opt :color :scolor))) - (body body)))) - -;*---------------------------------------------------------------------*/ -;* base */ -;*---------------------------------------------------------------------*/ -(let ((be (find-engine 'base))) - (skribe-message "Base slides setup...\n") - ;; slide-pause - (markup-writer 'slide-pause be - :action #f) - ;; slide-vspace - (markup-writer 'slide-vspace be - :options '() - :action #f) - ;; slide-embed - (markup-writer 'slide-embed be - :options '(:alt :geometry-opt) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-record - (markup-writer 'slide-record be - :options '(:tag :play) - :action (lambda (n e) - (output (markup-body n) e))) - ;; slide-play - (markup-writer 'slide-play be - :options '(:tag :color) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-play* - (markup-writer 'slide-play* be - :options '(:tag :color :scolor) - :action (lambda (n e) - (output (markup-option n :alt) e)))) - -;*---------------------------------------------------------------------*/ -;* slide-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (slide-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 95.))) - -;*---------------------------------------------------------------------*/ -;* html-slide-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-slide-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (slide-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "
") - (output title e) - (display ""))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* slide-number ... */ -;*---------------------------------------------------------------------*/ -(define (slide-number) - (length (filter (lambda (n) - (and (is-markup? n 'slide) - (markup-option n :number))) - %slide-the-slides))) - -;*---------------------------------------------------------------------*/ -;* html */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") - ;; &html-page-title - (markup-writer '&html-document-title he - :predicate (lambda (n e) %slide-initialized) - :action html-slide-title) - ;; slide - (markup-writer 'slide he - :options '(:title :number :transition :toc :bg) - :before (lambda (n e) - (printf "" (markup-ident n)) - (display "
\n")) - :action (lambda (n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (skribe-eval - (center - (color :width (slide-body-width e) - :bg (or (markup-option n :bg) "#ffffff") - (table :width 100. - (tr (th :align 'left - (list - (if nb - (format "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) - :after "
") - ;; slide-vspace - (markup-writer 'slide-vspace he - :action (lambda (n e) (display "
")))) - -;*---------------------------------------------------------------------*/ -;* latex */ -;*---------------------------------------------------------------------*/ -(define &latex-slide #f) -(define &latex-pause #f) -(define &latex-embed #f) -(define &latex-record #f) -(define &latex-play #f) -(define &latex-play* #f) - -(let ((le (find-engine 'latex))) - ;; slide-vspace - (markup-writer 'slide-vspace le - :options '(:unit) - :action (lambda (n e) - (display "\n\\vspace{") - (output (markup-body n) e) - (printf " ~a}\n\n" (markup-option n :unit)))) - ;; slide-slide - (markup-writer 'slide le - :options '(:title :number :transition :vfill :toc :vspace :image) - :action (lambda (n e) - (if (procedure? &latex-slide) - (&latex-slide n e)))) - ;; slide-pause - (markup-writer 'slide-pause le - :options '() - :action (lambda (n e) - (if (procedure? &latex-pause) - (&latex-pause n e)))) - ;; slide-embed - (markup-writer 'slide-embed le - :options '(:alt :command :geometry-opt :geometry - :rgeometry :transient :transient-opt) - :action (lambda (n e) - (if (procedure? &latex-embed) - (&latex-embed n e)))) - ;; slide-record - (markup-writer 'slide-record le - :options '(:tag :play) - :action (lambda (n e) - (if (procedure? &latex-record) - (&latex-record n e)))) - ;; slide-play - (markup-writer 'slide-play le - :options '(:tag :color) - :action (lambda (n e) - (if (procedure? &latex-play) - (&latex-play n e)))) - ;; slide-play* - (markup-writer 'slide-play* le - :options '(:tag :color :scolor) - :action (lambda (n e) - (if (procedure? &latex-play*) - (&latex-play* n e))))) - -;*---------------------------------------------------------------------*/ -;* %slide-seminar-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-seminar-setup!) - (skribe-message "Seminar slides setup...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - ;; latex configuration - (define (seminar-slide n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (display "\\begin{slide}\n") - (if nb (printf "~a/~a -- " nb (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n")) - (engine-custom-set! le 'documentclass - "\\documentclass[landscape]{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[setpagesize=false]{hyperref}\n") - ;; slide-slide - (set! &latex-slide seminar-slide))) - -;*---------------------------------------------------------------------*/ -;* %slide-advi-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-advi-setup!) - (skribe-message "Generating `Advi Seminar' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - (define (advi-geometry geo) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) - (if (pair? r) - (let* ((w (cadr r)) - (w' (string->integer w)) - (w'' (number->string (/ w' *skribe-slide-advi-scale*))) - (h (caddr r)) - (h' (string->integer h)) - (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) - (values "" (string-append w "x" h "+!x+!y"))) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) - (if (pair? r) - (let ((w (number->string (/ (string->integer (cadr r)) - *skribe-slide-advi-scale*))) - (h (number->string (/ (string->integer (caddr r)) - *skribe-slide-advi-scale*))) - (x (cadddr r)) - (y (car (cddddr r)))) - (values (string-append "width=" w "cm,height=" h "cm") - "!g")) - (values "" geo)))))) - (define (advi-transition trans) - (cond - ((string? trans) - (printf "\\advitransition{~s}" trans)) - ((and (symbol? trans) - (memq trans '(wipe block slide))) - (printf "\\advitransition{~s}" trans)) - (else - #f))) - ;; latex configuration - (define (advi-slide n e) - (let ((i (markup-option n :image)) - (n (markup-option n :number)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition))) - (if (and i (engine-custom e 'advi)) - (printf "\\advibg[global]{image=~a}\n" - (if (and (pair? i) - (null? (cdr i)) - (string? (car i))) - (car i) - i))) - (display "\\begin{slide}\n") - (advi-transition (or lt gt)) - (if n (printf "~a/~a -- " n (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n\n\n")) - ;; advi record - (define (advi-record n e) - (display "\\advirecord") - (when (markup-option n :play) (display "[play]")) - (printf "{~a}{" (markup-option n :tag)) - (output (markup-body n) e) - (display "}")) - ;; advi play - (define (advi-play n e) - (display "\\adviplay") - (let ((c (markup-option n :color))) - (when c - (display "[") - (display (skribe-get-latex-color c)) - (display "]"))) - (printf "{~a}" (markup-option n :tag))) - ;; advi play* - (define (advi-play* n e) - (let ((c (skribe-get-latex-color (markup-option n :color))) - (d (skribe-get-latex-color (markup-option n :scolor)))) - (let loop ((lbls (markup-body n)) - (last #f)) - (when last - (display "\\adviplay[") - (display d) - (printf "]{~a}" last)) - (when (pair? lbls) - (let ((lbl (car lbls))) - (match-case lbl - ((?id ?col) - (display "\\adviplay[") - (display (skribe-get-latex-color col)) - (printf "]{" ~a "}" id) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) id)) - (else - (display "\\adviplay[") - (display c) - (printf "]{~a}" lbl) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) lbl)))))))) - (engine-custom-set! le 'documentclass - "\\documentclass{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'usepackage - (string-append "\\usepackage{advi}\n" - (engine-custom le 'usepackage))) - ;; slide - (set! &latex-slide advi-slide) - (set! &latex-pause - (lambda (n e) (display "\\adviwait\n"))) - (set! &latex-embed - (lambda (n e) - (let ((geometry-opt (markup-option n :geometry-opt)) - (geometry (markup-option n :geometry)) - (rgeometry (markup-option n :rgeometry)) - (transient (markup-option n :transient)) - (transient-opt (markup-option n :transient-opt)) - (cmd (markup-option n :command))) - (let* ((a (string-append "ephemeral=" - (symbol->string (gensym)))) - (c (cond - (geometry - (string-append cmd " " - geometry-opt " " - geometry)) - (rgeometry - (multiple-value-bind (aopt dopt) - (advi-geometry rgeometry) - (set! a (string-append a "," aopt)) - (string-append cmd " " - geometry-opt " " - dopt))) - (else - cmd))) - (c (if (and transient transient-opt) - (string-append c " " transient-opt " !p") - c))) - (printf "\\adviembed[~a]{~a}\n" a c))))) - (set! &latex-record advi-record) - (set! &latex-play advi-play) - (set! &latex-play* advi-play*))) - -;*---------------------------------------------------------------------*/ -;* %slide-prosper-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-prosper-setup!) - (skribe-message "Generating `Prosper' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base)) - (overlay-count 0)) - ;; transitions - (define (prosper-transition trans) - (cond - ((string? trans) - (printf "[~s]" trans)) - ((eq? trans 'slide) - (printf "[Blinds]")) - ((and (symbol? trans) - (memq trans '(split blinds box wipe dissolve glitter))) - (printf "[~s]" - (string-upcase (symbol->string trans)))) - (else - #f))) - ;; latex configuration - (define (prosper-slide n e) - (let* ((i (markup-option n :image)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition)) - (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) - (lpa (length pa))) - (set! overlay-count 1) - (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) - (display "\\begin{slide}") - (prosper-transition (or lt gt)) - (display "{") - (output t e) - (display "}\n") - (output (markup-body n) e) - (display "\\end{slide}\n") - (if (>= lpa 1) (display "}\n")) - (newline) - (newline))) - (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") - (let* ((cap (engine-custom le 'slide-caption)) - (o (engine-custom le 'predocument)) - (n (if (string? cap) - (format "~a\\slideCaption{~a}\n" - &slide-prosper-predocument - cap) - &slide-prosper-predocument))) - (engine-custom-set! le 'predocument - (if (string? o) (string-append n o) n))) - (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") - ;; writers - (set! &latex-slide prosper-slide) - (set! &latex-pause - (lambda (n e) - (set! overlay-count (+ 1 overlay-count)) - (printf "\\FromSlide{~s}%\n" overlay-count))))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &slide-load-options) - (p (memq :prosper opt))) - (if (and (pair? p) (pair? (cdr p)) (cadr p)) - ;; prosper - (set! %slide-latex-mode 'prosper) - (let ((a (memq :advi opt))) - (if (and (pair? a) (pair? (cdr a)) (cadr a)) - ;; advi - (set! %slide-latex-mode 'advi))))) - diff --git a/skribe/skr/web-article.skr b/skribe/skr/web-article.skr deleted file mode 100644 index e33328b..0000000 --- a/skribe/skr/web-article.skr +++ /dev/null @@ -1,230 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-article.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jan 10 09:09:43 2004 */ -;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* A Skribe style for producing web articles */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* &web-article-load-options ... */ -;*---------------------------------------------------------------------*/ -(define &web-article-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* web-article-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 98.))) - -;*---------------------------------------------------------------------*/ -;* html-document-title-web ... */ -;*---------------------------------------------------------------------*/ -(define (html-document-title-web n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (web-article-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "

") - (output title e) - (display "

"))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-document-title ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-document-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (id (markup-ident n))) - ;; the title - (printf "
\n" - (string-canonicalize id)) - (output title e) - (display "
\n") - ;; the authors - (printf "
\n" - (string-canonicalize id)) - (for-each (lambda (a) (output a e)) - (cond - ((is-markup? authors 'author) - (list authors)) - ((list? authors) - authors) - (else - '()))) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-author ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-author n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (when name - (printf "" - (string-canonicalize (markup-ident n))) - (output name e) - (display "\n")) - (when title - (printf "" - (string-canonicalize (markup-ident n))) - (output title e) - (display "\n")) - (when affiliation - (printf "" - (string-canonicalize (markup-ident n))) - (output affiliation e) - (display "\n")) - (when (pair? address) - (printf "" - (string-canonicalize (markup-ident n))) - (for-each (lambda (a) - (output a e) - (newline)) - address) - (display "\n")) - (when phone - (printf "" - (string-canonicalize (markup-ident n))) - (output phone e) - (display "\n")) - (when email - (printf "" - (string-canonicalize (markup-ident n))) - (output email e) - (display "\n")) - (when url - (printf "" - (string-canonicalize (markup-ident n))) - (output url e) - (display "\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML settings */ -;*---------------------------------------------------------------------*/ -(define (web-article-modern-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :action html-document-title-web) - ;; section - (markup-writer 'section he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background))) - (markup-writer 'section e1 - :options 'all - :action (lambda (n e2) (output n e sec))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg n)) - e1)))) - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background)) - (fg (engine-custom he 'subsection-title-foreground))) - (markup-writer '&html-footnotes e1 - :options 'all - :action (lambda (n e2) - (invoke (writer-action ft) n e))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg :fg fg n)) - e1)))))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-setup ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :before (lambda (n e) - (printf "
\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-document-title - :after "
\n") - ;; author - (markup-writer 'author he - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (printf "\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-author - :after "" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) (output n e sec)) - :after "\n") - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before (lambda (n e) - (printf "
" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) - (output n e ft)) - :after "
\n"))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &web-article-load-options) - (p (memq :style opt)) - (css (memq :css opt)) - (he (find-engine 'html))) - (cond - ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) - (web-article-css-setup he)) - ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) - (engine-custom-set! he 'css (cadr css)) - (web-article-css-setup he)) - (else - (web-article-modern-setup he)))) diff --git a/skribe/skr/web-book.skr b/skribe/skr/web-book.skr deleted file mode 100644 index f907c8b..0000000 --- a/skribe/skr/web-book.skr +++ /dev/null @@ -1,107 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-book.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 10:54:32 2003 */ -;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe web book style. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html customization */ -;*---------------------------------------------------------------------*/ -(define he (find-engine 'html)) -(engine-custom-set! he 'main-browsing-extra #f) -(engine-custom-set! he 'chapter-file #t) - -;*---------------------------------------------------------------------*/ -;* main-browsing ... */ -;*---------------------------------------------------------------------*/ -(define main-browsing - (lambda (n e) - ;; search the document - (let ((p (ast-document n))) - (cond - ((document? p) - ;; got it - (let* ((mt (markup-option p :margin-title)) - (r (ref :handle (handle p) - :text (or mt (markup-option p :title)))) - (fx (engine-custom e 'web-book-main-browsing-extra))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold "main page")))) - (tr :bg (engine-custom e 'background) - (td (apply table :width 100. :border 0 - (tr (td :align 'left - :valign 'top - (bold "top:")) - (td :align 'right - :valign 'top r)) - (if (procedure? fx) - (list (tr (td :width 100. - :colspan 2 - (fx n e)))) - '())))))))) - ((not p) - ;; no document!!! - #f))))) - -;*---------------------------------------------------------------------*/ -;* chapter-browsing ... */ -;*---------------------------------------------------------------------*/ -(define chapter-browsing - (lambda (n e) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (markup-option n :title))))) - (tr :bg (engine-custom e 'background) - (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) - -;*---------------------------------------------------------------------*/ -;* document-browsing ... */ -;*---------------------------------------------------------------------*/ -(define document-browsing - (lambda (n e) - (let ((chap (find1-down (lambda (n) - (is-markup? n 'chapter)) - n))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (if chap "Chapters" "Sections"))))) - (tr :bg (engine-custom e 'background) - (td (if chap - (toc (handle n) :chapter #t :section #f) - (toc (handle n) :section #t :subsection #t))))))))) - -;*---------------------------------------------------------------------*/ -;* left margin ... */ -;*---------------------------------------------------------------------*/ -(engine-custom-set! he 'left-margin-size 20.) - -(engine-custom-set! he 'left-margin - (lambda (n e) - (let ((d (ast-document n)) - (c (ast-chapter n))) - (list (linebreak 1) - (main-browsing n e) - (if (is-markup? c 'chapter) - (list (linebreak 2) - (chapter-browsing c e)) - #f) - (if (document? d) - (list (linebreak 2) - (document-browsing d e)) - #f))))) - diff --git a/skribe/skr/xml.skr b/skribe/skr/xml.skr deleted file mode 100644 index 784b6f0..0000000 --- a/skribe/skr/xml.skr +++ /dev/null @@ -1,111 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/xml.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 09:46:09 2003 */ -;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Generic XML Skribe engine */ -;* ------------------------------------------------------------- */ -;* Implementation: */ -;* common: @path ../src/common/api.src@ */ -;* bigloo: @path ../src/bigloo/api.bgl@ */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/xmle.skb:ref@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* xml-engine ... */ -;*---------------------------------------------------------------------*/ -(define xml-engine - ;; setup the xml engine - (default-engine-set! - (make-engine 'xml - :version 1.0 - :format "html" - :delegate (find-engine 'base) - :filter (make-string-replace '((#\< "<") - (#\> ">") - (#\& "&") - (#\" """) - (#\@ "@")))))) - -;*---------------------------------------------------------------------*/ -;* markup ... */ -;*---------------------------------------------------------------------*/ -(let ((xml-margin 0)) - (define (make-margin) - (make-string xml-margin #\space)) - (define (xml-attribute? val) - (cond - ((or (string? val) (number? val) (boolean? val)) - #t) - ((list? val) - (every? xml-attribute? val)) - (else - #f))) - (define (xml-attribute att val) - (let ((s (keyword->string att))) - (printf " ~a=\"" (substring s 1 (string-length s))) - (let loop ((val val)) - (cond - ((or (string? val) (number? val)) - (display val)) - ((boolean? val) - (display (if val "true" "false"))) - ((pair? val) - (for-each loop val)) - (else - #f))) - (display #\"))) - (define (xml-option opt val e) - (let* ((m (make-margin)) - (ks (keyword->string opt)) - (s (substring ks 1 (string-length ks)))) - (printf "~a<~a>\n" m s) - (output val e) - (printf "~a\n" m s))) - (define (xml-options n e) - ;; display the true options - (let ((opts (filter (lambda (o) - (and (keyword? (car o)) - (not (xml-attribute? (cadr o))))) - (markup-options n)))) - (if (pair? opts) - (let ((m (make-margin))) - (display m) - (display "\n") - (set! xml-margin (+ xml-margin 1)) - (for-each (lambda (o) - (xml-option (car o) (cadr o) e)) - opts) - (set! xml-margin (- xml-margin 1)) - (display m) - (display "\n"))))) - (markup-writer #t - :options 'all - :before (lambda (n e) - (printf "~a<~a" (make-margin) (markup-markup n)) - ;; display the xml attributes - (for-each (lambda (o) - (if (and (keyword? (car o)) - (xml-attribute? (cadr o))) - (xml-attribute (car o) (cadr o)))) - (markup-options n)) - (set! xml-margin (+ xml-margin 1)) - (display ">\n")) - :action (lambda (n e) - ;; options - (xml-options n e) - ;; body - (output (markup-body n) e)) - :after (lambda (n e) - (printf "~a\n" (make-margin) (markup-markup n)) - (set! xml-margin (- xml-margin 1))))) - -;*---------------------------------------------------------------------*/ -;* Restore the base engine */ -;*---------------------------------------------------------------------*/ -(default-engine-set! (find-engine 'base)) diff --git a/skribe/skribe.prj b/skribe/skribe.prj deleted file mode 100644 index 1539075..0000000 --- a/skribe/skribe.prj +++ /dev/null @@ -1,332 +0,0 @@ -;; -*- Prcs -*- -(Created-By-Prcs-Version 1 3 3) -(Project-Description "") -(Project-Version skribe 1.2d 2) -(Parent-Version skribe 1.2d 1) -(Version-Log "") -(New-Version-Log "") -(Checkin-Time "Fri, 03 Jun 2005 16:52:04 +0200") -(Checkin-Login serrano) -(Populate-Ignore ("\\.o$" "\\~$" "\\.log$" "\\.ps$" "\\.aux$" "\\.date_of_backup$" "\\.so$" "\\.a$" "if_not_there$" "if_mach$" "threadlibs$")) -(Project-Keywords) -(Files -;; This is a comment. Fill in files here. -;; For example: (prcs/checkout.cc ()) - -;; Files added by populate at Thu, 18 Dec 2003 10:00:47 +0100, -;; to version 0.0(w), by serrano: - - (tools/Makefile (skribe/10_Makefile 1.3 640)) - (src/stklos/xml.stk (skribe/11_xml.stk 1.2 644)) - (src/stklos/writer.stk (skribe/12_writer.stk 1.3 644)) - (src/stklos/verify.stk (skribe/13_verify.stk 1.4 644)) - (src/stklos/vars.stk (skribe/14_vars.stk 1.3 644)) - (src/stklos/types.stk (skribe/16_types.stk 1.4 644)) - (src/stklos/source.stk (skribe/17_source.stk 1.3 644)) - (src/stklos/runtime.stk (skribe/18_runtime.st 1.4 644)) - (src/stklos/resolve.stk (skribe/19_resolve.st 1.2 644)) - (src/stklos/reader.stk (skribe/20_reader.stk 1.2 644)) - (src/stklos/prog.stk (skribe/21_prog.stk 1.1 644)) - (src/stklos/output.stk (skribe/22_output.stk 1.3 644)) - (src/stklos/main.stk (skribe/23_main.stk 1.3 644)) - (src/stklos/lisp.stk (skribe/24_lisp.stk 1.4 644)) - (src/stklos/lib.stk (skribe/25_lib.stk 1.4 644)) - (src/stklos/eval.stk (skribe/26_eval.stk 1.4 644)) - (src/stklos/engine.stk (skribe/27_engine.stk 1.4 644)) - (src/stklos/debug.stk (skribe/28_debug.stk 1.3 644)) - (src/stklos/color.stk (skribe/29_color.stk 1.2 644)) - (src/stklos/biblio.stk (skribe/30_biblio.stk 1.3 644)) - (src/stklos/Makefile.in (skribe/31_Makefile.i 1.3 644)) - (src/common/param.scm (skribe/32_param.scm 1.2 640)) - (src/common/lib.scm (skribe/33_lib.scm 1.4 640)) - (src/common/index.scm (skribe/34_index.scm 1.2 640)) - (src/common/configure.scm.in (skribe/35_configure. 1.3 640)) - (src/common/bib.scm (skribe/36_bib.scm 1.2 640)) - (src/common/api.scm (skribe/37_api.scm 1.9 640)) - (src/bigloo/xml.scm (skribe/38_xml.scm 1.3 640)) - (src/bigloo/writer.scm (skribe/39_writer.scm 1.3 640)) - (src/bigloo/verify.scm (skribe/40_verify.scm 1.6 640)) - (src/bigloo/types.scm (skribe/42_types.scm 1.6 640)) - (src/bigloo/source.scm (skribe/43_source.scm 1.5 640)) - (src/bigloo/resolve.scm (skribe/44_resolve.sc 1.4 640)) - (src/bigloo/read.scm (skribe/45_read.scm 1.2 640)) - (src/bigloo/prog.scm (skribe/46_prog.scm 1.3 640)) - (src/bigloo/param.bgl (skribe/48_param.bgl 1.4 640)) - (src/bigloo/output.scm (skribe/49_output.scm 1.3 640)) - (src/bigloo/new.sch (skribe/50_new.sch 1.1 640)) - (src/bigloo/main.scm (skribe/51_main.scm 1.4 640)) - (src/bigloo/lisp.scm (skribe/b/0_lisp.scm 1.5 640)) - (src/bigloo/lib.bgl (skribe/b/1_lib.bgl 1.5 640)) - (src/bigloo/index.bgl (skribe/b/2_index.bgl 1.2 640)) - (src/bigloo/evapi.scm (skribe/b/3_evapi.scm 1.6 640)) - (src/bigloo/eval.scm (skribe/b/4_eval.scm 1.7 640)) - (src/bigloo/engine.scm (skribe/b/5_engine.scm 1.4 640)) - (src/bigloo/debug.scm (skribe/b/6_debug.scm 1.2 640)) - (src/bigloo/debug.sch (skribe/b/7_debug.sch 1.2 640)) - (src/bigloo/configure.bgl (skribe/b/8_configure. 1.3 640)) - (src/bigloo/color.scm (skribe/b/9_color.scm 1.2 640)) - (src/bigloo/c.scm (skribe/b/10_c.scm 1.4 640)) - (src/bigloo/bib.bgl (skribe/b/11_bib.bgl 1.4 640)) - (src/bigloo/api.sch (skribe/b/12_api.sch 1.5 640)) - (src/bigloo/api.bgl (skribe/b/13_api.bgl 1.2 640)) - (src/bigloo/Makefile (skribe/b/14_Makefile 1.6 640)) - (src/Makefile (skribe/b/15_Makefile 1.2 640)) - (skr/xml.skr (skribe/b/16_xml.skr 1.2 640)) - (skr/web-book.skr (skribe/b/17_web-book.s 1.5 640)) - (skr/slide.skr (skribe/b/19_slide.skr 1.6 640)) - (skr/skribe.skr (skribe/b/20_skribe.skr 1.4 640)) - (skr/scribe.skr (skribe/b/21_scribe.skr 1.1 640)) - (skr/lncs.skr (skribe/b/22_lncs.skr 1.2 640)) - (skr/letter.skr (skribe/b/23_letter.skr 1.3 640)) - (skr/latex.skr (skribe/b/24_latex.skr 1.6 640)) - (skr/jfp.skr (skribe/b/25_jfp.skr 1.4 640)) - (skr/html.skr (skribe/b/26_html.skr 1.8 640)) - (skr/french.skr (skribe/b/27_french.skr 1.1 640)) - (skr/base.skr (skribe/b/28_base.skr 1.6 640)) - (skr/acmproc.skr (skribe/b/29_acmproc.sk 1.4 640)) - (skr/Makefile (skribe/b/30_Makefile 1.6 640)) - (examples/slide/skr/local.skr (skribe/b/34_local.skr 1.1 640)) - (examples/slide/skb/slides.skb (skribe/b/35_slides.skb 1.1 640)) - (examples/slide/ex/syntax.scr (skribe/b/36_syntax.scr 1.1 640)) - (examples/slide/ex/skribe.skb (skribe/b/37_skribe.skb 1.1 640)) - (examples/slide/advi.sty (skribe/b/38_advi.sty 1.1 640)) - (examples/slide/README (skribe/b/39_README 1.1 640)) - (examples/slide/PPRskribe.sty (skribe/b/40_PPRskribe. 1.1 640)) - (examples/slide/Makefile (skribe/b/41_Makefile 1.1 640)) - (examples/Makefile (skribe/b/42_Makefile 1.2 640)) - (etc/stklos/configure.in (skribe/b/43_configure. 1.2 640)) - (etc/stklos/configure (skribe/b/44_configure 1.2 751)) - (etc/stklos/Makefile.skb.in (skribe/b/45_Makefile.s 1.1 644)) - (etc/stklos/Makefile.in (skribe/b/46_Makefile.i 1.1 640)) - (etc/stklos/Makefile.config.in (skribe/b/47_Makefile.c 1.1 644)) - (etc/skribe-config.in (skribe/b/48_skribe-con 1.2 644)) - (etc/bigloo/configure (skribe/b/49_configure 1.6 740)) - (etc/bigloo/autoconf/gmaketest (skribe/b/50_gmaketest 1.1 750)) - (etc/bigloo/autoconf/getbversion (skribe/b/51_getbversio 1.1 750)) - (etc/bigloo/autoconf/bversion (skribe/c/0_bversion 1.1 750)) - (etc/bigloo/autoconf/blibdir (skribe/c/1_blibdir 1.1 750)) - (etc/bigloo/autoconf/bfildir (skribe/c/2_bfildir 1.1 750)) - (etc/bigloo/autoconf/Makefile (skribe/c/3_Makefile 1.1 640)) - (etc/bigloo/Makefile.tpl (skribe/c/4_Makefile.t 1.3 640)) - (etc/bigloo/Makefile (skribe/c/5_Makefile 1.4 640)) - (etc/Makefile (skribe/c/6_Makefile 1.3 640)) - (emacs/skribe.el.in (skribe/c/7_skribe.el. 1.6 640)) - (emacs/Makefile (skribe/c/8_Makefile 1.2 640)) - (doc/user/user.skb (skribe/c/9_user.skb 1.5 640)) - (doc/user/toc.skb (skribe/c/10_toc.skb 1.1 640)) - (doc/user/table.skb (skribe/c/11_table.skb 1.4 640)) - (doc/user/syntax.skb (skribe/c/12_syntax.skb 1.3 640)) - (doc/user/start.skb (skribe/c/13_start.skb 1.3 640)) - (doc/user/src/start5.skb (skribe/c/14_start5.skb 1.1 644)) - (doc/user/src/start4.skb (skribe/c/15_start4.skb 1.1 640)) - (doc/user/src/start3.skb (skribe/c/16_start3.skb 1.1 640)) - (doc/user/src/start2.skb (skribe/c/17_start2.skb 1.1 640)) - (doc/user/src/start1.skb (skribe/c/18_start1.skb 1.1 640)) - (doc/user/src/prgm3.skb (skribe/c/19_prgm3.skb 1.2 640)) - (doc/user/src/prgm2.skb (skribe/c/20_prgm2.skb 1.2 640)) - (doc/user/src/prgm1.skb (skribe/c/21_prgm1.skb 1.1 640)) - (doc/user/src/links2.skb (skribe/c/22_links2.skb 1.1 640)) - (doc/user/src/links1.skb (skribe/c/23_links1.skb 1.1 640)) - (doc/user/src/index3.skb (skribe/c/24_index3.skb 1.1 640)) - (doc/user/src/index2.skb (skribe/c/25_index2.skb 1.1 640)) - (doc/user/src/index1.skb (skribe/c/26_index1.skb 1.1 640)) - (doc/user/src/bib6.skb (skribe/c/27_bib6.skb 1.1 640)) - (doc/user/src/bib5.skb (skribe/c/28_bib5.skb 1.1 640)) - (doc/user/src/bib4.skb (skribe/c/29_bib4.skb 1.1 640)) - (doc/user/src/bib3.skb (skribe/c/30_bib3.skb 1.1 640)) - (doc/user/src/bib2.skb (skribe/c/31_bib2.skb 1.1 640)) - (doc/user/src/bib1.sbib (skribe/c/32_bib1.sbib 1.1 640)) - (doc/user/src/api9.skb (skribe/c/33_api9.skb 1.1 640)) - (doc/user/src/api8.skb (skribe/c/34_api8.skb 1.1 640)) - (doc/user/src/api7.skb (skribe/c/35_api7.skb 1.1 640)) - (doc/user/src/api6.skb (skribe/c/36_api6.skb 1.1 640)) - (doc/user/src/api5.skb (skribe/c/37_api5.skb 1.1 640)) - (doc/user/src/api4.skb (skribe/c/38_api4.skb 1.1 640)) - (doc/user/src/api3.skb (skribe/c/39_api3.skb 1.1 640)) - (doc/user/src/api20.skb (skribe/c/40_api20.skb 1.3 640)) - (doc/user/src/api2.skb (skribe/c/41_api2.skb 1.1 640)) - (doc/user/src/api19.skb (skribe/c/42_api19.skb 1.1 640)) - (doc/user/src/api18.skb (skribe/c/43_api18.skb 1.1 640)) - (doc/user/src/api17.skb (skribe/c/44_api17.skb 1.2 640)) - (doc/user/src/api16.skb (skribe/c/45_api16.skb 1.1 640)) - (doc/user/src/api15.skb (skribe/c/46_api15.skb 1.1 640)) - (doc/user/src/api14.skb (skribe/c/47_api14.skb 1.1 640)) - (doc/user/src/api13.skb (skribe/c/48_api13.skb 1.3 640)) - (doc/user/src/api12.skb (skribe/c/49_api12.skb 1.1 640)) - (doc/user/src/api11.skb (skribe/c/50_api11.skb 1.1 640)) - (doc/user/src/api10.skb (skribe/c/51_api10.skb 1.2 640)) - (doc/user/src/api1.skb (skribe/d/0_api1.skb 1.1 640)) - (doc/user/skribeinfo.skb (skribe/d/1_skribeinfo 1.1 640)) - (doc/user/skribec.skb (skribe/d/2_skribec.sk 1.3 640)) - (doc/user/sectioning.skb (skribe/d/3_sectioning 1.3 640)) - (doc/user/prgm.skb (skribe/d/4_prgm.skb 1.4 640)) - (doc/user/ornament.skb (skribe/d/5_ornament.s 1.1 640)) - (doc/user/markup.skb (skribe/d/6_markup.skb 1.2 640)) - (doc/user/links.skb (skribe/d/7_links.skb 1.5 640)) - (doc/user/line.skb (skribe/d/8_line.skb 1.1 640)) - (doc/user/lib.skb (skribe/d/9_lib.skb 1.3 644)) - (doc/user/latexe.skb (skribe/d/10_latexe.skb 1.4 640)) - (doc/user/justify.skb (skribe/d/11_justify.sk 1.1 640)) - (doc/user/index.skb (skribe/d/12_index.skb 1.4 640)) - (doc/user/image.skb (skribe/d/13_image.skb 1.3 640)) - (doc/user/htmle.skb (skribe/d/14_htmle.skb 1.6 640)) - (doc/user/footnote.skb (skribe/d/15_footnote.s 1.1 640)) - (doc/user/font.skb (skribe/d/16_font.skb 1.1 640)) - (doc/user/figure.skb (skribe/d/17_figure.skb 1.1 640)) - (doc/user/examples.skb (skribe/d/18_examples.s 1.2 640)) - (doc/user/enumeration.skb (skribe/d/19_enumeratio 1.1 640)) - (doc/user/engine.skb (skribe/d/20_engine.skb 1.4 640)) - (doc/user/emacs.skb (skribe/d/21_emacs.skb 1.3 640)) - (doc/user/document.skb (skribe/d/22_document.s 1.2 640)) - (doc/user/colframe.skb (skribe/d/23_colframe.s 1.3 640)) - (doc/user/char.skb (skribe/d/24_char.skb 1.2 640)) - (doc/user/bib.skb (skribe/d/25_bib.skb 1.5 640)) - (doc/img/linux.gif (skribe/d/29_linux.gif 1.2 640) :no-keywords) - (doc/img/lambda.gif (skribe/d/30_lambda.gif 1.1 640) :no-keywords) - (doc/img/bsd.gif (skribe/d/31_bsd.gif 1.1 640) :no-keywords) - (doc/Makefile (skribe/d/32_Makefile 1.6 640)) - (configure (skribe/d/33_configure 1.5 750)) - (README.java (skribe/d/34_README.jav 1.2 640)) - (README (skribe/d/35_README 1.1 640)) - (LICENSE (skribe/d/36_LICENSE 1.2 640)) - (INSTALL (skribe/d/37_INSTALL 1.2 640)) - (Makefile (skribe/d/38_Makefile 1.5 640)) - -;; Files added by populate at Sat, 17 Jan 2004 08:29:33 +0100, -;; to version 1.0b.1(w), by serrano: - - (src/common/sui.scm (skribe/d/39_sui.scm 1.2 640)) - (src/bigloo/sui.bgl (skribe/d/40_sui.bgl 1.1 640)) - (etc/ChangeLog (skribe/d/41_ChangeLog 1.11 640)) - (doc/user/src/slides.skb (skribe/d/42_slides.skb 1.2 640)) - (doc/user/slide.skb (skribe/d/43_slide.skb 1.4 640)) - (doc/user/skribe-config.skb (skribe/d/44_skribe-con 1.2 640)) - (doc/skr/manual.skr (skribe/d/45_manual.skr 1.3 640)) - (doc/skr/extension.skr (skribe/d/46_extension. 1.1 640)) - (doc/skr/env.skr (skribe/d/47_env.skr 1.2 640)) - (doc/skr/api.skr (skribe/d/48_api.skr 1.5 640)) - (doc/dir/dir.skb (skribe/d/49_dir.skb 1.1 640)) - (doc/Makefile.dir (skribe/d/50_Makefile.d 1.2 640)) - -;; Files added by populate at Sun, 18 Jan 2004 12:46:07 +0100, -;; to version 1.0b.4(w), by serrano: - - (src/bigloo/asm.scm (skribe/d/51_asm.scm 1.2 640)) - -;; Files added by populate at Wed, 18 Feb 2004 21:22:35 +0100, -;; to version 1.0b.5(w), by serrano: - - (src/stklos/xml-lex.l (skribe/e/0_xml-lex.l 1.1 644)) - (src/stklos/configure.stk (skribe/e/1_configure. 1.1 644)) - (doc/user/xmle.skb (skribe/e/2_xmle.skb 1.2 640)) - (contribs/tools/skribeinfo/src/Makefile (skribe/e/3_Makefile 1.2 640)) - (contribs/tools/skribeinfo/skr/skribeinfo.skr (skribe/e/4_skribeinfo 1.1 640)) - (contribs/tools/skribeinfo/doc/pckg/skribeinfo.skb (skribe/e/5_skribeinfo 1.1 640)) - (contribs/tools/skribeinfo/configure (skribe/e/6_configure 1.2 750)) - (contribs/tools/skribeinfo/README (skribe/e/7_README 1.2 640)) - (contribs/tools/skribeinfo/Makefile.in (skribe/e/8_Makefile.i 1.3 640)) - (contribs/tools/Makefile (skribe/e/9_Makefile 1.3 640)) - (contribs/ext/bc-table/src/skribebctable.scm (skribe/e/10_skribebcta 1.2 640)) - (contribs/ext/bc-table/src/example.bc (skribe/e/11_example.bc 1.1 640)) - (contribs/ext/bc-table/src/Makefile (skribe/e/12_Makefile 1.2 640)) - (contribs/ext/bc-table/skr/bc-table.skr (skribe/e/13_bc-table.s 1.4 640)) - (contribs/ext/bc-table/example/example.skb (skribe/e/14_example.sk 1.2 640)) - (contribs/ext/bc-table/doc/pckg/bc-table.skb (skribe/e/15_bc-table.s 1.2 640)) - (contribs/ext/bc-table/configure (skribe/e/16_configure 1.2 750)) - (contribs/ext/bc-table/README (skribe/e/17_README 1.1 640)) - (contribs/ext/bc-table/Makefile.in (skribe/e/18_Makefile.i 1.2 640)) - (contribs/ext/Makefile (skribe/e/19_Makefile 1.3 640)) - (contribs/Makefile (skribe/e/20_Makefile 1.1 640)) - -;; Files added by populate at Wed, 18 Feb 2004 21:24:57 +0100, -;; to version 1.0b.6(w), by serrano: - - (contribs/ext/longtable/skr/longtable.skr (skribe/e/21_longtable. 1.1 640)) - (contribs/ext/longtable/example/example.skb (skribe/e/22_example.sk 1.1 640)) - (contribs/ext/longtable/doc/pckg/longtable.skb (skribe/e/23_longtable. 1.1 640)) - (contribs/ext/longtable/configure (skribe/e/24_configure 1.2 750)) - (contribs/ext/longtable/README (skribe/e/25_README 1.1 640)) - (contribs/ext/longtable/Makefile.in (skribe/e/26_Makefile.i 1.3 640)) - -;; Files added by populate at Sat, 21 Feb 2004 10:39:55 +0100, -;; to version 1.0b.8(w), by serrano: - - (doc/user/package.skb (skribe/e/27_package.sk 1.3 640)) - (contribs/tools/skribeinfo/example/example.skb (skribe/e/28_example.sk 1.2 640)) - (contribs/ext/html-navbar/skr/html-navbar.skr (skribe/e/29_html-navba 1.2 640)) - (contribs/ext/html-navbar/example/example.skb (skribe/e/30_example.sk 1.2 640)) - (contribs/ext/html-navbar/doc/pckg/html-navbar.skb (skribe/e/31_html-navba 1.2 640)) - (contribs/ext/html-navbar/configure (skribe/e/32_configure 1.1 750)) - (contribs/ext/html-navbar/README (skribe/e/33_README 1.1 640)) - (contribs/ext/html-navbar/Makefile.in (skribe/e/34_Makefile.i 1.2 640)) - (contribs/ext/html-gui/skr/html-gui.skr (skribe/e/35_html-gui.s 1.3 640)) - (contribs/ext/html-gui/example/example.skb (skribe/e/36_example.sk 1.2 640)) - (contribs/ext/html-gui/doc/pckg/html-gui.skb (skribe/e/37_html-gui.s 1.2 640)) - (contribs/ext/html-gui/configure (skribe/e/38_configure 1.2 755)) - (contribs/ext/html-gui/README (skribe/e/39_README 1.1 640)) - (contribs/ext/html-gui/Makefile.in (skribe/e/40_Makefile.i 1.2 640)) - -;; Files added by populate at Wed, 19 May 2004 14:41:48 +0200, -;; to version 1.0b.9(w), by serrano: - - (src/stklos/lisp-lex.l (skribe/e/41_lisp-lex.l 1.2 644)) - (src/stklos/c.stk (skribe/e/42_c.stk 1.1 644)) - (src/stklos/c-lex.l (skribe/e/43_c-lex.l 1.1 644)) - (skr/web-article.skr (skribe/e/44_web-articl 1.1 640)) - (skr/html4.skr (skribe/e/45_html4.skr 1.1 644)) - (contribs/tools/skribeinfo/CONTRIB.skb (skribe/e/46_CONTRIB.sk 1.1 640)) - (contribs/tools/skribecolsel/src/skribecolsel.scm (skribe/e/47_skribecols 1.1 640)) - (contribs/tools/skribecolsel/src/Makefile (skribe/e/48_Makefile 1.1 640)) - (contribs/tools/skribecolsel/emacs/skribecolsel.el (skribe/e/49_skribecols 1.1 640)) - (contribs/tools/skribecolsel/configure (skribe/e/50_configure 1.1 750)) - (contribs/tools/skribecolsel/README (skribe/e/51_README 1.1 640)) - (contribs/tools/skribecolsel/Makefile.in (skribe/f/0_Makefile.i 1.1 640)) - (contribs/tools/skribecolsel/CONTRIB.skb (skribe/f/1_CONTRIB.sk 1.1 640)) - (contribs/ext/longtable/CONTRIB.skb (skribe/f/2_CONTRIB.sk 1.1 640)) - (contribs/ext/js-tricks/skr/js-tricks.skr (skribe/f/3_js-tricks. 1.1 640)) - (contribs/ext/js-tricks/example/example.skb (skribe/f/4_example.sk 1.2 640)) - (contribs/ext/js-tricks/doc/pckg/js-tricks.skb (skribe/f/5_js-tricks. 1.1 640)) - (contribs/ext/js-tricks/configure (skribe/f/6_configure 1.1 750)) - (contribs/ext/js-tricks/README (skribe/f/7_README 1.1 640)) - (contribs/ext/js-tricks/Makefile.in (skribe/f/8_Makefile.i 1.1 640)) - (contribs/ext/html-navtabs/skr/html-navtabs.skr (skribe/f/9_html-navta 1.1 640)) - (contribs/ext/html-navtabs/example/example.skb (skribe/f/10_example.sk 1.1 640)) - (contribs/ext/html-navtabs/doc/pckg/html-navtabs.skb (skribe/f/11_html-navta 1.1 640)) - (contribs/ext/html-navtabs/configure (skribe/f/12_configure 1.1 750)) - (contribs/ext/html-navtabs/README (skribe/f/13_README 1.1 640)) - (contribs/ext/html-navtabs/Makefile.in (skribe/f/14_Makefile.i 1.1 640)) - (contribs/ext/html-navtabs/CONTRIB.skb (skribe/f/15_CONTRIB.sk 1.1 640)) - (contribs/ext/html-gui/CONTRIB.skb (skribe/f/16_CONTRIB.sk 1.1 640)) - (contribs/ext/fontsample/skr/fontsample.skr (skribe/f/17_fontsample 1.1 640)) - (contribs/ext/fontsample/example/example.skb (skribe/f/18_example.sk 1.1 640)) - (contribs/ext/fontsample/doc/pckg/fontsample.skb (skribe/f/19_fontsample 1.1 640)) - (contribs/ext/fontsample/configure (skribe/f/20_configure 1.1 750)) - (contribs/ext/fontsample/README (skribe/f/21_README 1.1 640)) - (contribs/ext/fontsample/Makefile.in (skribe/f/22_Makefile.i 1.1 640)) - (contribs/ext/fontsample/CONTRIB.skb (skribe/f/23_CONTRIB.sk 1.1 640)) - -;; Files added by populate at Wed, 22 Sep 2004 02:17:27 +0200, -;; to version 1.1b.2(w), by serrano: - - (src/bigloo/parseargs.scm (skribe/f/24_parseargs. 1.2 640)) - -;; Files added by populate at Wed, 22 Sep 2004 14:53:18 +0200, -;; to version 1.1b.5(w), by serrano: - - (skr/latex-simple.skr (skribe/f/25_latex-simp 1.2 640)) - -;; Files added by populate at Fri, 03 Jun 2005 16:47:11 +0200, -;; to version 1.1b.7(w), by serrano: - - (tools/skribebibtex/stklos/main.stk (skribe/f/26_main.stk 1.1 644)) - (tools/skribebibtex/stklos/bibtex-parser.y (skribe/f/27_bibtex-par 1.1 644)) - (tools/skribebibtex/stklos/bibtex-lex.l (skribe/f/28_bibtex-lex 1.1 644)) - (tools/skribebibtex/stklos/Makefile (skribe/f/29_Makefile 1.1 644)) - (tools/skribebibtex/bigloo/skribebibtex.scm (skribe/f/30_skribebibt 1.1 640)) - (tools/skribebibtex/bigloo/main.scm (skribe/f/31_main.scm 1.1 640)) - (tools/skribebibtex/bigloo/Makefile (skribe/f/32_Makefile 1.1 640)) - (skr/sigplan.skr (skribe/f/33_sigplan.sk 1.1 640)) - (skr/context.skr (skribe/f/34_context.sk 1.1 644)) -) -(Merge-Parents) -(New-Merge-Parents) diff --git a/skribe/src/Makefile b/skribe/src/Makefile deleted file mode 100644 index 09e96d5..0000000 --- a/skribe/src/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:15:57 2003 */ -#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The meta Makefile for the sources */ -#*=====================================================================*/ -include ../etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo src/Makefile - @ (cd bigloo && $(MAKE) pop) - @ (cd stklos && $(MAKE) pop) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - (cd $(SYSTEM) && $(MAKE) install) - -uninstall: - (cd $(SYSTEM) && $(MAKE) uninstall) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - (cd $(SYSTEM) && $(MAKE) clean) - diff --git a/skribe/src/bigloo/Makefile b/skribe/src/bigloo/Makefile deleted file mode 100644 index 02d2b6a..0000000 --- a/skribe/src/bigloo/Makefile +++ /dev/null @@ -1,271 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/bigloo/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Mon Jul 21 18:21:11 2003 */ -#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Bigloo API */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* General inclusion */ -#*---------------------------------------------------------------------*/ -include ../../etc/bigloo/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compilers and tools */ -#*---------------------------------------------------------------------*/ -BSKBFLAGS = -I $(SRCDIR)/bigloo - -#*---------------------------------------------------------------------*/ -#* Targets ... */ -#*---------------------------------------------------------------------*/ -PROJECT = skribe -CTARGET = $(SKRIBEBINDIR)/skribe.bigloo -JVMTARGET = $(SKRIBEBINDIR)/skribe.zip - -PBASE = bigloo.$(PROJECT) -ODIR = o -CLASSDIR = class_s/bigloo/$(PROJECT) -OBJDIR = obj/bigloo/$(PROJECT) - -#*---------------------------------------------------------------------*/ -#* Objects */ -#*---------------------------------------------------------------------*/ -SRCDIR = .. -SKRIBECOMMON = param api bib index lib sui -SKRIBEBGL = types parseargs main eval evapi \ - output resolve verify debug read prog source \ - lisp xml c asm engine writer color -SKRIBEINCLUDE = api new debug - -MODULES = $(SKRIBEBGL:%=%.scm) \ - $(SKRIBECOMMON:%=%.bgl) \ - configure.bgl -INCLUDES = $(SKRIBEINCLUDE:%=%.sch) -SOURCES = $(MODULES) \ - $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ - $(SRCDIR)/common/configure.scm \ - $(INCLUDES) -OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure -COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) -JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) - -#*---------------------------------------------------------------------*/ -#* Population */ -#*---------------------------------------------------------------------*/ -POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile -POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .scm .bgl .class .o .obj - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -.PHONY: c jvm dotnet - -all: $(TARGET) - -c: $(CTARGET) -jvm: $(JVMTARGET) -dotnet: - echo "Not implemented yet" - -#*--- c ---------------------------------------------------------------*/ -$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) - $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) - -#*--- jvm -------------------------------------------------------------*/ -$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) - $(RM) -f $(JVMTARGET) - (cd $(ODIR)/class_s && \ - $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) - -$(SKRIBEBINDIR): - mkdir -p $(SKRIBEBINDIR) - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATIONSCM:%=src/common/%) - @ echo $(POPULATIONBGL:%=src/bigloo/%) - -#*---------------------------------------------------------------------*/ -#* ude */ -#*---------------------------------------------------------------------*/ -.PHONY: ude .etags .afile - -ude: - @ $(MAKE) -f Makefile .afile .etags dep - -.afile: - @ $(AFILE) -o .afile $(MODULES) - -.jfile: - @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) - -.etags: - @ $(BTAGS) -o .etags $(SOURCES) - -dep: - @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ - head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) - @ $(BDEPEND) -search-path ../common \ - -search-path ../bigloo \ - -strict-obj-dir $(ODIR) \ - -strict-class-dir $(CLASSDIR) \ - -fno-mco $(SOURCES) >> /tmp/Makefile.aux - @ mv /tmp/Makefile.aux Makefile - -getbinary: - @ echo $(PROJECT) - -getsources: - @ echo $(SOURCES) - -#*---------------------------------------------------------------------*/ -#* The implicit rules */ -#*---------------------------------------------------------------------*/ -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ - $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(OBJDIR)/%.obj: src/%.scm - $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ - -#*---------------------------------------------------------------------*/ -#* Ad hoc rules */ -#*---------------------------------------------------------------------*/ -$(ODIR): - mkdir -p $(ODIR) - -$(CLASSDIR): - mkdir -p $(CLASSDIR) - -$(OBJDIR): - mkdir -p $(OBJDIR) - - -#*---------------------------------------------------------------------*/ -#* install/uninstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm - -install: - $(MAKE) install-$(TARGET) - -uninstall: - $(MAKE) uninstall-$(TARGET) - -install-c: $(DESTDIR)$(INSTALL_BINDIR) - cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe - -uninstall-c: - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - -install-jvm: $(DESTDIR)$(INSTALL_FILDIR) - cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) - -uninstall-jvm: - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip - -$(DESTDIR)$(INSTALL_BINDIR): - mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) - -$(DESTDIR)$(INSTALL_FILDIR): - mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -clean: - $(RM) -f .afile - $(RM) -f .jfile - $(RM) -rf $(ODIR) - $(RM) -f $(CTARGET) - $(RM) -f $(JVMTARGET) - -#*---------------------------------------------------------------------*/ -#* Cleanall */ -#*---------------------------------------------------------------------*/ -cleanall: clean - -#*---------------------------------------------------------------------*/ -#* Manual dependency */ -#*---------------------------------------------------------------------*/ -o/eval.o o/class/bigloo/skribe/eval.class: \ - $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm - -#bdepend start (don't edit) -#*---------------------------------------------------------------------*/ -#* Dependencies ... */ -#*---------------------------------------------------------------------*/ -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch - -#bdepend stop diff --git a/skribe/src/bigloo/api.bgl b/skribe/src/bigloo/api.bgl deleted file mode 100644 index 55493b0..0000000 --- a/skribe/src/bigloo/api.bgl +++ /dev/null @@ -1,117 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:21:34 2003 */ -;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo header for the API. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../common/api.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_api - - (include "new.sch" - "api.sch") - - (import skribe_param - skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_bib - skribe_index - skribe_prog - skribe_source - skribe_engine - skribe_color - skribe_sui) - - (export (include string) - - (document::%markup . opts) - (author::%markup . opts) - (toc::%markup . opts) - - (chapter::%markup . opts) - (section::%markup . opts) - (subsection::%markup . opts) - (subsubsection::%markup . opts) - (paragraph::%markup . opts) - - (footnote::%markup . opts) - - (linebreak . opts) - (hrule::%markup . opts) - - (color::%markup . opts) - (frame::%markup . opts) - (font::%markup . opts) - - (flush::%markup . opts) - (center::%markup . opts) - (pre::%markup . opts) - (prog::%markup . opts) - (source::obj . opts) - (language::obj . opts) - - (itemize::%markup . opts) - (enumerate::%markup . opts) - (description::%markup . opts) - (item::%markup . opts) - - (figure::%markup . opts) - - (table::%markup . opts) - (tr::%markup . opts) - (td::%markup . opts) - (th::%markup . opts) - - (image::%markup . opts) - - (blockquote::%markup . opts) - - (roman::%markup . opts) - (bold::%markup . opts) - (underline::%markup . opts) - (strike::%markup . opts) - (emph::%markup . opts) - (kbd::%markup . opts) - (it::%markup . opts) - (tt::%markup . opts) - (code::%markup . opts) - (var::%markup . opts) - (samp::%markup . opts) - (sf::%markup . opts) - (sc::%markup . opts) - (sub::%markup . opts) - (sup::%markup . opts) - - (mailto::%markup . opts) - (mark::%markup . opts) - - (handle . obj) - (ref::%ast . obj) - (resolve::%ast ::procedure) - - (bibliography . files) - (the-bibliography . opts) - - (make-index ::bstring) - (index . args) - (the-index . args) - - (char::bstring char) - (symbol::%markup symbol) - (!::%command string . args) - - (processor::%processor . opts) - - (html-processor::%processor . opts) - (tex-processor::%processor . opts))) diff --git a/skribe/src/bigloo/api.sch b/skribe/src/bigloo/api.sch deleted file mode 100644 index 390b8fa..0000000 --- a/skribe/src/bigloo/api.sch +++ /dev/null @@ -1,91 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:15:25 2003 */ -;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo macros for the API implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* define-pervasive-macro ... */ -;*---------------------------------------------------------------------*/ -(define-macro (define-pervasive-macro proto . body) - `(begin - (eval '(define-macro ,proto ,@body)) - (define-macro ,proto ,@body))) - -;*---------------------------------------------------------------------*/ -;* define-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-markup proto . body) - (define (s2k symbol) - (string->keyword (string-append ":" (symbol->string symbol)))) - (if (not (pair? proto)) - (error 'define-markup "Illegal markup definition" proto) - (let* ((id (car proto)) - (args (cdr proto)) - (dargs (dsssl-formals->scheme-formals args error))) - `(begin - ,(if (and (memq #!key args) - (memq '&skribe-eval-location args)) - `(define-expander ,id - (lambda (x e) - (append - (cons ',id (map (lambda (x) (e x e)) (cdr x))) - (list :&skribe-eval-location - '(skribe-eval-location))))) - #unspecified) - (define ,(cons id dargs) - ,(make-dsssl-function-prelude proto - args `(begin ,@body) - error s2k)))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-markup markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new markup - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-container ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-container markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new container - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-processor-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-processor-markup proc) - `(define-markup (,proc #!rest opts) - (new processor - (engine (find-engine ',proc)) - (body (the-body opts)) - (options (the-options opts))))) - -;*---------------------------------------------------------------------*/ -;* new (at runtime) */ -;*---------------------------------------------------------------------*/ -(eval '(define-macro (new id . inits) - (cons (symbol-append 'new- id) - (map (lambda (i) - (list 'list (list 'quote (car i)) (cadr i))) - inits)))) diff --git a/skribe/src/bigloo/asm.scm b/skribe/src/bigloo/asm.scm deleted file mode 100644 index 03196ac..0000000 --- a/skribe/src/bigloo/asm.scm +++ /dev/null @@ -1,99 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* ASM fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_asm - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export asm)) - -;*---------------------------------------------------------------------*/ -;* asm ... */ -;*---------------------------------------------------------------------*/ -(define asm - (new language - (name "asm") - (fontifier asm-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* asm-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (asm-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "#" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((: (* (in #\tab #\space)) - (+ (out #\: #\Space #\Tab #\Newline)) #\:) - ;; labels - (let ((c (new markup - (markup '&source-define) - (body (the-string))))) - (cons c (ignore)))) - ((or (in "<>=!/\\+*-([])") - #\/ - (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(asm)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/skribe/src/bigloo/bib.bgl b/skribe/src/bigloo/bib.bgl deleted file mode 100644 index 6b0f7dd..0000000 --- a/skribe/src/bigloo/bib.bgl +++ /dev/null @@ -1,161 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../common/bib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_bib - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_read) - - (export (bib-table?::bool ::obj) - (make-bib-table ::bstring) - (default-bib-table) - (bib-load! ::obj ::bstring ::obj) - (bib-add! ::obj . entries) - (resolve-bib ::obj ::obj) - (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) - (bib-sort/authors::pair-nil ::pair-nil) - (bib-sort/idents::pair-nil ::pair-nil) - (bib-sort/dates::pair-nil ::pair-nil))) - -;*---------------------------------------------------------------------*/ -;* bib-table? ... */ -;*---------------------------------------------------------------------*/ -(define (bib-table? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *bib-table* ... */ -;*---------------------------------------------------------------------*/ -(define *bib-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (default-bib-table) - (if (not *bib-table*) - (set! *bib-table* (make-bib-table "default-bib-table"))) - *bib-table*) - -;*---------------------------------------------------------------------*/ -;* bib-parse-error ... */ -;*---------------------------------------------------------------------*/ -(define (bib-parse-error entry) - (if (epair? entry) - (match-case (cer entry) - ((at ?fname ?pos ?-) - (error/location "parse-biblio" - "bibliography syntax error" - entry - fname - pos)) - (else - (error 'bib-parse "bibliography syntax error" entry))) - (error 'bib-parse "bibliography syntax error" entry))) - -;*---------------------------------------------------------------------*/ -;* bib-duplicate ... */ -;*---------------------------------------------------------------------*/ -(define (bib-duplicate ident from old) - (let ((ofrom (markup-option old 'from))) - (skribe-warning 2 - 'bib - (format "Duplicated bibliographic entry ~a'.\n" ident) - (if ofrom - (format " Using version of `~a'.\n" ofrom) - "") - (if from - (format " Ignoring version of `~a'." from) - " Ignoring redefinition.")))) - -;*---------------------------------------------------------------------*/ -;* parse-bib ... */ -;*---------------------------------------------------------------------*/ -(define (parse-bib table port) - (if (not (bib-table? table)) - (skribe-error 'parse-bib "Illegal bibliography table" table) - (let ((from (input-port-name port))) - (let loop ((entry (skribe-read port))) - (if (not (eof-object? entry)) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (else - (bib-parse-error entry)))))))) - -;*---------------------------------------------------------------------*/ -;* bib-add! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-add! table . entries) - (if (not (bib-table? table)) - (skribe-error 'bib-add! "Illegal bibliography table" table) - (for-each (lambda (entry) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (else - (bib-parse-error entry)))) - entries))) - - - diff --git a/skribe/src/bigloo/c.scm b/skribe/src/bigloo/c.scm deleted file mode 100644 index 07290ce..0000000 --- a/skribe/src/bigloo/c.scm +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/c.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Thu May 27 10:11:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* C fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_c - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export C)) - -;*---------------------------------------------------------------------*/ -;* C stamps */ -;*---------------------------------------------------------------------*/ -(define *keyword* (gensym)) -(define *cpp* (gensym)) - -;*---------------------------------------------------------------------*/ -;* C keywords */ -;*---------------------------------------------------------------------*/ -(for-each (lambda (symbol) - (putprop! symbol *keyword* #t)) - '(for class template while return try catch break continue - do if else typedef struct union goto switch case - static extern default finally throw)) -(let ((sharp (string->symbol "#"))) - (for-each (lambda (symbol) - (putprop! (symbol-append sharp symbol) *cpp* #t)) - '(include define if ifdef ifdef else endif))) - -;*---------------------------------------------------------------------*/ -;* C ... */ -;*---------------------------------------------------------------------*/ -(define C - (new language - (name "C") - (fontifier c-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* c-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (c-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-line-comment) - (body s)))) - str) - (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((in "{}") - ;; brackets - (let ((str (the-string))) - (let ((c (new markup - (markup '&source-bracket) - (body (the-string))))) - (cons c (ignore))))) - ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) - ;; keywords - (let* ((string (the-string)) - (symbol (the-symbol))) - (cond - ((getprop symbol *keyword*) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((getprop symbol *cpp*) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons string (ignore)))))) - ((in "<>=!/\\+*-([])") - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(C)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/skribe/src/bigloo/color.scm b/skribe/src/bigloo/color.scm deleted file mode 100644 index e40638b..0000000 --- a/skribe/src/bigloo/color.scm +++ /dev/null @@ -1,702 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/color.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Apr 10 13:46:50 2002 */ -;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Tex color manager */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_color - (import skribe_configure) - (export (skribe-color->rgb ::obj) - (skribe-get-used-colors) - (skribe-use-color! color))) - -;*---------------------------------------------------------------------*/ -;* *skribe-rgb-string* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-rgb-string* - "255 250 250 snow -248 248 255 ghostwhite -245 245 245 whitesmoke -220 220 220 gainsboro -255 250 240 floralwhite -253 245 230 oldlace -250 240 230 linen -250 235 215 antiquewhite -255 239 213 papayawhip -255 235 205 blanchedalmond -255 228 196 bisque -255 218 185 peachpuff -255 222 173 navajowhite -255 228 181 moccasin -255 248 220 cornsilk -255 255 240 ivory -255 250 205 lemonchiffon -255 245 238 seashell -240 255 240 honeydew -245 255 250 mintcream -240 255 255 azure -240 248 255 aliceblue -230 230 250 lavender -255 240 245 lavenderblush -255 228 225 mistyrose -255 255 255 white -0 0 0 black -47 79 79 darkslategrey -105 105 105 dimgrey -112 128 144 slategrey -119 136 153 lightslategrey -190 190 190 grey -211 211 211 lightgrey -25 25 112 midnightblue -0 0 128 navy -0 0 128 navyblue -100 149 237 cornflowerblue -72 61 139 darkslateblue -106 90 205 slateblue -123 104 238 mediumslateblue -132 112 255 lightslateblue -0 0 205 mediumblue -65 105 225 royalblue -0 0 255 blue -30 144 255 dodgerblue -0 191 255 deepskyblue -135 206 235 skyblue -135 206 250 lightskyblue -70 130 180 steelblue -176 196 222 lightsteelblue -173 216 230 lightblue -176 224 230 powderblue -175 238 238 paleturquoise -0 206 209 darkturquoise -72 209 204 mediumturquoise -64 224 208 turquoise -0 255 255 cyan -224 255 255 lightcyan -95 158 160 cadetblue -102 205 170 mediumaquamarine -127 255 212 aquamarine -0 100 0 darkgreen -85 107 47 darkolivegreen -143 188 143 darkseagreen -46 139 87 seagreen -60 179 113 mediumseagreen -32 178 170 lightseagreen -152 251 152 palegreen -0 255 127 springgreen -124 252 0 lawngreen -0 255 0 green -127 255 0 chartreuse -0 250 154 mediumspringgreen -173 255 47 greenyellow -50 205 50 limegreen -154 205 50 yellowgreen -34 139 34 forestgreen -107 142 35 olivedrab -189 183 107 darkkhaki -240 230 140 khaki -238 232 170 palegoldenrod -250 250 210 lightgoldenrodyellow -255 255 224 lightyellow -255 255 0 yellow -255 215 0 gold -238 221 130 lightgoldenrod -218 165 32 goldenrod -184 134 11 darkgoldenrod -188 143 143 rosybrown -205 92 92 indianred -139 69 19 saddlebrown -160 82 45 sienna -205 133 63 peru -222 184 135 burlywood -245 245 220 beige -245 222 179 wheat -244 164 96 sandybrown -210 180 140 tan -210 105 30 chocolate -178 34 34 firebrick -165 42 42 brown -233 150 122 darksalmon -250 128 114 salmon -255 160 122 lightsalmon -255 165 0 orange -255 140 0 darkorange -255 127 80 coral -240 128 128 lightcoral -255 99 71 tomato -255 69 0 orangered -255 0 0 red -255 105 180 hotpink -255 20 147 deeppink -255 192 203 pink -255 182 193 lightpink -219 112 147 palevioletred -176 48 96 maroon -199 21 133 mediumvioletred -208 32 144 violetred -255 0 255 magenta -238 130 238 violet -221 160 221 plum -218 112 214 orchid -186 85 211 mediumorchid -153 50 204 darkorchid -148 0 211 darkviolet -138 43 226 blueviolet -160 32 240 purple -147 112 219 mediumpurple -216 191 216 thistle -255 250 250 snow1 -238 233 233 snow2 -205 201 201 snow3 -139 137 137 snow4 -255 245 238 seashell1 -238 229 222 seashell2 -205 197 191 seashell3 -139 134 130 seashell4 -255 239 219 antiquewhite1 -238 223 204 antiquewhite2 -205 192 176 antiquewhite3 -139 131 120 antiquewhite4 -255 228 196 bisque1 -238 213 183 bisque2 -205 183 158 bisque3 -139 125 107 bisque4 -255 218 185 peachpuff1 -238 203 173 peachpuff2 -205 175 149 peachpuff3 -139 119 101 peachpuff4 -255 222 173 navajowhite1 -238 207 161 navajowhite2 -205 179 139 navajowhite3 -139 121 94 navajowhite4 -255 250 205 lemonchiffon1 -238 233 191 lemonchiffon2 -205 201 165 lemonchiffon3 -139 137 112 lemonchiffon4 -255 248 220 cornsilk1 -238 232 205 cornsilk2 -205 200 177 cornsilk3 -139 136 120 cornsilk4 -255 255 240 ivory1 -238 238 224 ivory2 -205 205 193 ivory3 -139 139 131 ivory4 -240 255 240 honeydew1 -224 238 224 honeydew2 -193 205 193 honeydew3 -131 139 131 honeydew4 -255 240 245 lavenderblush1 -238 224 229 lavenderblush2 -205 193 197 lavenderblush3 -139 131 134 lavenderblush4 -255 228 225 mistyrose1 -238 213 210 mistyrose2 -205 183 181 mistyrose3 -139 125 123 mistyrose4 -240 255 255 azure1 -224 238 238 azure2 -193 205 205 azure3 -131 139 139 azure4 -131 111 255 slateblue1 -122 103 238 slateblue2 -105 89 205 slateblue3 -71 60 139 slateblue4 -72 118 255 royalblue1 -67 110 238 royalblue2 -58 95 205 royalblue3 -39 64 139 royalblue4 -0 0 255 blue1 -0 0 238 blue2 -0 0 205 blue3 -0 0 139 blue4 -30 144 255 dodgerblue1 -28 134 238 dodgerblue2 -24 116 205 dodgerblue3 -16 78 139 dodgerblue4 -99 184 255 steelblue1 -92 172 238 steelblue2 -79 148 205 steelblue3 -54 100 139 steelblue4 -0 191 255 deepskyblue1 -0 178 238 deepskyblue2 -0 154 205 deepskyblue3 -0 104 139 deepskyblue4 -135 206 255 skyblue1 -126 192 238 skyblue2 -108 166 205 skyblue3 -74 112 139 skyblue4 -176 226 255 lightskyblue1 -164 211 238 lightskyblue2 -141 182 205 lightskyblue3 -96 123 139 lightskyblue4 -202 225 255 lightsteelblue1 -188 210 238 lightsteelblue2 -162 181 205 lightsteelblue3 -110 123 139 lightsteelblue4 -191 239 255 lightblue1 -178 223 238 lightblue2 -154 192 205 lightblue3 -104 131 139 lightblue4 -224 255 255 lightcyan1 -209 238 238 lightcyan2 -180 205 205 lightcyan3 -122 139 139 lightcyan4 -187 255 255 paleturquoise1 -174 238 238 paleturquoise2 -150 205 205 paleturquoise3 -102 139 139 paleturquoise4 -152 245 255 cadetblue1 -142 229 238 cadetblue2 -122 197 205 cadetblue3 -83 134 139 cadetblue4 -0 245 255 turquoise1 -0 229 238 turquoise2 -0 197 205 turquoise3 -0 134 139 turquoise4 -0 255 255 cyan1 -0 238 238 cyan2 -0 205 205 cyan3 -0 139 139 cyan4 -127 255 212 aquamarine1 -118 238 198 aquamarine2 -102 205 170 aquamarine3 -69 139 116 aquamarine4 -193 255 193 darkseagreen1 -180 238 180 darkseagreen2 -155 205 155 darkseagreen3 -105 139 105 darkseagreen4 -84 255 159 seagreen1 -78 238 148 seagreen2 -67 205 128 seagreen3 -46 139 87 seagreen4 -154 255 154 palegreen1 -144 238 144 palegreen2 -124 205 124 palegreen3 -84 139 84 palegreen4 -0 255 127 springgreen1 -0 238 118 springgreen2 -0 205 102 springgreen3 -0 139 69 springgreen4 -0 255 0 green1 -0 238 0 green2 -0 205 0 green3 -0 139 0 green4 -127 255 0 chartreuse1 -118 238 0 chartreuse2 -102 205 0 chartreuse3 -69 139 0 chartreuse4 -192 255 62 olivedrab1 -179 238 58 olivedrab2 -154 205 50 olivedrab3 -105 139 34 olivedrab4 -202 255 112 darkolivegreen1 -188 238 104 darkolivegreen2 -162 205 90 darkolivegreen3 -110 139 61 darkolivegreen4 -255 246 143 khaki1 -238 230 133 khaki2 -205 198 115 khaki3 -139 134 78 khaki4 -255 236 139 lightgoldenrod1 -238 220 130 lightgoldenrod2 -205 190 112 lightgoldenrod3 -139 129 76 lightgoldenrod4 -255 255 224 lightyellow1 -238 238 209 lightyellow2 -205 205 180 lightyellow3 -139 139 122 lightyellow4 -255 255 0 yellow1 -238 238 0 yellow2 -205 205 0 yellow3 -139 139 0 yellow4 -255 215 0 gold1 -238 201 0 gold2 -205 173 0 gold3 -139 117 0 gold4 -255 193 37 goldenrod1 -238 180 34 goldenrod2 -205 155 29 goldenrod3 -139 105 20 goldenrod4 -255 185 15 darkgoldenrod1 -238 173 14 darkgoldenrod2 -205 149 12 darkgoldenrod3 -139 101 8 darkgoldenrod4 -255 193 193 rosybrown1 -238 180 180 rosybrown2 -205 155 155 rosybrown3 -139 105 105 rosybrown4 -255 106 106 indianred1 -238 99 99 indianred2 -205 85 85 indianred3 -139 58 58 indianred4 -255 130 71 sienna1 -238 121 66 sienna2 -205 104 57 sienna3 -139 71 38 sienna4 -255 211 155 burlywood1 -238 197 145 burlywood2 -205 170 125 burlywood3 -139 115 85 burlywood4 -255 231 186 wheat1 -238 216 174 wheat2 -205 186 150 wheat3 -139 126 102 wheat4 -255 165 79 tan1 -238 154 73 tan2 -205 133 63 tan3 -139 90 43 tan4 -255 127 36 chocolate1 -238 118 33 chocolate2 -205 102 29 chocolate3 -139 69 19 chocolate4 -255 48 48 firebrick1 -238 44 44 firebrick2 -205 38 38 firebrick3 -139 26 26 firebrick4 -255 64 64 brown1 -238 59 59 brown2 -205 51 51 brown3 -139 35 35 brown4 -255 140 105 salmon1 -238 130 98 salmon2 -205 112 84 salmon3 -139 76 57 salmon4 -255 160 122 lightsalmon1 -238 149 114 lightsalmon2 -205 129 98 lightsalmon3 -139 87 66 lightsalmon4 -255 165 0 orange1 -238 154 0 orange2 -205 133 0 orange3 -139 90 0 orange4 -255 127 0 darkorange1 -238 118 0 darkorange2 -205 102 0 darkorange3 -139 69 0 darkorange4 -255 114 86 coral1 -238 106 80 coral2 -205 91 69 coral3 -139 62 47 coral4 -255 99 71 tomato1 -238 92 66 tomato2 -205 79 57 tomato3 -139 54 38 tomato4 -255 69 0 orangered1 -238 64 0 orangered2 -205 55 0 orangered3 -139 37 0 orangered4 -255 0 0 red1 -238 0 0 red2 -205 0 0 red3 -139 0 0 red4 -255 20 147 deeppink1 -238 18 137 deeppink2 -205 16 118 deeppink3 -139 10 80 deeppink4 -255 110 180 hotpink1 -238 106 167 hotpink2 -205 96 144 hotpink3 -139 58 98 hotpink4 -255 181 197 pink1 -238 169 184 pink2 -205 145 158 pink3 -139 99 108 pink4 -255 174 185 lightpink1 -238 162 173 lightpink2 -205 140 149 lightpink3 -139 95 101 lightpink4 -255 130 171 palevioletred1 -238 121 159 palevioletred2 -205 104 137 palevioletred3 -139 71 93 palevioletred4 -255 52 179 maroon1 -238 48 167 maroon2 -205 41 144 maroon3 -139 28 98 maroon4 -255 62 150 violetred1 -238 58 140 violetred2 -205 50 120 violetred3 -139 34 82 violetred4 -255 0 255 magenta1 -238 0 238 magenta2 -205 0 205 magenta3 -139 0 139 magenta4 -255 131 250 orchid1 -238 122 233 orchid2 -205 105 201 orchid3 -139 71 137 orchid4 -255 187 255 plum1 -238 174 238 plum2 -205 150 205 plum3 -139 102 139 plum4 -224 102 255 mediumorchid1 -209 95 238 mediumorchid2 -180 82 205 mediumorchid3 -122 55 139 mediumorchid4 -191 62 255 darkorchid1 -178 58 238 darkorchid2 -154 50 205 darkorchid3 -104 34 139 darkorchid4 -155 48 255 purple1 -145 44 238 purple2 -125 38 205 purple3 -85 26 139 purple4 -171 130 255 mediumpurple1 -159 121 238 mediumpurple2 -137 104 205 mediumpurple3 -93 71 139 mediumpurple4 -255 225 255 thistle1 -238 210 238 thistle2 -205 181 205 thistle3 -139 123 139 thistle4 -0 0 0 grey0 -3 3 3 grey1 -5 5 5 grey2 -8 8 8 grey3 -10 10 10 grey4 -13 13 13 grey5 -15 15 15 grey6 -18 18 18 grey7 -20 20 20 grey8 -23 23 23 grey9 -26 26 26 grey10 -28 28 28 grey11 -31 31 31 grey12 -33 33 33 grey13 -36 36 36 grey14 -38 38 38 grey15 -41 41 41 grey16 -43 43 43 grey17 -46 46 46 grey18 -48 48 48 grey19 -51 51 51 grey20 -54 54 54 grey21 -56 56 56 grey22 -59 59 59 grey23 -61 61 61 grey24 -64 64 64 grey25 -66 66 66 grey26 -69 69 69 grey27 -71 71 71 grey28 -74 74 74 grey29 -77 77 77 grey30 -79 79 79 grey31 -82 82 82 grey32 -84 84 84 grey33 -87 87 87 grey34 -89 89 89 grey35 -92 92 92 grey36 -94 94 94 grey37 -97 97 97 grey38 -99 99 99 grey39 -102 102 102 grey40 -105 105 105 grey41 -107 107 107 grey42 -110 110 110 grey43 -112 112 112 grey44 -115 115 115 grey45 -117 117 117 grey46 -120 120 120 grey47 -122 122 122 grey48 -125 125 125 grey49 -127 127 127 grey50 -130 130 130 grey51 -133 133 133 grey52 -135 135 135 grey53 -138 138 138 grey54 -140 140 140 grey55 -143 143 143 grey56 -145 145 145 grey57 -148 148 148 grey58 -150 150 150 grey59 -153 153 153 grey60 -156 156 156 grey61 -158 158 158 grey62 -161 161 161 grey63 -163 163 163 grey64 -166 166 166 grey65 -168 168 168 grey66 -171 171 171 grey67 -173 173 173 grey68 -176 176 176 grey69 -179 179 179 grey70 -181 181 181 grey71 -184 184 184 grey72 -186 186 186 grey73 -189 189 189 grey74 -191 191 191 grey75 -194 194 194 grey76 -196 196 196 grey77 -199 199 199 grey78 -201 201 201 grey79 -204 204 204 grey80 -207 207 207 grey81 -209 209 209 grey82 -212 212 212 grey83 -214 214 214 grey84 -217 217 217 grey85 -219 219 219 grey86 -222 222 222 grey87 -224 224 224 grey88 -227 227 227 grey89 -229 229 229 grey90 -232 232 232 grey91 -235 235 235 grey92 -237 237 237 grey93 -240 240 240 grey94 -242 242 242 grey95 -245 245 245 grey96 -247 247 247 grey97 -250 250 250 grey98 -252 252 252 grey99 -255 255 255 grey100 -169 169 169 darkgrey -0 0 139 darkblue -0 139 139 darkcyan -139 0 139 darkmagenta -139 0 0 darkred -144 238 144 lightgreen") - -;*---------------------------------------------------------------------*/ -;* *rgb-port* ... */ -;*---------------------------------------------------------------------*/ -(define *rgb-port* #unspecified) - -;*---------------------------------------------------------------------*/ -;* same-color? ... */ -;*---------------------------------------------------------------------*/ -(define (same-color? s1 s2) - (define (skip-rgb s) - (let ((l (string-length s))) - (let loop ((i 0)) - (if (=fx i l) - l - (let ((c (string-ref s i))) - (if (or (char-numeric? c) (char-whitespace? c)) - (loop (+fx i 1)) - i)))))) - (let ((l1 (string-length s1)) - (l2 (string-length s2))) - (if (>fx l1 l2) - (let ((lc (skip-rgb s1))) - (and (=fx (-fx l1 lc) l2) - (let loop ((i1 (-fx l1 l2)) - (i2 0)) - (cond - ((=fx i1 l1) - #t) - ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) - (loop (+fx i1 1) (+fx i2 1))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* rgb-grep ... */ -;*---------------------------------------------------------------------*/ -(define (rgb-grep symbol) - (let ((parser (regular-grammar () - ((bol (: #\! (* all))) - (ignore)) - ((+ #\Newline) - (ignore)) - ((: (* (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ all)) - (let ((s (the-string))) - (if (same-color? s symbol) - (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) - (values (string->number (cadr m)) - (string->number (caddr m)) - (string->number (cadddr m)))) - (ignore)))) - (else - (values 0 0 0))))) - ;; initialization the port reading rgb.txt file - (with-input-from-string *skribe-rgb-string* - (lambda () - (read/rp parser (current-input-port)))))) - -;*---------------------------------------------------------------------*/ -;* *color-parser* ... */ -;*---------------------------------------------------------------------*/ -(define *color-parser* - (regular-grammar ((blank* (* blank)) - (blank+ (+ blank))) - - ;; rgb color - ((: #\# (+ xdigit)) - (let ((val (the-substring 1 (the-length)))) - (cond - ((=fx (string-length val) 6) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 2 4) 16) - (string->integer (substring val 4 6) 16))) - ((=fx (string-length val) 12) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 4 6) 16) - (string->integer (substring val 8 10) 16))) - (else - (values 0 0 0))))) - - ;; symbolic names - ((+ (out #\Newline)) - (let ((name (the-string))) - (cond - ((string-ci=? name "none") - (values 0 0 0)) - ((string-ci=? name "black") - (values #xff #xff #xff)) - ((string-ci=? name "white") - (values 0 0 0)) - (else - (rgb-grep name))))) - - ;; error - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->rgb spec) - (cond - ((string? spec) - (with-input-from-string spec - (lambda () - (read/rp *color-parser* (current-input-port))))) - ((fixnum? spec) - (values (bit-and #xff (bit-rsh spec 16)) - (bit-and #xff (bit-rsh spec 8)) - (bit-and #xff spec))) - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* *used-colors* ... */ -;*---------------------------------------------------------------------*/ -(define *used-colors* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-get-used-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-used-colors) - *used-colors*) - -;*---------------------------------------------------------------------*/ -;* skribe-use-color! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-use-color! color) - (set! *used-colors* (cons color *used-colors*)) - color) diff --git a/skribe/src/bigloo/configure.bgl b/skribe/src/bigloo/configure.bgl deleted file mode 100644 index e100d8d..0000000 --- a/skribe/src/bigloo/configure.bgl +++ /dev/null @@ -1,90 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:42:21 2003 */ -;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The general configuration options. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_configure - (export (skribe-release) - (skribe-url) - (skribe-doc-dir) - (skribe-ext-dir) - (skribe-default-path) - (skribe-scheme) - - (skribe-configure . opt) - (skribe-enforce-configure . opt))) - -;*---------------------------------------------------------------------*/ -;* skribe-configuration ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configuration) - `((:release ,(skribe-release)) - (:scheme ,(skribe-scheme)) - (:url ,(skribe-url)) - (:doc-dir ,(skribe-doc-dir)) - (:ext-dir ,(skribe-ext-dir)) - (:default-path ,(skribe-default-path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configure . opt) - (let ((conf (skribe-configuration))) - (cond - ((null? opt) - conf) - ((null? (cdr opt)) - (let ((cell (assq (car opt) conf))) - (if (pair? cell) - (cadr cell) - 'void))) - (else - (let loop ((opt opt)) - (cond - ((null? opt) - #t) - ((not (keyword? (car opt))) - #f) - ((or (null? (cdr opt)) (keyword? (cadr opt))) - #f) - (else - (let ((cell (assq (car opt) conf))) - (if (and (pair? cell) - (if (procedure? (cadr opt)) - ((cadr opt) (cadr cell)) - (equal? (cadr opt) (cadr cell)))) - (loop (cddr opt)) - #f))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-enforce-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-enforce-configure . opt) - (let loop ((o opt)) - (when (pair? o) - (cond - ((or (not (keyword? (car o))) - (null? (cdr o))) - (error 'skribe-enforce-configure - "Illegal enforcement" - opt)) - ((skribe-configure (car o) (cadr o)) - (loop (cddr o))) - (else - (error 'skribe-enforce-configure - (format "Configuration mismatch: ~a" (car o)) - (if (procedure? (cadr o)) - (format "provided `~a'" - (skribe-configure (car o))) - (format "provided `~a', required `~a'" - (skribe-configure (car o)) - (cadr o))))))))) diff --git a/skribe/src/bigloo/debug.sch b/skribe/src/bigloo/debug.sch deleted file mode 100644 index 9b53c84..0000000 --- a/skribe/src/bigloo/debug.sch +++ /dev/null @@ -1,54 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu May 29 06:46:33 2003 */ -;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* directives */ -;*---------------------------------------------------------------------*/ -(directives - (import skribe_debug)) - -;*---------------------------------------------------------------------*/ -;* when-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (when-debug level . exp) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(if (>= *skribe-debug* ,level) (begin ,@exp)) - #unspecified)) - -;*---------------------------------------------------------------------*/ -;* with-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-debug level lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* with-push-trace ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-push-trace lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - (let ((r (gensym))) - `(let () - (c-push-trace ,lbl) - (let ((,r ,@arg*)) - (c-pop-trace) - ,r))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* debug-item ... */ -;*---------------------------------------------------------------------*/ -(define-expander debug-item - (lambda (x e) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) - #unspecified))) diff --git a/skribe/src/bigloo/debug.scm b/skribe/src/bigloo/debug.scm deleted file mode 100644 index 8f1691c..0000000 --- a/skribe/src/bigloo/debug.scm +++ /dev/null @@ -1,188 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jun 11 10:01:47 2003 */ -;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_debug - - (export *skribe-debug* - *skribe-debug-symbols* - *skribe-debug-color* - - (skribe-debug::int) - (debug-port::output-port . ::obj) - (debug-margin::bstring) - (debug-color::bstring ::int . ::obj) - (debug-bold::bstring . ::obj) - (debug-string ::obj) - (debug-item . ::obj) - - (%with-debug ::obj ::obj ::procedure))) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-symbols* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-symbols* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-color* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-color* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-item* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-item* #f) - -;*---------------------------------------------------------------------*/ -;* *debug-port* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-port* (current-error-port)) - -;*---------------------------------------------------------------------*/ -;* *debug-depth* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-depth* 0) - -;*---------------------------------------------------------------------*/ -;* *debug-margin* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-margin* "") - -;*---------------------------------------------------------------------*/ -;* *skribe-margin-debug-level* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-margin-debug-level* 0) - -;*---------------------------------------------------------------------*/ -;* skribe-debug ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-debug) - *skribe-debug*) - -;*---------------------------------------------------------------------*/ -;* debug-port ... */ -;*---------------------------------------------------------------------*/ -(define (debug-port . o) - (cond - ((null? o) - *debug-port*) - ((output-port? (car o)) - (set! *debug-port* o) - o) - (else - (error 'debug-port "Illegal debug port" (car o))))) - -;*---------------------------------------------------------------------*/ -;* debug-margin ... */ -;*---------------------------------------------------------------------*/ -(define (debug-margin) - *debug-margin*) - -;*---------------------------------------------------------------------*/ -;* debug-color ... */ -;*---------------------------------------------------------------------*/ -(define (debug-color col::int . o) - (with-output-to-string - (if *skribe-debug-color* - (lambda () - (display* "[1;" (+ 31 col) "m") - (apply display* o) - (display "")) - (lambda () - (apply display* o))))) - -;*---------------------------------------------------------------------*/ -;* debug-bold ... */ -;*---------------------------------------------------------------------*/ -(define (debug-bold . o) - (apply debug-color -30 o)) - -;*---------------------------------------------------------------------*/ -;* debug-item ... */ -;*---------------------------------------------------------------------*/ -(define (debug-item . args) - (if (or (>= *skribe-debug* *skribe-margin-debug-level*) - *skribe-debug-item*) - (begin - (display (debug-margin) *debug-port*) - (display (debug-color (-fx *debug-depth* 1) "- ")) - (for-each (lambda (a) (display a *debug-port*)) args) - (newline *debug-port*)))) - -;*---------------------------------------------------------------------*/ -;* %with-debug-margin ... */ -;*---------------------------------------------------------------------*/ -(define (%with-debug-margin margin thunk) - (let ((om *debug-margin*)) - (set! *debug-depth* (+fx *debug-depth* 1)) - (set! *debug-margin* (string-append om margin)) - (let ((res (thunk))) - (set! *debug-depth* (-fx *debug-depth* 1)) - (set! *debug-margin* om) - res))) - -;*---------------------------------------------------------------------*/ -;* %with-debug ... */ -;*---------------------------------------------------------------------*/ -(define (%with-debug lvl lbl thunk) - (let ((ol *skribe-margin-debug-level*) - (oi *skribe-debug-item*)) - (set! *skribe-margin-debug-level* lvl) - (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) - (and (symbol? lbl) - (memq lbl *skribe-debug-symbols*) - (set! *skribe-debug-item* #t))) - (with-output-to-port *debug-port* - (lambda () - (display (debug-margin)) - (display (if (= *debug-depth* 0) - (debug-color *debug-depth* "+ " lbl) - (debug-color *debug-depth* "--+ " lbl))) - (newline) - (%with-debug-margin (debug-color *debug-depth* " |") - thunk))) - (thunk)))) - (set! *skribe-debug-item* oi) - (set! *skribe-margin-debug-level* ol) - r))) - -;*---------------------------------------------------------------------*/ -;* debug-string ... */ -;*---------------------------------------------------------------------*/ -(define (debug-string o) - (with-output-to-string - (lambda () - (write o)))) - -;*---------------------------------------------------------------------*/ -;* example */ -;*---------------------------------------------------------------------*/ -;; (%with-debug 0 'foo1.1 -;; (lambda () -;; (debug-item 'foo2.1) -;; (debug-item 'foo2.2) -;; (%with-debug 0 'foo2.3 -;; (lambda () -;; (debug-item 'foo3.1) -;; (%with-debug 0 'foo3.2 -;; (lambda () -;; (debug-item 'foo4.1) -;; (debug-item 'foo4.2))) -;; (debug-item 'foo3.3))) -;; (debug-item 'foo2.4))) - diff --git a/skribe/src/bigloo/engine.scm b/skribe/src/bigloo/engine.scm deleted file mode 100644 index bd8a027..0000000 --- a/skribe/src/bigloo/engine.scm +++ /dev/null @@ -1,262 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 08:01:30 2003 */ -;* Last change : Fri May 21 16:12:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe engines */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_engine - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output) - - (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) - (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) - (find-engine ::symbol #!key version) - - (default-engine::obj) - (default-engine-set! ::%engine) - (push-default-engine ::%engine) - (pop-default-engine) - - (processor-get-engine ::obj ::obj ::%engine) - - (engine-format? ::bstring . e) - - (engine-custom::obj ::%engine ::symbol) - (engine-custom-set! ::%engine ::symbol ::obj) - - (engine-add-writer! ::%engine ::obj ::procedure ::obj - ::obj ::obj ::obj ::obj ::obj ::obj))) - -;*---------------------------------------------------------------------*/ -;* *engines* ... */ -;*---------------------------------------------------------------------*/ -(define *engines* '()) - -;*---------------------------------------------------------------------*/ -;* *default-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *default-engine* #f) -(define *default-engines* '()) - -;*---------------------------------------------------------------------*/ -;* default-engine-set! ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine-set! e) - (if (not (engine? e)) - (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) - (begin - (set! *default-engine* e) - (set! *default-engines* (cons *default-engine* *default-engines*)) - e))) - -;*---------------------------------------------------------------------*/ -;* default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine) - *default-engine*) - -;*---------------------------------------------------------------------*/ -;* push-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (push-default-engine e) - (set! *default-engines* (cons e *default-engines*)) - (default-engine-set! e)) - -;*---------------------------------------------------------------------*/ -;* pop-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (pop-default-engine) - (if (null? *default-engines*) - (skribe-error 'pop-default-engine "Empty engine stack" '()) - (begin - (set! *default-engines* (cdr *default-engines*)) - (if (pair? *default-engines*) - (default-engine-set! (car *default-engines*)) - (set! *default-engine* #f))))) - -;*---------------------------------------------------------------------*/ -;* processor-get-engine ... */ -;*---------------------------------------------------------------------*/ -(define (processor-get-engine combinator newe olde) - (cond - ((procedure? combinator) - (combinator newe olde)) - ((engine? newe) - newe) - (else - olde))) - -;*---------------------------------------------------------------------*/ -;* engine-format? ... */ -;*---------------------------------------------------------------------*/ -(define (engine-format? fmt . e) - (let ((e (cond - ((pair? e) (car e)) - ((%engine? *skribe-engine*) *skribe-engine*) - (else (find-engine *skribe-engine*))))) - (if (not (%engine? e)) - (skribe-error 'engine-format? "No engine" e) - (string=? fmt (%engine-format e))))) - -;*---------------------------------------------------------------------*/ -;* make-engine ... */ -;*---------------------------------------------------------------------*/ -(define (make-engine ident - #!key - (version #unspecified) - (format "raw") - (filter #f) - (delegate #f) - (symbol-table '()) - (custom '()) - (info '())) - (let ((e (instantiate::%engine - (ident ident) - (version version) - (format format) - (filter filter) - (delegate delegate) - (symbol-table symbol-table) - (customs custom) - (info info)))) - ;; store the engine in the global table - (set! *engines* (cons e *engines*)) - ;; return it - e)) - -;*---------------------------------------------------------------------*/ -;* copy-engine ... */ -;*---------------------------------------------------------------------*/ -(define (copy-engine ident - e - #!key - (version #unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) - (let ((e (duplicate::%engine e - (ident ident) - (version version) - (filter (or filter (%engine-filter e))) - (delegate (or delegate (%engine-delegate e))) - (symbol-table (or symbol-table (%engine-symbol-table e))) - (customs (or custom (%engine-customs e)))))) - (set! *engines* (cons e *engines*)) - e)) - -;*---------------------------------------------------------------------*/ -;* find-loaded-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-loaded-engine id version) - (let loop ((es *engines*)) - (cond - ((null? es) - #f) - ((eq? (%engine-ident (car es)) id) - (cond - ((eq? version #unspecified) - (car es)) - ((eq? version (%engine-version (car es))) - (car es)) - (else - (loop (cdr es))))) - (else - (loop (cdr es)))))) - -;*---------------------------------------------------------------------*/ -;* find-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-engine id #!key (version #unspecified)) - (with-debug 5 'find-engine - (debug-item "id=" id " version=" version) - (or (find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and (pair? c) (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (find-loaded-engine id version)) - #f))))) - -;*---------------------------------------------------------------------*/ -;* engine-custom ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom e id) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (cadr c) - #unspecified)))) - -;*---------------------------------------------------------------------*/ -;* engine-custom-set! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-set! e id val) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (set-car! (cdr c) val) - (set! customs (cons (list id val) customs)))))) - -;*---------------------------------------------------------------------*/ -;* engine-add-writer! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-add-writer! e id pred upred opt before action after class va) - ;; check the arity of a procedure - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error id "Illegal procedure" proc)) - ((not (correct-arity? proc arity)) - (skribe-error id - (string-append "Illegal `" name "'procedure") - proc)))) - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) - ;; check the engine - (if (not (engine? e)) - (skribe-error id "Illegal engine" e)) - ;; check the options - (if (not (or (eq? opt 'all) (list? opt))) - (skribe-error id "Illegal options" opt)) - ;; check the correctness of the predicate and the validator - (check-procedure "predicate" pred 2) - (when va (check-procedure "validate" va 2)) - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - ;; create a new writer... - (let ((n (instantiate::%writer - (ident (if (symbol? id) id 'all)) - (class class) - (pred pred) - (upred upred) - (options opt) - (before before) - (action action) - (after after) - (validate va)))) - ;; ...and bind it - (with-access::%engine e (writers) - (set! writers (cons n writers)) - n))) diff --git a/skribe/src/bigloo/eval.scm b/skribe/src/bigloo/eval.scm deleted file mode 100644 index b5c6548..0000000 --- a/skribe/src/bigloo/eval.scm +++ /dev/null @@ -1,335 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed May 18 15:52:01 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe evaluator */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_eval - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_param - skribe_types - skribe_resolve - skribe_verify - skribe_output - skribe_read - skribe_lib - skribe_engine) - - (export (skribe-eval-location) - (skribe-error ::obj ::obj ::obj) - (skribe-type-error ::obj ::obj ::obj ::bstring) - (skribe-warning ::int . obj) - (skribe-warning/ast ::int ::%ast . obj) - (skribe-message ::bstring . obj) - (skribe-load ::bstring #!rest opt #!key engine path) - (skribe-load-options) - (skribe-include ::bstring . rest) - (skribe-open-bib-file ::bstring ::obj) - (skribe-eval-port ::input-port ::obj #!key env) - (skribe-eval ::obj ::%engine #!key env) - (skribe-path::pair-nil) - (skribe-path-set! ::obj) - (skribe-image-path::pair-nil) - (skribe-image-path-set! ::obj) - (skribe-bib-path::pair-nil) - (skribe-bib-path-set! ::obj) - (skribe-source-path::pair-nil) - (skribe-source-path-set! ::obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-location ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-location) - (evmeaning-location)) - -;*---------------------------------------------------------------------*/ -;* skribe-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-error proc msg obj) - (if (ast? obj) - (skribe-ast-error proc msg obj) - (error/evloc proc msg obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-type-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-type-error proc msg obj etype) - (let ((ty (if (%markup? obj) - (format "~a#~a" (markup-markup obj) (markup-ident obj)) - (find-runtime-type obj)))) - (skribe-error proc - (bigloo-type-error-msg msg etype ty) - obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-ast-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-ast-error proc msg obj) - (let ((l (ast-loc obj)) - (shape (if (%markup? obj) - (%markup-markup obj) - (find-runtime-type obj)))) - (if (location? l) - (error/location proc msg shape (location-file l) (location-pos l)) - (error/evloc proc msg shape)))) - -;*---------------------------------------------------------------------*/ -;* error/evloc ... */ -;*---------------------------------------------------------------------*/ -(define (error/evloc proc msg obj) - (let ((l (evmeaning-location))) - (if (location? l) - (error/location proc msg obj (location-file l) (location-pos l)) - ((begin error) proc msg obj)))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning level . obj) - (if (>= *skribe-warning* level) - (let ((l (evmeaning-location))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply warning obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning/ast ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning/ast level ast . obj) - (if (>= *skribe-warning* level) - (let ((l (%ast-loc ast))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply skribe-warning level obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-message ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-message fmt . obj) - (if (> *skribe-verbose* 0) - (apply fprintf (current-error-port) fmt obj))) - -;*---------------------------------------------------------------------*/ -;* *skribe-loaded* ... */ -;* ------------------------------------------------------------- */ -;* This hash table stores the list of loaded files in order */ -;* to avoid one file to be loaded twice. */ -;*---------------------------------------------------------------------*/ -(define *skribe-loaded* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* *skribe-load-options* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-load-options* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-load ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load file #!rest opt #!key engine path) - (with-debug 4 'skribe-load - (debug-item " engine=" engine) - (debug-item " path=" path) - (debug-item " opt" opt) - (let* ((ei (cond - ((not engine) - *skribe-engine*) - ((engine? engine) - engine) - ((not (symbol? engine)) - (skribe-error 'skribe-load "Illegal engine" engine)) - (else - engine))) - (path (cond - ((not path) - (skribe-path)) - ((string? path) - (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else - path))) - (filep (find-file/path file path))) - (set! *skribe-load-options* opt) - (if (and (string? filep) (file-exists? filep)) - (if (not (hashtable-get *skribe-loaded* filep)) - (begin - (hashtable-put! *skribe-loaded* filep #t) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [loading file: " filep " " opt "]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [loading file: " filep "]"))) - (with-input-from-file filep - (lambda () - (skribe-eval-port (current-input-port) ei))))) - (skribe-error 'skribe-load - (format "Can't find file `~a' in path" file) - path))))) - -;*---------------------------------------------------------------------*/ -;* skribe-load-options ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load-options) - *skribe-load-options*) - -;*---------------------------------------------------------------------*/ -;* evaluate ... */ -;*---------------------------------------------------------------------*/ -(define (evaluate exp) - (try (eval exp) - (lambda (a p m o) - (evmeaning-notify-error p m o) - (flush-output-port (current-error-port))))) - -;*---------------------------------------------------------------------*/ -;* skribe-include ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-include file . rest) - (let* ((path (cond - ((or (null? rest) (null? (cdr rest))) - (skribe-path)) - ((not (every? string? (cdr rest))) - (skribe-error 'skribe-include "Illegal path" (cdr rest))) - (else - (cdr rest)))) - (filep (find-file/path file (if (null? path) (skribe-path) path)))) - (if (and (string? filep) (file-exists? filep)) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [including file: " filep "]")) - (with-input-from-file filep - (lambda () - (let loop ((exp (skribe-read (current-input-port))) - (res '())) - (if (eof-object? exp) - (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (loop (skribe-read (current-input-port)) - (cons (evaluate exp) res))))))) - (skribe-error 'skribe-include - (format "Can't find file `~a 'in path" file) - path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-open-bib-file ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-open-bib-file file command) - (let ((filep (find-file/path file *skribe-bib-path*))) - (if (string? filep) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [loading bib: " filep "]")) - (open-input-file (if (string? command) - (string-append "| " - (format command filep)) - filep))) - (begin - (skribe-warning 1 - 'bibliography - "Can't find bibliography -- " file) - #f)))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-port ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-port port ei #!key (env '())) - (with-debug 2 'skribe-eval-port - (debug-item "ei=" ei) - (let ((e (if (symbol? ei) (find-engine ei) ei))) - (debug-item "e=" e) - (if (not (%engine? e)) - (skribe-error 'find-engine "Can't find engine" ei) - (let loop ((exp (skribe-read port))) - (with-debug 10 'skribe-eval-port - (debug-item "exp=" exp)) - (if (not (eof-object? exp)) - (begin - (skribe-eval (evaluate exp) e :env env) - (loop (skribe-read port))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval a e #!key (env '())) - (with-debug 2 'skribe-eval - (debug-item "a=" a " e=" (%engine-ident e)) - (let ((a2 (resolve! a e env))) - (debug-item "resolved a=" a) - (let ((a3 (verify a2 e))) - (debug-item "verified a=" a3) - (output a3 e))))) - -;*---------------------------------------------------------------------*/ -;* skribe-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path) - *skribe-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-path-set! "Illegal path" path) - (set! *skribe-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path) - *skribe-image-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-image-path-set! "Illegal path" path) - (set! *skribe-image-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path) - *skribe-bib-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-bib-path-set! "Illegal path" path) - (set! *skribe-bib-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path) - *skribe-source-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-source-path-set! "Illegal path" path) - (set! *skribe-source-path* path))) diff --git a/skribe/src/bigloo/evapi.scm b/skribe/src/bigloo/evapi.scm deleted file mode 100644 index 6f0d49e..0000000 --- a/skribe/src/bigloo/evapi.scm +++ /dev/null @@ -1,39 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:57:09 2003 */ -;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo eval declarations */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_evapi - (import skribe_types - skribe_lib - skribe_api - skribe_engine - skribe_writer - skribe_output - skribe_eval - skribe_read - skribe_resolve - skribe_param - skribe_source - skribe_index - skribe_configure - skribe_lisp - skribe_xml - skribe_c - skribe_asm - skribe_bib - skribe_color - skribe_sui - skribe_debug) - (eval (export-all))) - - diff --git a/skribe/src/bigloo/index.bgl b/skribe/src/bigloo/index.bgl deleted file mode 100644 index 9697981..0000000 --- a/skribe/src/bigloo/index.bgl +++ /dev/null @@ -1,32 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes Bigloo module declaration */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../common/index.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_index - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (index?::bool ::obj) - (default-index) - (make-index-table ::bstring) - (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) - diff --git a/skribe/src/bigloo/lib.bgl b/skribe/src/bigloo/lib.bgl deleted file mode 100644 index 6dd6d37..0000000 --- a/skribe/src/bigloo/lib.bgl +++ /dev/null @@ -1,340 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe runtime (i.e., the style user functions). */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../common/lib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lib - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output - skribe_engine) - - (export (markup-option ::%markup ::obj) - (markup-option-add! ::%markup ::obj ::obj) - (markup-class ::%markup) - - (container-env-get ::%container ::symbol) - (container-search-down::pair-nil ::procedure ::%container) - (search-down::pair-nil ::procedure ::obj) - - (find-markup-ident::pair-nil ::bstring) - - (find-down::pair-nil ::procedure ::obj) - (find1-down::obj ::procedure ::obj) - (find-up::pair-nil ::procedure ::obj) - (find1-up::obj ::procedure ::obj) - - (ast-document ::%ast) - (ast-chapter ::%ast) - (ast-section ::%ast) - - (the-body ::pair-nil) - (the-options ::pair-nil . rest) - - (list-split::pair-nil ::pair-nil ::int . ::obj) - - (generic ast->string::bstring ::obj) - - (strip-ref-base ::bstring) - (ast->file-location ::%ast) - - (convert-image ::bstring ::pair-nil) - - (make-string-replace ::pair-nil) - (string-canonicalize::bstring ::bstring) - (inline unspecified?::bool ::obj))) - -;*---------------------------------------------------------------------*/ -;* markup-option ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option m opt) - (if (%markup? m) - (with-access::%markup m (options) - (let ((c (assq opt options))) - (and (pair? c) (pair? (cdr c)) (cadr c)))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-option-add! ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option-add! m opt val) - (if (%markup? m) - (with-access::%markup m (options) - (set! options (cons (list opt val) options))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (markup-class m) - (%markup-class m)) - -;*---------------------------------------------------------------------*/ -;* container-env-get ... */ -;*---------------------------------------------------------------------*/ -(define (container-env-get m key) - (with-access::%container m (env) - (let ((c (assq key env))) - (and (pair? c) (cadr c))))) - -;*---------------------------------------------------------------------*/ -;* strip-ref-base ... */ -;*---------------------------------------------------------------------*/ -(define (strip-ref-base file) - (if (not (string? *skribe-ref-base*)) - file - (let ((l (string-length *skribe-ref-base*))) - (cond - ((not (>fx (string-length file) (+fx l 2))) - file) - ((not (substring=? file *skribe-ref-base* l)) - file) - ((not (char=? (string-ref file l) (file-separator))) - file) - (else - (substring file (+fx l 1) (string-length file))))))) - -;*---------------------------------------------------------------------*/ -;* ast->file-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast->file-location ast) - (let ((l (ast-loc ast))) - (if (location? l) - (format "~a:~a" (location-file l) (location-pos l)) - ""))) - -;*---------------------------------------------------------------------*/ -;* builtin-convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) - (to (make-file-name dir f))) - (cond - ((string=? s fmt) - to) - ((file-exists? to) - to) - (else - (let ((c (if (string=? s "fig") - (string-append "fig2dev -L " fmt " " from " > " to) - (string-append "convert " from " " to)))) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [converting image: " from " (" c ")]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [converting image: " from "]"))) - (if (=fx (system c) 0) to #f)))))) - -;*---------------------------------------------------------------------*/ -;* convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (convert-image file formats) - (let ((path (find-file/path file (skribe-image-path)))) - (if (not (string? path)) - (skribe-error 'image - (format "Can't find `~a' image file in path: " file) - (skribe-image-path)) - (let ((suf (suffix file))) - (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - #f))) - (if dir - (let ((dest (basename path))) - (copy-file path (make-file-name dir dest)) - dest) - path)) - (let loop ((fmts formats)) - (if (null? fmts) - #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - ".")) - (p (builtin-convert-image path (car fmts) dir))) - (if (string? p) - p - (loop (cdr fmts))))))))))) - -;*---------------------------------------------------------------------*/ -;* html-string ... */ -;*---------------------------------------------------------------------*/ -(define (html-string str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (if (=fx nlen len) - str - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let ((c (string-ref-ur str r))) - (case c - ((#\<) - (blit-string! "<" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\>) - (blit-string! ">" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\&) - (blit-string! "&" 0 res w 5) - (loop (+fx r 1) (+fx w 5))) - ((#\") - (blit-string! """ 0 res w 6) - (loop (+fx r 1) (+fx w 6))) - (else - (string-set! res w c) - (loop (+fx r 1) (+fx w 1))))))))) - (case (string-ref-ur str r) - ((#\< #\>) - (loop (+fx r 1) (+fx nlen 3))) - ((#\&) - (loop (+fx r 1) (+fx nlen 4))) - ((#\") - (loop (+fx r 1) (+fx nlen 5))) - (else - (loop (+fx r 1) nlen))))))) - -;*---------------------------------------------------------------------*/ -;* make-generic-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-generic-string-replace lst) - (lambda (str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (let ((pl (string-length (cadr p)))) - (blit-string! (cadr p) 0 res w pl) - (loop (+fx r 1) (+fx w pl))) - (begin - (string-set! res w c) - (loop (+fx r 1) (+fx w 1)))))))) - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (loop (+fx r 1) - (+fx nlen (-fx (string-length (cadr p)) 1))) - (loop (+fx r 1) - nlen)))))))) - -;*---------------------------------------------------------------------*/ -;* make-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-string-replace lst) - (let ((l (sort lst (lambda (r1 r2) (char ">"))) - html-string) - (else - (make-generic-string-replace lst))))) - -;*---------------------------------------------------------------------*/ -;* ast->string ... */ -;*---------------------------------------------------------------------*/ -(define-generic (ast->string ast) - (cond - ((string? ast) - ast) - ((number? ast) - (number->string ast)) - ((pair? ast) - (let* ((t (map ast->string ast)) - (res (make-string - (apply + -1 (length t) (map string-length t)) - #\space))) - (let loop ((t t) - (w 0)) - (if (null? t) - res - (let ((l (string-length (car t)))) - (blit-string! (car t) 0 res w l) - (loop (cdr t) (+ w l 1))))))) - (else - ""))) - -;*---------------------------------------------------------------------*/ -;* ast->string ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (ast->string ast::%node) - (ast->string (%node-body ast))) - -;*---------------------------------------------------------------------*/ -;* string-canonicalize ... */ -;*---------------------------------------------------------------------*/ -(define (string-canonicalize old) - (let* ((l (string-length old)) - (new (make-string l))) - (let loop ((r 0) - (w 0) - (s #f)) - (cond - ((=fx r l) - (cond - ((=fx w 0) - "") - ((char-whitespace? (string-ref new (-fx w 1))) - (substring new 0 (-fx w 1))) - ((=fx w r) - new) - (else - (substring new 0 w)))) - ((char-whitespace? (string-ref old r)) - (if s - (loop (+fx r 1) w #t) - (begin - (string-set! new w #\-) - (loop (+fx r 1) (+fx w 1) #t)))) - ((or (char=? (string-ref old r) #\#) - (char=? (string-ref old r) #\,) - (>= (char->integer (string-ref old r)) #x7f)) - (string-set! new w #\-) - (loop (+fx r 1) (+fx w 1) #t)) - (else - (string-set! new w (string-ref old r)) - (loop (+fx r 1) (+fx w 1) #f)))))) - -;*---------------------------------------------------------------------*/ -;* unspecified? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unspecified? obj) - (eq? obj #unspecified)) - -;*---------------------------------------------------------------------*/ -;* base */ -;* ------------------------------------------------------------- */ -;* A base engine must pre-exist before anything is loaded. In */ -;* particular, this dummy base engine is used to load the */ -;* actual definition of base. */ -;*---------------------------------------------------------------------*/ -(make-engine 'base :version 'bootstrap) - diff --git a/skribe/src/bigloo/lisp.scm b/skribe/src/bigloo/lisp.scm deleted file mode 100644 index 65a8227..0000000 --- a/skribe/src/bigloo/lisp.scm +++ /dev/null @@ -1,530 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Aug 29 08:14:59 2003 */ -;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Handling of lispish source files. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lisp - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export bigloo - scheme - lisp - skribe)) - -;*---------------------------------------------------------------------*/ -;* keys ... */ -;*---------------------------------------------------------------------*/ -(define *the-key* #f) -(define *bracket-highlight* #t) -(define *bigloo-key* #f) -(define *scheme-key* #f) -(define *lisp-key* #f) -(define *skribe-key* #f) - -;*---------------------------------------------------------------------*/ -;* init-bigloo-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-bigloo-fontifier!) - (if (not *bigloo-key*) - (begin - (set! *bigloo-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'symbol)) - '(set! if let cond case quote begin letrec let* - lambda export extern class generic inline - static import foreign type with-access instantiate - duplicate labels - match-case match-lambda - syntax-rules pragma widen! shrink! - wide-class profile profile/gc - regular-grammar lalr-grammar apply)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'define)) - '(define define-inline define-struct define-macro - define-generic define-method define-syntax - define-expander)) - ;; error - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'error)) - '(bind-exit unwind-protect call/cc error warning)) - ;; module - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'module)) - '(module import export library)) - ;; thread - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'thread)) - '(make-thread thread-start! thread-yield! - thread-await! thread-await*! - thread-sleep! thread-join! - thread-terminate! thread-suspend! - thread-resume! thread-yield! - thread-specific thread-specific-set! - thread-name thread-name-set! - scheduler-react! scheduler-start! - broadcast! scheduler-broadcast! - current-thread thread? - current-scheduler scheduler? make-scheduler - make-input-signal make-output-signal - make-connect-signal make-process-signal - make-accept-signal make-timer-signal - thread-get-values! thread-get-values*!))))) - -;*---------------------------------------------------------------------*/ -;* init-lisp-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-lisp-fontifier!) - (if (not *lisp-key*) - (begin - (set! *lisp-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'symbol)) - '(setq if let cond case else progn letrec let* - lambda labels try unwind-protect apply funcall)) - ;; defun - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'define)) - '(define defun defvar defmacro))))) - -;*---------------------------------------------------------------------*/ -;* init-skribe-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-skribe-fontifier!) - (if (not *skribe-key*) - (begin - (set! *skribe-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'symbol)) - '(set! bold it emph tt color ref index underline - figure center pre flush hrule linebreak - image kbd code var samp sc sf sup sub - itemize description enumerate item - table tr td th item prgm author - prgm hook font lambda)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'define)) - '(define define-markup)) - ;; markup - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'markup)) - '(document chapter section subsection subsubsection - paragraph p handle resolve processor - abstract margin toc table-of-contents - current-document current-chapter current-section - document-sections* section-number - footnote print-index include skribe-load - slide))))) - -;*---------------------------------------------------------------------*/ -;* bigloo ... */ -;*---------------------------------------------------------------------*/ -(define bigloo - (new language - (name "bigloo") - (fontifier bigloo-fontifier) - (extractor bigloo-extractor))) - -;*---------------------------------------------------------------------*/ -;* scheme ... */ -;*---------------------------------------------------------------------*/ -(define scheme - (new language - (name "scheme") - (fontifier scheme-fontifier) - (extractor scheme-extractor))) - -;*---------------------------------------------------------------------*/ -;* lisp ... */ -;*---------------------------------------------------------------------*/ -(define lisp - (new language - (name "lisp") - (fontifier lisp-fontifier) - (extractor lisp-extractor))) - -;*---------------------------------------------------------------------*/ -;* bigloo-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-fontifier s) - (init-bigloo-fontifier!) - (set! *the-key* *bigloo-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* bigloo-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-inline define-generic - define-method define-macro define-expander) - (?fun . ?-) . ?-) - (eq? def fun)) - (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* skribe ... */ -;*---------------------------------------------------------------------*/ -(define skribe - (new language - (name "skribe") - (fontifier skribe-fontifier) - (extractor skribe-extractor))) - -;*---------------------------------------------------------------------*/ -;* skribe-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-fontifier s) - (init-skribe-fontifier!) - (set! *the-key* *skribe-key*) - (set! *bracket-highlight* #t) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* skribe-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro define-markup) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - ((markup-output (quote ?mk) . ?-) - (eq? mk def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* scheme-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-fontifier s) s) - -;*---------------------------------------------------------------------*/ -;* scheme-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* lisp-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-fontifier s) - (init-lisp-fontifier!) - (set! *the-key* *lisp-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* lisp-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or defun defmacro) ?fun ?- . ?-) - (eq? def fun)) - ((defvar ?var . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* definition-search ... */ -;* ------------------------------------------------------------- */ -;* This function seeks a Bigloo definition. If it finds it, it */ -;* returns two values the starting char number of the definition */ -;* and the stop char. */ -;*---------------------------------------------------------------------*/ -(define (definition-search ip tab semipred) - (cond-expand - (bigloo2.6 - (define (reader-current-line-number) - (let* ((port (open-input-string "(9)")) - (exp (read port #t))) - (close-input-port port) - (line-number exp))) - (define (line-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos ?line) - line)))) - (reader-reset!) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (line-number exp)) - (e (reader-current-line-number))) - (source-read-lines (input-port-name ip) b e tab))))))) - (else - (define (char-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos) - pos)))) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (char-number exp)) - (e (input-port-position ip))) - (source-read-chars (input-port-name ip) - b - e - tab))))))))) - - -;*---------------------------------------------------------------------*/ -;* fontify-lisp ... */ -;*---------------------------------------------------------------------*/ -(define (fontify-lisp port::input-port) - (let ((g (regular-grammar () - ((: ";;" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";*" (* all)) - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-string))) - (cons str (ignore)))) - ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-substring 1 (the-length)))) - (cons str (ignore)))) - ((+ #\Space) - ;; separators - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - (#\( - ;; open parenthesis - (let ((str (highlight (the-string)))) - (pupush-highlight) - (cons str (ignore)))) - (#\) - ;; close parenthesis - (let ((str (highlight (the-string) -1))) - (cons str (ignore)))) - ((+ (in "[]")) - ;; brackets - (let ((s (the-string))) - (if *bracket-highlight* - (let ((c (new markup - (markup '&source-bracket) - (body s)))) - (cons c (ignore))) - (cons s (ignore))))) - ((+ #\Tab) - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((: #\( (+ (out "; \t()[]:\"\n"))) - ;; keywords - (let* ((string (the-substring 1 (the-length))) - (symbol (string->symbol string)) - (key (getprop symbol *the-key*))) - (cons - "(" - (case key - ((symbol) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((define) - (let ((c (new markup - (markup '&source-define) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-define) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((error) - (let ((c (new markup - (markup '&source-error) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((module) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((markup) - (let ((c (new markup - (markup '&source-markup) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((thread) - (let ((c (new markup - (markup '&source-thread) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons (highlight string 1) (ignore))))))) - ((+ (out "; \t()[]:\"\n")) - (let ((string (the-string))) - (cons (highlight string 1) (ignore)))) - ((+ #\Newline) - ;; newline - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (ident (symbol->string (gensym))) - (body s)))) - str) - (ignore)))) - ((: "::" (+ (out ";\n \t()[]:\""))) - ;; type annotations - (let ((c (new markup - (markup '&source-type) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) - ;; keywords annotations - (let ((c (new markup - (markup '&source-key) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\: #\; #\")) - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - ((: #\# #\\ (+ (out " \n\t"))) - ;; characters - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(lisp)" "Unexpected character" c))))))) - (reset-highlight!) - (read/rp g port))) - -;*---------------------------------------------------------------------*/ -;* *highlight* ... */ -;*---------------------------------------------------------------------*/ -(define *highlight* '()) - -;*---------------------------------------------------------------------*/ -;* reset-highlight! ... */ -;*---------------------------------------------------------------------*/ -(define (reset-highlight!) - (set! *highlight* '())) - -;*---------------------------------------------------------------------*/ -;* push-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (push-highlight col pv) - (set! *highlight* (cons (cons col pv) *highlight*))) - -;*---------------------------------------------------------------------*/ -;* pupush-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pupush-highlight) - (if (pair? *highlight*) - (let ((c (car *highlight*))) - (set-cdr! c 100000)))) - -;*---------------------------------------------------------------------*/ -;* pop-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pop-highlight pv) - (case pv - ((-1) - (set! *highlight* (cdr *highlight*))) - ((0) - 'nop) - (else - (let ((c (car *highlight*))) - (if (>fx (cdr c) 1) - (set-cdr! c (-fx (cdr c) 1)) - (set! *highlight* (cdr *highlight*))))))) - -;*---------------------------------------------------------------------*/ -;* highlight ... */ -;*---------------------------------------------------------------------*/ -(define (highlight exp . pop) - (if (pair? *highlight*) - (let* ((c (car *highlight*)) - (r (if (>fx (cdr c) 0) - ((car c) exp) - exp))) - (if (pair? pop) (pop-highlight (car pop))) - r) - exp)) - - diff --git a/skribe/src/bigloo/main.scm b/skribe/src/bigloo/main.scm deleted file mode 100644 index 5b9e5e5..0000000 --- a/skribe/src/bigloo/main.scm +++ /dev/null @@ -1,96 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/main.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:51:49 2003 */ -;* Last change : Wed May 18 15:45:27 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe main entry point */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_main - - (include "debug.sch") - - (import skribe_types - skribe_parse-args - skribe_param - skribe_lib - skribe_eval - skribe_read - skribe_engine - skribe_evapi) - - (main main)) - -;*---------------------------------------------------------------------*/ -;* main ... */ -;*---------------------------------------------------------------------*/ -(define (main args) - (with-debug 2 'main - (debug-item "parse env variables...") - (parse-env-variables) - - (debug-item "load rc file...") - (load-rc) - - (debug-item "parse command line...") - (parse-args args) - - (debug-item "load base...") - (skribe-load "base.skr" :engine 'base) - - (debug-item "preload... (" *skribe-engine* ")") - (for-each (lambda (f) - (skribe-load f :engine *skribe-engine*)) - *skribe-preload*) - - ;; Load the specified variants - (debug-item "variant... (" *skribe-variants* ")") - (for-each (lambda (x) - (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) - (reverse! *skribe-variants*)) - - (debug-item "body..." *skribe-engine*) - (if (string? *skribe-dest*) - (cond-expand - (bigloo2.6 - (try (with-output-to-file *skribe-dest* doskribe) - (lambda (e a b c) - (delete-file *skribe-dest*) - (let ((s (with-output-to-string - (lambda () (write c))))) - (notify-error a b s)) - (exit -1)))) - (else - (with-exception-handler - (lambda (e) - (if (&warning? e) - (raise e) - (begin - (delete-file *skribe-dest*) - (if (&error? e) - (error-notify e) - (raise e)) - (exit 1)))) - (lambda () - (with-output-to-file *skribe-dest* doskribe))))) - (doskribe)))) - -;*---------------------------------------------------------------------*/ -;* doskribe ... */ -;*---------------------------------------------------------------------*/ -(define (doskribe) - (let ((e (find-engine *skribe-engine*))) - (if (and (engine? e) (pair? *skribe-precustom*)) - (for-each (lambda (cv) - (engine-custom-set! e (car cv) (cdr cv))) - *skribe-precustom*)) - (if (pair? *skribe-src*) - (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) - *skribe-src*) - (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/skribe/src/bigloo/new.sch b/skribe/src/bigloo/new.sch deleted file mode 100644 index 16bb7d5..0000000 --- a/skribe/src/bigloo/new.sch +++ /dev/null @@ -1,17 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/new.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 17 11:58:30 2003 */ -;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The new facility */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* new ... */ -;*---------------------------------------------------------------------*/ -(define-macro (new id . inits) - `(,(symbol-append 'instantiate::% id) ,@inits)) - diff --git a/skribe/src/bigloo/output.scm b/skribe/src/bigloo/output.scm deleted file mode 100644 index 4bc6271..0000000 --- a/skribe/src/bigloo/output.scm +++ /dev/null @@ -1,167 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/output.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_output - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (output ::obj ::%engine . w))) - -;*---------------------------------------------------------------------*/ -;* output ... */ -;*---------------------------------------------------------------------*/ -(define (output node e . writer) - (with-debug 3 'output - (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) - (debug-item "writer=" writer) - (if (pair? writer) - (cond - ((%writer? (car writer)) - (out/writer node e (car writer))) - ((not (car writer)) - (skribe-error 'output - (format "Illegal `~a' user writer" (%engine-ident e)) - (if (markup? node) (%markup-markup node) node))) - (else - (skribe-error 'output "Illegal user writer" (car writer)))) - (out node e)))) - -;*---------------------------------------------------------------------*/ -;* out/writer ... */ -;*---------------------------------------------------------------------*/ -(define (out/writer n e w) - (with-debug 5 'out/writer - (debug-item "n=" (find-runtime-type n) - " " (if (markup? n) (markup-markup n) "")) - (debug-item "e=" (%engine-ident e)) - (debug-item "w=" (%writer-ident w)) - (if (%writer? w) - (with-access::%writer w (before action after) - (invoke before n e) - (invoke action n e) - (invoke after n e))))) - -;*---------------------------------------------------------------------*/ -;* out ... */ -;*---------------------------------------------------------------------*/ -(define-generic (out node e::%engine) - (cond - ((pair? node) - (out* node e)) - ((string? node) - (let ((f (%engine-filter e))) - (if (procedure? f) - (display (f node)) - (display node)))) - ((number? node) - (display node)) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* out ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (out n::%processor e::%engine) - (with-access::%processor n (combinator engine body procedure) - (let ((newe (processor-get-engine combinator engine e))) - (out (procedure body newe) newe)))) - -;*---------------------------------------------------------------------*/ -;* out ::%command ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%command e::%engine) - (with-access::%command node (fmt body) - (let ((lb (length body)) - (lf (string-length fmt))) - (define (loops i n) - (if (= i lf) - (begin - (if (> n 0) - (if (<= n lb) - (output (list-ref body (- n 1)) e) - (skribe-error '! - "Too few arguments provided" - node))) - lf) - (let ((c (string-ref fmt i))) - (cond - ((char=? c #\$) - (display "$") - (+ 1 i)) - ((not (char-numeric? c)) - (cond - ((= n 0) - i) - ((<= n lb) - (output (list-ref body (- n 1)) e) - i) - (else - (skribe-error '! - "Too few arguments provided" - node)))) - (else - (loops (+ i 1) - (+ (- (char->integer c) - (char->integer #\0)) - (* 10 n)))))))) - (let loop ((i 0)) - (cond - ((= i lf) - #f) - ((not (char=? (string-ref fmt i) #\$)) - (display (string-ref fmt i)) - (loop (+ i 1))) - (else - (loop (loops (+ i 1) 0)))))))) - -;*---------------------------------------------------------------------*/ -;* out ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%handle e::%engine) - #unspecified) - -;*---------------------------------------------------------------------*/ -;* out ::%unresolved ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%unresolved e::%engine) - (error 'output "Orphan unresolved" node)) - -;*---------------------------------------------------------------------*/ -;* out ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%markup e::%engine) - (let ((w (lookup-markup-writer node e))) - (if (writer? w) - (out/writer node e w) - (output (%markup-body node) e)))) - -;*---------------------------------------------------------------------*/ -;* out* ... */ -;*---------------------------------------------------------------------*/ -(define (out* n+ e) - (let loop ((n* n+)) - (cond - ((pair? n*) - (out (car n*) e) - (loop (cdr n*))) - ((not (null? n*)) - (error 'output "Illegal argument" n*))))) - - diff --git a/skribe/src/bigloo/param.bgl b/skribe/src/bigloo/param.bgl deleted file mode 100644 index 6ff6b42..0000000 --- a/skribe/src/bigloo/param.bgl +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 14:03:15 2003 */ -;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe parameters */ -;* ------------------------------------------------------------- */ -;* Implementation: @label param@ */ -;* bigloo: @path ../common/param.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_param - - (import skribe_configure) - - (export *skribe-verbose* - *skribe-warning* - *skribe-path* - *skribe-bib-path* - *skribe-source-path* - *skribe-image-path* - *load-rc* - - *skribe-src* - *skribe-dest* - *skribe-engine* - *skribe-variants* - *skribe-chapter-split* - - *skribe-ref-base* - - *skribe-rc-directory* - *skribe-rc-file* - *skribe-auto-mode-alist* - *skribe-auto-load-alist* - *skribe-preload* - *skribe-precustom* - - *skribebib-auto-mode-alist*)) - -;*---------------------------------------------------------------------*/ -;* *skribe-verbose* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-verbose* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-warning* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-warning* 5) - -;*---------------------------------------------------------------------*/ -;* *skribe-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-path* (skribe-default-path)) - -;*---------------------------------------------------------------------*/ -;* *skribe-bib-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-bib-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-source-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-source-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-image-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-image-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *load-rc* ... */ -;*---------------------------------------------------------------------*/ -(define *load-rc* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-src* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-src* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-dest* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-dest* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-engine* 'html) - -;*---------------------------------------------------------------------*/ -;* *skribe-variants* */ -;*---------------------------------------------------------------------*/ -(define *skribe-variants* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-chapter-split* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-chapter-split* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-ref-base* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-ref-base* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-directory* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file directory. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-directory* - (let ((home (getenv "HOME")) - (host (hostname))) - (let loop ((host (if (not (string? host)) (getenv "HOST") host))) - (if (string? host) - (let ((home/host (string-append home "/.skribe" host))) - (if (and (file-exists? home/host) (directory? home/host)) - home/host - (if (string=? (suffix host) "") - (let ((home/def (make-file-name home ".skribe"))) - (cond - ((and (file-exists? home/def) - (directory? home/def)) - home/def) - (else - home))) - (loop (prefix host))))))))) - diff --git a/skribe/src/bigloo/parseargs.scm b/skribe/src/bigloo/parseargs.scm deleted file mode 100644 index 4ce58c4..0000000 --- a/skribe/src/bigloo/parseargs.scm +++ /dev/null @@ -1,186 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:52:53 2003 */ -;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Argument parsing */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_parse-args - - (include "debug.sch") - - (import skribe_configure - skribe_param - skribe_read - skribe_types - skribe_eval) - - (export (parse-env-variables) - (parse-args ::pair) - (load-rc))) - -;*---------------------------------------------------------------------*/ -;* parse-env-variables ... */ -;*---------------------------------------------------------------------*/ -(define (parse-env-variables) - (let ((e (getenv "SKRIBEPATH"))) - (if (string? e) - (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) - -;*---------------------------------------------------------------------*/ -;* parse-args ... */ -;*---------------------------------------------------------------------*/ -(define (parse-args args) - (define (usage args-parse-usage) - (print "usage: skribe [options] [input]") - (newline) - (args-parse-usage #f) - (newline) - (print "Rc file:") - (newline) - (print " *skribe-rc* (searched in \".\" then $HOME)") - (newline) - (print "Target formats:") - (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) - (newline) - (print "Shell Variables:") - (newline) - (for-each (lambda (var) - (print " - " (car var) " " (cdr var))) - '(("SKRIBEPATH" . "Skribe input path (all files)")))) - (define (version) - (print "skribe v" (skribe-release))) - (define (query) - (version) - (newline) - (for-each (lambda (x) - (let ((s (keyword->string (car x)))) - (printf " ~a: ~a\n" - (substring s 1 (string-length s)) - (cadr x)))) - (skribe-configure))) - (let ((np '()) - (engine #f)) - (args-parse (cdr args) - ((("-h" "--help") (help "This message")) - (usage args-parse-usage) - (exit 0)) - (("--options" (help "Display the skribe options and exit")) - (args-parse-usage #t) - (exit 0)) - (("--version" (help "The version of Skribe")) - (version) - (exit 0)) - ((("-q" "--query") (help "Display informations about the Skribe configuration")) - (query) - (exit 0)) - ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) - (let ((l (string-length key=val))) - (let loop ((i 0)) - (cond - ((= i l) - (skribe-error 'skribe "Illegal option" key=val)) - ((char=? (string-ref key=val i) #\=) - (let ((key (substring key=val 0 i)) - (val (substring key=val (+ i 1) l))) - (set! *skribe-precustom* - (cons (cons (string->symbol key) val) - *skribe-precustom*)))) - (else - (loop (+ i 1))))))) - (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) - (set! *skribe-verbose* (string->integer level)))) - (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-warning* (+fx 1 *skribe-warning*)) - (set! *skribe-warning* (string->integer level)))) - (("-g?level" (help "Increase or set debug level")) - (if (string=? level "") - (set! *skribe-debug* (+fx 1 *skribe-debug*)) - (let ((l (string->integer level))) - (if (= l 0) - (begin - (set! *skribe-debug* 1) - (set! *skribe-debug-symbols* - (cons (string->symbol level) - *skribe-debug-symbols*))) - (set! *skribe-debug* l))))) - (("--no-color" (help "Disable coloring for debug")) - (set! *skribe-debug-color* #f)) - ((("-t" "--target") ?e (help "The output target format")) - (set! engine (string->symbol e))) - (("-I" ?path (help "Add to skribe path")) - (set! np (cons path np))) - (("-B" ?path (help "Add to skribe bibliography path")) - (skribe-bib-path-set! (cons path (skribe-bib-path)))) - (("-S" ?path (help "Add to skribe source path")) - (skribe-source-path-set! (cons path (skribe-source-path)))) - (("-P" ?path (help "Add to skribe image path")) - (skribe-image-path-set! (cons path (skribe-image-path)))) - ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files")) - (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) - (("--eval" ?expr (help "Evaluate expression")) - (with-input-from-string expr - (lambda () - (eval (skribe-read))))) - (("--no-init-file" (help "Dont load rc Skribe file")) - (set! *load-rc* #f)) - ((("-p" "--preload") ?file (help "Preload file")) - (set! *skribe-preload* (cons file *skribe-preload*))) - ((("-u" "--use-variant") ?variant (help "use output format")) - (set! *skribe-variants* (cons variant *skribe-variants*))) - ((("-o" "--output") ?o (help "The output target name")) - (set! *skribe-dest* o) - (let* ((s (suffix o)) - (c (assoc s *skribe-auto-mode-alist*))) - (if (and (pair? c) (symbol? (cdr c))) - (set! *skribe-engine* (cdr c))))) - ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks")) - (set! *skribe-ref-base* base)) - ;; skribe rc directory - ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory")) - (set! *skribe-rc-directory* dir)) - (else - (set! *skribe-src* (cons else *skribe-src*)))) - ;; we have to configure according to the environment variables - (if engine (set! *skribe-engine* engine)) - (set! *skribe-src* (reverse! *skribe-src*)) - (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH") - (reverse! np) - (skribe-path))))) - -;*---------------------------------------------------------------------*/ -;* build-path-from-shell-variable ... */ -;*---------------------------------------------------------------------*/ -(define (build-path-from-shell-variable var) - (let ((val (getenv var))) - (if (string? val) - (string-case val - ((+ (out #\:)) - (let* ((str (the-string)) - (res (ignore))) - (cons str res))) - (#\: - (ignore)) - (else - '())) - '()))) - -;*---------------------------------------------------------------------*/ -;* load-rc ... */ -;*---------------------------------------------------------------------*/ -(define (load-rc) - (if *load-rc* - (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*))) - (if (and (string? file) (file-exists? file)) - (loadq file))))) - diff --git a/skribe/src/bigloo/prog.scm b/skribe/src/bigloo/prog.scm deleted file mode 100644 index baad0f0..0000000 --- a/skribe/src/bigloo/prog.scm +++ /dev/null @@ -1,196 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Aug 27 09:14:28 2003 */ -;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe prog bigloo implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_prog - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (make-prog-body ::obj ::obj ::obj ::obj) - (resolve-line ::bstring))) - -;*---------------------------------------------------------------------*/ -;* *lines* ... */ -;*---------------------------------------------------------------------*/ -(define *lines* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* make-line-mark ... */ -;*---------------------------------------------------------------------*/ -(define (make-line-mark m lnum b) - (let* ((ls (integer->string lnum)) - (n (list (mark ls) b))) - (hashtable-put! *lines* m n) - n)) - -;*---------------------------------------------------------------------*/ -;* resolve-line ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-line id) - (hashtable-get *lines* id)) - -;*---------------------------------------------------------------------*/ -;* extract-string-mark ... */ -;*---------------------------------------------------------------------*/ -(define (extract-string-mark line mark regexp) - (let ((m (pregexp-match regexp line))) - (if (pair? m) - (values (substring (car m) - (string-length mark) - (string-length (car m))) - (pregexp-replace regexp line "")) - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* extract-mark ... */ -;* ------------------------------------------------------------- */ -;* Extract the prog mark from a line. */ -;*---------------------------------------------------------------------*/ -(define (extract-mark line mark regexp) - (cond - ((not regexp) - (values #f line)) - ((string? line) - (extract-string-mark line mark regexp)) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - (values #f line) - (multiple-value-bind (m l) - (extract-mark (car ls) mark regexp) - (if (not m) - (loop (cdr ls) (cons l res)) - (values m (append (reverse! res) (cons l (cdr ls))))))))) - ((%node? line) - (multiple-value-bind (m l) - (extract-mark (%node-body line) mark regexp) - (if (not m) - (values #f line) - (begin - (%node-body-set! line l) - (values m line))))) - (else - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* split-line ... */ -;*---------------------------------------------------------------------*/ -(define (split-line line) - (cond - ((string? line) - (let ((l (string-length line))) - (let loop ((r1 0) - (r2 0) - (res '())) - (cond - ((=fx r2 l) - (if (=fx r1 r2) - (reverse! res) - (reverse! (cons (substring line r1 r2) res)))) - ((char=? (string-ref line r2) #\Newline) - (loop (+fx r2 1) - (+fx r2 1) - (if (=fx r1 r2) - (cons 'eol res) - (cons* 'eol (substring line r1 r2) res)))) - (else - (loop r1 - (+fx r2 1) - res)))))) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - res - (loop (cdr ls) (append res (split-line (car ls))))))) - (else - (list line)))) - -;*---------------------------------------------------------------------*/ -;* flat-lines ... */ -;*---------------------------------------------------------------------*/ -(define (flat-lines lines) - (apply append (map split-line lines))) - -;*---------------------------------------------------------------------*/ -;* collect-lines ... */ -;*---------------------------------------------------------------------*/ -(define (collect-lines lines) - (let loop ((lines (flat-lines lines)) - (res '()) - (tmp '())) - (cond - ((null? lines) - (reverse! (cons (reverse! tmp) res))) - ((eq? (car lines) 'eol) - (cond - ((null? (cdr lines)) - (reverse! (cons (reverse! tmp) res))) - ((and (null? res) (null? tmp)) - (loop (cdr lines) - res - '())) - (else - (loop (cdr lines) - (cons (reverse! tmp) res) - '())))) - (else - (loop (cdr lines) - res - (cons (car lines) tmp)))))) - -;*---------------------------------------------------------------------*/ -;* make-prog-body ... */ -;*---------------------------------------------------------------------*/ -(define (make-prog-body src lnum-init ldigit mark) - (define (int->str i rl) - (let* ((s (integer->string i)) - (l (string-length s))) - (if (= l rl) - s - (string-append (make-string (- rl l) #\space) s)))) - (let* ((regexp (and mark - (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" - (pregexp-quote mark)))) - (src (cond - ((not (pair? src)) (list src)) - ((and (pair? (car src)) (null? (cdr src))) (car src)) - (else src))) - (lines (collect-lines src)) - (lnum (if (integer? lnum-init) lnum-init 1)) - (s (integer->string (+fx (if (integer? ldigit) - (max lnum (expt 10 (-fx ldigit 1))) - lnum) - (length lines)))) - (cs (string-length s))) - (let loop ((lines lines) - (lnum lnum) - (res '())) - (if (null? lines) - (reverse! res) - (multiple-value-bind (m l) - (extract-mark (car lines) mark regexp) - (let ((n (new markup - (markup '&prog-line) - (ident (and lnum-init (int->str lnum cs))) - (body (if m (make-line-mark m lnum l) l))))) - (loop (cdr lines) - (+ lnum 1) - (cons n res)))))))) diff --git a/skribe/src/bigloo/read.scm b/skribe/src/bigloo/read.scm deleted file mode 100644 index 91cd345..0000000 --- a/skribe/src/bigloo/read.scm +++ /dev/null @@ -1,482 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/read.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Dec 27 11:16:00 1994 */ -;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ -;* ------------------------------------------------------------- */ -;* Skribe's reader */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Le module */ -;*---------------------------------------------------------------------*/ -(module skribe_read - (export (skribe-read . port))) - -;*---------------------------------------------------------------------*/ -;* Global counteurs ... */ -;*---------------------------------------------------------------------*/ -(define *par-open* 0) - -;*---------------------------------------------------------------------*/ -;* Parenthesis mismatch (or unclosing) errors. */ -;*---------------------------------------------------------------------*/ -(define *list-error-level* 20) -(define *list-errors* (make-vector *list-error-level* #unspecified)) -(define *vector-errors* (make-vector *list-error-level* #unspecified)) - -;*---------------------------------------------------------------------*/ -;* Control variables. */ -;*---------------------------------------------------------------------*/ -(define *end-of-list* (cons 0 0)) -(define *dotted-mark* (cons 1 1)) - -;*---------------------------------------------------------------------*/ -;* skribe-reader-reset! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-reader-reset!) - (set! *par-open* 0)) - -;*---------------------------------------------------------------------*/ -;* read-error ... */ -;*---------------------------------------------------------------------*/ -(define (read-error msg obj port) - (let* ((obj-loc (if (epair? obj) - (match-case (cer obj) - ((at ?fname ?pos ?-) - pos) - (else - #f)) - #f)) - (loc (if (number? obj-loc) - obj-loc - (cond - ((>fx *par-open* 0) - (let ((open-key (-fx *par-open* 1))) - (if (char (string->integer (the-substring 2 5)))))) - ((: "#\\" (or letter digit special (in "|#; []" quote paren))) - (string-ref (the-string) 2)) - ((: "#\\" (>= 2 letter)) - (let ((char-name (string->symbol - (string-upcase! - (the-substring 2 (the-length)))))) - (case char-name - ((NEWLINE) - #\Newline) - ((TAB) - #\tab) - ((SPACE) - #\space) - ((RETURN) - (integer->char 13)) - (else - (error/location "skribe-read" - "Illegal character" - (the-string) - (input-port-name (the-port)) - (input-port-position (the-port))))))) - - ;; ucs-2 characters - ((: "#u" (= 4 xdigit)) - (integer->ucs2 (string->integer (the-substring 2 6) 16))) - - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (let ((str (the-substring 1 (-fx (the-length) 1)))) - (let ((str (the-substring 0 (-fx (the-length) 1)))) - (escape-C-string str)))) - ;; ucs2 strings - ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (let ((str (the-substring 3 (-fx (the-length) 1)))) - (utf8-string->ucs2-string str))) - - ;; fixnums - ((: (? (in "-+")) (+ digit)) - (the-fixnum)) - ((: "#o" (? (in "-+")) (+ (in ("07")))) - (string->integer (the-substring 2 (the-length)) 8)) - ((: "#d" (? (in "-+")) (+ (in ("09")))) - (string->integer (the-substring 2 (the-length)) 10)) - ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af")))))) - (string->integer (the-substring 2 (the-length)) 16)) - ((: "#e" (? (in "-+")) (+ digit)) - (string->elong (the-substring 2 (the-length)) 10)) - ((: "#l" (? (in "-+")) (+ digit)) - (string->llong (the-substring 2 (the-length)) 10)) - - ;; flonum - ((: (? (in "-+")) - (or float - (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit)))) - (the-flonum)) - - ;; doted pairs - ("." - (if (<=fx *par-open* 0) - (error/location "read" - "Illegal token" - #\. - (input-port-name (the-port)) - (input-port-position (the-port))) - *dotted-mark*)) - - ;; unspecified and eof-object - ((: "#" (in "ue") (+ (in "nspecified-objt"))) - (let ((symbol (string->symbol - (string-upcase! - (the-substring 1 (the-length)))))) - (case symbol - ((UNSPECIFIED) - unspec) - ((EOF-OBJECT) - beof) - (else - (error/location "read" - "Illegal identifier" - symbol - (input-port-name (the-port)) - (input-port-position (the-port))))))) - - ;; booleans - ((: "#" (uncase #\t)) - #t) - ((: "#" (uncase #\f)) - #f) - - ;; keywords - ((or (: ":" kid) (: kid ":")) - ;; since the keyword expression is also matched by the id - ;; rule, keyword rule has to be placed before the id rule. - (the-keyword)) - - ;; identifiers - (id - ;; this rule has to be placed after the rule matching the `.' char - (the-symbol)) - ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|") - (if (=fx (the-length) 2) - (the-symbol) - (let ((str (the-substring 0 (-fx (the-length) 1)))) - (string->symbol (escape-C-string str))))) - - ;; quotations - ("'" - (read-quote 'quote (the-port) ignore)) - ("`" - (read-quote 'quasiquote (the-port) ignore)) - ("," - (read-quote 'unquote (the-port) ignore)) - (",@" - (read-quote 'unquote-splicing (the-port) ignore)) - - ;; lists - (#\( - ;; if possible, we store the opening parenthesis. - (if (and (vector? *list-errors*) - (vector (reverse! (collect-up-to ignore "vector" (the-port))))) - - ;; error or eof - (else - (let ((port (the-port)) - (char (the-failure))) - (if (eof-object? char) - (cond - ((>fx *par-open* 0) - (let ((open-key (-fx *par-open* 1))) - (skribe-reader-reset!) - (if (and (fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (let loop ((c -1) - (s (readl (current-input-port))) - (r '())) - (let ((p (input-port-position (current-input-port)))) - (cond - ((eof-object? s) - (apply string-append (reverse! r))) - ((>=fx p stop) - (let* ((len (-fx (-fx stop start) c)) - (line (untabify (substring s 0 len) tab))) - (apply string-append - (reverse! (cons line r))))) - ((>=fx c 0) - (loop (+fx (string-length s) c) - (readl (current-input-port)) - (cons (untabify s tab) r))) - ((>=fx p start) - (let* ((len (string-length s)) - (nc (-fx p start))) - (if (>fx p stop) - (untabify - (substring s - (-fx len (-fx p start)) - (-fx (-fx p stop) 1)) - tab) - (loop nc - (readl (current-input-port)) - (list - (untabify - (substring s - (-fx len (-fx p start)) - len) - tab)))))) - (else - (loop c (readl (current-input-port)) r)))))))))) - -;*---------------------------------------------------------------------*/ -;* source-read-lines ... */ -;*---------------------------------------------------------------------*/ -(define (source-read-lines file start stop tab) - (let ((p (find-file/path file (skribe-source-path)))) - (if (or (not (string? p)) (not (file-exists? p))) - (skribe-error 'source - (format "Can't find `~a' source file in path" file) - (skribe-source-path)) - (with-input-from-file p - (lambda () - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (let ((startl (if (string? start) (string-length start) -1)) - (stopl (if (string? stop) (string-length stop) -1))) - (let loop ((l 1) - (armedp (not (or (integer? start) - (string? start)))) - (s (read-line)) - (r '())) - (cond - ((or (eof-object? s) - (and (integer? stop) (> l stop)) - (and (string? stop) (substring=? stop s stopl))) - (apply string-append (reverse! r))) - (armedp - (loop (+fx l 1) - #t - (read-line) - (cons* "\n" (untabify s tab) r))) - ((and (integer? start) (>= l start)) - (loop (+fx l 1) - #t - (read-line) - (cons* "\n" (untabify s tab) r))) - ((and (string? start) (substring=? start s startl)) - (loop (+fx l 1) #t (read-line) r)) - (else - (loop (+fx l 1) #f (read-line) r)))))))))) - -;*---------------------------------------------------------------------*/ -;* untabify ... */ -;*---------------------------------------------------------------------*/ -(define (untabify obj tab) - (if (not tab) - obj - (let ((len (string-length obj)) - (tabl tab)) - (let loop ((i 0) - (col 1)) - (cond - ((=fx i len) - (let ((nlen (-fx col 1))) - (if (=fx len nlen) - obj - (let ((new (make-string col #\space))) - (let liip ((i 0) - (j 0) - (col 1)) - (cond - ((=fx i len) - new) - ((char=? (string-ref obj i) #\tab) - (let ((next-tab (*fx (/fx (+fx col tabl) - tabl) - tabl))) - (liip (+fx i 1) - next-tab - next-tab))) - (else - (string-set! new j (string-ref obj i)) - (liip (+fx i 1) (+fx j 1) (+fx col 1))))))))) - ((char=? (string-ref obj i) #\tab) - (loop (+fx i 1) - (*fx (/fx (+fx col tabl) tabl) tabl))) - (else - (loop (+fx i 1) (+fx col 1)))))))) - -;*---------------------------------------------------------------------*/ -;* source-read-definition ... */ -;*---------------------------------------------------------------------*/ -(define (source-read-definition file definition tab lang) - (let ((p (find-file/path file (skribe-source-path)))) - (cond - ((not (%language-extractor lang)) - (skribe-error 'source - "The specified language has not defined extractor" - lang)) - ((or (not p) (not (file-exists? p))) - (skribe-error 'source - (format "Can't find `~a' program file in path" file) - (skribe-source-path))) - (else - (let ((ip (open-input-file p))) - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (if (not (input-port? ip)) - (skribe-error 'source "Can't open file for input" p) - (unwind-protect - (let ((s ((%language-extractor lang) ip definition tab))) - (if (not (string? s)) - (skribe-error 'source - "Can't find definition" - definition) - s)) - (close-input-port ip)))))))) - -;*---------------------------------------------------------------------*/ -;* source-fontify ... */ -;*---------------------------------------------------------------------*/ -(define (source-fontify o language) - (define (fontify f o) - (cond - ((string? o) (f o)) - ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) - (else o))) - (let ((f (%language-fontifier language))) - (if (procedure? f) - (fontify f o) - o))) - -;*---------------------------------------------------------------------*/ -;* split-string-newline ... */ -;*---------------------------------------------------------------------*/ -(define (split-string-newline str) - (let ((l (string-length str))) - (let loop ((i 0) - (j 0) - (r '())) - (cond - ((=fx i l) - (if (=fx i j) - (reverse! r) - (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) - (loop (+fx i 1) - (+fx i 1) - (if (=fx i j) - (cons 'eol r) - (cons* 'eol (substring str j i) r)))) - ((and (char=? (string-ref str i) #a013) - (url ::bstring ::obj ::obj ::pair-nil) - (sui-title::bstring ::pair-nil) - (sui-file::obj ::pair-nil) - (sui-key::obj ::pair-nil ::obj) - (sui-filter::pair-nil ::obj ::procedure ::procedure))) - diff --git a/skribe/src/bigloo/types.scm b/skribe/src/bigloo/types.scm deleted file mode 100644 index b8babd4..0000000 --- a/skribe/src/bigloo/types.scm +++ /dev/null @@ -1,685 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/types.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:40:42 2003 */ -;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The definition of the Skribe classes */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_types - - (export (abstract-class %ast - (parent (default #unspecified)) - (loc (default (evmeaning-location)))) - - (class %command::%ast - (fmt::bstring read-only) - (body (default #f))) - - (class %unresolved::%ast - (proc::procedure read-only)) - - (class %handle::%ast - (ast (default #f))) - - (abstract-class %node::%ast - (required-options::pair-nil read-only (default '())) - (options::pair-nil (default '())) - (body (default #f))) - - (class %processor::%node - (combinator (default (lambda (e1 e2) e1))) - (procedure::procedure (default (lambda (n e) n))) - engine) - - (class %markup::%node - (markup-init) - (ident (default #f)) - (class (default #f)) - (markup::symbol read-only)) - - (class %container::%markup - (env::pair-nil (default '()))) - - (class %document::%container) - - (class %engine - (ident::symbol read-only) - (format::bstring (default "raw")) - (info::pair-nil (default '())) - (version::obj read-only (default #unspecified)) - (delegate read-only (default #f)) - (writers::pair-nil (default '())) - (filter::obj (default #f)) - (customs::pair-nil (default '())) - (symbol-table::pair-nil (default '()))) - - (class %writer - (ident::symbol read-only) - (class read-only) - (pred::procedure read-only) - (upred read-only) - (options::obj read-only) - (verified?::bool (default #f)) - (validate (default #f)) - (before read-only) - (action read-only) - (after read-only)) - - (class %language - (name::bstring read-only) - (fontifier read-only (default #f)) - (extractor read-only (default #f))) - - (markup-init ::%markup) - (find-markups ::bstring) - - (inline ast?::bool ::obj) - (inline ast-parent::obj ::%ast) - (inline ast-loc::obj ::%ast) - (inline ast-loc-set!::obj ::%ast ::obj) - (ast-location::bstring ::%ast) - - (new-command . inits) - (inline command?::bool ::obj) - (inline command-fmt::bstring ::%command) - (inline command-body::obj ::%command) - - (new-unresolved . inits) - (inline unresolved?::bool ::obj) - (inline unresolved-proc::procedure ::%unresolved) - - (new-handle . inits) - (inline handle?::bool ::obj) - (inline handle-ast::obj ::%handle) - - (inline node?::bool ::obj) - (inline node-body::obj ::%node) - (inline node-options::pair-nil ::%node) - (inline node-loc::obj ::%node) - - (new-processor . inits) - (inline processor?::bool ::obj) - (inline processor-combinator::obj ::%processor) - (inline processor-engine::obj ::%processor) - - (new-markup . inits) - (inline markup?::bool ::obj) - (inline is-markup?::bool ::obj ::symbol) - (inline markup-markup::obj ::%markup) - (inline markup-ident::obj ::%markup) - (inline markup-body::obj ::%markup) - (inline markup-options::pair-nil ::%markup) - - (new-container . inits) - (inline container?::bool ::obj) - (inline container-ident::obj ::%container) - (inline container-body::obj ::%container) - (inline container-options::pair-nil ::%container) - - (new-document . inits) - (inline document?::bool ::obj) - (inline document-ident::bool ::%document) - (inline document-body::bool ::%document) - (inline document-options::pair-nil ::%document) - (inline document-env::pair-nil ::%document) - - (inline engine?::bool ::obj) - (inline engine-ident::obj ::obj) - (inline engine-format::obj ::obj) - (inline engine-customs::pair-nil ::obj) - (inline engine-filter::obj ::obj) - (inline engine-symbol-table::pair-nil ::%engine) - - (inline writer?::bool ::obj) - (inline writer-before::obj ::%writer) - (inline writer-action::obj ::%writer) - (inline writer-after::obj ::%writer) - (inline writer-options::obj ::%writer) - - (inline language?::bool ::obj) - (inline language-name::obj ::obj) - (inline language-fontifier::obj ::obj) - (inline language-extractor::obj ::obj) - - (new-language . inits) - - (location?::bool ::obj) - (location-file::bstring ::pair) - (location-pos::int ::pair))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate ... */ -;*---------------------------------------------------------------------*/ -(define-macro (skribe-instantiate type values . slots) - `(begin - (skribe-instantiate-check-values ',type ,values ',slots) - (,(symbol-append 'instantiate::% type) - ,@(map (lambda (slot) - (let ((id (if (pair? slot) (car slot) slot)) - (def (if (pair? slot) (cadr slot) #f))) - `(,id (new-get-value ',id ,values ,def)))) - slots)))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate-check-values ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-instantiate-check-values id values slots) - (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) - (when (pair? bs) - (for-each (lambda (b) - (error (symbol-append '|new | id) - "Illegal field" - b)) - bs)))) - -;*---------------------------------------------------------------------*/ -;* object-print ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-print obj::%ast port print-slot::procedure) - (let* ((class (object-class obj)) - (class-name (class-name class))) - (display "#|" port) - (display class-name port) - (display #\| port))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%ast ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%ast . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a>" - (find-runtime-type n))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a>" - (find-runtime-type n) - (markup-markup n))) - -;*---------------------------------------------------------------------*/ -;* object-write ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-write n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a:~a>" - (find-runtime-type n) - (markup-markup n) - (find-runtime-type (markup-body n)))) - -;*---------------------------------------------------------------------*/ -;* *node-table* */ -;* ------------------------------------------------------------- */ -;* A private hashtable that stores all the nodes of an ast. It */ -;* is used for retreiving a node from its identifier. */ -;*---------------------------------------------------------------------*/ -(define *node-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* ast? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast? obj) - (%ast? obj)) - -;*---------------------------------------------------------------------*/ -;* ast-parent ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-parent obj) - (%ast-parent obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc obj) - (%ast-loc obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc-set! ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc-set! obj loc) - (%ast-loc-set! obj loc)) - -;*---------------------------------------------------------------------*/ -;* ast-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast-location obj) - (with-access::%ast obj (loc) - (if (location? loc) - (let* ((fname (location-file loc)) - (char (location-pos loc)) - (pwd (pwd)) - (len (string-length pwd)) - (lenf (string-length fname)) - (file (if (and (substring=? pwd fname len) - (and (>fx lenf len))) - (substring fname len (+fx 1 (string-length fname))) - fname))) - (format "~a, char ~a" file char)) - "no source location"))) - -;*---------------------------------------------------------------------*/ -;* new-command ... */ -;*---------------------------------------------------------------------*/ -(define (new-command . init) - (skribe-instantiate command init - (parent #unspecified) - (loc #f) - fmt - (body #f))) - -;*---------------------------------------------------------------------*/ -;* command? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command? obj) - (%command? obj)) - -;*---------------------------------------------------------------------*/ -;* command-fmt ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-fmt cmd) - (%command-fmt cmd)) - -;*---------------------------------------------------------------------*/ -;* command-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-body cmd) - (%command-body cmd)) - -;*---------------------------------------------------------------------*/ -;* new-unresolved ... */ -;*---------------------------------------------------------------------*/ -(define (new-unresolved . init) - (skribe-instantiate unresolved init - (parent #unspecified) - loc - proc)) - -;*---------------------------------------------------------------------*/ -;* unresolved? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved? obj) - (%unresolved? obj)) - -;*---------------------------------------------------------------------*/ -;* unresolved-proc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved-proc unr) - (%unresolved-proc unr)) - -;*---------------------------------------------------------------------*/ -;* new-handle ... */ -;*---------------------------------------------------------------------*/ -(define (new-handle . init) - (skribe-instantiate handle init - (parent #unspecified) - loc - (ast #f))) - -;*---------------------------------------------------------------------*/ -;* handle? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle? obj) - (%handle? obj)) - -;*---------------------------------------------------------------------*/ -;* handle-ast ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle-ast obj) - (%handle-ast obj)) - -;*---------------------------------------------------------------------*/ -;* node? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node? obj) - (%node? obj)) - -;*---------------------------------------------------------------------*/ -;* node-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-body obj) - (%node-body obj)) - -;*---------------------------------------------------------------------*/ -;* node-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-options obj) - (%node-options obj)) - -;*---------------------------------------------------------------------*/ -;* node-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-loc obj) - (%node-loc obj)) - -;*---------------------------------------------------------------------*/ -;* new-processor ... */ -;*---------------------------------------------------------------------*/ -(define (new-processor . init) - (skribe-instantiate processor init - (parent #unspecified) - loc - (combinator (lambda (e1 e2) e1)) - engine - (body #f))) - -;*---------------------------------------------------------------------*/ -;* processor? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor? obj) - (%processor? obj)) - -;*---------------------------------------------------------------------*/ -;* processor-combinator ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-combinator proc) - (%processor-combinator proc)) - -;*---------------------------------------------------------------------*/ -;* processor-engine ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-engine proc) - (%processor-engine proc)) - -;*---------------------------------------------------------------------*/ -;* new-markup ... */ -;*---------------------------------------------------------------------*/ -(define (new-markup . init) - (skribe-instantiate markup init - (parent #unspecified) - (loc #f) - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()))) - -;*---------------------------------------------------------------------*/ -;* markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup? obj) - (%markup? obj)) - -;*---------------------------------------------------------------------*/ -;* is-markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (is-markup? obj markup) - (and (markup? obj) (eq? (markup-markup obj) markup))) - -;*---------------------------------------------------------------------*/ -;* markup-init ... */ -;* ------------------------------------------------------------- */ -;* The markup constructor simply stores in the markup table the */ -;* news markups. */ -;*---------------------------------------------------------------------*/ -(define (markup-init markup) - (bind-markup! markup)) - -;*---------------------------------------------------------------------*/ -;* bind-markup! ... */ -;*---------------------------------------------------------------------*/ -(define (bind-markup! node) - (hashtable-update! *node-table* - (markup-ident node) - (lambda (cur) (cons node cur)) - (list node))) - -;*---------------------------------------------------------------------*/ -;* find-markups ... */ -;*---------------------------------------------------------------------*/ -(define (find-markups ident) - (hashtable-get *node-table* ident)) - -;*---------------------------------------------------------------------*/ -;* markup-markup ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-markup obj) - (%markup-markup obj)) - -;*---------------------------------------------------------------------*/ -;* markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-ident obj) - (%markup-ident obj)) - -;*---------------------------------------------------------------------*/ -;* markup-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-body obj) - (%markup-body obj)) - -;*---------------------------------------------------------------------*/ -;* markup-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-options obj) - (%markup-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-container ... */ -;*---------------------------------------------------------------------*/ -(define (new-container . init) - (skribe-instantiate container init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* container? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container? obj) - (%container? obj)) - -;*---------------------------------------------------------------------*/ -;* container-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-ident obj) - (%container-ident obj)) - -;*---------------------------------------------------------------------*/ -;* container-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-body obj) - (%container-body obj)) - -;*---------------------------------------------------------------------*/ -;* container-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-options obj) - (%container-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-document ... */ -;*---------------------------------------------------------------------*/ -(define (new-document . init) - (skribe-instantiate document init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* document? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document? obj) - (%document? obj)) - -;*---------------------------------------------------------------------*/ -;* document-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-options doc) - (%document-options doc)) - -;*---------------------------------------------------------------------*/ -;* document-env ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-env doc) - (%document-env doc)) - -;*---------------------------------------------------------------------*/ -;* document-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-ident doc) - (%document-ident doc)) - -;*---------------------------------------------------------------------*/ -;* document-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-body doc) - (%document-body doc)) - -;*---------------------------------------------------------------------*/ -;* engine? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine? obj) - (%engine? obj)) - -;*---------------------------------------------------------------------*/ -;* engine-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-ident obj) - (%engine-ident obj)) - -;*---------------------------------------------------------------------*/ -;* engine-format ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-format obj) - (%engine-format obj)) - -;*---------------------------------------------------------------------*/ -;* engine-customs ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-customs obj) - (%engine-customs obj)) - -;*---------------------------------------------------------------------*/ -;* engine-filter ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-filter obj) - (%engine-filter obj)) - -;*---------------------------------------------------------------------*/ -;* engine-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-symbol-table obj) - (%engine-symbol-table obj)) - -;*---------------------------------------------------------------------*/ -;* writer? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer? obj) - (%writer? obj)) - -;*---------------------------------------------------------------------*/ -;* writer-before ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-before obj) - (%writer-before obj)) - -;*---------------------------------------------------------------------*/ -;* writer-action ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-action obj) - (%writer-action obj)) - -;*---------------------------------------------------------------------*/ -;* writer-after ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-after obj) - (%writer-after obj)) - -;*---------------------------------------------------------------------*/ -;* writer-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-options obj) - (%writer-options obj)) - -;*---------------------------------------------------------------------*/ -;* language? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language? obj) - (%language? obj)) - -;*---------------------------------------------------------------------*/ -;* language-name ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-name lg) - (%language-name lg)) - -;*---------------------------------------------------------------------*/ -;* language-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-fontifier lg) - (%language-fontifier lg)) - -;*---------------------------------------------------------------------*/ -;* language-extractor ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-extractor lg) - (%language-extractor lg)) - -;*---------------------------------------------------------------------*/ -;* new-get-value ... */ -;*---------------------------------------------------------------------*/ -(define (new-get-value key init def) - (let ((c (assq key init))) - (match-case c - ((?- ?v) - v) - (else - def)))) - -;*---------------------------------------------------------------------*/ -;* new-language ... */ -;*---------------------------------------------------------------------*/ -(define (new-language . init) - (skribe-instantiate language init name fontifier extractor)) - -;*---------------------------------------------------------------------*/ -;* location? ... */ -;*---------------------------------------------------------------------*/ -(define (location? o) - (match-case o - ((at ?- ?-) - #t) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* location-file ... */ -;*---------------------------------------------------------------------*/ -(define (location-file o) - (match-case o - ((at ?fname ?-) - fname) - (else - (error 'location-file "Illegal location" o)))) - -;*---------------------------------------------------------------------*/ -;* location-pos ... */ -;*---------------------------------------------------------------------*/ -(define (location-pos o) - (match-case o - ((at ?- ?loc) - loc) - (else - (error 'location-pos "Illegal location" o)))) diff --git a/skribe/src/bigloo/verify.scm b/skribe/src/bigloo/verify.scm deleted file mode 100644 index 602a951..0000000 --- a/skribe/src/bigloo/verify.scm +++ /dev/null @@ -1,143 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jul 25 09:54:55 2003 */ -;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe verification stage */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_verify - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (generic verify ::obj ::%engine))) - -;*---------------------------------------------------------------------*/ -;* check-required-options ... */ -;*---------------------------------------------------------------------*/ -(define (check-required-options n::%markup w::%writer e::%engine) - (with-access::%markup n (required-options) - (with-access::%writer w (ident options verified?) - (or verified? - (eq? options 'all) - (begin - (for-each (lambda (o) - (if (not (memq o options)) - (skribe-error (%engine-ident e) - (format "Option unsupported: ~a, supported options: ~a" o options) - n))) - required-options) - (set! verified? #t)))))) - -;*---------------------------------------------------------------------*/ -;* check-options ... */ -;* ------------------------------------------------------------- */ -;* Only keywords are checked, symbols are voluntary left unchecked. */ -;*---------------------------------------------------------------------*/ -(define (check-options eo*::pair-nil m::%markup e::%engine) - (with-debug 6 'check-options - (debug-item "markup=" (%markup-markup m)) - (debug-item "options=" (%markup-options m)) - (debug-item "eo*=" eo*) - (for-each (lambda (o2) - (for-each (lambda (o) - (if (and (keyword? o) - (not (eq? o :&skribe-eval-location)) - (not (memq o eo*))) - (skribe-warning/ast - 3 - m - 'verify - (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" - (%engine-ident e) - (%markup-markup m) - o - (markup-option m o))))) - o2)) - (%markup-options m)))) - -;*---------------------------------------------------------------------*/ -;* verify :: ... */ -;*---------------------------------------------------------------------*/ -(define-generic (verify node e) - (if (pair? node) - (for-each (lambda (n) (verify n e)) node)) - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify n::%processor e) - (with-access::%processor n (combinator engine body) - (verify body (processor-get-engine combinator engine e)) - n)) - -;*---------------------------------------------------------------------*/ -;* verify ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%node e) - (with-access::%node node (body options) - (verify body e) - (for-each (lambda (o) (verify (cadr o) e)) options) - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%markup e) - (with-debug 5 'verify::%markup - (debug-item "node=" (%markup-markup node)) - (debug-item "options=" (%markup-options node)) - (debug-item "e=" (%engine-ident e)) - (call-next-method) - (let ((w (lookup-markup-writer node e))) - (if (%writer? w) - (begin - (check-required-options node w e) - (if (pair? (%writer-options w)) - (check-options (%writer-options w) node e)) - (let ((validate (%writer-validate w))) - (when (procedure? validate) - (unless (validate node e) - (skribe-warning - 1 - node - (format "Node `~a' forbidden here by ~a engine" - (markup-markup node) - (engine-ident e)) - node))))))) - ;; return the node - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%document ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%document e) - (call-next-method) - ;; verify the engine custom - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (set-car! (cdr c) (verify a e)))) - (%engine-customs e)) - ;; return the node - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%handle e) - node) - diff --git a/skribe/src/bigloo/writer.scm b/skribe/src/bigloo/writer.scm deleted file mode 100644 index ce515bf..0000000 --- a/skribe/src/bigloo/writer.scm +++ /dev/null @@ -1,232 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 06:19:57 2003 */ -;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe writer management */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_writer - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_engine - skribe_output - skribe_lib) - - (export (invoke proc node e) - - (lookup-markup-writer ::%markup ::%engine) - - (markup-writer ::obj #!optional e #!key p class opt va bef aft act) - (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) - (markup-writer-get ::obj #!optional e #!key class pred) - (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) - -;*---------------------------------------------------------------------*/ -;* invoke ... */ -;*---------------------------------------------------------------------*/ -(define (invoke proc node e) - (let ((id (if (markup? node) - (string->symbol - (format "~a#~a" - (%engine-ident e) - (%markup-markup node))) - (%engine-ident e)))) - (with-push-trace id - (with-debug 5 'invoke - (debug-item "e=" (%engine-ident e)) - (debug-item "node=" (find-runtime-type node) - " " (if (markup? node) (%markup-markup node) "")) - (if (string? proc) - (display proc) - (if (procedure? proc) - (proc node e))))))) - -;*---------------------------------------------------------------------*/ -;* lookup-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (lookup-markup-writer node e) - (with-access::%engine e (writers delegate) - (let loop ((w* writers)) - (cond - ((pair? w*) - (with-access::%writer (car w*) (pred) - (if (pred node e) - (car w*) - (loop (cdr w*))))) - ((engine? delegate) - (lookup-markup-writer node delegate)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* make-writer-predicate ... */ -;*---------------------------------------------------------------------*/ -(define (make-writer-predicate markup predicate class) - (let* ((t1 (if (symbol? markup) - (lambda (n e) (is-markup? n markup)) - (lambda (n e) #t))) - (t2 (if class - (lambda (n e) - (and (t1 n e) (equal? (%markup-class n) class))) - t1))) - (if predicate - (cond - ((not (procedure? predicate)) - (skribe-error 'markup-writer - "Illegal predicate (procedure expected)" - predicate)) - ((not (correct-arity? predicate 2)) - (skribe-error 'markup-writer - "Illegal predicate arity (2 arguments expected)" - predicate)) - (else - (lambda (n e) - (and (t2 n e) (predicate n e))))) - t2))) - -;*---------------------------------------------------------------------*/ -;* markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (markup-writer markup - #!optional - engine - #!key - (predicate #f) - (class #f) - (options '()) - (validate #f) - (before #f) - (action #unspecified) - (after #f)) - (let ((e (or engine (default-engine)))) - (cond - ((and (not (symbol? markup)) (not (eq? markup #t))) - (skribe-error 'markup-writer "Illegal markup" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - ((and (not predicate) - (not class) - (null? options) - (not before) - (eq? action #unspecified) - (not after)) - (skribe-error 'markup-writer "Illegal writer" markup)) - (else - (let ((m (make-writer-predicate markup predicate class)) - (ac (if (eq? action #unspecified) - (lambda (n e) - (output (markup-body n) e)) - action))) - (engine-add-writer! e markup m predicate - options before ac after class validate)))))) - -;*---------------------------------------------------------------------*/ -;* copy-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (copy-markup-writer markup old-engine - #!optional new-engine - #!key - (predicate #unspecified) - (class #unspecified) - (options #unspecified) - (validate #unspecified) - (before #unspecified) - (action #unspecified) - (after #unspecified)) - (let ((old (markup-writer-get markup old-engine)) - (new-engine (or new-engine old-engine))) - (markup-writer markup new-engine - :pred (if (unspecified? predicate) - (%writer-pred old) - predicate) - :class (if (unspecified? class) - (%writer-class old) - class) - :options (if (unspecified? options) - (%writer-options old) - options) - :validate (if (unspecified? validate) - (%writer-validate old) - validate) - :before (if (unspecified? before) - (%writer-before old) - before) - :action (if (unspecified? action) - (%writer-action old) - action) - :after (if (unspecified? after) - (%writer-after old) after)))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get ... */ -;* ------------------------------------------------------------- */ -;* Finds the writer that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e)) - (let loop ((w* (%engine-writers e))) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class) - (or (eq? pred #unspecified) - (eq? (%writer-upred (car w*)) pred))) - (car w*) - (loop (cdr w*)))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get* ... */ -;* ------------------------------------------------------------- */ -;* Finds alll writers that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get* markup #!optional engine #!key (class #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e) - (res '())) - (let loop ((w* (%engine-writers e)) - (res res)) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class)) - (loop (cdr w*) (cons (car w*) res)) - (loop (cdr w*) res))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e) res)) - (else - (reverse! res))))))))) diff --git a/skribe/src/bigloo/xml.scm b/skribe/src/bigloo/xml.scm deleted file mode 100644 index d4c662e..0000000 --- a/skribe/src/bigloo/xml.scm +++ /dev/null @@ -1,92 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Mon May 17 10:14:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* XML fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_xml - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export xml)) - -;*---------------------------------------------------------------------*/ -;* xml ... */ -;*---------------------------------------------------------------------*/ -(define xml - (new language - (name "xml") - (fontifier xml-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* xml-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (xml-fontifier s) - (let ((g (regular-grammar () - ((: #\; (in "") - ;; italic comments - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-line-comment) - (body s)))) - str) - (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>) - ;; markup - (let ((str (the-string))) - (let ((c (new markup - (markup '&source-module) - (body (the-string))))) - (cons c (ignore))))) - ((+ (out #\< #\> #\Space #\Tab #\= #\")) - ;; regular text - (let ((string (the-string))) - (cons string (ignore)))) - ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'")) - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((in "\"=") - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(xml)" "Unexpected character" c))))))) - (with-input-from-string s - (lambda () - (read/rp g (current-input-port)))))) - diff --git a/skribe/src/common/api.scm b/skribe/src/common/api.scm deleted file mode 100644 index 397ba09..0000000 --- a/skribe/src/common/api.scm +++ /dev/null @@ -1,1243 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/api.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:11:56 2003 */ -;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scribe API */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../bigloo/api.bgl@ */ -;* Documentation: */ -;* @path ../../doc/user/markup.skb@ */ -;* @path ../../doc/user/document.skb@ */ -;* @path ../../doc/user/sectioning.skb@ */ -;* @path ../../doc/user/toc.skb@ */ -;* @path ../../doc/user/ornament.skb@ */ -;* @path ../../doc/user/line.skb@ */ -;* @path ../../doc/user/font.skb@ */ -;* @path ../../doc/user/justify.skb@ */ -;* @path ../../doc/user/enumeration.skb@ */ -;* @path ../../doc/user/colframe.skb@ */ -;* @path ../../doc/user/figure.skb@ */ -;* @path ../../doc/user/image.skb@ */ -;* @path ../../doc/user/table.skb@ */ -;* @path ../../doc/user/footnote.skb@ */ -;* @path ../../doc/user/char.skb@ */ -;* @path ../../doc/user/links.skb@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* include ... */ -;*---------------------------------------------------------------------*/ -(define-markup (include file) - (if (not (string? file)) - (skribe-error 'include "Illegal file (string expected)" file) - (skribe-include file))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(define-markup (document #!rest - opts - #!key - (ident #f) (class "document") - (title #f) (html-title #f) (author #f) - (ending #f) (env '())) - (new document - (markup 'document) - (ident (or ident - (ast->string title) - (symbol->string (gensym 'document)))) - (class class) - (required-options '(:title :author :ending)) - (options (the-options opts :ident :class :env)) - (body (the-body opts)) - (env (append env - (list (list 'chapter-counter 0) (list 'chapter-env '()) - (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()) - (list 'figure-counter 0) (list 'figure-env '())))))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(define-markup (author #!rest - opts - #!key - (ident #f) (class "author") - name - (title #f) - (affiliation #f) - (email #f) - (url #f) - (address #f) - (phone #f) - (photo #f) - (align 'center)) - (if (not (memq align '(center left right))) - (skribe-error 'author "Illegal align value" align) - (new container - (markup 'author) - (ident (or ident (symbol->string (gensym 'author)))) - (class class) - (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) - (options `((:name ,name) - (:align ,align) - ,@(the-options opts :ident :class))) - (body #f)))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(define-markup (toc #!rest - opts - #!key - (ident #f) (class "toc") - (chapter #t) (section #t) (subsection #f)) - (let ((body (the-body opts))) - (new container - (markup 'toc) - (ident (or ident (symbol->string (gensym 'toc)))) - (class class) - (required-options '()) - (options `((:chapter ,chapter) - (:section ,section) - (:subsection ,subsection) - ,@(the-options opts :ident :class))) - (body (cond - ((null? body) - (new unresolved - (proc (lambda (n e env) - (handle - (resolve-search-parent n env document?)))))) - ((null? (cdr body)) - (if (handle? (car body)) - (car body) - (skribe-error 'toc - "Illegal argument (handle expected)" - (if (markup? (car body)) - (markup-markup (car body)) - "???")))) - (else - (skribe-error 'toc "Illegal argument" body))))))) - -;*---------------------------------------------------------------------*/ -;* chapter ... ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:chapter@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:chapter@ */ -;*---------------------------------------------------------------------*/ -(define-markup (chapter #!rest - opts - #!key - (ident #f) (class "chapter") - title (html-title #f) (file #f) (toc #t) (number #t)) - (new container - (markup 'chapter) - (ident (or ident (ast->string title))) - (class class) - (required-options '(:title :file :toc :number)) - (options `((:toc ,toc) - (:number ,(and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n - env - 'chapter - number)))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()))))) - -;*---------------------------------------------------------------------*/ -;* section-number ... */ -;*---------------------------------------------------------------------*/ -(define (section-number number markup) - (and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n env markup number)))))) - -;*---------------------------------------------------------------------*/ -;* section ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:section@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:sectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (section #!rest - opts - #!key - (ident #f) (class "section") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'section) - (ident (or ident (ast->string title))) - (class class) - (required-options '(:title :toc :file :toc :number)) - (options `((:number ,(section-number number 'section)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (if file - (list (list 'subsection-counter 0) (list 'subsection-env '()) - (list 'footnote-counter 0) (list 'footnote-env '())) - (list (list 'subsection-counter 0) (list 'subsection-env '())))))) - -;*---------------------------------------------------------------------*/ -;* subsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsection #!rest - opts - #!key - (ident #f) (class "subsection") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'subsection) - (ident (or ident (ast->string title))) - (class class) - (required-options '(:title :toc :file :number)) - (options `((:number ,(section-number number 'subsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsubsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsubsection #!rest - opts - #!key - (ident #f) (class "subsubsection") - title (file #f) (toc #f) (number #t)) - (new container - (markup 'subsubsection) - (ident (or ident (ast->string title))) - (class class) - (required-options '(:title :toc :number :file)) - (options `((:number ,(section-number number 'subsubsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup paragraph) - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(define-markup (footnote #!rest opts - #!key (ident #f) (class "footnote") (number #f)) - (new container - (markup 'footnote) - (ident (symbol->string (gensym 'footnote))) - (class class) - (required-options '()) - (options `((:number - ,(new unresolved - (proc (lambda (n e env) - (resolve-counter n env 'footnote #t))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) - (let ((ln (new markup - (ident (or ident (symbol->string (gensym 'linebreak)))) - (class class) - (markup 'linebreak))) - (num (the-body opts))) - (cond - ((null? num) - ln) - ((not (null? (cdr num))) - (skribe-error 'linebreak "Illegal arguments" num)) - ((not (and (integer? (car num)) (positive? (car num)))) - (skribe-error 'linebreak "Illegal argument" (car num))) - (else - (vector->list (make-vector (car num) ln)))))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(define-markup (hrule #!rest - opts - #!key - (ident #f) (class #f) - (width 100.) (height 1)) - (new markup - (markup 'hrule) - (ident (or ident (symbol->string (gensym 'hrule)))) - (class class) - (required-options '()) - (options `((:width ,width) - (:height ,height) - ,@(the-options opts :ident :class))) - (body #f))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(define-markup (color #!rest - opts - #!key - (ident #f) (class "color") - (bg #f) (fg #f) (width #f) (margin #f)) - (new container - (markup 'color) - (ident (or ident (symbol->string (gensym 'color)))) - (class class) - (required-options '(:bg :fg :width)) - (options `((:bg ,(if bg (skribe-use-color! bg) bg)) - (:fg ,(if fg (skribe-use-color! fg) fg)) - ,@(the-options opts :ident :class :bg :fg))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define-markup (frame #!rest - opts - #!key - (ident #f) (class "frame") - (width #f) (margin 2) (border 1)) - (new container - (markup 'frame) - (ident (or ident (symbol->string (gensym 'frame)))) - (class class) - (required-options '(:width :border :margin)) - (options `((:margin ,margin) - (:border ,(cond - ((integer? border) border) - (border 1) - (else #f))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(define-markup (font #!rest - opts - #!key - (ident #f) (class #f) - (size #f) (face #f)) - (new container - (markup 'font) - (ident (or ident (symbol->string (gensym 'font)))) - (class class) - (required-options '(:size)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(define-markup (flush #!rest - opts - #!key - (ident #f) (class #f) - side) - (case side - ((center left right) - (new container - (markup 'flush) - (ident (or ident (symbol->string (gensym 'flush)))) - (class class) - (required-options '(:side)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - (else - (skribe-error 'flush "Illegal side" side)))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container center) - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container pre) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:prog@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:prog@ */ -;*---------------------------------------------------------------------*/ -(define-markup (prog #!rest - opts - #!key - (ident #f) (class "prog") - (line 1) (linedigit #f) (mark ";!")) - (if (not (or (string? mark) (eq? mark #f))) - (skribe-error 'prog "Illegal mark" mark) - (new container - (markup 'prog) - (ident (or ident (symbol->string (gensym 'prog)))) - (class class) - (required-options '(:line :mark)) - (options (the-options opts :ident :class :linedigit)) - (body (make-prog-body (the-body opts) line linedigit mark))))) - -;*---------------------------------------------------------------------*/ -;* source ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:source@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:source@ */ -;*---------------------------------------------------------------------*/ -(define-markup (source #!rest - opts - #!key - language - (file #f) (start #f) (stop #f) - (definition #f) (tab 8)) - (let ((body (the-body opts))) - (cond - ((and (not (null? body)) (or file start stop definition)) - (skribe-error 'source - "file, start/stop, and definition are exclusive with body" - body)) - ((and start stop definition) - (skribe-error 'source - "start/stop are exclusive with a definition" - body)) - ((and (or start stop definition) (not file)) - (skribe-error 'source - "start/stop and definition require a file specification" - file)) - ((and definition (not language)) - (skribe-error 'source - "definition requires a language specification" - definition)) - ((and file (not (string? file))) - (skribe-error 'source "Illegal file" file)) - ((and start (not (or (integer? start) (string? start)))) - (skribe-error 'source "Illegal start" start)) - ((and stop (not (or (integer? stop) (string? stop)))) - (skribe-error 'source "Illegal start" stop)) - ((and (integer? start) (integer? stop) (> start stop)) - (skribe-error 'source - "start line > stop line" - (format "~a/~a" start stop))) - ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) - ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) - (file - (let ((s (if (not definition) - (source-read-lines file start stop tab) - (source-read-definition file definition tab language)))) - (if language - (source-fontify s language) - s))) - (language - (source-fontify body language)) - (else - body)))) - -;*---------------------------------------------------------------------*/ -;* language ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:language@ */ -;*---------------------------------------------------------------------*/ -(define-markup (language #!key name (fontifier #f) (extractor #f)) - (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") - (new language - (name name) - (fontifier fontifier) - (extractor extractor)))) - -;*---------------------------------------------------------------------*/ -;* figure ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/figure.skb:figure@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:figure@ */ -;*---------------------------------------------------------------------*/ -(define-markup (figure #!rest - opts - #!key - (ident #f) (class "figure") - (legend #f) (number #t) (multicolumns #f)) - (new container - (markup 'figure) - (ident (or ident - (let ((s (ast->string legend))) - (if (not (string=? s "")) - s - (symbol->string (gensym 'figure)))))) - (class class) - (required-options '(:legend :number :multicolumns)) - (options `((:number - ,(new unresolved - (proc (lambda (n e env) - (resolve-counter n env 'figure number))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* parse-list-of ... */ -;* ------------------------------------------------------------- */ -;* The function table accepts two different prototypes. It */ -;* may receive its N elements in a list of N elements or in */ -;* a list of one element which is a list of N elements. This */ -;* gets rid of APPLY when calling container markup such as ITEMIZE */ -;* or TABLE. */ -;*---------------------------------------------------------------------*/ -(define (parse-list-of for markup lst) - (cond - ((null? lst) - '()) - ((and (pair? lst) - (or (pair? (car lst)) (null? (car lst))) - (null? (cdr lst))) - (parse-list-of for markup (car lst))) - (else - (let loop ((lst lst)) - (cond - ((null? lst) - '()) - ((pair? (car lst)) - (loop (car lst))) - (else - (let ((r (car lst))) - (if (not (is-markup? r markup)) - (skribe-warning 2 - for - (format "Illegal `~a' element, `~a' expected" - (if (markup? r) - (markup-markup r) - (find-runtime-type r)) - markup))) - (cons r (loop (cdr lst)))))))))) - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) - (new container - (markup 'itemize) - (ident (or ident (symbol->string (gensym 'itemize)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'itemize 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) - (new container - (markup 'enumerate) - (ident (or ident (symbol->string (gensym 'enumerate)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'enumerate 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) - (new container - (markup 'description) - (ident (or ident (symbol->string (gensym 'description)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'description 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(define-markup (item #!rest opts #!key (ident #f) (class #f) key) - (if (and key (not (or (string? key) - (number? key) - (markup? key) - (pair? key)))) - (skribe-type-error 'item "Illegal key:" key "node") - (new container - (markup 'item) - (ident (or ident (symbol->string (gensym 'item)))) - (class class) - (required-options '(:key)) - (options `((:key ,key) ,@(the-options opts :ident :class :key))) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* table */ -;*---------------------------------------------------------------------*/ -(define-markup (table #!rest - opts - #!key - (ident #f) (class #f) - (border #f) (width #f) - (frame 'none) (rules 'none) - (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) - (let ((frame (cond - ((string? frame) - (string->symbol frame)) - ((not frame) - #f) - (else - frame))) - (rules (cond - ((string? rules) - (string->symbol rules)) - ((not rules) - #f) - (else - rules))) - (frame-vals '(none above below hsides vsides lhs rhs box border)) - (rules-vals '(none rows cols all header)) - (cells-vals '(collapse separate))) - (cond - ((and frame (not (memq frame frame-vals))) - (skribe-error 'table - (format "frame should be one of \"~a\"" frame-vals) - frame)) - ((and rules (not (memq rules rules-vals))) - (skribe-error 'table - (format "rules should be one of \"~a\"" rules-vals) - rules)) - ((not (or (memq cellstyle cells-vals) - (string? cellstyle) - (number? cellstyle))) - (skribe-error 'table - (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) - cellstyle)) - (else - (new container - (markup 'table) - (ident (or ident (symbol->string (gensym 'table)))) - (class class) - (required-options '(:width :frame :rules)) - (options `((:frame ,frame) - (:rules ,rules) - (:cellstyle ,cellstyle) - ,@(the-options opts :ident :class))) - (body (parse-list-of 'table 'tr (the-body opts)))))))) - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) - (new container - (markup 'tr) - (ident (or ident (symbol->string (gensym 'tr)))) - (class class) - (required-options '()) - (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) - ,@(the-options opts :ident :class :bg))) - (body (parse-list-of 'tr 'tc (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* tc... */ -;*---------------------------------------------------------------------*/ -(define-markup (tc m - #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (let ((align (if (string? align) - (string->symbol align) - align)) - (valign (if (string? valign) - (string->symbol valign) - valign))) - (cond - ((not (integer? colspan)) - (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) - ((not (symbol? align)) - (skribe-type-error 'tc "Illegal align, " align "align")) - ((not (memq align '(#f center left right))) - (skribe-error - 'tc - "align should be one of 'left', `center', or `right'" - align)) - ((not (memq valign '(#f top middle center bottom))) - (skribe-error - 'tc - "valign should be one of 'top', `middle', `center', or `bottom'" - valign)) - (else - (new container - (markup 'tc) - (ident (or ident (symbol->string (gensym 'tc)))) - (class class) - (required-options '(:width :align :valign :colspan)) - (options `((markup ,m) - (:align ,align) - (:valign ,valign) - (:colspan ,colspan) - ,@(if bg - `((:bg ,(if bg (skribe-use-color! bg) bg))) - '()) - ,@(the-options opts :ident :class :bg :align :valign))) - (body (the-body opts))))))) - -;*---------------------------------------------------------------------*/ -;* th ... */ -;*---------------------------------------------------------------------*/ -(define-markup (th #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'th opts)) - -;*---------------------------------------------------------------------*/ -;* td ... */ -;*---------------------------------------------------------------------*/ -(define-markup (td #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'td opts)) - -;*---------------------------------------------------------------------*/ -;* image ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/image.skb:image@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:image@ */ -;* latex: @ref ../../skr/latex.skr:image@ */ -;*---------------------------------------------------------------------*/ -(define-markup (image #!rest - opts - #!key - (ident #f) (class #f) - file (url #f) (width #f) (height #f) (zoom #f)) - (cond - ((not (or (string? file) (string? url))) - (skribe-error 'image "No file or url provided" file)) - ((and (string? file) (string? url)) - (skribe-error 'image "Both file and url provided" (list file url))) - (else - (new markup - (markup 'image) - (ident (or ident (symbol->string (gensym 'image)))) - (class class) - (required-options '(:file :url :width :height)) - (options (the-options opts :ident :class)) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* blockquote */ -;*---------------------------------------------------------------------*/ -(define-simple-markup blockquote) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup roman) -(define-simple-markup bold) -(define-simple-markup underline) -(define-simple-markup strike) -(define-simple-markup emph) -(define-simple-markup kbd) -(define-simple-markup it) -(define-simple-markup tt) -(define-simple-markup code) -(define-simple-markup var) -(define-simple-markup samp) -(define-simple-markup sf) -(define-simple-markup sc) -(define-simple-markup sub) -(define-simple-markup sup) - -;*---------------------------------------------------------------------*/ -;* char ... */ -;*---------------------------------------------------------------------*/ -(define-markup (char char) - (cond - ((char? char) - (string char)) - ((integer? char) - (string (integer->char char))) - ((and (string? char) (= (string-length char) 1)) - char) - (else - (skribe-error 'char "Illegal char" char)))) - -;*---------------------------------------------------------------------*/ -;* symbol ... */ -;*---------------------------------------------------------------------*/ -(define-markup (symbol symbol) - (let ((v (cond - ((symbol? symbol) - (symbol->string symbol)) - ((string? symbol) - symbol) - (else - (skribe-error 'symbol - "Illegal argument (symbol expected)" - symbol))))) - (new markup - (markup 'symbol) - (body v)))) - -;*---------------------------------------------------------------------*/ -;* ! ... */ -;*---------------------------------------------------------------------*/ -(define-markup (! format #!rest node) - (if (not (string? format)) - (skribe-type-error '! "Illegal format:" format "string") - (new command - (fmt format) - (body node)))) - -;*---------------------------------------------------------------------*/ -;* processor ... */ -;*---------------------------------------------------------------------*/ -(define-markup (processor #!rest opts - #!key (combinator #f) (engine #f) (procedure #f)) - (cond - ((and combinator (not (procedure? combinator))) - (skribe-error 'processor "Combinator not a procedure" combinator)) - ((and engine (not (engine? engine))) - (skribe-error 'processor "Illegal engine" engine)) - ((and procedure - (or (not (procedure? procedure)) - (not (correct-arity? procedure 2)))) - (skribe-error 'processor "Illegal procedure" procedure)) - (else - (new processor - (combinator combinator) - (engine engine) - (procedure (or procedure (lambda (n e) n))) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* Processors ... */ -;*---------------------------------------------------------------------*/ -(define-processor-markup html-processor) -(define-processor-markup tex-processor) - -;*---------------------------------------------------------------------*/ -;* handle ... */ -;*---------------------------------------------------------------------*/ -(define-markup (handle #!rest opts - #!key (ident #f) (class "handle") value section) - (let ((body (the-body opts))) - (cond - (section - (error 'handle "Illegal handle `section' option" section) - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident section 'section n env))) - (new handle - (ast s))))))) - ((and (pair? body) - (null? (cdr body)) - (markup? (car body))) - (new handle - (ast (car body)))) - (else - (skribe-error 'handle "Illegal handle" opts))))) - -;*---------------------------------------------------------------------*/ -;* mailto ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mailto@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mailto@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) - (new markup - (markup 'mailto) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* *mark-table* ... */ -;*---------------------------------------------------------------------*/ -(define *mark-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mark@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mark@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) - (let ((bd (the-body opts))) - (cond - ((and (pair? bd) (not (null? (cdr bd)))) - (skribe-error 'mark "Too many argument provided" bd)) - ((null? bd) - (skribe-error 'mark "Missing argument" '())) - ((not (string? (car bd))) - (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) - (ident - (skribe-error 'mark "Illegal `ident:' option" ident)) - (else - (let* ((bs (ast->string bd)) - (n (new markup - (markup 'mark) - (ident bs) - (class class) - (options (the-options opts :ident :class :text)) - (body text)))) - (hashtable-put! *mark-table* bs n) - n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:ref@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:ref@ */ -;* latex: @ref ../../skr/latex.skr:ref@ */ -;*---------------------------------------------------------------------*/ -(define-markup (ref #!rest - opts - #!key - (class #f) - (ident #f) - (text #f) - (chapter #f) - (section #f) - (subsection #f) - (subsubsection #f) - (bib #f) - (bib-table (default-bib-table)) - (url #f) - (figure #f) - (mark #f) - (handle #f) - (line #f) - (skribe #f) - (page #f)) - (define (unref ast text kind) - (let ((msg (format "Can't find `~a': " kind))) - (if (ast? ast) - (begin - (skribe-warning/ast 1 ast 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body (list text ": " (ast->file-location ast))))) - (begin - (skribe-warning 1 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body text)))))) - (define (skribe-ref skribe) - (let ((path (find-file/path skribe (skribe-path)))) - (if (not path) - (unref #f skribe 'sui-file) - (let* ((sui (load-sui path)) - (os (the-options opts :skribe :class :text)) - (u (sui-ref->url (dirname path) sui ident os))) - (if (not u) - (unref #f os 'sui-ref) - (ref :url u :text text :ident ident :class class)))))) - (define (handle-ref text) - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind handle) ,@(the-options opts :ident :class))) - (body text))) - (define (doref text kind) - (if (not (string? text)) - (skribe-type-error 'ref "Illegal reference" text "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident text kind n env))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) - (mark ,text) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n text (or kind 'ident))))))))) - (define (mark-ref mark) - (if (not (string? mark)) - (skribe-type-error 'mark "Illegal mark, " mark "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (hashtable-get *mark-table* mark))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind mark) - (mark ,mark) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n mark 'mark)))))))) - (define (make-bib-ref v) - (let ((s (resolve-bib bib-table v))) - (if s - (let* ((n (new markup - (markup 'bib-ref) - (ident (symbol->string 'bib-ref)) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (new handle - (ast s))))) - (h (new handle (ast n))) - (o (markup-option s 'used))) - (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) - n) - (unref #f v 'bib)))) - (define (bib-ref text) - (if (pair? text) - (new markup - (markup 'bib-ref+) - (ident (symbol->string 'bib-ref+)) - (class class) - (options (the-options opts :ident :class)) - (body (map make-bib-ref text))) - (make-bib-ref text))) - (define (url-ref) - (new markup - (markup 'url-ref) - (ident (symbol->string 'url-ref)) - (class class) - (required-options '(:url :text)) - (options (the-options opts :ident :class)))) - (define (line-ref line) - (new unresolved - (proc (lambda (n e env) - (let ((l (resolve-line line))) - (if (pair? l) - (new markup - (markup 'line-ref) - (ident (symbol->string 'line-ref)) - (class class) - (options `((:text ,(markup-ident (car l))) - ,@(the-options opts :ident :class))) - (body (new handle - (ast (car l))))) - (unref n line 'line))))))) - (let ((b (the-body opts))) - (if (not (null? b)) - (skribe-warning 1 'ref "Arguments ignored " b)) - (cond - (skribe (skribe-ref skribe)) - (handle (handle-ref handle)) - (ident (doref ident #f)) - (chapter (doref chapter 'chapter)) - (section (doref section 'section)) - (subsection (doref subsection 'subsection)) - (subsubsection (doref subsubsection 'subsubsection)) - (figure (doref figure 'figure)) - (mark (mark-ref mark)) - (bib (bib-ref bib)) - (url (url-ref)) - (line (line-ref line)) - (else (skribe-error 'ref "Illegal reference" opts))))) - -;*---------------------------------------------------------------------*/ -;* resolve ... */ -;*---------------------------------------------------------------------*/ -(define-markup (resolve fun) - (new unresolved - (proc fun))) - -;*---------------------------------------------------------------------*/ -;* bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (bibliography #!rest files - #!key - (command #f) (bib-table (default-bib-table))) - (for-each (lambda (f) - (cond - ((string? f) - (bib-load! bib-table f command)) - ((pair? f) - (bib-add! bib-table f)) - (else - (skribe-error "bibliography" "Illegal entry" f)))) - (the-body files))) - -;*---------------------------------------------------------------------*/ -;* the-bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:the-bibliography@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-bibliography #!rest opts - #!key - pred - (bib-table (default-bib-table)) - (sort bib-sort/authors) - (count 'partial)) - (if (not (memq count '(partial full))) - (skribe-error 'the-bibliography - "Cound must be either `partial' or `full'" - count) - (new unresolved - (proc (lambda (n e env) - (resolve-the-bib bib-table - (new handle (ast n)) - sort - pred - count - (the-options opts))))))) - -;*---------------------------------------------------------------------*/ -;* make-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:make-index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (make-index ident) - (make-index-table ident)) - -;*---------------------------------------------------------------------*/ -;* index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (index #!rest - opts - #!key - (ident #f) (class "index") - (note #f) (index #f) (shape #f) - (url #f)) - (let* ((entry-name (the-body opts)) - (ename (cond - ((string? entry-name) - entry-name) - ((and (pair? entry-name) (every string? entry-name)) - (apply string-append entry-name)) - (else - (skribe-error - 'index - "entry-name must be either a string or a list of strings" - entry-name)))) - (table (cond - ((not index) (default-index)) - ((index? index) index) - (else (skribe-type-error 'index - "Illegal index table, " - index - "index")))) - (m (mark (symbol->string (gensym)))) - (h (new handle (ast m))) - (new (new markup - (markup '&index-entry) - (ident (or ident (symbol->string (gensym 'index)))) - (class class) - (options `((name ,ename) ,@(the-options opts :ident :class))) - (body (if url - (ref :url url :text (or shape ename)) - (ref :handle h :text (or shape ename))))))) - ;; New is bound to a dummy option of the mark in order - ;; to make new options verified. - (markup-option-add! m 'to-verify new) - (hashtable-update! table - ename - (lambda (cur) (cons new cur)) - (list new)) - m)) - -;*---------------------------------------------------------------------*/ -;* the-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:the-index@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-index@ */ -;* html: @ref ../../skr/html.skr:the-index-header@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-index #!rest - opts - #!key - (ident #f) - (class "the-index") - (split #f) - (char-offset 0) - (header-limit 50) - (column 1)) - (let ((bd (the-body opts))) - (cond - ((not (and (integer? char-offset) (>= char-offset 0))) - (skribe-error 'the-index "Illegal char offset" char-offset)) - ((not (integer? column)) - (skribe-error 'the-index "Illegal column number" column)) - ((not (every? index? bd)) - (skribe-error 'the-index - "Illegal indexes" - (filter (lambda (o) (not (index? o))) bd))) - (else - (new unresolved - (proc (lambda (n e env) - (resolve-the-index (ast-loc n) - ident class - bd - split - char-offset - header-limit - column)))))))) diff --git a/skribe/src/common/bib.scm b/skribe/src/common/bib.scm deleted file mode 100644 index b73c5f0..0000000 --- a/skribe/src/common/bib.scm +++ /dev/null @@ -1,192 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/bib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Wed Jan 14 08:02:45 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../bigloo/bib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* bib-load! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-load! table filename command) - (if (not (bib-table? table)) - (skribe-error 'bib-load "Illegal bibliography table" table) - ;; read the file - (let ((p (skribe-open-bib-file filename command))) - (if (not (input-port? p)) - (skribe-error 'bib-load "Can't open data base" filename) - (unwind-protect - (parse-bib table p) - (close-input-port p)))))) - -;*---------------------------------------------------------------------*/ -;* resolve-bib ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-bib table ident) - (if (not (bib-table? table)) - (skribe-error 'resolve-bib "Illegal bibliography table" table) - (let* ((i (cond - ((string? ident) ident) - ((symbol? ident) (symbol->string ident)) - (else (skribe-error 'resolve-bib "Illegal ident" ident)))) - (en (hashtable-get table i))) - (if (is-markup? en '&bib-entry) - en - #f)))) - -;*---------------------------------------------------------------------*/ -;* make-bib-entry ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-entry kind ident fields from) - (let* ((m (new markup - (markup '&bib-entry) - (ident ident) - (options `((kind ,kind) (from ,from))))) - (h (new handle - (ast m)))) - (for-each (lambda (f) - (if (and (pair? f) - (pair? (cdr f)) - (null? (cddr f)) - (symbol? (car f))) - (markup-option-add! m - (car f) - (new markup - (markup (symbol-append - '&bib-entry- - (car f))) - (parent h) - (body (cadr f)))) - (bib-parse-error f))) - fields) - m)) - -;*---------------------------------------------------------------------*/ -;* bib-sort/authors ... */ -;*---------------------------------------------------------------------*/ -(define (bib-sort/authors l) - (define (cmp i1 i2 def) - (cond - ((and (markup? i1) (markup? i2)) - (cmp (markup-body i1) (markup-body i2) def)) - ((markup? i1) - (cmp (markup-body i1) i2 def)) - ((markup? i2) - (cmp i1 (markup-body i2) def)) - ((and (string? i1) (string? i2)) - (if (string=? i1 i2) - (def) - (string (string-length body) 3) - (substring body 0 3) - body)) - (sy (string->symbol (string-downcase body))) - (c (assq sy '((jan . 1) - (feb . 2) - (mar . 3) - (apr . 4) - (may . 5) - (jun . 6) - (jul . 7) - (aug . 8) - (sep . 9) - (oct . 10) - (nov . 11) - (dec . 12))))) - (if (pair? c) (cdr c) 13))))) - (let ((d1 (markup-option p1 'year)) - (d2 (markup-option p2 'year))) - (cond - ((not (markup? d1)) #f) - ((not (markup? d2)) #t) - (else - (let ((y1 (markup-body d1)) - (y2 (markup-body d2))) - (cond - ((string>? y1 y2) #t) - ((string m1 m2)))))))))))))) - -;*---------------------------------------------------------------------*/ -;* resolve-the-bib ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-the-bib table n sort pred count opts) - (define (count! entries) - (let loop ((es entries) - (i 1)) - (if (pair? es) - (begin - (markup-option-add! (car es) - :title - (new markup - (markup '&bib-entry-ident) - (parent (car es)) - (options `((number ,i))) - (body (new handle - (ast (car es)))))) - (loop (cdr es) (+ i 1)))))) - (if (not (bib-table? table)) - (skribe-error 'resolve-the-bib "Illegal bibliography table" table) - (let* ((es (sort (hashtable->list table))) - (fes (filter (if (procedure? pred) - (lambda (m) (pred m n)) - (lambda (m) (pair? (markup-option m 'used)))) - es))) - (count! (if (eq? count 'full) es fes)) - (new markup - (markup '&the-bibliography) - (options opts) - (body fes))))) - diff --git a/skribe/src/common/configure.scm.in b/skribe/src/common/configure.scm.in deleted file mode 100644 index 830ec4d..0000000 --- a/skribe/src/common/configure.scm.in +++ /dev/null @@ -1,6 +0,0 @@ -(define (skribe-release) "@SKRIBE_RELEASE@") -(define (skribe-url) "@SKRIBE_URL@") -(define (skribe-doc-dir) "@SKRIBE_DOC_DIR@") -(define (skribe-ext-dir) "@SKRIBE_EXT_DIR@") -(define (skribe-default-path) @SKRIBE_SKR_PATH@) -(define (skribe-scheme) "@SKRIBE_SCHEME@") diff --git a/skribe/src/common/index.scm b/skribe/src/common/index.scm deleted file mode 100644 index 65c271f..0000000 --- a/skribe/src/common/index.scm +++ /dev/null @@ -1,126 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/index.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../bigloo/index.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* index? ... */ -;*---------------------------------------------------------------------*/ -(define (index? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *index-table* ... */ -;*---------------------------------------------------------------------*/ -(define *index-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-index-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-index-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-index ... */ -;*---------------------------------------------------------------------*/ -(define (default-index) - (if (not *index-table*) - (set! *index-table* (make-index-table "default-index"))) - *index-table*) - -;*---------------------------------------------------------------------*/ -;* resolve-the-index ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) - ;; fetch the descriminating index name letter - (define (index-ref n) - (let ((name (markup-option n 'name))) - (if (>= char-offset (string-length name)) - (skribe-error 'the-index "char-offset out of bound" char-offset) - (string-ref name char-offset)))) - ;; sort a bucket of entries (the entries in a bucket share there name) - (define (sort-entries-bucket ie) - (sort ie - (lambda (i1 i2) - (or (not (markup-option i1 :note)) - (markup-option i2 :note))))) - ;; accumulate all the entries starting with the same letter - (define (letter-references refs) - (let ((letter (index-ref (car (car refs))))) - (let loop ((refs refs) - (acc '())) - (if (or (null? refs) - (not (char-ci=? letter (index-ref (car (car refs)))))) - (values (char-upcase letter) acc refs) - (loop (cdr refs) (cons (car refs) acc)))))) - ;; merge the buckets that comes from different index tables - (define (merge-buckets buckets) - (if (null? buckets) - '() - (let loop ((buckets buckets) - (res '())) - (cond - ((null? (cdr buckets)) - (reverse! (cons (car buckets) res))) - ((string=? (markup-option (car (car buckets)) 'name) - (markup-option (car (cadr buckets)) 'name)) - ;; we merge - (loop (cons (append (car buckets) (cadr buckets)) - (cddr buckets)) - res)) - (else - (loop (cdr buckets) - (cons (car buckets) res))))))) - (let* ((entries (apply append (map hashtable->list indexes))) - (sorted (map sort-entries-bucket - (merge-buckets - (sort entries - (lambda (e1 e2) - (string-cistring (gensym s)) :text s)) - (h (new handle (loc loc) (ast m))) - (r (ref :handle h :text s))) - (ast-loc-set! m loc) - (ast-loc-set! r loc) - (loop next-refs - (cons r lrefs) - (append lr (cons m body))))))))))) - diff --git a/skribe/src/common/lib.scm b/skribe/src/common/lib.scm deleted file mode 100644 index b0fa2d0..0000000 --- a/skribe/src/common/lib.scm +++ /dev/null @@ -1,238 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/lib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 10 11:57:54 2003 */ -;* Last change : Wed Oct 27 12:16:40 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scheme independent lib part. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/lib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* engine-custom-add! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-add! e id val) - (let ((old (engine-custom e id))) - (if (unspecified? old) - (engine-custom-set! e id (list val)) - (engine-custom-set! e id (cons val old))))) - -;*---------------------------------------------------------------------*/ -;* find-markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define (find-markup-ident ident) - (let ((r (find-markups ident))) - (if (or (pair? r) (null? r)) - r - '()))) - -;*---------------------------------------------------------------------*/ -;* container-search-down ... */ -;*---------------------------------------------------------------------*/ -(define (container-search-down pred obj) - (with-debug 4 'container-search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((container? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* search-down ... */ -;*---------------------------------------------------------------------*/ -(define (search-down pred obj) - (with-debug 4 'search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* find-down ... */ -;*---------------------------------------------------------------------*/ -(define (find-down pred obj) - (with-debug 4 'find-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj obj)) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (debug-item "loop=" (find-runtime-type obj) - " " (markup-ident obj)) - (if (pred obj) - (list (cons obj (loop (markup-body obj)))) - '())) - (else - (if (pred obj) - (list obj) - '())))))) - -;*---------------------------------------------------------------------*/ -;* find1-down ... */ -;*---------------------------------------------------------------------*/ -(define (find1-down pred obj) - (with-debug 4 'find1-down - (let loop ((obj obj) - (stack '())) - (debug-item "obj=" (find-runtime-type obj) - " " (if (markup? obj) (markup-markup obj) "???") - " " (if (markup? obj) (markup-ident obj) "")) - (cond - ((memq obj stack) - (skribe-error 'find1-down "Illegal cyclic object" obj)) - ((pair? obj) - (let liip ((obj obj)) - (cond - ((null? obj) - #f) - (else - (or (loop (car obj) (cons obj stack)) - (liip (cdr obj))))))) - ((pred obj) - obj) - ((markup? obj) - (loop (markup-body obj) (cons obj stack))) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* find-up ... */ -;*---------------------------------------------------------------------*/ -(define (find-up pred obj) - (let loop ((obj obj) - (res '())) - (cond - ((not (ast? obj)) - res) - ((pred obj) - (loop (ast-parent obj) (cons obj res))) - (else - (loop (ast-parent obj) (cons obj res)))))) - -;*---------------------------------------------------------------------*/ -;* find1-up ... */ -;*---------------------------------------------------------------------*/ -(define (find1-up pred obj) - (let loop ((obj obj)) - (cond - ((not (ast? obj)) - #f) - ((pred obj) - obj) - (else - (loop (ast-parent obj)))))) - -;*---------------------------------------------------------------------*/ -;* ast-document ... */ -;*---------------------------------------------------------------------*/ -(define (ast-document m) - (find1-up document? m)) - -;*---------------------------------------------------------------------*/ -;* ast-chapter ... */ -;*---------------------------------------------------------------------*/ -(define (ast-chapter m) - (find1-up (lambda (n) (is-markup? n 'chapter)) m)) - -;*---------------------------------------------------------------------*/ -;* ast-section ... */ -;*---------------------------------------------------------------------*/ -(define (ast-section m) - (find1-up (lambda (n) (is-markup? n 'section)) m)) - -;*---------------------------------------------------------------------*/ -;* the-body ... */ -;* ------------------------------------------------------------- */ -;* Filter out the options */ -;*---------------------------------------------------------------------*/ -(define (the-body opt+) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-body "Illegal body" opt*)) - ((keyword? (car opt*)) - (if (null? (cdr opt*)) - (skribe-error 'the-body "Illegal option" (car opt*)) - (loop (cddr opt*) res))) - (else - (loop (cdr opt*) (cons (car opt*) res)))))) - -;*---------------------------------------------------------------------*/ -;* the-options ... */ -;* ------------------------------------------------------------- */ -;* Returns an list made of options. The OUT argument contains */ -;* keywords that are filtered out. */ -;*---------------------------------------------------------------------*/ -(define (the-options opt+ . out) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-options "Illegal options" opt*)) - ((keyword? (car opt*)) - (cond - ((null? (cdr opt*)) - (skribe-error 'the-options "Illegal option" (car opt*))) - ((memq (car opt*) out) - (loop (cdr opt*) res)) - (else - (loop (cdr opt*) - (cons (list (car opt*) (cadr opt*)) res))))) - (else - (loop (cdr opt*) res))))) - -;*---------------------------------------------------------------------*/ -;* list-split ... */ -;*---------------------------------------------------------------------*/ -(define (list-split l num . fill) - (let loop ((l l) - (i 0) - (acc '()) - (res '())) - (cond - ((null? l) - (reverse! (cons (if (or (null? fill) (= i num)) - (reverse! acc) - (append! (reverse! acc) - (make-list (- num i) (car fill)))) - res))) - ((= i num) - (loop l - 0 - '() - (cons (reverse! acc) res))) - (else - (loop (cdr l) - (+ i 1) - (cons (car l) acc) - res))))) - diff --git a/skribe/src/common/param.scm b/skribe/src/common/param.scm deleted file mode 100644 index ba8d489..0000000 --- a/skribe/src/common/param.scm +++ /dev/null @@ -1,69 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/param.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 30 09:06:53 2003 */ -;* Last change : Thu Oct 28 21:51:49 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Common Skribe parameters */ -;* Implementation: @label param@ */ -;* bigloo: @path ../bigloo/param.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-file* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-file* "skriberc") - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-mode-alist* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-load-alist* ... */ -;* ------------------------------------------------------------- */ -;* Autoload engines. */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-load-alist* - '((base . "base.skr") - (html . "html.skr") - (sui . "html.skr") - (latex . "latex.skr") - (context . "context.skr") - (xml . "xml.skr"))) - -;*---------------------------------------------------------------------*/ -;* *skribe-preload* ... */ -;* ------------------------------------------------------------- */ -;* The list of skribe files (e.g. styles) to be loaded at boot-time */ -;*---------------------------------------------------------------------*/ -(define *skribe-preload* - '("skribe.skr")) - -;*---------------------------------------------------------------------*/ -;* *skribe-precustom* ... */ -;* ------------------------------------------------------------- */ -;* The list of pair to be assigned to the default */ -;* engine. */ -;*---------------------------------------------------------------------*/ -(define *skribe-precustom* - '()) - -;*---------------------------------------------------------------------*/ -;* *skribebib-auto-mode-alist* ... */ -;*---------------------------------------------------------------------*/ -(define *skribebib-auto-mode-alist* - '(("bib" . "skribebibtex"))) diff --git a/skribe/src/common/sui.scm b/skribe/src/common/sui.scm deleted file mode 100644 index eb6134b..0000000 --- a/skribe/src/common/sui.scm +++ /dev/null @@ -1,166 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/sui.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Dec 31 11:44:33 2003 */ -;* Last change : Tue Feb 17 11:35:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Url Indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/sui.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *sui-table* ... */ -;*---------------------------------------------------------------------*/ -(define *sui-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* load-sui ... */ -;* ------------------------------------------------------------- */ -;* Returns a SUI sexp if already loaded. Load it otherwise. */ -;* Raise an error if the file cannot be open. */ -;*---------------------------------------------------------------------*/ -(define (load-sui path) - (let ((sexp (hashtable-get *sui-table* path))) - (or sexp - (begin - (when (> *skribe-verbose* 0) - (fprintf (current-error-port) " [loading sui: ~a]\n" path)) - (let ((p (open-input-file path))) - (if (not (input-port? p)) - (skribe-error 'load-sui - "Can't find `Skribe Url Index' file" - path) - (unwind-protect - (let ((sexp (read p))) - (match-case sexp - ((sui (? string?) . ?-) - (hashtable-put! *sui-table* path sexp)) - (else - (skribe-error 'load-sui - "Illegal `Skribe Url Index' file" - path))) - sexp) - (close-input-port p)))))))) - -;*---------------------------------------------------------------------*/ -;* sui-ref->url ... */ -;*---------------------------------------------------------------------*/ -(define (sui-ref->url dir sui ident opts) - (let ((refs (sui-find-ref sui ident opts))) - (and (pair? refs) - (let ((base (sui-file sui)) - (file (car (car refs))) - (mark (cdr (car refs)))) - (format "~a/~a#~a" dir (or file base) mark))))) - -;*---------------------------------------------------------------------*/ -;* sui-title ... */ -;*---------------------------------------------------------------------*/ -(define (sui-title sexp) - (match-case sexp - ((sui (and ?title (? string?)) . ?-) - title) - (else - (skribe-error 'sui-title "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-file sexp) - (sui-key sexp :file)) - -;*---------------------------------------------------------------------*/ -;* sui-key ... */ -;*---------------------------------------------------------------------*/ -(define (sui-key sexp key) - (match-case sexp - ((sui ?- . ?rest) - (let loop ((rest rest)) - (and (pair? rest) - (if (eq? (car rest) key) - (and (pair? (cdr rest)) - (cadr rest)) - (loop (cdr rest)))))) - (else - (skribe-error 'sui-key "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-find-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-find-ref sui ident opts) - (let ((ident (assq :ident opts)) - (mark (assq :mark opts)) - (class (let ((c (assq :class opts))) - (and (pair? c) (cadr c)))) - (chapter (assq :chapter opts)) - (section (assq :section opts)) - (subsection (assq :subsection opts)) - (subsubsection (assq :subsubsection opts))) - (match-case sui - ((sui (? string?) . ?refs) - (cond - (mark (sui-search-ref 'marks refs (cadr mark) class)) - (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) - (section (sui-search-ref 'sections refs (cadr section) class)) - (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) - (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) - (ident (sui-search-all-refs sui ident class)) - (else '()))) - (else - (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) - -;*---------------------------------------------------------------------*/ -;* sui-search-all-refs ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-all-refs sui id refs) - '()) - -;*---------------------------------------------------------------------*/ -;* sui-search-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-ref kind refs val class) - (define (find-ref refs val class) - (map (lambda (r) - (let ((f (memq :file r)) - (c (memq :mark r))) - (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) - (filter (if class - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val) - (let ((c (memq :class m))) - (and (pair? c) - (eq? (cadr c) class))))) - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val)))) - refs))) - (let loop ((refs refs)) - (if (pair? refs) - (if (and (pair? (car refs)) (eq? (caar refs) kind)) - (find-ref (cdar refs) val class) - (loop (cdr refs))) - '()))) - -;*---------------------------------------------------------------------*/ -;* sui-filter ... */ -;*---------------------------------------------------------------------*/ -(define (sui-filter sui pred1 pred2) - (match-case sui - ((sui (? string?) . ?refs) - (let loop ((refs refs) - (res '())) - (if (pair? refs) - (if (and (pred1 (car refs))) - (loop (cdr refs) - (cons (filter pred2 (cdar refs)) res)) - (loop (cdr refs) res)) - (reverse! res)))) - (else - (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/skribe/src/stklos/Makefile.in b/skribe/src/stklos/Makefile.in deleted file mode 100644 index 80a26de..0000000 --- a/skribe/src/stklos/Makefile.in +++ /dev/null @@ -1,110 +0,0 @@ -# -# Makefile.in -- Skribe Src Makefile -# -# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -# -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 10-Aug-2003 20:26 (eg) -# Last file update: 6-Mar-2004 16:00 (eg) -# -include ../../etc/stklos/Makefile.skb - -prefix=@PREFIX@ - -SKR = $(wildcard ../../skr/*.skr) - -DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ - ../common/index.scm ../common/bib.scm ../common/lib.scm - -SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ - eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ - resolve.stk runtime.stk source.stk types.stk vars.stk \ - verify.stk writer.stk xml.stk - -LEXFILES = c-lex.l lisp-lex.l xml-lex.l - -LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk - -BINDIR=../../bin - -EXE= $(BINDIR)/skribe.stklos - -PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) - -SFLAGS= - -all: $(EXE) - -Makefile: Makefile.in - (cd ../../etc/stklos; autoconf; configure) - -$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) - stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ - chmod $(BMASK) $(EXE) - -# -# Lex files -# -lisp-lex.stk: lisp-lex.l - stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex - -xml-lex.stk: xml-lex.l - stklos-genlex xml-lex.l xml-lex.stk xml-lex - -c-lex.stk: c-lex.l - stklos-genlex c-lex.l c-lex.stk c-lex - - -install: $(INSTALL_BINDIR) - cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ - && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos - rm -f $(INSTALL_BINDIR)/skribe - ln -s skribe.stklos $(INSTALL_BINDIR)/skribe - -uninstall: - rm $(INSTALL_BINDIR)/skribe - rm $(INSTALL_BINDIR)/skribe.stklos - -$(BINDIR): - mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) - -$(INSTALL_BINDIR): - mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) - -## -## Services -## -tags: TAGS - -TAGS: $(SRCS) - etags -l scheme $(SRCS) - -pop: - @echo $(PRCS_FILES:%=src/stklos/%) - -links: - ln -s $(DEPS) . - ln -s $(SKR) . - -clean: - /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr - -distclean: clean - /bin/rm -f Makefile - /bin/rm -f ../common/configure.scm diff --git a/skribe/src/stklos/biblio.stk b/skribe/src/stklos/biblio.stk deleted file mode 100644 index 5691588..0000000 --- a/skribe/src/stklos/biblio.stk +++ /dev/null @@ -1,161 +0,0 @@ -;;;; -;;;; biblio.stk -- Bibliography functions -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA.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/skribe/src/stklos/c-lex.l b/skribe/src/stklos/c-lex.l deleted file mode 100644 index a5b337e..0000000 --- a/skribe/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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 6-Mar-2004 15:35 (eg) -;;;; Last file update: 7-Mar-2004 00:10 (eg) -;;;; - -space [ \n\9] -letter [_a-zA-Z] -alphanum [_a-zA-Z0-9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -;;Comments -/\*.*\*/ (new markup - (markup '&source-line-comment) - (body yytext)) -//.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Identifiers (only letters since we are interested in keywords only) -[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) - (tmp (memq ident *the-keys*))) - (if tmp - (new markup - (markup '&source-module) - (body yytext)) - yytext)) - -;; Regular text -[^\"a-zA-Z]+ (begin yytext) - - - -<> 'eof -<> (skribe-error 'lisp-fontifier "Parse error" yytext) - - - - - - - \ No newline at end of file diff --git a/skribe/src/stklos/c.stk b/skribe/src/stklos/c.stk deleted file mode 100644 index 265c421..0000000 --- a/skribe/src/stklos/c.stk +++ /dev/null @@ -1,95 +0,0 @@ -;;;; -;;;; c.stk -- C fontifier for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 6-Mar-2004 15:35 (eg) -;;;; Last file update: 7-Mar-2004 00:12 (eg) -;;;; - -(require "lex-rt") ;; to avoid module problems - -(define-module SKRIBE-C-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/skribe/src/stklos/color.stk b/skribe/src/stklos/color.stk deleted file mode 100644 index 0cb829f..0000000 --- a/skribe/src/stklos/color.stk +++ /dev/null @@ -1,622 +0,0 @@ -;;;; -;;;; color.stk -- Skribe Color Management -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 25-Oct-2003 00:10 (eg) -;;;; Last file update: 12-Feb-2004 18:24 (eg) -;;;; - -(define-module SKRIBE-COLOR-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/skribe/src/stklos/configure.stk b/skribe/src/stklos/configure.stk deleted file mode 100644 index ece7abc..0000000 --- a/skribe/src/stklos/configure.stk +++ /dev/null @@ -1,90 +0,0 @@ -;;;; -;;;; configure.stk -- Skribe configuration options -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 10-Feb-2004 11:47 (eg) -;;;; Last file update: 17-Feb-2004 09:43 (eg) -;;;; - -(define-module SKRIBE-CONFIGURE-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/skribe/src/stklos/debug.stk b/skribe/src/stklos/debug.stk deleted file mode 100644 index a9fefde..0000000 --- a/skribe/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 -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 10-Aug-2003 20:45 (eg) -;;;; Last file update: 28-Oct-2004 13:16 (eg) -;;;; - - -(define-module SKRIBE-DEBUG-MODULE - (export debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol - no-debug-color) - -(define *skribe-debug* 0) -(define *skribe-debug-symbols* '()) -(define *skribe-debug-color* #t) -(define *skribe-debug-item* #f) -(define *debug-port* (current-error-port)) -(define *debug-depth* 0) -(define *debug-margin* "") -(define *skribe-margin-debug-level* 0) - - -(define (set-skribe-debug! val) - (set! *skribe-debug* val)) - -(define (add-skribe-debug-symbol s) - (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*))) - - -(define (no-debug-color) - (set! *skribe-debug-color* #f)) - -(define (skribe-debug) - *skribe-debug*) - -;; -;; debug-port -;; -; (define (debug-port . o) -; (cond -; ((null? o) -; *debug-port*) -; ((output-port? (car o)) -; (set! *debug-port* o) -; o) -; (else -; (error 'debug-port "Illegal debug port" (car o))))) -; - -;;; -;;; debug-color -;;; -(define (debug-color col . o) - (with-output-to-string - (if (and *skribe-debug-color* - (equal? (getenv "TERM") "xterm") - (interactive-port? *debug-port*)) - (lambda () - (format #t "[1;~Am" (+ 31 col)) - (for-each display o) - (display "")) - (lambda () - (for-each display o))))) - -;;; -;;; debug-bold -;;; -(define (debug-bold . o) - (apply debug-color -30 o)) - -;;; -;;; debug-item -;;; -(define (debug-item . args) - (when (or (>= *skribe-debug* *skribe-margin-debug-level*) - *skribe-debug-item*) - (display *debug-margin* *debug-port*) - (display (debug-color (- *debug-depth* 1) "- ") *debug-port*) - (for-each (lambda (a) (display a *debug-port*)) args) - (newline *debug-port*))) - -;;(define-macro (debug-item . args) -;; `()) - -;;; -;;; %with-debug-margin -;;; -(define (%with-debug-margin margin thunk) - (let ((om *debug-margin*)) - (set! *debug-depth* (+ *debug-depth* 1)) - (set! *debug-margin* (string-append om margin)) - (let ((res (thunk))) - (set! *debug-depth* (- *debug-depth* 1)) - (set! *debug-margin* om) - res))) - -;;; -;;; %with-debug -;; -(define (%with-debug lvl lbl thunk) - (let ((ol *skribe-margin-debug-level*) - (oi *skribe-debug-item*)) - (set! *skribe-margin-debug-level* lvl) - (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) - (and (symbol? lbl) - (memq lbl *skribe-debug-symbols*) - (set! *skribe-debug-item* #t))) - (begin - (display *debug-margin* *debug-port*) - (display (if (= *debug-depth* 0) - (debug-color *debug-depth* "+ " lbl) - (debug-color *debug-depth* "--+ " lbl)) - *debug-port*) - (newline *debug-port*) - (%with-debug-margin (debug-color *debug-depth* " |") - thunk)) - (thunk)))) - (set! *skribe-debug-item* oi) - (set! *skribe-margin-debug-level* ol) - r))) - -(define-macro (with-debug level label . body) - `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body))) - -;;(define-macro (with-debug level label . body) -;; `(begin ,@body)) - -) - -#| -Example: - -(with-debug 0 'foo1.1 - (debug-item 'foo2.1) - (debug-item 'foo2.2) - (with-debug 0 'foo2.3 - (debug-item 'foo3.1) - (with-debug 0 'foo3.2 - (debug-item 'foo4.1) - (debug-item 'foo4.2)) - (debug-item 'foo3.3)) - (debug-item 'foo2.4)) -|# diff --git a/skribe/src/stklos/engine.stk b/skribe/src/stklos/engine.stk deleted file mode 100644 index a13ed0f..0000000 --- a/skribe/src/stklos/engine.stk +++ /dev/null @@ -1,242 +0,0 @@ -;;;; -;;;; engines.stk -- Skribe Engines Stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 24-Jul-2003 20:33 (eg) -;;;; Last file update: 28-Oct-2004 21:21 (eg) -;;;; - -(define-module SKRIBE-ENGINE-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 :ident ident :version version :format format - :filter filter :delegate delegate - :symbol-table symbol-table - :custom custom :info info))) - ;; store the engine in the global table - (set! *engines* (cons e *engines*)) - ;; return it - e)) - - -;;; -;;; COPY-ENGINE -;;; -(define (copy-engine ident e :key (version 'unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) - (let ((new (shallow-clone e))) - (slot-set! new 'ident ident) - (slot-set! new 'version version) - (slot-set! new 'filter (or filter (slot-ref e 'filter))) - (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) - (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) - (slot-set! new 'customs (or custom (slot-ref e 'customs))) - - (set! *engines* (cons new *engines*)) - new)) - - -;;; -;;; FIND-ENGINE -;;; -(define (%find-loaded-engine id version) - (let Loop ((es *engines*)) - (cond - ((null? es) #f) - ((eq? (slot-ref (car es) 'ident) id) - (cond - ((eq? version 'unspecified) (car es)) - ((eq? version (slot-ref (car es) 'version)) (car es)) - (else (Loop (cdr es))))) - (else (loop (cdr es)))))) - - -(define (find-engine id :key (version 'unspecified)) - (with-debug 5 'find-engine - (debug-item "id=" id " version=" version) - - (or (%find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and c (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (%find-loaded-engine id version)) - #f))))) - -;;; -;;; ENGINE-CUSTOM -;;; -(define (engine-custom e id) - (let* ((customs (slot-ref e 'customs)) - (c (assq id customs))) - (if (pair? c) - (cadr c) - 'unspecified))) - - -;;; -;;; ENGINE-CUSTOM-SET! -;;; -(define (engine-custom-set! e id val) - (let* ((customs (slot-ref e 'customs)) - (c (assq id customs))) - (if (pair? c) - (set-car! (cdr c) val) - (slot-set! e 'customs (cons (list id val) customs))))) - - -;;; -;;; ENGINE-ADD-WRITER! -;;; -(define (engine-add-writer! e ident pred upred opt before action after class valid) - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error ident "Illegal procedure" proc)) - ((not (equal? (%procedure-arity proc) arity)) - (skribe-error ident - (format #f "Illegal ~S procedure" name) - proc)))) - - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) - - ;; - ;; Engine-add-writer! starts here - ;; - (unless (is-a? e ) - (skribe-error ident "Illegal engine" e)) - - ;; check the options - (unless (or (eq? opt 'all) (list? opt)) - (skribe-error ident "Illegal options" opt)) - - ;; check the correctness of the predicate - (check-procedure "predicate" pred 2) - - ;; check the correctness of the validation proc - (when valid - (check-procedure "validate" valid 2)) - - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - - ;; create a new writer and bind it - (let ((n (make - :ident (if (symbol? ident) ident 'all) - :class class :pred pred :upred upred :options opt - :before before :action action :after after - :validate valid))) - (slot-set! e 'writers (cons n (slot-ref e 'writers))) - n)) - -;;;; ====================================================================== -;;;; -;;;; I N I T S -;;;; -;;;; ====================================================================== - -;; A base engine must pre-exist before anything is loaded. In -;; particular, this dummy base engine is used to load the actual -;; definition of base. - -(make-engine 'base :version 'bootstrap) - - -(select-module STklos) diff --git a/skribe/src/stklos/eval.stk b/skribe/src/stklos/eval.stk deleted file mode 100644 index 3acace9..0000000 --- a/skribe/src/stklos/eval.stk +++ /dev/null @@ -1,149 +0,0 @@ -;;;; -;;;; eval.stk -- Skribe Evaluator -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 27-Jul-2003 09:15 (eg) -;;;; Last file update: 28-Oct-2004 15:05 (eg) -;;;; - - -;; FIXME; On peut implémenter maintenant skribe-warning/node - - -(define-module SKRIBE-EVAL-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 )) - (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/skribe/src/stklos/lib.stk b/skribe/src/stklos/lib.stk deleted file mode 100644 index 3c3b9f0..0000000 --- a/skribe/src/stklos/lib.stk +++ /dev/null @@ -1,317 +0,0 @@ -;;;; -;;;; lib.stk -- Utilities -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 11-Aug-2003 20:29 (eg) -;;;; Last file update: 27-Oct-2004 12:41 (eg) -;;;; - -;;; -;;; 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/skribe/src/stklos/lisp-lex.l b/skribe/src/stklos/lisp-lex.l deleted file mode 100644 index efad24b..0000000 --- a/skribe/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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 5-Jan-2004 18:24 (eg) -;;;; - -space [ \n\9] -letter [#?!_:a-zA-Z\-] -digit [0-9] - - -%% -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) - -;;Comment -\;.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Skribe text (i.e. [....]) -\[|\] (if *bracket-highlight* - (new markup - (markup '&source-bracket) - (body yytext)) - yytext) -;; Spaces & parenthesis -[ \n\9\(\)]+ (begin - yytext) - -;; Identifier (real syntax is slightly more complicated but we are -;; interested here in the identifiers that we will fontify) -[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) - (cond - ((or (char=? c #\:) - (char=? (string-ref yytext - (- (string-length yytext) 1)) - #\:)) - ;; Scheme keyword - (new markup - (markup '&source-type) - (body yytext))) - ((char=? c #\<) - ;; STklos class - (let* ((len (string-length yytext)) - (c (string-ref yytext (- len 1)))) - (if (char=? c #\>) - (if *class-highlight* - (new markup - (markup '&source-module) - (body yytext)) - yytext) ; no - yytext))) ; no - (else - (let ((tmp (assoc (string->symbol yytext) - *the-keys*))) - (if tmp - (new markup - (markup (cdr tmp)) - (body yytext)) - yytext))))) - - -<> 'eof -<> (skribe-error 'lisp-fontifier "Parse error" yytext) - - -; LocalWords: fontify diff --git a/skribe/src/stklos/lisp.stk b/skribe/src/stklos/lisp.stk deleted file mode 100644 index 9bfe75a..0000000 --- a/skribe/src/stklos/lisp.stk +++ /dev/null @@ -1,294 +0,0 @@ -;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:17 (eg) -;;;; Last file update: 28-Oct-2004 21:14 (eg) -;;;; - -(require "lex-rt") ;; to avoid module problems - -(define-module SKRIBE-LISP-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/skribe/src/stklos/main.stk b/skribe/src/stklos/main.stk deleted file mode 100644 index 4905423..0000000 --- a/skribe/src/stklos/main.stk +++ /dev/null @@ -1,264 +0,0 @@ -;;;; -;;;; skribe.stk -- Skribe Main -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 24-Jul-2003 20:33 (eg) -;;;; Last file update: 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 ") - (set! engine (string->symbol target))) - (("I" :arg path :help "adds to Skribe path") - (set! paths (cons path paths))) - (("B" :arg path :help "adds to bibliography path") - (skribe-bib-path-set! (cons path (skribe-bib-path)))) - (("S" :arg path :help "adds to source path") - (skribe-source-path-set! (cons path (skribe-source-path)))) - (("P" :arg path :help "adds to image path") - (skribe-image-path-set! (cons path (skribe-image-path)))) - (("split-chapters" :alternate "C" :arg chapter - :help "emit chapter's sections in separate files") - (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) - (("preload" :arg file :help "preload ") - (set! *skribe-preload* (cons file *skribe-preload*))) - (("use-variant" :alternate "u" :arg variant - :help "use output format") - (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
") - (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 ") - (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 . 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 . 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 ") - (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 ") - (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/skribe/src/stklos/output.stk b/skribe/src/stklos/output.stk deleted file mode 100644 index 3c00323..0000000 --- a/skribe/src/stklos/output.stk +++ /dev/null @@ -1,158 +0,0 @@ -;;;; -;;;; output.stk -- Skribe Output Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 13-Aug-2003 18:42 (eg) -;;;; Last file update: 5-Mar-2004 10:32 (eg) -;;;; - -(define-module SKRIBE-OUTPUT-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) ) - (%out/writer node e (car writer))) - ((not (car writer)) - (skribe-error 'output - (format "Illegal ~A user writer" (engine-ident e)) - (if (markup? node) (markup-markup node) node))) - (else - (skribe-error 'output "Illegal user writer" (car writer))))))) - - -;;; -;;; OUT implementations -;;; -(define-method out (node e) - #f) - - -(define-method out ((node ) e) - (let Loop ((n* node)) - (cond - ((pair? n*) - (out (car n*) e) - (loop (cdr n*))) - ((not (null? n*)) - (skribe-error 'out "Illegal argument" n*))))) - - -(define-method out ((node ) e) - (let ((f (slot-ref e 'filter))) - (if (procedure? f) - (display (f node)) - (display node)))) - - -(define-method out ((node ) e) - (out (number->string node) e)) - - -(define-method out ((n ) e) - (let ((combinator (slot-ref n 'combinator)) - (engine (slot-ref n 'engine)) - (body (slot-ref n 'body)) - (procedure (slot-ref n 'procedure))) - (let ((newe (processor-get-engine combinator engine e))) - (out (procedure body newe) newe)))) - - -(define-method out ((n ) e) - (let* ((fmt (slot-ref n 'fmt)) - (body (slot-ref n 'body)) - (lb (length body)) - (lf (string-length fmt))) - (define (loops i n) - (if (= i lf) - (begin - (if (> n 0) - (if (<= n lb) - (output (list-ref body (- n 1)) e) - (skribe-error '! "Too few arguments provided" n))) - lf) - (let ((c (string-ref fmt i))) - (cond - ((char=? c #\$) - (display "$") - (+ 1 i)) - ((not (char-numeric? c)) - (cond - ((= n 0) - i) - ((<= n lb) - (output (list-ref body (- n 1)) e) - i) - (else - (skribe-error '! "Too few arguments provided" n)))) - (else - (loops (+ i 1) - (+ (- (char->integer c) - (char->integer #\0)) - (* 10 n)))))))) - - (let loop ((i 0)) - (cond - ((= i lf) - #f) - ((not (char=? (string-ref fmt i) #\$)) - (display (string-ref fmt i)) - (loop (+ i 1))) - (else - (loop (loops (+ i 1) 0))))))) - - -(define-method out ((n ) e) - 'unspecified) - - -(define-method out ((n ) e) - (skribe-error 'output "Orphan unresolved" n)) - - -(define-method out ((node ) e) - (let ((w (lookup-markup-writer node e))) - (if (writer? w) - (%out/writer node e w) - (output (slot-ref node 'body) e)))) -) diff --git a/skribe/src/stklos/prog.stk b/skribe/src/stklos/prog.stk deleted file mode 100644 index 6301ece..0000000 --- a/skribe/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 -;;;; -;;;; -;;;; 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/skribe/src/stklos/reader.stk b/skribe/src/stklos/reader.stk deleted file mode 100644 index bd38562..0000000 --- a/skribe/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 -;;;; -;;;; -;;;; 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/skribe/src/stklos/resolve.stk b/skribe/src/stklos/resolve.stk deleted file mode 100644 index 91dc965..0000000 --- a/skribe/src/stklos/resolve.stk +++ /dev/null @@ -1,255 +0,0 @@ -;;;; -;;;; resolve.stk -- Skribe Resolve Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 13-Aug-2003 18:39 (eg) -;;;; Last file update: 17-Feb-2004 14:43 (eg) -;;;; - -(define-module SKRIBE-RESOLVE-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 ) engine env) - (let Loop ((n* ast)) - (cond - ((pair? n*) - (set-car! n* (do-resolve! (car n*) engine env)) - (Loop (cdr n*))) - ((not (null? n*)) - (error 'do-resolve "Illegal argument" n*)) - (else - ast)))) - - -(define-method do-resolve! ((node ) engine env) - (let ((body (slot-ref node 'body)) - (options (slot-ref node 'options)) - (parent (slot-ref node 'parent))) - (with-debug 5 'do-resolve - (debug-item "body=" body) - (when (eq? parent 'unspecified) - (let ((p (assq 'parent env))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (when (pair? options) - (debug-item "unresolved options=" options) - (for-each (lambda (o) - (set-car! (cdr o) - (do-resolve! (cadr o) engine env))) - options) - (debug-item "resolved options=" options)))) - (slot-set! node 'body (do-resolve! body engine env)) - node))) - - - -(define-method do-resolve! ((node ) engine env0) - (let ((body (slot-ref node 'body)) - (options (slot-ref node 'options)) - (env (slot-ref node 'env)) - (parent (slot-ref node 'parent))) - (with-debug 5 'do-resolve - (debug-item "markup=" (markup-markup node)) - (debug-item "body=" body) - (debug-item "env0=" env0) - (debug-item "env=" env) - (when (eq? parent 'unspecified) - (let ((p (assq 'parent env0))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (when (pair? options) - (let ((e (append `((parent ,node)) env0))) - (debug-item "unresolved options=" options) - (for-each (lambda (o) - (set-car! (cdr o) - (do-resolve! (cadr o) engine e))) - options) - (debug-item "resolved options=" options))) - (let ((e `((parent ,node) ,@env ,@env0))) - (slot-set! node 'body (do-resolve! body engine e))))) - node))) - - -(define-method do-resolve! ((node ) engine env0) - (next-method) - ;; resolve the engine custom - (let ((env (append `((parent ,node)) env0))) - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (debug-item "custom=" i " " a) - (set-car! (cdr c) (do-resolve! a engine env)))) - (slot-ref engine 'customs))) - node) - - -(define-method do-resolve! ((node ) engine env) - (with-debug 5 'do-resolve - (debug-item "node=" node) - (let ((p (assq 'parent env))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) - - (let* ((proc (slot-ref node 'proc)) - (res (resolve! (proc node engine env) engine env)) - (loc (ast-loc node))) - (when (ast? res) - (ast-loc-set! res loc)) - (debug-item "res=" res) - (set! *unresolved* #t) - res))) - - -(define-method do-resolve! ((node ) engine env) - node) - - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-PARENT -;;;; -;;;; ====================================================================== -(define (resolve-parent n e) - (with-debug 5 'resolve-parent - (debug-item "n=" n) - (cond - ((not (is-a? n )) - (let ((c (assq 'parent e))) - (if (pair? c) - (cadr c) - n))) - ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) - (else - (slot-ref n 'parent))))) - - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-SEARCH-PARENT -;;;; -;;;; ====================================================================== -(define (resolve-search-parent n e pred) - (with-debug 5 'resolve-search-parent - (debug-item "node=" n) - (debug-item "searching=" pred) - (let ((p (resolve-parent n e))) - (debug-item "parent=" p " " - (if (is-a? p 'markup) (slot-ref p 'markup) "???")) - (cond - ((pred p) p) - ((is-a? p ) p) - ((not p) #f) - (else (resolve-search-parent p e pred)))))) - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-COUNTER -;;;; -;;;; ====================================================================== -;;FIXME: factoriser -(define (resolve-counter n e cnt val . opt) - (let ((c (assq (symbol-append cnt '-counter) e))) - (if (not (pair? c)) - (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "Orphan node" n) - (begin - (set-cdr! (last-pair e) - (list (list (symbol-append cnt '-counter) 0) - (list (symbol-append cnt '-env) '()))) - (resolve-counter n e cnt val))) - (let* ((num (cadr c)) - (nval (if (integer? val) - val - (+ 1 num)))) - (let ((c2 (assq (symbol-append cnt '-env) e))) - (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) - (cond - ((integer? val) - (set-car! (cdr c) val) - (car val)) - ((not val) - val) - (else - (set-car! (cdr c) (+ 1 num)) - (+ 1 num))))))) - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-IDENT -;;;; -;;;; ====================================================================== -(define (resolve-ident ident markup n e) - (with-debug 4 'resolve-ident - (debug-item "ident=" ident) - (debug-item "markup=" markup) - (debug-item "n=" (if (markup? n) (markup-markup n) n)) - (if (not (string? ident)) - (skribe-type-error 'resolve-ident - "Illegal ident" - ident - "string") - (let ((mks (find-markups ident))) - (and mks - (if (not markup) - (car mks) - (let loop ((mks mks)) - (cond - ((null? mks) - #f) - ((is-markup? (car mks) markup) - (car mks)) - (else - (loop (cdr mks))))))))))) - -) diff --git a/skribe/src/stklos/runtime.stk b/skribe/src/stklos/runtime.stk deleted file mode 100644 index 58d0d45..0000000 --- a/skribe/src/stklos/runtime.stk +++ /dev/null @@ -1,456 +0,0 @@ -;;;; -;;;; runtime.stk -- Skribe runtime system -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 13-Aug-2003 18:47 (eg) -;;;; Last file update: 15-Nov-2004 14:03 (eg) -;;;; - -(define-module SKRIBE-RUNTIME-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 )) -;; (skribe-error 'markup-writer "illegal engine" e)) -;; ((and (not before) -;; (not action) -;; (not after)) -;; (%find-markup-output e markup)) -;; (else -;; (let ((mp (if (procedure? predicate) -;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) -;; (lambda (n e) (is-markup? n markup))))) -;; (engine-output e markup mp options -;; (or before (slot-ref e 'default-before)) -;; (or action (slot-ref e 'default-action)) -;; (or after (slot-ref e 'default-after)))))))) - -(define (markup-option m opt) - (if (markup? m) - (let ((c (assq opt (slot-ref m 'options)))) - (and (pair? c) (pair? (cdr c)) - (cadr c))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - - -(define (markup-option-add! m opt val) - (if (markup? m) - (slot-set! m 'options (cons (list opt val) - (slot-ref m 'options))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - -;;;; ====================================================================== -;;;; -;;;; C O N T A I N E R S -;;;; -;;;; ====================================================================== -(define (container-env-get m key) - (let ((c (assq key (slot-ref m 'env)))) - (and (pair? c) (cadr c)))) - - -;;;; ====================================================================== -;;;; -;;;; I M A G E S -;;;; -;;;; ====================================================================== -(define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) - (to (string-append dir "/" f))) ;; FIXME: - (cond - ((string=? s fmt) - to) - ((file-exists? to) - to) - (else - (let ((c (if (string=? s "fig") - (string-append "fig2dev -L " fmt " " from " > " to) - (string-append "convert " from " " to)))) - (cond - ((> *skribe-verbose* 1) - (format (current-error-port) " [converting image: ~S (~S)]" from c)) - ((> *skribe-verbose* 0) - (format (current-error-port) " [converting image: ~S]" from))) - (and (zero? (system c)) - to)))))) - -(define (convert-image file formats) - (let ((path (find-path file (skribe-image-path)))) - (if (not path) - (skribe-error 'convert-image - (format "Can't find `~a' image file in path: " file) - (skribe-image-path)) - (let ((suf (suffix file))) - (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - #f))) - (if dir - (let ((dest (basename path))) - (copy-file path (make-path dir dest)) - dest) - path)) - (let loop ((fmts formats)) - (if (null? fmts) - #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - ".")) - (p (builtin-convert-image path (car fmts) dir))) - (if (string? p) - p - (loop (cdr fmts))))))))))) - -;;;; ====================================================================== -;;;; -;;;; S T R I N G - W R I T I N G -;;;; -;;;; ====================================================================== - -;; -;; (define (%make-html-replace) -;; ;; Ad-hoc version for HTML, a little bit faster than the -;; ;; make-general-string-replace define later (particularily if there -;; ;; is nothing to replace since, it does not allocate a new string -;; (let ((specials (string->regexp "&|\"|<|>"))) -;; (lambda (str) -;; (if (regexp-match specials str) -;; (begin -;; (let ((out (open-output-string))) -;; (dotimes (i (string-length str)) -;; (let ((ch (string-ref str i))) -;; (case ch -;; ((#\") (display """ out)) -;; ((#\&) (display "&" out)) -;; ((#\<) (display "<" out)) -;; ((#\>) (display ">" out)) -;; (else (write-char ch out))))) -;; (get-output-string out))) -;; str)))) - - -(define (%make-general-string-replace lst) - ;; The general version - (lambda (str) - (let ((out (open-output-string))) - (dotimes (i (string-length str)) - (let* ((ch (string-ref str i)) - (res (assq ch lst))) - (display (if res (cadr res) ch) out))) - (get-output-string out)))) - - -(define (make-string-replace lst) - (let ((l (sort lst (lambda (r1 r2) (char ">"))) - string->html) - (else - (%make-general-string-replace lst))))) - - - - -;;;; ====================================================================== -;;;; -;;;; O P T I O N S -;;;; -;;;; ====================================================================== - -;;NEW ;; -;;NEW ;; GET-OPTION -;;NEW ;; -;;NEW (define (get-option obj key) -;;NEW ;; This function either searches inside an a-list or a markup. -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (pair? (cdr c)) (cadr c)))) -;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key)) -;;NEW (else #f))) -;;NEW -;;NEW ;; -;;NEW ;; BIND-OPTION! -;;NEW ;; -;;NEW (define (bind-option! obj key value) -;;NEW (slot-set! obj 'option* (cons (list key value) -;;NEW (slot-ref obj 'option*)))) -;;NEW -;;NEW -;;NEW ;; -;;NEW ;; GET-ENV -;;NEW ;; -;;NEW (define (get-env obj key) -;;NEW ;; This function either searches inside an a-list or a container -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (cadr c)))) -;;NEW ((container? obj) (get-env (slot-ref obj 'env) key)) -;;NEW (else #f))) -;;NEW - - - - -;;;; ====================================================================== -;;;; -;;;; A S T -;;;; -;;;; ====================================================================== - -(define-generic ast->string) - - -(define-method ast->string ((ast )) "") -(define-method ast->string ((ast )) ast) -(define-method ast->string ((ast )) (number->string ast)) - -(define-method ast->string ((ast )) - (let ((out (open-output-string))) - (let Loop ((lst ast)) - (cond - ((null? lst) - (get-output-string out)) - (else - (display (ast->string (car lst)) out) - (unless (null? (cdr lst)) - (display #\space out)) - (Loop (cdr lst))))))) - -(define-method ast->string ((ast )) - (ast->string (slot-ref ast 'body))) - - -;;NEW ;; -;;NEW ;; AST-PARENT -;;NEW ;; -;;NEW (define (ast-parent n) -;;NEW (slot-ref n 'parent)) -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-PARENT -;;NEW ;; -;;NEW (define (markup-parent m) -;;NEW (let ((p (slot-ref m 'parent))) -;;NEW (if (eq? p 'unspecified) -;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m) -;;NEW p))) -;;NEW -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-DOCUMENT -;;NEW ;; -;;NEW (define (markup-document m) -;;NEW (let Loop ((p m) -;;NEW (l #f)) -;;NEW (cond -;;NEW ((is-markup? p 'document) p) -;;NEW ((or (eq? p 'unspecified) (not p)) l) -;;NEW (else (Loop (slot-ref p 'parent) p))))) -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-CHAPTER -;;NEW ;; -;;NEW (define (markup-chapter m) -;;NEW (let loop ((p m) -;;NEW (l #f)) -;;NEW (cond -;;NEW ((is-markup? p 'chapter) p) -;;NEW ((or (eq? p 'unspecified) (not p)) l) -;;NEW (else (loop (slot-ref p 'parent) p))))) -;;NEW -;;NEW -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; H A N D L E S -;;NEW ;;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (handle-body h) -;;NEW (slot-ref h 'body)) -;;NEW -;;NEW -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; F I N D -;;NEW ;;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (find pred obj) -;;NEW (with-debug 4 'find -;;NEW (debug-item "obj=" obj) -;;NEW (let loop ((obj (if (is-a? obj ) (container-body obj) obj))) -;;NEW (cond -;;NEW ((pair? obj) -;;NEW (apply append (map (lambda (o) (loop o)) obj))) -;;NEW ((is-a? obj ) -;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident)) -;;NEW (if (pred obj) -;;NEW (list (cons obj (loop (container-body obj)))) -;;NEW '())) -;;NEW (else -;;NEW (if (pred obj) -;;NEW (list obj) -;;NEW '())))))) -;;NEW - -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G -;;NEW ;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (the-body opt) -;;NEW ;; Filter out the options -;;NEW (let loop ((opt* opt) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-body "Illegal body" opt)) -;;NEW ((keyword? (car opt*)) -;;NEW (if (null? (cdr opt*)) -;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) -;;NEW (loop (cddr opt*) res))) -;;NEW (else -;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) -;;NEW -;;NEW -;;NEW -;;NEW (define (the-options opt+ . out) -;;NEW ;; Returns an list made of options.The OUT argument contains -;;NEW ;; keywords that are filtered out. -;;NEW (let loop ((opt* opt+) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-options "Illegal options" opt*)) -;;NEW ((keyword? (car opt*)) -;;NEW (cond -;;NEW ((null? (cdr opt*)) -;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) -;;NEW ((memq (car opt*) out) -;;NEW (loop (cdr opt*) res)) -;;NEW (else -;;NEW (loop (cdr opt*) -;;NEW (cons (list (car opt*) (cadr opt*)) res))))) -;;NEW (else -;;NEW (loop (cdr opt*) res))))) -;;NEW - - -) diff --git a/skribe/src/stklos/source.stk b/skribe/src/stklos/source.stk deleted file mode 100644 index a3102c1..0000000 --- a/skribe/src/stklos/source.stk +++ /dev/null @@ -1,191 +0,0 @@ -;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 3-Sep-2003 12:22 (eg) -;;;; Last file update: 27-Oct-2004 20:09 (eg) -;;;; - - - -(define-module SKRIBE-SOURCE-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/skribe/src/stklos/types.stk b/skribe/src/stklos/types.stk deleted file mode 100644 index fb16230..0000000 --- a/skribe/src/stklos/types.stk +++ /dev/null @@ -1,294 +0,0 @@ -;;;; -;;;; types.stk -- Definition of Skribe classes -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 12-Aug-2003 22:18 (eg) -;;;; Last file update: 28-Oct-2004 16:18 (eg) -;;;; - - -(define *node-table* (make-hash-table equal?)) - ; Used to stores the nodes of an AST. - ; It permits to retrieve a node from its - ; identifier. - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -;;FIXME: set! location in -(define-class () - ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) - (loc :init-form #f))) - -(define (ast? obj) (is-a? obj )) -(define (ast-loc obj) (slot-ref obj 'loc)) -(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((fmt :init-keyword :fmt) - (body :init-keyword :body))) - -(define (command? obj) (is-a? obj )) -(define (command-fmt obj) (slot-ref obj 'fmt)) -(define (command-body obj) (slot-ref obj 'body)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((proc :init-keyword :proc))) - -(define (unresolved? obj) (is-a? obj )) -(define (unresolved-proc obj) (slot-ref obj 'proc)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ast :init-keyword :ast :init-form #f :getter handle-ast))) - -(define (handle? obj) (is-a? obj )) -(define (handle-ast obj) (slot-ref obj 'ast)) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((required-options :init-keyword :required-options :init-form '()) - (options :init-keyword :options :init-form '()) - (body :init-keyword :body :init-form #f - :getter node-body))) - -(define (node? obj) (is-a? obj )) -(define (node-options obj) (slot-ref obj 'options)) -(define node-loc ast-loc) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1)) - (engine :init-keyword :engine :init-form 'unspecified) - (procedure :init-keyword :procedure :init-form (lambda (n e) n)))) - -(define (processor? obj) (is-a? obj )) -(define (processor-combinator obj) (slot-ref obj 'combinator)) -(define (processor-engine obj) (slot-ref obj 'engine)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :getter markup-ident :init-form #f) - (class :init-keyword :class :getter markup-class :init-form #f) - (markup :init-keyword :markup :getter markup-markup))) - - -(define (bind-markup! node) - (hash-table-update! *node-table* - (markup-ident node) - (lambda (cur) (cons node cur)) - (list node))) - - -(define-method initialize ((self ) initargs) - (next-method) - (bind-markup! self)) - - -(define (markup? obj) (is-a? obj )) -(define (markup-options obj) (slot-ref obj 'options)) -(define markup-body node-body) - - -(define (is-markup? obj markup) - (and (is-a? obj ) - (eq? (slot-ref obj 'markup) markup))) - - - -(define (find-markups ident) - (hash-table-get *node-table* ident #f)) - - -(define-method write-object ((obj ) port) - (format port "#[~A (~A/~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'markup) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((env :init-keyword :env :init-form '()))) - -(define (container? obj) (is-a? obj )) -(define (container-env obj) (slot-ref obj 'env)) -(define container-options markup-options) -(define container-ident markup-ident) -(define container-body node-body) - - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ()) - -(define (document? obj) (is-a? obj )) -(define (document-ident obj) (slot-ref obj 'ident)) -(define (document-body obj) (slot-ref obj 'body)) -(define document-options markup-options) -(define document-env container-env) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :init-form '???) - (format :init-keyword :format :init-form "raw") - (info :init-keyword :info :init-form '()) - (version :init-keyword :version :init-form 'unspecified) - (delegate :init-keyword :delegate :init-form #f) - (writers :init-keyword :writers :init-form '()) - (filter :init-keyword :filter :init-form #f) - (customs :init-keyword :custom :init-form '()) - (symbol-table :init-keyword :symbol-table :init-form '()))) - - - -(define (engine? obj) - (is-a? obj )) - -(define (engine-ident obj) ;; Define it here since the doc searches it - (slot-ref obj 'ident)) - -(define (engine-format obj) ;; Define it here since the doc searches it - (slot-ref obj 'format)) - -(define (engine-customs obj) ;; Define it here since the doc searches it - (slot-ref obj 'customs)) - -(define (engine-filter obj) ;; Define it here since the doc searches it - (slot-ref obj 'filter)) - -(define (engine-symbol-table obj) ;; Define it here since the doc searches it - (slot-ref obj 'symbol-table)) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :init-form '??? :getter writer-ident) - (class :init-keyword :class :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 )) - -(define-method write-object ((obj ) port) - (format port "#[~A (~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((name :init-keyword :name :init-form #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))) - -(define (language? obj) - (is-a? obj )) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((file :init-keyword :file :getter location-file) - (pos :init-keyword :pos :getter location-pos) - (line :init-keyword :line :getter location-line))) - -(define (location? obj) - (is-a? obj )) - -(define (ast-location obj) - (let ((loc (slot-ref obj 'loc))) - (if (location? loc) - (let* ((fname (location-file loc)) - (line (location-line loc)) - (pwd (getcwd)) - (len (string-length pwd)) - (lenf (string-length fname)) - (file (if (and (substring=? pwd fname len) - (> lenf len)) - (substring fname len (+ 1 (string-length fname))) - fname))) - (format "~a, line ~a" file line)) - "no source location"))) diff --git a/skribe/src/stklos/vars.stk b/skribe/src/stklos/vars.stk deleted file mode 100644 index 1c875f8..0000000 --- a/skribe/src/stklos/vars.stk +++ /dev/null @@ -1,82 +0,0 @@ -;;;; -;;;; vars.stk -- Skribe Globals -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 11-Aug-2003 16:18 (eg) -;;;; Last file update: 26-Feb-2004 20:36 (eg) -;;;; - - -;;; -;;; Switches -;;; -(define *skribe-verbose* 0) -(define *skribe-warning* 5) -(define *load-rc* #t) - -;;; -;;; PATH variables -;;; -(define *skribe-path* #f) -(define *skribe-bib-path* '(".")) -(define *skribe-source-path* '(".")) -(define *skribe-image-path* '(".")) - - -(define *skribe-rc-directory* - (make-path (getenv "HOME") ".skribe")) - - -;;; -;;; In and out ports -;;; -(define *skribe-src* '()) -(define *skribe-dest* #f) - -;;; -;;; Engine -;;; -(define *skribe-engine* 'html) ;; Use HTML by default - -;;; -;;; Misc -;;; -(define *skribe-chapter-split* '()) -(define *skribe-ref-base* #f) -(define *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter -(define *skribe-variants* '()) - - - - -;;; Forward definitions (to avoid warnings when compiling Skribe) -;;; This is a KLUDGE. -(define mark #f) -(define ref #f) -;;(define invoke 3) -(define lookup-markup-writer #f) - -(define-module SKRIBE-ENGINE-MODULE - (define find-engine #f)) - -(define-module SKRIBE-OUTPUT-MODULE) - -(define-module SKRIBE-RUNTIME-MODULE) diff --git a/skribe/src/stklos/verify.stk b/skribe/src/stklos/verify.stk deleted file mode 100644 index da9b132..0000000 --- a/skribe/src/stklos/verify.stk +++ /dev/null @@ -1,157 +0,0 @@ -;;;; -;;;; verify.stk -- Skribe Verification Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 13-Aug-2003 11:57 (eg) -;;;; Last file update: 27-Oct-2004 16:35 (eg) -;;;; - -(define-module SKRIBE-VERIFY-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 ) e) - obj) - -;;; PAIR -(define-method verify ((obj ) e) - (for-each (lambda (x) (verify x e)) obj) - obj) - -;;; PROCESSOR -(define-method verify ((obj ) e) - (let ((combinator (slot-ref obj 'combinator)) - (engine (slot-ref obj 'engine)) - (body (slot-ref obj 'body))) - (verify body (processor-get-engine combinator engine e)) - obj)) - -;;; NODE -(define-method verify ((node ) e) - ;; Verify body - (verify (slot-ref node 'body) e) - ;; Verify options - (for-each (lambda (o) (verify (cadr o) e)) - (slot-ref node 'options)) - node) - -;;; MARKUP -(define-method verify ((node ) e) - (with-debug 5 'verify:: - (debug-item "node=" (markup-markup node)) - (debug-item "options=" (slot-ref node 'options)) - (debug-item "e=" (engine-ident e)) - - (next-method) - - (let ((w (lookup-markup-writer node e))) - (when (writer? w) - (check-required-options node w e) - (when (pair? (writer-options w)) - (check-options (slot-ref w 'options) node e)) - (let ((validate (slot-ref w 'validate))) - (when (procedure? validate) - (unless (validate node e) - (skribe-warning - 1 - node - (format "Node `~a' forbidden here by ~a engine" - (markup-markup node) - (engine-ident e)))))))) - node)) - - -;;; DOCUMENT -(define-method verify ((node ) e) - (next-method) - - ;; verify the engine customs - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (set-car! (cdr c) (verify a e)))) - (slot-ref e 'customs)) - - node) - - -) - diff --git a/skribe/src/stklos/writer.stk b/skribe/src/stklos/writer.stk deleted file mode 100644 index 2b0f91c..0000000 --- a/skribe/src/stklos/writer.stk +++ /dev/null @@ -1,211 +0,0 @@ -;;;; -;;;; writer.stk -- Skribe Writer Stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 15-Sep-2003 22:21 (eg) -;;;; Last file update: 4-Mar-2004 10:48 (eg) -;;;; - - -(define-module SKRIBE-WRITER-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/skribe/src/stklos/xml-lex.l b/skribe/src/stklos/xml-lex.l deleted file mode 100644 index 5d9a8d9..0000000 --- a/skribe/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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 21-Dec-2003 22:38 (eg) -;;;; - -space [ \n\9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -'[^']*' (new markup - (markup '&source-string) - (body yytext)) - -;;Comment - (new markup - (markup '&source-comment) - (body yytext)) - -;; Markup -<[^>\n ]+|> (new markup - (markup '&source-module) - (body yytext)) - -;; Regular text -[^<>\"']+ (begin yytext) - - -<> 'eof -<> (skribe-error 'xml-fontifier "Parse error" yytext) - - - - - - - - - \ No newline at end of file diff --git a/skribe/src/stklos/xml.stk b/skribe/src/stklos/xml.stk deleted file mode 100644 index 47dd46f..0000000 --- a/skribe/src/stklos/xml.stk +++ /dev/null @@ -1,52 +0,0 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:33 (eg) -;;;; Last file update: 28-Dec-2003 17:33 (eg) -;;;; - - -(require "lex-rt") ;; to avoid module problems - - -(define-module SKRIBE-XML-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))) -) diff --git a/skribe/tools/Makefile b/skribe/tools/Makefile deleted file mode 100644 index 200db45..0000000 --- a/skribe/tools/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/tools/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Wed Jul 30 16:23:07 2003 */ -#* Last change : Tue Oct 26 19:36:26 2004 (eg) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Skribe Tools general makefile */ -#*=====================================================================*/ -include ../etc/Makefile.config - -TOOLS= skribebibtex - -#*---------------------------------------------------------------------*/ -#* all */ -#*---------------------------------------------------------------------*/ -.PHONY: all - -all: - for p in $(TOOLS); do \ - (cd $$p/$(SYSTEM) && $(MAKE)) || exit -1; \ - done - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ for p in $(TOOLS); do \ - (cd $$p/bigloo && $(MAKE) pop); \ - (cd $$p/stklos && $(MAKE) pop); \ - done - @ echo tools/Makefile - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - @ for p in $(TOOLS); do \ - (cd $$p/$(SYSTEM) && $(MAKE) install) || exit -1; \ - done -uninstall: - @ for p in $(TOOLS); do \ - (cd $$p/$(SYSTEM) && $(MAKE) uninstall) || exit -1; \ - done - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - for p in $(TOOLS); do \ - (cd $$p/$(SYSTEM) && $(MAKE) clean); \ - done - diff --git a/skribe/tools/skribebibtex/bigloo/Makefile b/skribe/tools/skribebibtex/bigloo/Makefile deleted file mode 100644 index c2a4cc1..0000000 --- a/skribe/tools/skribebibtex/bigloo/Makefile +++ /dev/null @@ -1,70 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/tools/skribebibtex/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Thu Dec 20 10:42:25 2001 */ -#* Last change : Tue Oct 26 19:34:00 2004 (eg) */ -#* Copyright : 2001-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to compile the bibtex->Skribe translator */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* Standard configuration */ -#*---------------------------------------------------------------------*/ -include ../../../etc/bigloo/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Binary */ -#*---------------------------------------------------------------------*/ -TARGETNAME = skribebibtex - -#*---------------------------------------------------------------------*/ -#* Objects */ -#*---------------------------------------------------------------------*/ -_BGL_OBJECTS = skribebibtex main -_C_OBJECTS = -_JAVA_OBJECTS = - -_OBJECTS = $(_BGL_OBJECTS) $(_C_OBJECTS) -OBJECTS = $(_OBJECTS:%=o/%.o) - -_CLASSES = $(_BGL_OBJECTS) $(_JAVA_OBJECTS) -CLASSES = $(_OBJECTS:%=o/class_s/bigloo/skribe/$(TARGETNAME)/%.class) - -_BGL_SOURCES = $(_BGL_OBJECTS:%=%.scm) -_C_SOURCES = $(_C_OBJECTS:%=%.c) -_JAVA_SOURCES = $(_JAVA_OBJECTS:%=%.java) - -SOURCES = $(_BGL_SOURCES) $(_C_SOURCES) $(_JAVA_SOURCES) -INCLUDES = - -#*---------------------------------------------------------------------*/ -#* Sources */ -#*---------------------------------------------------------------------*/ -POPULATION = $(SOURCES) $(INCLUDES) Makefile - -#*---------------------------------------------------------------------*/ -#* all, c & jvm */ -#*---------------------------------------------------------------------*/ -all: bin-$(TARGET) -c: bin-c -jvm: bin-jvm - -#*---------------------------------------------------------------------*/ -#* Standard Skribe Makefile */ -#*---------------------------------------------------------------------*/ -include ../../../etc/bigloo/Makefile.tpl - -#*---------------------------------------------------------------------*/ -#* pop: */ -#*---------------------------------------------------------------------*/ -pop: - @ echo $(POPULATION:%=tools/$(TARGETNAME)/bigloo/%) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -clean: stdclean - - diff --git a/skribe/tools/skribebibtex/bigloo/main.scm b/skribe/tools/skribebibtex/bigloo/main.scm deleted file mode 100644 index 3ff89de..0000000 --- a/skribe/tools/skribebibtex/bigloo/main.scm +++ /dev/null @@ -1,44 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/tools/skribebibtex/main.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 12 14:57:58 2001 */ -;* Last change : Fri Oct 24 12:00:23 2003 (serrano) */ -;* Copyright : 2001-03 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The entry point of the bibtex->skribe translator */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module main - (import skribebibtex) - (main main)) - -;*---------------------------------------------------------------------*/ -;* main ... */ -;*---------------------------------------------------------------------*/ -(define (main argv) - (define (usage args-parse-usage) - (print "usage: skribebibtex [options] [input]") - (newline) - (args-parse-usage #f)) - (let ((stage 'scr) - (dest #f) - (in #f)) - (args-parse (cdr argv) - ((("-h" "--help") (help "This help message")) - (usage args-parse-usage) - (exit 0)) - ((("--options") (help "Display the options and exit")) - (args-parse-usage #t) - (exit 0)) - (("-o" ?out (help "Set the destination file")) - (set! dest out)) - (else - (set! in else))) - (if (string? dest) - (with-output-to-file dest (lambda () (skribebibtex in))) - (skribebibtex in)))) - diff --git a/skribe/tools/skribebibtex/bigloo/skribebibtex.scm b/skribe/tools/skribebibtex/bigloo/skribebibtex.scm deleted file mode 100644 index b581537..0000000 --- a/skribe/tools/skribebibtex/bigloo/skribebibtex.scm +++ /dev/null @@ -1,385 +0,0 @@ -;*=====================================================================*/ -;* .../skribe/tools/skribebibtex/bigloo/skribebibtex.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 12 14:57:58 2001 */ -;* Last change : Sun Apr 10 09:10:02 2005 (serrano) */ -;* Copyright : 2001-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The bibtex->skribe translator */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribebibtex - (export (skribebibtex in))) - -;*---------------------------------------------------------------------*/ -;* skribebibtex ... */ -;*---------------------------------------------------------------------*/ -(define (skribebibtex in) - (let* ((port (if (string? in) - (let ((p (open-input-file in))) - (if (not (input-port? p)) - (error "skribebibtext" - "Can't read input file" - in) - p)) - (current-input-port))) - (sexp (parse-bibtex port))) - (for-each (lambda (e) - (match-case e - ((?kind ?ident . ?fields) - (display* "(" - (string-downcase (symbol->string kind)) - " \"" ident "\"") - (for-each (lambda (f) - (display* "\n (" (car f) " ") - (write (cdr f)) - (display ")")) - fields) - (print ")\n")))) - sexp))) - -;*---------------------------------------------------------------------*/ -;* *bibtex-string-table* ... */ -;*---------------------------------------------------------------------*/ -(define *bibtex-string-table* #unspecified) - -;*---------------------------------------------------------------------*/ -;* make-bibtex-hashtable ... */ -;*---------------------------------------------------------------------*/ -(define (make-bibtex-hashtable) - (let ((table (make-hashtable))) - (for-each (lambda (k) - (let ((cp (string-capitalize k))) - (hashtable-put! table k cp) - (hashtable-put! table cp cp))) - '("jan" "feb" "mar" "apr" "may" "jun" "jul" - "aug" "sep" "oct" "nov" "dec")) - table)) - -;*---------------------------------------------------------------------*/ -;* parse-bibtex ... */ -;*---------------------------------------------------------------------*/ -(define (parse-bibtex port::input-port) - (set! *bibtex-string-table* (make-bibtex-hashtable)) - (cond-expand - (bigloo2.6 - (try (read/lalrp bibtex-parser bibtex-lexer port) - (lambda (escape proc mes obj) - (match-case obj - ((?token (?fname . ?pos) . ?val) - (error/location proc "bibtex parse error" token fname pos)) - (else - (notify-error proc mes obj) - (error proc mes obj)))))) - (else - (with-exception-handler - (lambda (e) - (if (&io-parse-error? e) - (let ((o (&error-obj e))) - (match-case o - ((?token (?fname . ?pos) . ?val) - (error/location (&error-proc e) - "bibtex parse error" - token - fname - pos)) - (else - (raise e)))) - (raise e))) - (lambda () - (read/lalrp bibtex-parser bibtex-lexer port)))))) - -;*---------------------------------------------------------------------*/ -;* the-coord ... */ -;*---------------------------------------------------------------------*/ -(define (the-coord port) - (cons (input-port-name port) (input-port-position port))) - -;*---------------------------------------------------------------------*/ -;* bibtex-lexer ... */ -;*---------------------------------------------------------------------*/ -(define bibtex-lexer - (regular-grammar ((blank (in " \t\n"))) - ;; separators - ((+ blank) - (list 'BLANK (the-coord (the-port)))) - ;; comments - ((: "%" (* all)) - (ignore)) - ;; egal sign - (#\= - (list 'EGAL (the-coord (the-port)))) - ;; sharp sign - ((: (* blank) #\# (* blank)) - (list 'SHARP (the-coord (the-port)))) - ;; open bracket - (#\{ - (list 'BRA-OPEN (the-coord (the-port)))) - ;; close bracket - (#\} - (list 'BRA-CLO (the-coord (the-port)))) - ;; comma - (#\, - (list 'COMMA (the-coord (the-port)))) - ;; double quote - ((: #\\ (in "\"\\_")) - (list 'CHAR (the-coord (the-port)) (the-character))) - ;; optional linebreak - ((: #\\ #\-) - (ignore)) - ;; special latin characters - ((or "{\\'e}" "\\'e") - (list 'CHAR (the-coord (the-port)) "é")) - ((or "{\\o}" "\\o") - (list 'CHAR (the-coord (the-port)) "ø")) - ((or "{\\~{n}}" "\\~{n}") - (list 'CHAR (the-coord (the-port)) "ñ")) - ((or "{\\~{N}}" "\\~{N}") - (list 'CHAR (the-coord (the-port)) "Ñ")) - ((or "{\\^{o}}" "\\^{o}") - (list 'CHAR (the-coord (the-port)) "ô")) - ((or "{\\^{O}}" "\\^{O}") - (list 'CHAR (the-coord (the-port)) "Ô")) - ((or "{\\\"{o}}" "\\\"{o}") - (list 'CHAR (the-coord (the-port)) "ö")) - ((or "{\\\"{O}}" "\\\"{O}") - (list 'CHAR (the-coord (the-port)) "Ö")) - ((or "{\\`e}" "\\`e") - (list 'CHAR (the-coord (the-port)) "è")) - ((or "{\\`a}" "\\`a") - (list 'CHAR (the-coord (the-port)) "à")) - ((or "{\\\"i}" "{\\\"{i}}" "\\\"i" "\\\"{i}") - (list 'CHAR (the-coord (the-port)) "ï")) - ((or "{\\\"u}" "\\\"u") - (list 'CHAR (the-coord (the-port)) "ü")) - ((or "{\\`u}" "\\`u") - (list 'CHAR (the-coord (the-port)) "ù")) - ;; latex commands - ((: #\\ alpha (+ (or alpha digit))) - (let ((s (the-substring 1 (the-length)))) - (cond - ((member s '("pi" "Pi" "lambda" "Lambda")) - (list 'IDENT (the-coord (the-port)) s)) - (else - (ignore))))) - ;; strings - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (list 'STRING - (the-coord (the-port)) - (the-substring 1 (-fx (the-length) 1)))) - ;; commands - ((: "@" (+ alpha)) - (let* ((str (string-upcase (the-substring 1 (the-length)))) - (sym (string->symbol str))) - (case sym - ((STRING) - (list 'BIBSTRING (the-coord (the-port)))) - (else - (list 'BIBITEM (the-coord (the-port)) sym))))) - ;; digit - ((+ digit) - (list 'NUMBER (the-coord (the-port)) (the-string))) - ;; ident - ((+ (or alpha digit (in ".:-&/?+*"))) - (list 'IDENT (the-coord (the-port)) (the-string))) - ;; default - (else - (let ((c (the-failure))) - (if (eof-object? c) - c - (list 'CHAR (the-coord (the-port)) c)))))) - -;*---------------------------------------------------------------------*/ -;* bibtex-parser ... */ -;*---------------------------------------------------------------------*/ -(define bibtex-parser - (lalr-grammar - ;; tokens - (CHAR IDENT STRING COMMA BRA-OPEN BRA-CLO SHARP BLANK NUMBER EGAL - BIBSTRING BIBITEM) - - ;; bibtex - (bibtex - (() - '()) - ((bibtex string-def) - bibtex) - ((bibtex bibtex-entry) - (cons bibtex-entry bibtex)) - ((bibtex BLANK) - bibtex)) - - ;; blank* - (blank* - (() '()) - ((blank* BLANK) '())) - - ;; string-def - (string-def - ((BIBSTRING BRA-OPEN blank* IDENT blank* EGAL blank* bibtex-entry-value BRA-CLO) - (bibtex-string-def! (cadr IDENT) bibtex-entry-value))) - - ;; bibtex-entry - (bibtex-entry - ((BIBITEM blank* BRA-OPEN blank* IDENT blank* COMMA - bibtex-entry-item* BRA-CLO) - (make-bibtex-entry (cadr BIBITEM) - (cadr IDENT) - bibtex-entry-item*))) - - ;; bibtex-entry-item* - (bibtex-entry-item* - ((blank*) - '()) - ((bibtex-entry-item) - (list bibtex-entry-item)) - ((bibtex-entry-item COMMA bibtex-entry-item*) - (cons bibtex-entry-item bibtex-entry-item*))) - - ;; bibtex-entry-item - (bibtex-entry-item - ((blank* IDENT blank* EGAL blank* bibtex-entry-value blank*) - (cons (cadr IDENT) bibtex-entry-value))) - - ;; bibtex-entry-value - (bibtex-entry-value - ((NUMBER) - (list (cadr NUMBER))) - ((bibtex-entry-value-string) - bibtex-entry-value-string) - ((BRA-OPEN bibtex-entry-value-block* BRA-CLO) - bibtex-entry-value-block*)) - - ;; bibtex-entry-value-string - (bibtex-entry-value-string - ((bibtex-entry-value-string-simple) - (list bibtex-entry-value-string-simple)) - ((bibtex-entry-value-string SHARP bibtex-entry-value-string-simple) - `(,@bibtex-entry-value-string ,bibtex-entry-value-string-simple))) - - ;; bibtex-entry-value-string-simple - (bibtex-entry-value-string-simple - ((STRING) - (cadr STRING)) - ((IDENT) - `(ref ,(cadr IDENT)))) - - ;; bibtex-entry-value-block* - (bibtex-entry-value-block* - (() - '()) - ((bibtex-entry-value-block* bibtex-entry-value-block) - (append bibtex-entry-value-block* bibtex-entry-value-block))) - - ;; bibtex-entry-value-block - (bibtex-entry-value-block - ((BRA-OPEN bibtex-entry-value-block* BRA-CLO) - bibtex-entry-value-block*) - ((COMMA) - (list ",")) - ((IDENT) - (list (cadr IDENT))) - ((BLANK) - (list " ")) - ((EGAL) - (list "=")) - ((CHAR) - (list (cadr CHAR))) - ((NUMBER) - (list (cadr NUMBER))) - ((STRING) - (list (string-append "\"" (cadr STRING) "\"")))))) - -;*---------------------------------------------------------------------*/ -;* bibtex-string-def! ... */ -;*---------------------------------------------------------------------*/ -(define (bibtex-string-def! ident value) - (define (->string value) - (if (string? value) - value - (match-case value - (((and ?s (? string?))) - s) - (((and ?n (? number?))) - (number->string n)) - (else - (apply string-append (map ->string value)))))) - (hashtable-put! *bibtex-string-table* ident (->string value))) - -;*---------------------------------------------------------------------*/ -;* make-bibtex-entry ... */ -;*---------------------------------------------------------------------*/ -(define (make-bibtex-entry kind ident value) - (define (parse-entry-value line) - (let ((name (car line)) - (val (cdr line))) - (let loop ((val (reverse val)) - (res "")) - (cond - ((null? val) - (cons name (untexify res))) - ((char? (car val)) - (loop (cdr val) (string-append (string (car val)) res))) - ((string? (car val)) - (loop (cdr val) (string-append (car val) res))) - (else - (match-case (car val) - ((ref ?ref) - (let ((h (hashtable-get *bibtex-string-table* ref))) - (loop (cdr val) - (if (string? h) - (string-append h res) - res)))) - (else - (loop (cdr val) res)))))))) - (let ((fields (map parse-entry-value value))) - `(,kind ,ident ,@fields))) - -;*---------------------------------------------------------------------*/ -;* untexify ... */ -;*---------------------------------------------------------------------*/ -(define (untexify val) - (define (untexify-math-string str) - (string-case str - ((+ (out #\_ #\^ #\space #\Newline #\tab)) - (let ((s (the-string))) - (string-append s (ignore)))) - ((+ (in "^_")) - (ignore)) - ((+ (in " \n\t")) - (string-append " " (ignore))) - (else - ""))) - (define (untexify-string str) - (let ((s (pregexp-replace* "C[$]\\^[$]_[+][+][$][$]" str "C++"))) - (string-case (pregexp-replace* "[{}]" s "") - ((+ (out #\\ #\$ #\space #\Newline #\tab #\~)) - (let ((s (the-string))) - (string-append s (ignore)))) - ((: #\\ (+ (or (: "c" (out #\h)) - (: "ch" (out #\a)) - (: "cha" (out #\r)) - (: "char" (out digit)) - (out #\\ #\space #\c)))) - (ignore)) - ((: #\\ "char" (+ digit)) - (string-append - (string - (integer->char - (string->integer - (the-substring 5 (the-length))))) - (ignore))) - ((: #\$ (* (out #\$)) #\$) - (let ((s (the-substring 1 (-fx (the-length) 1)))) - (string-append (untexify-math-string s) (ignore)))) - ((+ (in " \n\t~")) - (string-append " " (ignore))) - (else - "")))) - (if (string? val) - (untexify-string val) - (map untexify val))) diff --git a/skribe/tools/skribebibtex/stklos/Makefile b/skribe/tools/skribebibtex/stklos/Makefile deleted file mode 100644 index 3e31d88..0000000 --- a/skribe/tools/skribebibtex/stklos/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -# -# Makefile for STklos skribebibtex -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 26-Oct-2004 18:40 (eg) -# Last file update: 8-Nov-2004 15:25 (eg) - -include ../../../etc/stklos/Makefile.skb -include ../../../etc/Makefile.config - -POPULATION = Makefile bibtex-lex.l bibtex-parser.y skribebibtex.stk main.stk -BINDIR = ../../../bin -TARGET = skribebibtex -EXE = $(BINDIR)/$(TARGET).stklos - -all: $(EXE) - -$(EXE): main.stk bibtex-lex.stk bibtex-parser.stk - stklos-compile -l -o $(EXE) main.stk - -bibtex-lex.stk: bibtex-lex.l - stklos-genlex bibtex-lex.l bibtex-lex.stk bibtex-lex - -bibtex-parser.stk: bibtex-parser.y - stklos -f bibtex-parser.y - -bibtex: bibtex-lex.stk - - -#====================================================================== -# install ... -#====================================================================== -install: $(INSTALL_BINDIR) - cp $(EXE) $(INSTALL_BINDIR)/$(TARGET).stklos \ - && chmod $(BMASK) $(INSTALL_BINDIR)/$(TARGET).stklos - rm -f $(INSTALL_BINDIR)/$(TARGET) - ln -s $(TARGET).stklos $(INSTALL_BINDIR)/$(TARGET) - -$(INSTALL_BINDIR): - mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) - - -#====================================================================== -# uninstall ... -#====================================================================== -uninstall: - rm $(INSTALL_BINDIR)/$(TARGET) - rm $(INSTALL_BINDIR)/$(TARGET).stklos - - -#====================================================================== -# pop ... -#====================================================================== -pop: - @echo $(POPULATION:%=tools/skribebibtex/stklos/%) - -#====================================================================== -# clean ... -#====================================================================== - -clean: - rm -f $(EXE) bibtex-lex.stk bibtex-parser.stk *~ diff --git a/skribe/tools/skribebibtex/stklos/bibtex-lex.l b/skribe/tools/skribebibtex/stklos/bibtex-lex.l deleted file mode 100644 index 03b4871..0000000 --- a/skribe/tools/skribebibtex/stklos/bibtex-lex.l +++ /dev/null @@ -1,75 +0,0 @@ -;;;; -*- Scheme -*- -;;;; bibtex-lex.l -- SILex input for BibTeX -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Oct-2004 17:47 (eg) -;;;; Last file update: 25-Oct-2004 20:16 (eg) -;;;; - - -space [ \n\9] -alpha [-+a-zA-ZàâäéèêëîïôöûüùÀÂÄÉÈÊËÎÏÔÖÛÜÙ./:()?!'&_~] - -%% - -;; Spaces -{space}+ (list 'BLANK) -;; Comment -\%.*$ (yycontinue) -;; equal sign -= (list 'EQUAL) -;; Open Bracket -\{ (list 'LBRACKET) -;; Close Bracket -\} (list 'RBRACKET) -;; Comma -, (list 'COMMA) -;; Strings -\"[^\"]*\" (list 'STRING yytext) -;; Commands -@{alpha}+ (let* ((str (string-downcase - (substring yytext 1 - (string-length yytext)))) - (sym (string->symbol str))) - (case sym - ((string) (list 'BIBSTRING)) - (else (list 'BIBITEM sym)))) -;; Ident -{alpha}({alpha}|[0-9])* (list 'IDENT yytext) -;; Number -[0-9]+ (list 'NUMBER yytext) -;; Diacritic -\\['`^\"][aeiouAEIOU] (lex-char (string-ref yytext 1) - (string-ref yytext 2)) -\{\\['`^\"][aeiouAEIOU]\} (lex-char (string-ref yytext 2) - (string-ref yytext 3)) - -;; Unrecognized character -. (begin - (format (current-error-port) - "Skipping character ~S\n" yytext) - (yycontinue)) - -;;;; ====================================================================== -<> '*eoi* -<> (error 'bibtex-lexer "Parse error" yytext) - - diff --git a/skribe/tools/skribebibtex/stklos/bibtex-parser.y b/skribe/tools/skribebibtex/stklos/bibtex-parser.y deleted file mode 100644 index 50236a9..0000000 --- a/skribe/tools/skribebibtex/stklos/bibtex-parser.y +++ /dev/null @@ -1,117 +0,0 @@ -;;;; -*- Scheme -*- -;;;; bibtex-parser.y -- SILex input for BibTeX -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Oct-2004 17:47 (eg) -;;;; Last file update: 22-Oct-2004 18:14 (eg) -;;;; - -(load "lalr") - -(define (main args) - ;; Build the parser - (lalr-parser - ;; Options - (output: parser "bibtex-parser.stk") - - ;; Terminal symbols - (CHAR BLANK IDENT STRING COMMA LBRACKET RBRACKET NUMBER EQUAL - BIBSTRING BIBITEM) - - ;; Rules - (S - () - (S string-def) - (S blank*) - (S bibtex-entry)) - - - (blank* - () - (blank* BLANK)) - - - (string-def - (BIBSTRING LBRACKET blank* IDENT blank* EQUAL blank* entry-value - blank* RBRACKET) - : (bibtex-string-def! (car $4) (car $8))) - - - (bibtex-entry - (BIBITEM LBRACKET blank* IDENT blank* COMMA blank* entry-item* RBRACKET) - : (make-bibentry $1 $4 $8)) - - - (entry-item* - (blank*) - : '() - (entry-item) - : (list $1) - (entry-item COMMA entry-item*) - : (cons $1 $3)) - - - (entry-item - (blank* IDENT blank* EQUAL blank* entry-value blank*) - : (cons (car $2) $6)) - - - (entry-value - (NUMBER) - : (list (car $1)) - (STRING) - : $1 - (IDENT) - : (bibtex-string-ref (car $1)) - (LBRACKET entry-value-block* RBRACKET) - : (list (apply string-append $2))) - - - (entry-value-block* - () - : '() - (entry-value-block* entry-value-block) - : (append $1 $2)) - - - (entry-value-block - (LBRACKET entry-value-block* RBRACKET) - : $2 - (COMMA) - : (list ",") - (IDENT) - : $1 - (BLANK) - : (list " ") - (EQUAL) - : (list "=") - (CHAR) - : $1 - (NUMBER) - : $1 - (STRING) - : $1) - ) - ;; Terminate - 0) - - - \ No newline at end of file diff --git a/skribe/tools/skribebibtex/stklos/main.stk b/skribe/tools/skribebibtex/stklos/main.stk deleted file mode 100644 index 3225658..0000000 --- a/skribe/tools/skribebibtex/stklos/main.stk +++ /dev/null @@ -1,118 +0,0 @@ -;;;; -;;;; main.stk -- Skribebibtex Main -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 22-Oct-2004 10:29 (eg) -;;;; Last file update: 26-Oct-2004 21:52 (eg) -;;;; - -(define *bibtex-strings* (make-hash-table string=?)) -(define *debug* (getenv "DEBUG")) -(define *in* (current-input-port)) -(define *out* (current-output-port)) - - -(define (bibtex-string-def! str val) - (hash-table-put! *bibtex-strings* str val)) - - -(define (bibtex-string-ref str) - (list (hash-table-get *bibtex-strings* str str))) - - -(define (lex-char accent letter) - (list 'CHAR - (case accent - ((#\') (case letter - ((#\a) "á") ((#\e) "é") ((#\i) "í") ((#\o) "ó") ((#\u) "ú") - ((#\A) "Á") ((#\E) "É") ((#\I) "Í") ((#\O) "Ó") ((#\U) "ú") - (else "?"))) - ((#\`) (case letter - ((#\a) "à") ((#\e) "è") ((#\i) "ì") ((#\o) "ò") ((#\u) "ù") - ((#\A) "À") ((#\E) "È") ((#\I) "Ì") ((#\O) "Ò") ((#\U) "Ù") - (else "?"))) - ((#\^) (case letter - ((#\a) "â") ((#\e) "ê") ((#\i) "î") ((#\o) "ô") ((#\u) "û") - ((#\A) "Â") ((#\E) "Ê") ((#\I) "Î") ((#\O) "Ô") ((#\U) "Û") - (else "?"))) - ((#\") (case letter - ((#\a) "ä") ((#\e) "ë") ((#\i) "ï") ((#\o) "ö") ((#\u) "ü") - ((#\A) "Ä") ((#\E) "Ë") ((#\I) "Ï") ((#\O) "Ö") ((#\U) "Ü") - (else "?"))) - (else "?")))) - - -(define (make-bibentry kind key infos) - (define (pretty-string s) - (if (and (string? s) - (>= (string-length s) 2) - (eq? #\" (string-ref s 0)) - (eq? #\" (string-ref s (- (string-length s) 1)))) - (substring s 1 (- (string-length s) 1)) - s)) - (format *out* ";;;;\n(~A ~S\n" (car kind) (car key)) - (for-each (lambda (x) (format *out* " (~A ~S)\n" - (car x) - (pretty-string (cadr x)))) - infos) - (format *out* ")\n\n")) - - -;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -(include "bibtex-lex.stk") -(include "bibtex-parser.stk") -;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -(define (bibtex2scheme in out) - (let* ((lex (bibtex-lex in)) - (scan (lambda () - (let ((tok (lexer-next-token lex))) - (when *debug* - (format (current-error-port) "token = ~S\n" tok)) - tok))) - (error (lambda (a b) (error 'bibtex-parser "~A~A" a b)))) - (parser scan error))) - - -(define (main args) - ;; Parse the program arguments - (parse-arguments args - "Usage: skribebibtex [options] [input]" - (("help" :alternate "h" :help "provide help for the command") - (arg-usage (current-error-port)) - (exit 0)) - (("options" :help "display the options and exit") - (arg-usage (current-output-port) #t) - (exit 0)) - (("output" :alternate "o" :arg file :help "set the output to ") - (let ((port (open-file file "w"))) - (if port - (set! *out* port) - (die (format "~A: bad output file ~S" 'skribebibtex file) 1)))) - (else - (cond - ((= (length other-arguments) 1) - (let* ((file (car other-arguments)) - (port (open-file file "r"))) - (if port - (set! *in* file) - (die (format "~A: bad input file ~S" 'skribebibtex file) 1))))))) - (bibtex2scheme *in* *out*)) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b675e8a..b466ac1 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -2876,93 +2876,93 @@ ;*---------------------------------------------------------------------*/ ;* Slides */ ;* */ -;* At some point, this should move to `slide.skr'. */ -;*---------------------------------------------------------------------*/ -; (skribe-load "slide.skr") - -; (markup-writer 'slide -; ;; FIXME: In `slide.skr', `:ident' is systematically generated. -; :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) - -; :validate (lambda (n e) -; (eq? (engine-custom e 'document-type) 'slides)) - -; :before (lambda (n e) -; (display "\n@Overhead\n") -; (display " @Title { ") -; (output (markup-option n :title) e) -; (display " }\n") -; (if (markup-ident n) -; (begin -; (display " @Tag { ") -; (display (lout-tagify (markup-ident n))) -; (display " }\n"))) -; (if (markup-option n :number) -; (begin -; (display " @BypassNumber { ") -; (output (markup-option n :number) e) -; (display " }\n"))) -; (display "@Begin\n") - -; ;; `doc' documents produce their PDF outline right after -; ;; `@Text @Begin'; other types of documents must produce it -; ;; as part of their first chapter. -; (lout-output-pdf-meta-info (ast-document n) e)) - -; :after "@End @Overhead\n") - -; (markup-writer 'slide-vspace -; :options '(:unit) -; :validate (lambda (n e) -; (and (pair? (markup-body n)) -; (number? (car (markup-body n))))) -; :action (lambda (n e) -; (printf "\n//~a~a # slide-vspace\n" -; (car (markup-body n)) -; (case (markup-option n :unit) -; ((cm) "c") -; ((point points pt) "p") -; ((inch inches) "i") -; (else -; (skribe-error 'lout -; "Unknown vspace unit" -; (markup-option n :unit))))))) - -; (markup-writer 'slide-pause -; ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. -; ;; << /Type /Action -; ;; << /S /Trans -; ;; entry in the trans dict -; ;; << /Type /Trans /S /Dissolve >> -; :action (lambda (n e) -; (let ((filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark " -; [ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) -; (display (lout-embedded-postscript-code -; (filter pdfmark)))))) - -; ;; For movies, see -; ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . -; (markup-writer 'slide-embed -; :options '(:alt :geometry :rgeometry :geometry-opt :command) -; ;; FIXME: `pdfmark'. -; ;; << /Type /Action /S /Launch -; :action (lambda (n e) -; (let ((command (markup-option n :command)) -; (filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark "[ /Rect [ 0 ysize xsize 0 ] -; /Name /Comment -; /Contents (This is an embedded application) -; /ANN pdfmark - -; [ /Type /Action -; /S /Launch -; /F (~a) -; /OBJ pdfmark")) -; (display (string-append -; "4c @Wide 3c @High " -; (lout-embedded-postscript-code -; (filter (format #f pdfmark command)))))))) +;* At some point, we might want to move this to `slide.scm'. */ +;*---------------------------------------------------------------------*/ + +(use-modules (skribilo packages slide)) + +(markup-writer 'slide + :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) + + :validate (lambda (n e) + (eq? (engine-custom e 'document-type) 'slides)) + + :before (lambda (n e) + (display "\n@Overhead\n") + (display " @Title { ") + (output (markup-option n :title) e) + (display " }\n") + (if (markup-ident n) + (begin + (display " @Tag { ") + (display (lout-tagify (markup-ident n))) + (display " }\n"))) + (if (markup-option n :number) + (begin + (display " @BypassNumber { ") + (output (markup-option n :number) e) + (display " }\n"))) + (display "@Begin\n") + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after "@End @Overhead\n") + +(markup-writer 'slide-vspace + :options '(:unit) + :validate (lambda (n e) + (and (pair? (markup-body n)) + (number? (car (markup-body n))))) + :action (lambda (n e) + (printf "\n//~a~a # slide-vspace\n" + (car (markup-body n)) + (case (markup-option n :unit) + ((cm) "c") + ((point points pt) "p") + ((inch inches) "i") + (else + (skribe-error 'lout + "Unknown vspace unit" + (markup-option n :unit))))))) + +(markup-writer 'slide-pause + ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. + ;; << /Type /Action + ;; << /S /Trans + ;; entry in the trans dict + ;; << /Type /Trans /S /Dissolve >> + :action (lambda (n e) + (let ((filter (make-string-replace lout-verbatim-encoding)) + (pdfmark " +[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) + (display (lout-embedded-postscript-code + (filter pdfmark)))))) + +For movies, see +http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . +(markup-writer 'slide-embed + :options '(:alt :geometry :rgeometry :geometry-opt :command) + ;; FIXME: `pdfmark'. + ;; << /Type /Action /S /Launch + :action (lambda (n e) + (let ((command (markup-option n :command)) + (filter (make-string-replace lout-verbatim-encoding)) + (pdfmark "[ /Rect [ 0 ysize xsize 0 ] + /Name /Comment + /Contents (This is an embedded application) + /ANN pdfmark + +[ /Type /Action + /S /Launch + /F (~a) + /OBJ pdfmark")) + (display (string-append + "4c @Wide 3c @High " + (lout-embedded-postscript-code + (filter (format #f pdfmark command)))))))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 703186c..616144d 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -50,7 +50,17 @@ (define *skribe-load-options* '()) (define (%evaluate expr) - (eval expr (current-module))) + (let ((result (eval expr (current-module)))) + (if (or (ast? result) (markup? result)) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (format #t "~%~%*** source props for `~a': ~a~%~%" + result (source-properties expr)) + (slot-set! result 'loc + (make + :file file :line line :pos column)))) + result)) diff --git a/src/guile/skribilo/packages/acmproc.scm b/src/guile/skribilo/packages/acmproc.scm new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/src/guile/skribilo/packages/acmproc.scm @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/acmproc.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[letterpaper]{acmproc}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\numberofauthors{~a}\n\\author{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "\\alignauthor\n") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\CopyrightYear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\crdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key (class "abstract") postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :class class :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/french.scm b/src/guile/skribilo/packages/french.scm new file mode 100644 index 0000000..3e454f5 --- /dev/null +++ b/src/guile/skribilo/packages/french.scm @@ -0,0 +1,21 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* French Skribe style */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages french)) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/src/guile/skribilo/packages/jfp.scm b/src/guile/skribilo/packages/jfp.scm new file mode 100644 index 0000000..e34a4fe --- /dev/null +++ b/src/guile/skribilo/packages/jfp.scm @@ -0,0 +1,319 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/jfp.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for JFP articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages jfp)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/src/guile/skribilo/packages/letter.scm b/src/guile/skribilo/packages/letter.scm new file mode 100644 index 0000000..565a1eb --- /dev/null +++ b/src/guile/skribilo/packages/letter.scm @@ -0,0 +1,148 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for letters */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages letter)) + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (display "\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "
") + (output n e) + (when hd + (display "") + (output hd e) + (set! hd #f)) + (display "
\n
\n\n")) + + diff --git a/src/guile/skribilo/packages/lncs.scm b/src/guile/skribilo/packages/lncs.scm new file mode 100644 index 0000000..4aadacc --- /dev/null +++ b/src/guile/skribilo/packages/lncs.scm @@ -0,0 +1,149 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/lncs.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for LNCS articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages lncs)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/scribe.scm b/src/guile/skribilo/packages/scribe.scm new file mode 100644 index 0000000..c97f8e9 --- /dev/null +++ b/src/guile/skribilo/packages/scribe.scm @@ -0,0 +1,231 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/scribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 29 10:07:21 2003 */ +;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Scribe Compatibility kit */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages scribe)) + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/packages/sigplan.scm b/src/guile/skribilo/packages/sigplan.scm new file mode 100644 index 0000000..c4ea1e2 --- /dev/null +++ b/src/guile/skribilo/packages/sigplan.scm @@ -0,0 +1,157 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/sigplan.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Wed May 18 16:00:38 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages sigplan)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/skribe.scm b/src/guile/skribilo/packages/skribe.scm new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/src/guile/skribilo/packages/skribe.scm @@ -0,0 +1,76 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/skribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 11 11:23:12 2002 */ +;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The standard Skribe style (always loaded). */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/packages/slide.scm b/src/guile/skribilo/packages/slide.scm new file mode 100644 index 0000000..54ac21c --- /dev/null +++ b/src/guile/skribilo/packages/slide.scm @@ -0,0 +1,667 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages slide)) + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "
\n" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "
") + (output title e) + (display ""))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "
")) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* html */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (skribe-message "HTML slides setup...\n") + ;; &html-page-title + (markup-writer '&html-document-title he + :predicate (lambda (n e) %slide-initialized) + :action html-slide-title) + ;; slide + (markup-writer 'slide he + :options '(:title :number :transition :toc :bg) + :before (lambda (n e) + (printf "
" (markup-ident n)) + (display "
\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "
") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "
")))) + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) diff --git a/src/guile/skribilo/packages/web-article.scm b/src/guile/skribilo/packages/web-article.scm new file mode 100644 index 0000000..f853231 --- /dev/null +++ b/src/guile/skribilo/packages/web-article.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-article.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jan 10 09:09:43 2004 */ +;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* A Skribe style for producing web articles */ +;*=====================================================================*/ + +(define-skribe-module (skribilo packages web-article)) + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "
\n" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "

") + (output title e) + (display "

"))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "
")) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-document-title ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-document-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (id (markup-ident n))) + ;; the title + (printf "
\n" + (string-canonicalize id)) + (output title e) + (display "
\n") + ;; the authors + (printf "
\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-author ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-author n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (when name + (printf "" + (string-canonicalize (markup-ident n))) + (output name e) + (display "\n")) + (when title + (printf "" + (string-canonicalize (markup-ident n))) + (output title e) + (display "\n")) + (when affiliation + (printf "" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "\n")) + (when (pair? address) + (printf "" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "\n")) + (when phone + (printf "" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "\n")) + (when email + (printf "" + (string-canonicalize (markup-ident n))) + (output email e) + (display "\n")) + (when url + (printf "" + (string-canonicalize (markup-ident n))) + (output url e) + (display "\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML settings */ +;*---------------------------------------------------------------------*/ +(define (web-article-modern-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :action html-document-title-web) + ;; section + (markup-writer 'section he + :options 'all + :before "
" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background))) + (markup-writer 'section e1 + :options 'all + :action (lambda (n e2) (output n e sec))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg n)) + e1)))) + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before "
" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background)) + (fg (engine-custom he 'subsection-title-foreground))) + (markup-writer '&html-footnotes e1 + :options 'all + :action (lambda (n e2) + (invoke (writer-action ft) n e))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg :fg fg n)) + e1)))))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-setup ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :before (lambda (n e) + (printf "
\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "
\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "
" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "
\n"))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &web-article-load-options) + (p (memq :style opt)) + (css (memq :css opt)) + (he (find-engine 'html))) + (cond + ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) + (web-article-css-setup he)) + ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) + (engine-custom-set! he 'css (cadr css)) + (web-article-css-setup he)) + (else + (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/packages/web-book.scm b/src/guile/skribilo/packages/web-book.scm new file mode 100644 index 0000000..f907c8b --- /dev/null +++ b/src/guile/skribilo/packages/web-book.scm @@ -0,0 +1,107 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-book.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:54:32 2003 */ +;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe web book style. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold "main page")))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (markup-option n :title))))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (if chap "Chapters" "Sections"))))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index 673a166..78f1814 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -22,7 +22,7 @@ :use-module (skribilo reader) :use-module (ice-9 optargs) - ;; the Scheme reader composition framework + ;; the Scheme reader composition framework :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) :export (reader-specification @@ -55,18 +55,28 @@ the Skribe syntax." (map r:standard-token-reader '(character srfi-4 number+radix - boolean)))))) - (r:make-reader (cons (r:make-token-reader #\# sharp-reader) - (map r:standard-token-reader - `(whitespace - sexp string number - symbol-lower-case - symbol-upper-case - symbol-misc-chars - quote-quasiquote-unquote - semicolon-comment - keyword ;; keywords à la `:key' - skribe-exp)))))) + boolean))) + #f ;; use default fault handler + 'reader/record-positions)) + (colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword))))) + + (r:make-reader (cons* (r:make-token-reader #\# sharp-reader) + colon-keywords + (map r:standard-token-reader + `(whitespace + sexp string number + symbol-lower-case + symbol-upper-case + symbol-misc-chars + quote-quasiquote-unquote + semicolon-comment + skribe-exp))) + #f ;; use the default fault handler + 'reader/record-positions + ))) ;; We actually cache an instance here. (define *skribe-reader* (%make-skribe-reader)) diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm index 8daca62..6aebd0a 100644 --- a/src/guile/skribilo/skribe/param.scm +++ b/src/guile/skribilo/skribe/param.scm @@ -44,15 +44,16 @@ ;* *skribe-auto-mode-alist* ... */ ;*---------------------------------------------------------------------*/ (define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) + ;; Note: In Skribilo, this list is completely useless. + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) ;*---------------------------------------------------------------------*/ ;* *skribe-auto-load-alist* ... */ diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index 4b3729c..c6188b6 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -66,14 +66,6 @@ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) (loc :init-value #f)) -(define-method (initialize (ast ) . args) - (next-method) - (let ((file (port-filename (current-input-port))) - (line (port-line (current-input-port))) - (column (port-column (current-input-port)))) - (slot-set! ast 'loc - (make - :file file :line line :pos (* line column))))) (define (ast? obj) (is-a? obj )) (define (ast-loc obj) (slot-ref obj 'loc)) -- cgit v1.2.3 From 89a424521b753ee7c2c67ebdc957865657f647c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 31 Oct 2005 16:16:54 +0000 Subject: Moved the STkLos and Bigloo code to `legacy'. Moved the STkLos and Bigloo code from `src' to `legacy'. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9 --- Makefile | 131 ----- configure | 124 ----- legacy/bigloo/Makefile | 271 ++++++++++ legacy/bigloo/api.bgl | 117 ++++ legacy/bigloo/api.sch | 91 ++++ legacy/bigloo/asm.scm | 99 ++++ legacy/bigloo/bib.bgl | 161 ++++++ legacy/bigloo/c.scm | 134 +++++ legacy/bigloo/color.scm | 702 ++++++++++++++++++++++++ legacy/bigloo/configure.bgl | 90 ++++ legacy/bigloo/debug.sch | 54 ++ legacy/bigloo/debug.scm | 188 +++++++ legacy/bigloo/engine.scm | 262 +++++++++ legacy/bigloo/eval.scm | 335 ++++++++++++ legacy/bigloo/evapi.scm | 39 ++ legacy/bigloo/index.bgl | 32 ++ legacy/bigloo/lib.bgl | 340 ++++++++++++ legacy/bigloo/lisp.scm | 530 ++++++++++++++++++ legacy/bigloo/main.scm | 96 ++++ legacy/bigloo/new.sch | 17 + legacy/bigloo/output.scm | 167 ++++++ legacy/bigloo/param.bgl | 134 +++++ legacy/bigloo/parseargs.scm | 186 +++++++ legacy/bigloo/prog.scm | 196 +++++++ legacy/bigloo/read.scm | 482 +++++++++++++++++ legacy/bigloo/resolve.scm | 283 ++++++++++ legacy/bigloo/source.scm | 238 +++++++++ legacy/bigloo/sui.bgl | 34 ++ legacy/bigloo/types.scm | 685 ++++++++++++++++++++++++ legacy/bigloo/verify.scm | 143 +++++ legacy/bigloo/writer.scm | 232 ++++++++ legacy/bigloo/xml.scm | 92 ++++ legacy/stklos/Makefile.in | 110 ++++ legacy/stklos/biblio.stk | 161 ++++++ legacy/stklos/c-lex.l | 67 +++ legacy/stklos/c.stk | 95 ++++ legacy/stklos/color.stk | 622 +++++++++++++++++++++ legacy/stklos/configure.stk | 90 ++++ legacy/stklos/debug.stk | 161 ++++++ legacy/stklos/engine.stk | 242 +++++++++ legacy/stklos/eval.stk | 149 ++++++ legacy/stklos/lib.stk | 317 +++++++++++ legacy/stklos/lisp-lex.l | 91 ++++ legacy/stklos/lisp.stk | 294 ++++++++++ legacy/stklos/main.stk | 264 +++++++++ legacy/stklos/output.stk | 158 ++++++ legacy/stklos/prog.stk | 219 ++++++++ legacy/stklos/reader.stk | 136 +++++ legacy/stklos/resolve.stk | 255 +++++++++ legacy/stklos/runtime.stk | 456 ++++++++++++++++ legacy/stklos/source.stk | 191 +++++++ legacy/stklos/types.stk | 294 ++++++++++ legacy/stklos/vars.stk | 82 +++ legacy/stklos/verify.stk | 157 ++++++ legacy/stklos/writer.stk | 211 ++++++++ legacy/stklos/xml-lex.l | 64 +++ legacy/stklos/xml.stk | 52 ++ src/Makefile | 41 -- src/bigloo/Makefile | 271 ---------- src/bigloo/api.bgl | 117 ---- src/bigloo/api.sch | 91 ---- src/bigloo/asm.scm | 99 ---- src/bigloo/bib.bgl | 161 ------ src/bigloo/c.scm | 134 ----- src/bigloo/color.scm | 702 ------------------------ src/bigloo/configure.bgl | 90 ---- src/bigloo/debug.sch | 54 -- src/bigloo/debug.scm | 188 ------- src/bigloo/engine.scm | 262 --------- src/bigloo/eval.scm | 335 ------------ src/bigloo/evapi.scm | 39 -- src/bigloo/index.bgl | 32 -- src/bigloo/lib.bgl | 340 ------------ src/bigloo/lisp.scm | 530 ------------------ src/bigloo/main.scm | 96 ---- src/bigloo/new.sch | 17 - src/bigloo/output.scm | 167 ------ src/bigloo/param.bgl | 134 ----- src/bigloo/parseargs.scm | 186 ------- src/bigloo/prog.scm | 196 ------- src/bigloo/read.scm | 482 ----------------- src/bigloo/resolve.scm | 283 ---------- src/bigloo/source.scm | 238 --------- src/bigloo/sui.bgl | 34 -- src/bigloo/types.scm | 685 ------------------------ src/bigloo/verify.scm | 143 ----- src/bigloo/writer.scm | 232 -------- src/bigloo/xml.scm | 92 ---- src/common/api.scm | 1249 ------------------------------------------- src/common/bib.scm | 192 ------- src/common/configure.scm | 8 - src/common/configure.scm.in | 6 - src/common/index.scm | 126 ----- src/common/lib.scm | 238 --------- src/common/param.scm | 69 --- src/common/sui.scm | 166 ------ src/stklos/Makefile.in | 110 ---- src/stklos/biblio.stk | 161 ------ src/stklos/c-lex.l | 67 --- src/stklos/c.stk | 95 ---- src/stklos/color.stk | 622 --------------------- src/stklos/configure.stk | 90 ---- src/stklos/debug.stk | 161 ------ src/stklos/engine.stk | 242 --------- src/stklos/eval.stk | 149 ------ src/stklos/lib.stk | 317 ----------- src/stklos/lisp-lex.l | 91 ---- src/stklos/lisp.stk | 294 ---------- src/stklos/main.stk | 264 --------- src/stklos/output.stk | 158 ------ src/stklos/prog.stk | 219 -------- src/stklos/reader.stk | 136 ----- src/stklos/resolve.stk | 255 --------- src/stklos/runtime.stk | 456 ---------------- src/stklos/source.stk | 191 ------- src/stklos/types.stk | 294 ---------- src/stklos/vars.stk | 82 --- src/stklos/verify.stk | 157 ------ src/stklos/writer.stk | 211 -------- src/stklos/xml-lex.l | 64 --- src/stklos/xml.stk | 52 -- 121 files changed, 11368 insertions(+), 13718 deletions(-) delete mode 100644 Makefile delete mode 100755 configure create mode 100644 legacy/bigloo/Makefile create mode 100644 legacy/bigloo/api.bgl create mode 100644 legacy/bigloo/api.sch create mode 100644 legacy/bigloo/asm.scm create mode 100644 legacy/bigloo/bib.bgl create mode 100644 legacy/bigloo/c.scm create mode 100644 legacy/bigloo/color.scm create mode 100644 legacy/bigloo/configure.bgl create mode 100644 legacy/bigloo/debug.sch create mode 100644 legacy/bigloo/debug.scm create mode 100644 legacy/bigloo/engine.scm create mode 100644 legacy/bigloo/eval.scm create mode 100644 legacy/bigloo/evapi.scm create mode 100644 legacy/bigloo/index.bgl create mode 100644 legacy/bigloo/lib.bgl create mode 100644 legacy/bigloo/lisp.scm create mode 100644 legacy/bigloo/main.scm create mode 100644 legacy/bigloo/new.sch create mode 100644 legacy/bigloo/output.scm create mode 100644 legacy/bigloo/param.bgl create mode 100644 legacy/bigloo/parseargs.scm create mode 100644 legacy/bigloo/prog.scm create mode 100644 legacy/bigloo/read.scm create mode 100644 legacy/bigloo/resolve.scm create mode 100644 legacy/bigloo/source.scm create mode 100644 legacy/bigloo/sui.bgl create mode 100644 legacy/bigloo/types.scm create mode 100644 legacy/bigloo/verify.scm create mode 100644 legacy/bigloo/writer.scm create mode 100644 legacy/bigloo/xml.scm create mode 100644 legacy/stklos/Makefile.in create mode 100644 legacy/stklos/biblio.stk create mode 100644 legacy/stklos/c-lex.l create mode 100644 legacy/stklos/c.stk create mode 100644 legacy/stklos/color.stk create mode 100644 legacy/stklos/configure.stk create mode 100644 legacy/stklos/debug.stk create mode 100644 legacy/stklos/engine.stk create mode 100644 legacy/stklos/eval.stk create mode 100644 legacy/stklos/lib.stk create mode 100644 legacy/stklos/lisp-lex.l create mode 100644 legacy/stklos/lisp.stk create mode 100644 legacy/stklos/main.stk create mode 100644 legacy/stklos/output.stk create mode 100644 legacy/stklos/prog.stk create mode 100644 legacy/stklos/reader.stk create mode 100644 legacy/stklos/resolve.stk create mode 100644 legacy/stklos/runtime.stk create mode 100644 legacy/stklos/source.stk create mode 100644 legacy/stklos/types.stk create mode 100644 legacy/stklos/vars.stk create mode 100644 legacy/stklos/verify.stk create mode 100644 legacy/stklos/writer.stk create mode 100644 legacy/stklos/xml-lex.l create mode 100644 legacy/stklos/xml.stk delete mode 100644 src/Makefile delete mode 100644 src/bigloo/Makefile delete mode 100644 src/bigloo/api.bgl delete mode 100644 src/bigloo/api.sch delete mode 100644 src/bigloo/asm.scm delete mode 100644 src/bigloo/bib.bgl delete mode 100644 src/bigloo/c.scm delete mode 100644 src/bigloo/color.scm delete mode 100644 src/bigloo/configure.bgl delete mode 100644 src/bigloo/debug.sch delete mode 100644 src/bigloo/debug.scm delete mode 100644 src/bigloo/engine.scm delete mode 100644 src/bigloo/eval.scm delete mode 100644 src/bigloo/evapi.scm delete mode 100644 src/bigloo/index.bgl delete mode 100644 src/bigloo/lib.bgl delete mode 100644 src/bigloo/lisp.scm delete mode 100644 src/bigloo/main.scm delete mode 100644 src/bigloo/new.sch delete mode 100644 src/bigloo/output.scm delete mode 100644 src/bigloo/param.bgl delete mode 100644 src/bigloo/parseargs.scm delete mode 100644 src/bigloo/prog.scm delete mode 100644 src/bigloo/read.scm delete mode 100644 src/bigloo/resolve.scm delete mode 100644 src/bigloo/source.scm delete mode 100644 src/bigloo/sui.bgl delete mode 100644 src/bigloo/types.scm delete mode 100644 src/bigloo/verify.scm delete mode 100644 src/bigloo/writer.scm delete mode 100644 src/bigloo/xml.scm delete mode 100644 src/common/api.scm delete mode 100644 src/common/bib.scm delete mode 100644 src/common/configure.scm delete mode 100644 src/common/configure.scm.in delete mode 100644 src/common/index.scm delete mode 100644 src/common/lib.scm delete mode 100644 src/common/param.scm delete mode 100644 src/common/sui.scm delete mode 100644 src/stklos/Makefile.in delete mode 100644 src/stklos/biblio.stk delete mode 100644 src/stklos/c-lex.l delete mode 100644 src/stklos/c.stk delete mode 100644 src/stklos/color.stk delete mode 100644 src/stklos/configure.stk delete mode 100644 src/stklos/debug.stk delete mode 100644 src/stklos/engine.stk delete mode 100644 src/stklos/eval.stk delete mode 100644 src/stklos/lib.stk delete mode 100644 src/stklos/lisp-lex.l delete mode 100644 src/stklos/lisp.stk delete mode 100644 src/stklos/main.stk delete mode 100644 src/stklos/output.stk delete mode 100644 src/stklos/prog.stk delete mode 100644 src/stklos/reader.stk delete mode 100644 src/stklos/resolve.stk delete mode 100644 src/stklos/runtime.stk delete mode 100644 src/stklos/source.stk delete mode 100644 src/stklos/types.stk delete mode 100644 src/stklos/vars.stk delete mode 100644 src/stklos/verify.stk delete mode 100644 src/stklos/writer.stk delete mode 100644 src/stklos/xml-lex.l delete mode 100644 src/stklos/xml.stk (limited to 'src') diff --git a/Makefile b/Makefile deleted file mode 100644 index 918e91a..0000000 --- a/Makefile +++ /dev/null @@ -1,131 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Wed Jul 30 16:23:07 2003 */ -#* Last change : Fri May 21 16:37:53 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The general Skribe makefile */ -#*=====================================================================*/ -include etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* DIRECTORIES */ -#*---------------------------------------------------------------------*/ -DIRECTORIES = skr \ - doc \ - examples \ - src \ - emacs \ - etc \ - tools - -POPULATIONDIRS = $(DIRECTORIES) \ - contribs - -#*---------------------------------------------------------------------*/ -#* all */ -#*---------------------------------------------------------------------*/ -.PHONY: all - -all: - (cd src/$(SYSTEM) && $(MAKE)) - (cd tools && $(MAKE)) - (cd doc && $(MAKE)) - -#*---------------------------------------------------------------------*/ -#* install */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) install) || exit -1; \ - done - -uninstall: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) uninstall) || exit -1; \ - done - -#*---------------------------------------------------------------------*/ -#* revision */ -#*---------------------------------------------------------------------*/ -.PHONY: revision populate skribe.prj - -revision: populate checkin - -populate: skribe.prj - prcs populate skribe `$(MAKE) pop` - -checkin: - prcs checkin -r$(SKRIBERELEASE).@ skribe - -checkout: - @ prcs checkout -r$(SKRIBERELEASE).@ skribe - -skribe.prj: - @ cat skribe.prj | sed -e s,"(Populate-Ignore ())","(Populate-Ignore (\"\\\\\\\\\\.o\\$$\" \"\\\\\\\\\\~$$\" \"\\\\\\\\\\.log\\$$\" \"\\\\\\\\\\.ps\\$$\" \"\\\\\\\\\\.aux\\$$\" \"\\\\\\\\\\.date_of_backup\\$$\" \"\\\\\\\\\\.so\\$$\" \"\\\\\\\\\\.a\\$$\" \"if_not_there\\$$\" \"if_mach\\$$\" \"threadlibs\\$$\"))", > skribe.dprj; $(RM) -f skribe.prj; mv skribe.dprj skribe.prj - -#*---------------------------------------------------------------------*/ -#* population */ -#* ------------------------------------------------------------- */ -#* The list of all files that have to be placed inside the */ -#* repository for revision. */ -#*---------------------------------------------------------------------*/ -.PHONY: subpop popfilelist - -subpop: - @ for d in $(POPULATIONDIRS); do \ - (cd $$d && $(MAKE) -s pop); \ - done - -pop: - @ echo Makefile INSTALL LICENSE README README.java - @ echo configure - @ (for p in `$(MAKE) -s subpop`; do \ - echo $$p; \ - done) | sort - -#*---------------------------------------------------------------------*/ -#* distrib */ -#*---------------------------------------------------------------------*/ -.PHONY: distrib distrib-jvm distrib-src - -distrib: - $(MAKE) distrib -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - (cd www && $(MAKE)) - -distrib-jvm: - $(MAKE) distrib-jvm -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -distrib-src: - $(MAKE) distrib-src -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -#*---------------------------------------------------------------------*/ -#* clean/distclean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - $(RM) -f etc/Makefile.config - -clean: - (cd src && $(MAKE) clean) - (cd doc && $(MAKE) clean) - (cd tools && $(MAKE) clean) - (cd etc && $(MAKE) clean) - -distclean: clean - (cd emacs && $(MAKE) distclean) - (cd etc && $(MAKE) distclean) - -#*---------------------------------------------------------------------*/ -#* devclean/devdistclean */ -#*---------------------------------------------------------------------*/ -.PHONY: devclean devdistclean - -devclean: clean - (cd www && $(MAKE) clean) - -devdistclean: devclean distclean - diff --git a/configure b/configure deleted file mode 100755 index 798d9d2..0000000 --- a/configure +++ /dev/null @@ -1,124 +0,0 @@ -#!/bin/sh -# -# This file is a simple trampoline to the real configure script which -# depends of the Scheme system used -# -# Known systems so far: -# - Bigloo (use --with-bigloo) -# - STklos (use --with-stklos) -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 29-Jul-2003 13:59 (eg) -# Last file update: 23-Sep-2004 17:14 (eg) - - -use_bigloo=0 -use_stklos=0 - -new_args="" -export new_args -prefix=/usr/local -export prefix - -for i in "$@"; do - case $i in - --with-bigloo) scheme=bigloo; use_bigloo=1;; - --with-stklos) scheme=stklos; use_stklos=1;; - --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; - new_args="$new_args $i";; - *) new_args="$new_args \"$i\"";; - esac -done - -#* for i in $* ;do */ -#* case $i in */ -#* --with-bigloo) scheme=bigloo; use_bigloo=1;; */ -#* --with-stklos) scheme=stklos; use_stklos=1;; */ -#* --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; */ -#* new_args="$new_args $i";; */ -#* *) new_args="$new_args $i";; */ -#* esac */ -#* done */ - - -case `expr $use_bigloo + $use_stklos` in - 0) echo "You must at least specify a Scheme system: "; - echo " --with-bigloo to use Bigloo" - echo " --with-stklos to use STklos" - exit 1;; - 1) ;; - *) echo "You must specify ONLY ONE Scheme system"; exit 1;; -esac - -if test $use_bigloo = 1 ;then - scheme=bigloo -fi - -if test $use_stklos = 1 ;then - scheme=stklos -fi - - - -# Common configuration -release="1.2d" -skribeurl="http://www.inria.fr/mimosa/fp/Skribe" -skribeextdir="$prefix/share/skribe/extensions" -skribedocdir=$prefix/doc/skribe-$release -skribeskrdir="'(\".\" \"$skribeextdir\" \"$prefix/share/skribe/$release/skr\" )" - -# etc/config -rm -f etc/config 2> /dev/null -echo "# Automatically generated file (don't edit)" > etc/config -echo "release=$release" >> etc/config -echo "skribeurl=$skribeurl" >> etc/config -echo "prefix=$prefix" >> etc/config - -# etc/skribe-config -cat etc/skribe-config.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_SKR_DIR@|$prefix/share/skribe/$release/skr|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - > etc/skribe-config -chmod a+x etc/skribe-config - -# emacs/skribe.el -cat emacs/skribe.el.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - | sed "s|@SKRIBE_DOCDIR@|$skribedocdir|" \ - > emacs/skribe.el - -# src/common/configure.scm -rm -f src/common/configure.scm 2> /dev/null -echo ";; Automatically generated file (don't edit)" > src/common/configure.scm -cat src/common/configure.scm.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@SKRIBE_URL@|$skribeurl|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_SKR_PATH@|$skribeskrdir|" \ - | sed "s|@SKRIBE_SCHEME@|$scheme|" \ - >> src/common/configure.scm -echo "" >> src/common/configure.scm - -if test $use_bigloo = 1 ;then - # pass all the arguments to the Bigloo autoconf without the --with-bigloo - echo "Using Bigloo system" - eval "cd etc/bigloo; SKRIBERELEASE=$release ./configure --docdir=$skribedocdir $new_args" - exit 0 -fi - -# If we are here, it means that we use the STklos system -if test $use_stklos = 1 ;then - # pass all the arguments to the STklos autoconf without the --with-stklos - echo "Using STklos system" - eval "cd etc/stklos; ./configure $new_args" - exit 0 -fi - diff --git a/legacy/bigloo/Makefile b/legacy/bigloo/Makefile new file mode 100644 index 0000000..02d2b6a --- /dev/null +++ b/legacy/bigloo/Makefile @@ -0,0 +1,271 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/src/bigloo/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Mon Jul 21 18:21:11 2003 */ +#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Bigloo API */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* General inclusion */ +#*---------------------------------------------------------------------*/ +include ../../etc/bigloo/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Compilers and tools */ +#*---------------------------------------------------------------------*/ +BSKBFLAGS = -I $(SRCDIR)/bigloo + +#*---------------------------------------------------------------------*/ +#* Targets ... */ +#*---------------------------------------------------------------------*/ +PROJECT = skribe +CTARGET = $(SKRIBEBINDIR)/skribe.bigloo +JVMTARGET = $(SKRIBEBINDIR)/skribe.zip + +PBASE = bigloo.$(PROJECT) +ODIR = o +CLASSDIR = class_s/bigloo/$(PROJECT) +OBJDIR = obj/bigloo/$(PROJECT) + +#*---------------------------------------------------------------------*/ +#* Objects */ +#*---------------------------------------------------------------------*/ +SRCDIR = .. +SKRIBECOMMON = param api bib index lib sui +SKRIBEBGL = types parseargs main eval evapi \ + output resolve verify debug read prog source \ + lisp xml c asm engine writer color +SKRIBEINCLUDE = api new debug + +MODULES = $(SKRIBEBGL:%=%.scm) \ + $(SKRIBECOMMON:%=%.bgl) \ + configure.bgl +INCLUDES = $(SKRIBEINCLUDE:%=%.sch) +SOURCES = $(MODULES) \ + $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ + $(SRCDIR)/common/configure.scm \ + $(INCLUDES) +OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure +COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) +JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) + +#*---------------------------------------------------------------------*/ +#* Population */ +#*---------------------------------------------------------------------*/ +POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile +POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .scm .bgl .class .o .obj + +#*---------------------------------------------------------------------*/ +#* All */ +#*---------------------------------------------------------------------*/ +.PHONY: c jvm dotnet + +all: $(TARGET) + +c: $(CTARGET) +jvm: $(JVMTARGET) +dotnet: + echo "Not implemented yet" + +#*--- c ---------------------------------------------------------------*/ +$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) + $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) + +#*--- jvm -------------------------------------------------------------*/ +$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) + $(RM) -f $(JVMTARGET) + (cd $(ODIR)/class_s && \ + $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) + +$(SKRIBEBINDIR): + mkdir -p $(SKRIBEBINDIR) + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo $(POPULATIONSCM:%=src/common/%) + @ echo $(POPULATIONBGL:%=src/bigloo/%) + +#*---------------------------------------------------------------------*/ +#* ude */ +#*---------------------------------------------------------------------*/ +.PHONY: ude .etags .afile + +ude: + @ $(MAKE) -f Makefile .afile .etags dep + +.afile: + @ $(AFILE) -o .afile $(MODULES) + +.jfile: + @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) + +.etags: + @ $(BTAGS) -o .etags $(SOURCES) + +dep: + @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ + head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) + @ $(BDEPEND) -search-path ../common \ + -search-path ../bigloo \ + -strict-obj-dir $(ODIR) \ + -strict-class-dir $(CLASSDIR) \ + -fno-mco $(SOURCES) >> /tmp/Makefile.aux + @ mv /tmp/Makefile.aux Makefile + +getbinary: + @ echo $(PROJECT) + +getsources: + @ echo $(SOURCES) + +#*---------------------------------------------------------------------*/ +#* The implicit rules */ +#*---------------------------------------------------------------------*/ +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ + $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(OBJDIR)/%.obj: src/%.scm + $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ + +#*---------------------------------------------------------------------*/ +#* Ad hoc rules */ +#*---------------------------------------------------------------------*/ +$(ODIR): + mkdir -p $(ODIR) + +$(CLASSDIR): + mkdir -p $(CLASSDIR) + +$(OBJDIR): + mkdir -p $(OBJDIR) + + +#*---------------------------------------------------------------------*/ +#* install/uninstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm + +install: + $(MAKE) install-$(TARGET) + +uninstall: + $(MAKE) uninstall-$(TARGET) + +install-c: $(DESTDIR)$(INSTALL_BINDIR) + cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe + +uninstall-c: + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + +install-jvm: $(DESTDIR)$(INSTALL_FILDIR) + cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) + +uninstall-jvm: + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip + +$(DESTDIR)$(INSTALL_BINDIR): + mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) + +$(DESTDIR)$(INSTALL_FILDIR): + mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) + +#*---------------------------------------------------------------------*/ +#* Clean */ +#*---------------------------------------------------------------------*/ +clean: + $(RM) -f .afile + $(RM) -f .jfile + $(RM) -rf $(ODIR) + $(RM) -f $(CTARGET) + $(RM) -f $(JVMTARGET) + +#*---------------------------------------------------------------------*/ +#* Cleanall */ +#*---------------------------------------------------------------------*/ +cleanall: clean + +#*---------------------------------------------------------------------*/ +#* Manual dependency */ +#*---------------------------------------------------------------------*/ +o/eval.o o/class/bigloo/skribe/eval.class: \ + $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm + +#bdepend start (don't edit) +#*---------------------------------------------------------------------*/ +#* Dependencies ... */ +#*---------------------------------------------------------------------*/ +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch + +#bdepend stop diff --git a/legacy/bigloo/api.bgl b/legacy/bigloo/api.bgl new file mode 100644 index 0000000..55493b0 --- /dev/null +++ b/legacy/bigloo/api.bgl @@ -0,0 +1,117 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:21:34 2003 */ +;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo header for the API. */ +;* ------------------------------------------------------------- */ +;* Implementation: @label api@ */ +;* bigloo: @path ../common/api.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_api + + (include "new.sch" + "api.sch") + + (import skribe_param + skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_bib + skribe_index + skribe_prog + skribe_source + skribe_engine + skribe_color + skribe_sui) + + (export (include string) + + (document::%markup . opts) + (author::%markup . opts) + (toc::%markup . opts) + + (chapter::%markup . opts) + (section::%markup . opts) + (subsection::%markup . opts) + (subsubsection::%markup . opts) + (paragraph::%markup . opts) + + (footnote::%markup . opts) + + (linebreak . opts) + (hrule::%markup . opts) + + (color::%markup . opts) + (frame::%markup . opts) + (font::%markup . opts) + + (flush::%markup . opts) + (center::%markup . opts) + (pre::%markup . opts) + (prog::%markup . opts) + (source::obj . opts) + (language::obj . opts) + + (itemize::%markup . opts) + (enumerate::%markup . opts) + (description::%markup . opts) + (item::%markup . opts) + + (figure::%markup . opts) + + (table::%markup . opts) + (tr::%markup . opts) + (td::%markup . opts) + (th::%markup . opts) + + (image::%markup . opts) + + (blockquote::%markup . opts) + + (roman::%markup . opts) + (bold::%markup . opts) + (underline::%markup . opts) + (strike::%markup . opts) + (emph::%markup . opts) + (kbd::%markup . opts) + (it::%markup . opts) + (tt::%markup . opts) + (code::%markup . opts) + (var::%markup . opts) + (samp::%markup . opts) + (sf::%markup . opts) + (sc::%markup . opts) + (sub::%markup . opts) + (sup::%markup . opts) + + (mailto::%markup . opts) + (mark::%markup . opts) + + (handle . obj) + (ref::%ast . obj) + (resolve::%ast ::procedure) + + (bibliography . files) + (the-bibliography . opts) + + (make-index ::bstring) + (index . args) + (the-index . args) + + (char::bstring char) + (symbol::%markup symbol) + (!::%command string . args) + + (processor::%processor . opts) + + (html-processor::%processor . opts) + (tex-processor::%processor . opts))) diff --git a/legacy/bigloo/api.sch b/legacy/bigloo/api.sch new file mode 100644 index 0000000..390b8fa --- /dev/null +++ b/legacy/bigloo/api.sch @@ -0,0 +1,91 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:15:25 2003 */ +;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo macros for the API implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* define-pervasive-macro ... */ +;*---------------------------------------------------------------------*/ +(define-macro (define-pervasive-macro proto . body) + `(begin + (eval '(define-macro ,proto ,@body)) + (define-macro ,proto ,@body))) + +;*---------------------------------------------------------------------*/ +;* define-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-markup proto . body) + (define (s2k symbol) + (string->keyword (string-append ":" (symbol->string symbol)))) + (if (not (pair? proto)) + (error 'define-markup "Illegal markup definition" proto) + (let* ((id (car proto)) + (args (cdr proto)) + (dargs (dsssl-formals->scheme-formals args error))) + `(begin + ,(if (and (memq #!key args) + (memq '&skribe-eval-location args)) + `(define-expander ,id + (lambda (x e) + (append + (cons ',id (map (lambda (x) (e x e)) (cdr x))) + (list :&skribe-eval-location + '(skribe-eval-location))))) + #unspecified) + (define ,(cons id dargs) + ,(make-dsssl-function-prelude proto + args `(begin ,@body) + error s2k)))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-markup markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-container ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-container markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-processor-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-processor-markup proc) + `(define-markup (,proc #!rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + +;*---------------------------------------------------------------------*/ +;* new (at runtime) */ +;*---------------------------------------------------------------------*/ +(eval '(define-macro (new id . inits) + (cons (symbol-append 'new- id) + (map (lambda (i) + (list 'list (list 'quote (car i)) (cadr i))) + inits)))) diff --git a/legacy/bigloo/asm.scm b/legacy/bigloo/asm.scm new file mode 100644 index 0000000..03196ac --- /dev/null +++ b/legacy/bigloo/asm.scm @@ -0,0 +1,99 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* ASM fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_asm + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export asm)) + +;*---------------------------------------------------------------------*/ +;* asm ... */ +;*---------------------------------------------------------------------*/ +(define asm + (new language + (name "asm") + (fontifier asm-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* asm-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (asm-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "#" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((: (* (in #\tab #\space)) + (+ (out #\: #\Space #\Tab #\Newline)) #\:) + ;; labels + (let ((c (new markup + (markup '&source-define) + (body (the-string))))) + (cons c (ignore)))) + ((or (in "<>=!/\\+*-([])") + #\/ + (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(asm)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/legacy/bigloo/bib.bgl b/legacy/bigloo/bib.bgl new file mode 100644 index 0000000..6b0f7dd --- /dev/null +++ b/legacy/bigloo/bib.bgl @@ -0,0 +1,161 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Dec 7 06:12:29 2001 */ +;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe Bibliography */ +;* ------------------------------------------------------------- */ +;* Implementation: @label bib@ */ +;* bigloo: @path ../common/bib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_bib + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_read) + + (export (bib-table?::bool ::obj) + (make-bib-table ::bstring) + (default-bib-table) + (bib-load! ::obj ::bstring ::obj) + (bib-add! ::obj . entries) + (resolve-bib ::obj ::obj) + (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) + (bib-sort/authors::pair-nil ::pair-nil) + (bib-sort/idents::pair-nil ::pair-nil) + (bib-sort/dates::pair-nil ::pair-nil))) + +;*---------------------------------------------------------------------*/ +;* bib-table? ... */ +;*---------------------------------------------------------------------*/ +(define (bib-table? obj) + (hashtable? obj)) + +;*---------------------------------------------------------------------*/ +;* *bib-table* ... */ +;*---------------------------------------------------------------------*/ +(define *bib-table* #f) + +;*---------------------------------------------------------------------*/ +;* make-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-table ident) + (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* default-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (default-bib-table) + (if (not *bib-table*) + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;*---------------------------------------------------------------------*/ +;* bib-parse-error ... */ +;*---------------------------------------------------------------------*/ +(define (bib-parse-error entry) + (if (epair? entry) + (match-case (cer entry) + ((at ?fname ?pos ?-) + (error/location "parse-biblio" + "bibliography syntax error" + entry + fname + pos)) + (else + (error 'bib-parse "bibliography syntax error" entry))) + (error 'bib-parse "bibliography syntax error" entry))) + +;*---------------------------------------------------------------------*/ +;* bib-duplicate ... */ +;*---------------------------------------------------------------------*/ +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + +;*---------------------------------------------------------------------*/ +;* parse-bib ... */ +;*---------------------------------------------------------------------*/ +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (input-port-name port))) + (let loop ((entry (skribe-read port))) + (if (not (eof-object? entry)) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (else + (bib-parse-error entry)))))))) + +;*---------------------------------------------------------------------*/ +;* bib-add! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (else + (bib-parse-error entry)))) + entries))) + + + diff --git a/legacy/bigloo/c.scm b/legacy/bigloo/c.scm new file mode 100644 index 0000000..07290ce --- /dev/null +++ b/legacy/bigloo/c.scm @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/c.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Thu May 27 10:11:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* C fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_c + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export C)) + +;*---------------------------------------------------------------------*/ +;* C stamps */ +;*---------------------------------------------------------------------*/ +(define *keyword* (gensym)) +(define *cpp* (gensym)) + +;*---------------------------------------------------------------------*/ +;* C keywords */ +;*---------------------------------------------------------------------*/ +(for-each (lambda (symbol) + (putprop! symbol *keyword* #t)) + '(for class template while return try catch break continue + do if else typedef struct union goto switch case + static extern default finally throw)) +(let ((sharp (string->symbol "#"))) + (for-each (lambda (symbol) + (putprop! (symbol-append sharp symbol) *cpp* #t)) + '(include define if ifdef ifdef else endif))) + +;*---------------------------------------------------------------------*/ +;* C ... */ +;*---------------------------------------------------------------------*/ +(define C + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* c-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (c-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((in "{}") + ;; brackets + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-bracket) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) + ;; keywords + (let* ((string (the-string)) + (symbol (the-symbol))) + (cond + ((getprop symbol *keyword*) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((getprop symbol *cpp*) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons string (ignore)))))) + ((in "<>=!/\\+*-([])") + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(C)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/legacy/bigloo/color.scm b/legacy/bigloo/color.scm new file mode 100644 index 0000000..e481d65 --- /dev/null +++ b/legacy/bigloo/color.scm @@ -0,0 +1,702 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/color.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Apr 10 13:46:50 2002 */ +;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Tex color manager */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_color + (import skribe_configure) + (export (skribe-color->rgb ::obj) + (skribe-get-used-colors) + (skribe-use-color! color))) + +;*---------------------------------------------------------------------*/ +;* *skribe-rgb-string* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-rgb-string* + "255 250 250 snow +248 248 255 ghostwhite +245 245 245 whitesmoke +220 220 220 gainsboro +255 250 240 floralwhite +253 245 230 oldlace +250 240 230 linen +250 235 215 antiquewhite +255 239 213 papayawhip +255 235 205 blanchedalmond +255 228 196 bisque +255 218 185 peachpuff +255 222 173 navajowhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemonchiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mintcream +240 255 255 azure +240 248 255 aliceblue +230 230 250 lavender +255 240 245 lavenderblush +255 228 225 mistyrose +255 255 255 white +0 0 0 black +47 79 79 darkslategrey +105 105 105 dimgrey +112 128 144 slategrey +119 136 153 lightslategrey +190 190 190 grey +211 211 211 lightgrey +25 25 112 midnightblue +0 0 128 navy +0 0 128 navyblue +100 149 237 cornflowerblue +72 61 139 darkslateblue +106 90 205 slateblue +123 104 238 mediumslateblue +132 112 255 lightslateblue +0 0 205 mediumblue +65 105 225 royalblue +0 0 255 blue +30 144 255 dodgerblue +0 191 255 deepskyblue +135 206 235 skyblue +135 206 250 lightskyblue +70 130 180 steelblue +176 196 222 lightsteelblue +173 216 230 lightblue +176 224 230 powderblue +175 238 238 paleturquoise +0 206 209 darkturquoise +72 209 204 mediumturquoise +64 224 208 turquoise +0 255 255 cyan +224 255 255 lightcyan +95 158 160 cadetblue +102 205 170 mediumaquamarine +127 255 212 aquamarine +0 100 0 darkgreen +85 107 47 darkolivegreen +143 188 143 darkseagreen +46 139 87 seagreen +60 179 113 mediumseagreen +32 178 170 lightseagreen +152 251 152 palegreen +0 255 127 springgreen +124 252 0 lawngreen +0 255 0 green +127 255 0 chartreuse +0 250 154 mediumspringgreen +173 255 47 greenyellow +50 205 50 limegreen +154 205 50 yellowgreen +34 139 34 forestgreen +107 142 35 olivedrab +189 183 107 darkkhaki +240 230 140 khaki +238 232 170 palegoldenrod +250 250 210 lightgoldenrodyellow +255 255 224 lightyellow +255 255 0 yellow +255 215 0 gold +238 221 130 lightgoldenrod +218 165 32 goldenrod +184 134 11 darkgoldenrod +188 143 143 rosybrown +205 92 92 indianred +139 69 19 saddlebrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandybrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 darksalmon +250 128 114 salmon +255 160 122 lightsalmon +255 165 0 orange +255 140 0 darkorange +255 127 80 coral +240 128 128 lightcoral +255 99 71 tomato +255 69 0 orangered +255 0 0 red +255 105 180 hotpink +255 20 147 deeppink +255 192 203 pink +255 182 193 lightpink +219 112 147 palevioletred +176 48 96 maroon +199 21 133 mediumvioletred +208 32 144 violetred +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 mediumorchid +153 50 204 darkorchid +148 0 211 darkviolet +138 43 226 blueviolet +160 32 240 purple +147 112 219 mediumpurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 antiquewhite1 +238 223 204 antiquewhite2 +205 192 176 antiquewhite3 +139 131 120 antiquewhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 peachpuff1 +238 203 173 peachpuff2 +205 175 149 peachpuff3 +139 119 101 peachpuff4 +255 222 173 navajowhite1 +238 207 161 navajowhite2 +205 179 139 navajowhite3 +139 121 94 navajowhite4 +255 250 205 lemonchiffon1 +238 233 191 lemonchiffon2 +205 201 165 lemonchiffon3 +139 137 112 lemonchiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 lavenderblush1 +238 224 229 lavenderblush2 +205 193 197 lavenderblush3 +139 131 134 lavenderblush4 +255 228 225 mistyrose1 +238 213 210 mistyrose2 +205 183 181 mistyrose3 +139 125 123 mistyrose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 slateblue1 +122 103 238 slateblue2 +105 89 205 slateblue3 +71 60 139 slateblue4 +72 118 255 royalblue1 +67 110 238 royalblue2 +58 95 205 royalblue3 +39 64 139 royalblue4 +0 0 255 blue1 +0 0 238 blue2 +0 0 205 blue3 +0 0 139 blue4 +30 144 255 dodgerblue1 +28 134 238 dodgerblue2 +24 116 205 dodgerblue3 +16 78 139 dodgerblue4 +99 184 255 steelblue1 +92 172 238 steelblue2 +79 148 205 steelblue3 +54 100 139 steelblue4 +0 191 255 deepskyblue1 +0 178 238 deepskyblue2 +0 154 205 deepskyblue3 +0 104 139 deepskyblue4 +135 206 255 skyblue1 +126 192 238 skyblue2 +108 166 205 skyblue3 +74 112 139 skyblue4 +176 226 255 lightskyblue1 +164 211 238 lightskyblue2 +141 182 205 lightskyblue3 +96 123 139 lightskyblue4 +202 225 255 lightsteelblue1 +188 210 238 lightsteelblue2 +162 181 205 lightsteelblue3 +110 123 139 lightsteelblue4 +191 239 255 lightblue1 +178 223 238 lightblue2 +154 192 205 lightblue3 +104 131 139 lightblue4 +224 255 255 lightcyan1 +209 238 238 lightcyan2 +180 205 205 lightcyan3 +122 139 139 lightcyan4 +187 255 255 paleturquoise1 +174 238 238 paleturquoise2 +150 205 205 paleturquoise3 +102 139 139 paleturquoise4 +152 245 255 cadetblue1 +142 229 238 cadetblue2 +122 197 205 cadetblue3 +83 134 139 cadetblue4 +0 245 255 turquoise1 +0 229 238 turquoise2 +0 197 205 turquoise3 +0 134 139 turquoise4 +0 255 255 cyan1 +0 238 238 cyan2 +0 205 205 cyan3 +0 139 139 cyan4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 +69 139 116 aquamarine4 +193 255 193 darkseagreen1 +180 238 180 darkseagreen2 +155 205 155 darkseagreen3 +105 139 105 darkseagreen4 +84 255 159 seagreen1 +78 238 148 seagreen2 +67 205 128 seagreen3 +46 139 87 seagreen4 +154 255 154 palegreen1 +144 238 144 palegreen2 +124 205 124 palegreen3 +84 139 84 palegreen4 +0 255 127 springgreen1 +0 238 118 springgreen2 +0 205 102 springgreen3 +0 139 69 springgreen4 +0 255 0 green1 +0 238 0 green2 +0 205 0 green3 +0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 +69 139 0 chartreuse4 +192 255 62 olivedrab1 +179 238 58 olivedrab2 +154 205 50 olivedrab3 +105 139 34 olivedrab4 +202 255 112 darkolivegreen1 +188 238 104 darkolivegreen2 +162 205 90 darkolivegreen3 +110 139 61 darkolivegreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 lightgoldenrod1 +238 220 130 lightgoldenrod2 +205 190 112 lightgoldenrod3 +139 129 76 lightgoldenrod4 +255 255 224 lightyellow1 +238 238 209 lightyellow2 +205 205 180 lightyellow3 +139 139 122 lightyellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 darkgoldenrod1 +238 173 14 darkgoldenrod2 +205 149 12 darkgoldenrod3 +139 101 8 darkgoldenrod4 +255 193 193 rosybrown1 +238 180 180 rosybrown2 +205 155 155 rosybrown3 +139 105 105 rosybrown4 +255 106 106 indianred1 +238 99 99 indianred2 +205 85 85 indianred3 +139 58 58 indianred4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 lightsalmon1 +238 149 114 lightsalmon2 +205 129 98 lightsalmon3 +139 87 66 lightsalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 darkorange1 +238 118 0 darkorange2 +205 102 0 darkorange3 +139 69 0 darkorange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 orangered1 +238 64 0 orangered2 +205 55 0 orangered3 +139 37 0 orangered4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 deeppink1 +238 18 137 deeppink2 +205 16 118 deeppink3 +139 10 80 deeppink4 +255 110 180 hotpink1 +238 106 167 hotpink2 +205 96 144 hotpink3 +139 58 98 hotpink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 lightpink1 +238 162 173 lightpink2 +205 140 149 lightpink3 +139 95 101 lightpink4 +255 130 171 palevioletred1 +238 121 159 palevioletred2 +205 104 137 palevioletred3 +139 71 93 palevioletred4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 violetred1 +238 58 140 violetred2 +205 50 120 violetred3 +139 34 82 violetred4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 mediumorchid1 +209 95 238 mediumorchid2 +180 82 205 mediumorchid3 +122 55 139 mediumorchid4 +191 62 255 darkorchid1 +178 58 238 darkorchid2 +154 50 205 darkorchid3 +104 34 139 darkorchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 +85 26 139 purple4 +171 130 255 mediumpurple1 +159 121 238 mediumpurple2 +137 104 205 mediumpurple3 +93 71 139 mediumpurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 +0 0 0 grey0 +3 3 3 grey1 +5 5 5 grey2 +8 8 8 grey3 +10 10 10 grey4 +13 13 13 grey5 +15 15 15 grey6 +18 18 18 grey7 +20 20 20 grey8 +23 23 23 grey9 +26 26 26 grey10 +28 28 28 grey11 +31 31 31 grey12 +33 33 33 grey13 +36 36 36 grey14 +38 38 38 grey15 +41 41 41 grey16 +43 43 43 grey17 +46 46 46 grey18 +48 48 48 grey19 +51 51 51 grey20 +54 54 54 grey21 +56 56 56 grey22 +59 59 59 grey23 +61 61 61 grey24 +64 64 64 grey25 +66 66 66 grey26 +69 69 69 grey27 +71 71 71 grey28 +74 74 74 grey29 +77 77 77 grey30 +79 79 79 grey31 +82 82 82 grey32 +84 84 84 grey33 +87 87 87 grey34 +89 89 89 grey35 +92 92 92 grey36 +94 94 94 grey37 +97 97 97 grey38 +99 99 99 grey39 +102 102 102 grey40 +105 105 105 grey41 +107 107 107 grey42 +110 110 110 grey43 +112 112 112 grey44 +115 115 115 grey45 +117 117 117 grey46 +120 120 120 grey47 +122 122 122 grey48 +125 125 125 grey49 +127 127 127 grey50 +130 130 130 grey51 +133 133 133 grey52 +135 135 135 grey53 +138 138 138 grey54 +140 140 140 grey55 +143 143 143 grey56 +145 145 145 grey57 +148 148 148 grey58 +150 150 150 grey59 +153 153 153 grey60 +156 156 156 grey61 +158 158 158 grey62 +161 161 161 grey63 +163 163 163 grey64 +166 166 166 grey65 +168 168 168 grey66 +171 171 171 grey67 +173 173 173 grey68 +176 176 176 grey69 +179 179 179 grey70 +181 181 181 grey71 +184 184 184 grey72 +186 186 186 grey73 +189 189 189 grey74 +191 191 191 grey75 +194 194 194 grey76 +196 196 196 grey77 +199 199 199 grey78 +201 201 201 grey79 +204 204 204 grey80 +207 207 207 grey81 +209 209 209 grey82 +212 212 212 grey83 +214 214 214 grey84 +217 217 217 grey85 +219 219 219 grey86 +222 222 222 grey87 +224 224 224 grey88 +227 227 227 grey89 +229 229 229 grey90 +232 232 232 grey91 +235 235 235 grey92 +237 237 237 grey93 +240 240 240 grey94 +242 242 242 grey95 +245 245 245 grey96 +247 247 247 grey97 +250 250 250 grey98 +252 252 252 grey99 +255 255 255 grey100 +169 169 169 darkgrey +0 0 139 darkblue +0 139 139 darkcyan +139 0 139 darkmagenta +139 0 0 darkred +144 238 144 lightgreen") + +;*---------------------------------------------------------------------*/ +;* *rgb-port* ... */ +;*---------------------------------------------------------------------*/ +(define *rgb-port* #unspecified) + +;*---------------------------------------------------------------------*/ +;* same-color? ... */ +;*---------------------------------------------------------------------*/ +(define (same-color? s1 s2) + (define (skip-rgb s) + (let ((l (string-length s))) + (let loop ((i 0)) + (if (=fx i l) + l + (let ((c (string-ref s i))) + (if (or (char-numeric? c) (char-whitespace? c)) + (loop (+fx i 1)) + i)))))) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (if (>fx l1 l2) + (let ((lc (skip-rgb s1))) + (and (=fx (-fx l1 lc) l2) + (let loop ((i1 (-fx l1 l2)) + (i2 0)) + (cond + ((=fx i1 l1) + #t) + ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) + (loop (+fx i1 1) (+fx i2 1))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* rgb-grep ... */ +;*---------------------------------------------------------------------*/ +(define (rgb-grep symbol) + (let ((parser (regular-grammar () + ((bol (: #\! (* all))) + (ignore)) + ((+ #\Newline) + (ignore)) + ((: (* (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ all)) + (let ((s (the-string))) + (if (same-color? s symbol) + (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) + (values (string->number (cadr m)) + (string->number (caddr m)) + (string->number (cadddr m)))) + (ignore)))) + (else + (values 0 0 0))))) + ;; initialization the port reading rgb.txt file + (with-input-from-string *skribe-rgb-string* + (lambda () + (read/rp parser (current-input-port)))))) + +;*---------------------------------------------------------------------*/ +;* *color-parser* ... */ +;*---------------------------------------------------------------------*/ +(define *color-parser* + (regular-grammar ((blank* (* blank)) + (blank+ (+ blank))) + + ;; rgb color + ((: #\# (+ xdigit)) + (let ((val (the-substring 1 (the-length)))) + (cond + ((=fx (string-length val) 6) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 2 4) 16) + (string->integer (substring val 4 6) 16))) + ((=fx (string-length val) 12) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 4 6) 16) + (string->integer (substring val 8 10) 16))) + (else + (values 0 0 0))))) + + ;; symbolic names + ((+ (out #\Newline)) + (let ((name (the-string))) + (cond + ((string-ci=? name "none") + (values 0 0 0)) + ((string-ci=? name "black") + (values 0 0 0)) + ((string-ci=? name "white") + (values #xff #xff #xff)) + (else + (rgb-grep name))))) + + ;; error + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->rgb spec) + (cond + ((string? spec) + (with-input-from-string spec + (lambda () + (read/rp *color-parser* (current-input-port))))) + ((fixnum? spec) + (values (bit-and #xff (bit-rsh spec 16)) + (bit-and #xff (bit-rsh spec 8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* *used-colors* ... */ +;*---------------------------------------------------------------------*/ +(define *used-colors* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-get-used-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-used-colors) + *used-colors*) + +;*---------------------------------------------------------------------*/ +;* skribe-use-color! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) diff --git a/legacy/bigloo/configure.bgl b/legacy/bigloo/configure.bgl new file mode 100644 index 0000000..e100d8d --- /dev/null +++ b/legacy/bigloo/configure.bgl @@ -0,0 +1,90 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:42:21 2003 */ +;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The general configuration options. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_configure + (export (skribe-release) + (skribe-url) + (skribe-doc-dir) + (skribe-ext-dir) + (skribe-default-path) + (skribe-scheme) + + (skribe-configure . opt) + (skribe-enforce-configure . opt))) + +;*---------------------------------------------------------------------*/ +;* skribe-configuration ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configuration) + `((:release ,(skribe-release)) + (:scheme ,(skribe-scheme)) + (:url ,(skribe-url)) + (:doc-dir ,(skribe-doc-dir)) + (:ext-dir ,(skribe-ext-dir)) + (:default-path ,(skribe-default-path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configure . opt) + (let ((conf (skribe-configuration))) + (cond + ((null? opt) + conf) + ((null? (cdr opt)) + (let ((cell (assq (car opt) conf))) + (if (pair? cell) + (cadr cell) + 'void))) + (else + (let loop ((opt opt)) + (cond + ((null? opt) + #t) + ((not (keyword? (car opt))) + #f) + ((or (null? (cdr opt)) (keyword? (cadr opt))) + #f) + (else + (let ((cell (assq (car opt) conf))) + (if (and (pair? cell) + (if (procedure? (cadr opt)) + ((cadr opt) (cadr cell)) + (equal? (cadr opt) (cadr cell)))) + (loop (cddr opt)) + #f))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-enforce-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-enforce-configure . opt) + (let loop ((o opt)) + (when (pair? o) + (cond + ((or (not (keyword? (car o))) + (null? (cdr o))) + (error 'skribe-enforce-configure + "Illegal enforcement" + opt)) + ((skribe-configure (car o) (cadr o)) + (loop (cddr o))) + (else + (error 'skribe-enforce-configure + (format "Configuration mismatch: ~a" (car o)) + (if (procedure? (cadr o)) + (format "provided `~a'" + (skribe-configure (car o))) + (format "provided `~a', required `~a'" + (skribe-configure (car o)) + (cadr o))))))))) diff --git a/legacy/bigloo/debug.sch b/legacy/bigloo/debug.sch new file mode 100644 index 0000000..9b53c84 --- /dev/null +++ b/legacy/bigloo/debug.sch @@ -0,0 +1,54 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu May 29 06:46:33 2003 */ +;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* directives */ +;*---------------------------------------------------------------------*/ +(directives + (import skribe_debug)) + +;*---------------------------------------------------------------------*/ +;* when-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (when-debug level . exp) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(if (>= *skribe-debug* ,level) (begin ,@exp)) + #unspecified)) + +;*---------------------------------------------------------------------*/ +;* with-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-debug level lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* with-push-trace ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-push-trace lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + (let ((r (gensym))) + `(let () + (c-push-trace ,lbl) + (let ((,r ,@arg*)) + (c-pop-trace) + ,r))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define-expander debug-item + (lambda (x e) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) + #unspecified))) diff --git a/legacy/bigloo/debug.scm b/legacy/bigloo/debug.scm new file mode 100644 index 0000000..8f1691c --- /dev/null +++ b/legacy/bigloo/debug.scm @@ -0,0 +1,188 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jun 11 10:01:47 2003 */ +;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_debug + + (export *skribe-debug* + *skribe-debug-symbols* + *skribe-debug-color* + + (skribe-debug::int) + (debug-port::output-port . ::obj) + (debug-margin::bstring) + (debug-color::bstring ::int . ::obj) + (debug-bold::bstring . ::obj) + (debug-string ::obj) + (debug-item . ::obj) + + (%with-debug ::obj ::obj ::procedure))) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-symbols* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-symbols* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-color* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-color* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-item* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-item* #f) + +;*---------------------------------------------------------------------*/ +;* *debug-port* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-port* (current-error-port)) + +;*---------------------------------------------------------------------*/ +;* *debug-depth* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-depth* 0) + +;*---------------------------------------------------------------------*/ +;* *debug-margin* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-margin* "") + +;*---------------------------------------------------------------------*/ +;* *skribe-margin-debug-level* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-margin-debug-level* 0) + +;*---------------------------------------------------------------------*/ +;* skribe-debug ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-debug) + *skribe-debug*) + +;*---------------------------------------------------------------------*/ +;* debug-port ... */ +;*---------------------------------------------------------------------*/ +(define (debug-port . o) + (cond + ((null? o) + *debug-port*) + ((output-port? (car o)) + (set! *debug-port* o) + o) + (else + (error 'debug-port "Illegal debug port" (car o))))) + +;*---------------------------------------------------------------------*/ +;* debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (debug-margin) + *debug-margin*) + +;*---------------------------------------------------------------------*/ +;* debug-color ... */ +;*---------------------------------------------------------------------*/ +(define (debug-color col::int . o) + (with-output-to-string + (if *skribe-debug-color* + (lambda () + (display* "[1;" (+ 31 col) "m") + (apply display* o) + (display "")) + (lambda () + (apply display* o))))) + +;*---------------------------------------------------------------------*/ +;* debug-bold ... */ +;*---------------------------------------------------------------------*/ +(define (debug-bold . o) + (apply debug-color -30 o)) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define (debug-item . args) + (if (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (begin + (display (debug-margin) *debug-port*) + (display (debug-color (-fx *debug-depth* 1) "- ")) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*)))) + +;*---------------------------------------------------------------------*/ +;* %with-debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+fx *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (-fx *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;*---------------------------------------------------------------------*/ +;* %with-debug ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (with-output-to-port *debug-port* + (lambda () + (display (debug-margin)) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl))) + (newline) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk))) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +;*---------------------------------------------------------------------*/ +;* debug-string ... */ +;*---------------------------------------------------------------------*/ +(define (debug-string o) + (with-output-to-string + (lambda () + (write o)))) + +;*---------------------------------------------------------------------*/ +;* example */ +;*---------------------------------------------------------------------*/ +;; (%with-debug 0 'foo1.1 +;; (lambda () +;; (debug-item 'foo2.1) +;; (debug-item 'foo2.2) +;; (%with-debug 0 'foo2.3 +;; (lambda () +;; (debug-item 'foo3.1) +;; (%with-debug 0 'foo3.2 +;; (lambda () +;; (debug-item 'foo4.1) +;; (debug-item 'foo4.2))) +;; (debug-item 'foo3.3))) +;; (debug-item 'foo2.4))) + diff --git a/legacy/bigloo/engine.scm b/legacy/bigloo/engine.scm new file mode 100644 index 0000000..bd8a027 --- /dev/null +++ b/legacy/bigloo/engine.scm @@ -0,0 +1,262 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 08:01:30 2003 */ +;* Last change : Fri May 21 16:12:32 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe engines */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_engine + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output) + + (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) + (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) + (find-engine ::symbol #!key version) + + (default-engine::obj) + (default-engine-set! ::%engine) + (push-default-engine ::%engine) + (pop-default-engine) + + (processor-get-engine ::obj ::obj ::%engine) + + (engine-format? ::bstring . e) + + (engine-custom::obj ::%engine ::symbol) + (engine-custom-set! ::%engine ::symbol ::obj) + + (engine-add-writer! ::%engine ::obj ::procedure ::obj + ::obj ::obj ::obj ::obj ::obj ::obj))) + +;*---------------------------------------------------------------------*/ +;* *engines* ... */ +;*---------------------------------------------------------------------*/ +(define *engines* '()) + +;*---------------------------------------------------------------------*/ +;* *default-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *default-engine* #f) +(define *default-engines* '()) + +;*---------------------------------------------------------------------*/ +;* default-engine-set! ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine-set! e) + (if (not (engine? e)) + (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) + (begin + (set! *default-engine* e) + (set! *default-engines* (cons *default-engine* *default-engines*)) + e))) + +;*---------------------------------------------------------------------*/ +;* default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine) + *default-engine*) + +;*---------------------------------------------------------------------*/ +;* push-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +;*---------------------------------------------------------------------*/ +;* pop-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + +;*---------------------------------------------------------------------*/ +;* processor-get-engine ... */ +;*---------------------------------------------------------------------*/ +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + +;*---------------------------------------------------------------------*/ +;* engine-format? ... */ +;*---------------------------------------------------------------------*/ +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + ((%engine? *skribe-engine*) *skribe-engine*) + (else (find-engine *skribe-engine*))))) + (if (not (%engine? e)) + (skribe-error 'engine-format? "No engine" e) + (string=? fmt (%engine-format e))))) + +;*---------------------------------------------------------------------*/ +;* make-engine ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine ident + #!key + (version #unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (instantiate::%engine + (ident ident) + (version version) + (format format) + (filter filter) + (delegate delegate) + (symbol-table symbol-table) + (customs custom) + (info info)))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + +;*---------------------------------------------------------------------*/ +;* copy-engine ... */ +;*---------------------------------------------------------------------*/ +(define (copy-engine ident + e + #!key + (version #unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((e (duplicate::%engine e + (ident ident) + (version version) + (filter (or filter (%engine-filter e))) + (delegate (or delegate (%engine-delegate e))) + (symbol-table (or symbol-table (%engine-symbol-table e))) + (customs (or custom (%engine-customs e)))))) + (set! *engines* (cons e *engines*)) + e)) + +;*---------------------------------------------------------------------*/ +;* find-loaded-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-loaded-engine id version) + (let loop ((es *engines*)) + (cond + ((null? es) + #f) + ((eq? (%engine-ident (car es)) id) + (cond + ((eq? version #unspecified) + (car es)) + ((eq? version (%engine-version (car es))) + (car es)) + (else + (loop (cdr es))))) + (else + (loop (cdr es)))))) + +;*---------------------------------------------------------------------*/ +;* find-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-engine id #!key (version #unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + (or (find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and (pair? c) (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (find-loaded-engine id version)) + #f))))) + +;*---------------------------------------------------------------------*/ +;* engine-custom ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom e id) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (cadr c) + #unspecified)))) + +;*---------------------------------------------------------------------*/ +;* engine-custom-set! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom-set! e id val) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (set! customs (cons (list id val) customs)))))) + +;*---------------------------------------------------------------------*/ +;* engine-add-writer! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-add-writer! e id pred upred opt before action after class va) + ;; check the arity of a procedure + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error id "Illegal procedure" proc)) + ((not (correct-arity? proc arity)) + (skribe-error id + (string-append "Illegal `" name "'procedure") + proc)))) + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + ;; check the engine + (if (not (engine? e)) + (skribe-error id "Illegal engine" e)) + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error id "Illegal options" opt)) + ;; check the correctness of the predicate and the validator + (check-procedure "predicate" pred 2) + (when va (check-procedure "validate" va 2)) + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + ;; create a new writer... + (let ((n (instantiate::%writer + (ident (if (symbol? id) id 'all)) + (class class) + (pred pred) + (upred upred) + (options opt) + (before before) + (action action) + (after after) + (validate va)))) + ;; ...and bind it + (with-access::%engine e (writers) + (set! writers (cons n writers)) + n))) diff --git a/legacy/bigloo/eval.scm b/legacy/bigloo/eval.scm new file mode 100644 index 0000000..b5c6548 --- /dev/null +++ b/legacy/bigloo/eval.scm @@ -0,0 +1,335 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed May 18 15:52:01 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe evaluator */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_eval + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_param + skribe_types + skribe_resolve + skribe_verify + skribe_output + skribe_read + skribe_lib + skribe_engine) + + (export (skribe-eval-location) + (skribe-error ::obj ::obj ::obj) + (skribe-type-error ::obj ::obj ::obj ::bstring) + (skribe-warning ::int . obj) + (skribe-warning/ast ::int ::%ast . obj) + (skribe-message ::bstring . obj) + (skribe-load ::bstring #!rest opt #!key engine path) + (skribe-load-options) + (skribe-include ::bstring . rest) + (skribe-open-bib-file ::bstring ::obj) + (skribe-eval-port ::input-port ::obj #!key env) + (skribe-eval ::obj ::%engine #!key env) + (skribe-path::pair-nil) + (skribe-path-set! ::obj) + (skribe-image-path::pair-nil) + (skribe-image-path-set! ::obj) + (skribe-bib-path::pair-nil) + (skribe-bib-path-set! ::obj) + (skribe-source-path::pair-nil) + (skribe-source-path-set! ::obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-location ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-location) + (evmeaning-location)) + +;*---------------------------------------------------------------------*/ +;* skribe-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error/evloc proc msg obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-type-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-type-error proc msg obj etype) + (let ((ty (if (%markup? obj) + (format "~a#~a" (markup-markup obj) (markup-ident obj)) + (find-runtime-type obj)))) + (skribe-error proc + (bigloo-type-error-msg msg etype ty) + obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-ast-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (%markup? obj) + (%markup-markup obj) + (find-runtime-type obj)))) + (if (location? l) + (error/location proc msg shape (location-file l) (location-pos l)) + (error/evloc proc msg shape)))) + +;*---------------------------------------------------------------------*/ +;* error/evloc ... */ +;*---------------------------------------------------------------------*/ +(define (error/evloc proc msg obj) + (let ((l (evmeaning-location))) + (if (location? l) + (error/location proc msg obj (location-file l) (location-pos l)) + ((begin error) proc msg obj)))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (let ((l (evmeaning-location))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply warning obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning/ast ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (%ast-loc ast))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply skribe-warning level obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-message ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-message fmt . obj) + (if (> *skribe-verbose* 0) + (apply fprintf (current-error-port) fmt obj))) + +;*---------------------------------------------------------------------*/ +;* *skribe-loaded* ... */ +;* ------------------------------------------------------------- */ +;* This hash table stores the list of loaded files in order */ +;* to avoid one file to be loaded twice. */ +;*---------------------------------------------------------------------*/ +(define *skribe-loaded* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* *skribe-load-options* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-load-options* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-load ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load file #!rest opt #!key engine path) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + (let* ((ei (cond + ((not engine) + *skribe-engine*) + ((engine? engine) + engine) + ((not (symbol? engine)) + (skribe-error 'skribe-load "Illegal engine" engine)) + (else + engine))) + (path (cond + ((not path) + (skribe-path)) + ((string? path) + (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else + path))) + (filep (find-file/path file path))) + (set! *skribe-load-options* opt) + (if (and (string? filep) (file-exists? filep)) + (if (not (hashtable-get *skribe-loaded* filep)) + (begin + (hashtable-put! *skribe-loaded* filep #t) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [loading file: " filep " " opt "]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [loading file: " filep "]"))) + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))))) + (skribe-error 'skribe-load + (format "Can't find file `~a' in path" file) + path))))) + +;*---------------------------------------------------------------------*/ +;* skribe-load-options ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load-options) + *skribe-load-options*) + +;*---------------------------------------------------------------------*/ +;* evaluate ... */ +;*---------------------------------------------------------------------*/ +(define (evaluate exp) + (try (eval exp) + (lambda (a p m o) + (evmeaning-notify-error p m o) + (flush-output-port (current-error-port))))) + +;*---------------------------------------------------------------------*/ +;* skribe-include ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-include file . rest) + (let* ((path (cond + ((or (null? rest) (null? (cdr rest))) + (skribe-path)) + ((not (every? string? (cdr rest))) + (skribe-error 'skribe-include "Illegal path" (cdr rest))) + (else + (cdr rest)))) + (filep (find-file/path file (if (null? path) (skribe-path) path)))) + (if (and (string? filep) (file-exists? filep)) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [including file: " filep "]")) + (with-input-from-file filep + (lambda () + (let loop ((exp (skribe-read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (loop (skribe-read (current-input-port)) + (cons (evaluate exp) res))))))) + (skribe-error 'skribe-include + (format "Can't find file `~a 'in path" file) + path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-open-bib-file ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-open-bib-file file command) + (let ((filep (find-file/path file *skribe-bib-path*))) + (if (string? filep) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [loading bib: " filep "]")) + (open-input-file (if (string? command) + (string-append "| " + (format command filep)) + filep))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-port ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-port port ei #!key (env '())) + (with-debug 2 'skribe-eval-port + (debug-item "ei=" ei) + (let ((e (if (symbol? ei) (find-engine ei) ei))) + (debug-item "e=" e) + (if (not (%engine? e)) + (skribe-error 'find-engine "Can't find engine" ei) + (let loop ((exp (skribe-read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (if (not (eof-object? exp)) + (begin + (skribe-eval (evaluate exp) e :env env) + (loop (skribe-read port))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval a e #!key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (%engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;*---------------------------------------------------------------------*/ +;* skribe-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path) + *skribe-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path) + *skribe-image-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path) + *skribe-bib-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path) + *skribe-source-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) diff --git a/legacy/bigloo/evapi.scm b/legacy/bigloo/evapi.scm new file mode 100644 index 0000000..6f0d49e --- /dev/null +++ b/legacy/bigloo/evapi.scm @@ -0,0 +1,39 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:57:09 2003 */ +;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo eval declarations */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_evapi + (import skribe_types + skribe_lib + skribe_api + skribe_engine + skribe_writer + skribe_output + skribe_eval + skribe_read + skribe_resolve + skribe_param + skribe_source + skribe_index + skribe_configure + skribe_lisp + skribe_xml + skribe_c + skribe_asm + skribe_bib + skribe_color + skribe_sui + skribe_debug) + (eval (export-all))) + + diff --git a/legacy/bigloo/index.bgl b/legacy/bigloo/index.bgl new file mode 100644 index 0000000..9697981 --- /dev/null +++ b/legacy/bigloo/index.bgl @@ -0,0 +1,32 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 24 08:01:45 2003 */ +;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe indexes Bigloo module declaration */ +;* ------------------------------------------------------------- */ +;* Implementation: @label index@ */ +;* bigloo: @path ../common/index.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_index + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (index?::bool ::obj) + (default-index) + (make-index-table ::bstring) + (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) + diff --git a/legacy/bigloo/lib.bgl b/legacy/bigloo/lib.bgl new file mode 100644 index 0000000..6dd6d37 --- /dev/null +++ b/legacy/bigloo/lib.bgl @@ -0,0 +1,340 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe runtime (i.e., the style user functions). */ +;* ------------------------------------------------------------- */ +;* Implementation: @label lib@ */ +;* bigloo: @path ../common/lib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lib + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output + skribe_engine) + + (export (markup-option ::%markup ::obj) + (markup-option-add! ::%markup ::obj ::obj) + (markup-class ::%markup) + + (container-env-get ::%container ::symbol) + (container-search-down::pair-nil ::procedure ::%container) + (search-down::pair-nil ::procedure ::obj) + + (find-markup-ident::pair-nil ::bstring) + + (find-down::pair-nil ::procedure ::obj) + (find1-down::obj ::procedure ::obj) + (find-up::pair-nil ::procedure ::obj) + (find1-up::obj ::procedure ::obj) + + (ast-document ::%ast) + (ast-chapter ::%ast) + (ast-section ::%ast) + + (the-body ::pair-nil) + (the-options ::pair-nil . rest) + + (list-split::pair-nil ::pair-nil ::int . ::obj) + + (generic ast->string::bstring ::obj) + + (strip-ref-base ::bstring) + (ast->file-location ::%ast) + + (convert-image ::bstring ::pair-nil) + + (make-string-replace ::pair-nil) + (string-canonicalize::bstring ::bstring) + (inline unspecified?::bool ::obj))) + +;*---------------------------------------------------------------------*/ +;* markup-option ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option m opt) + (if (%markup? m) + (with-access::%markup m (options) + (let ((c (assq opt options))) + (and (pair? c) (pair? (cdr c)) (cadr c)))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-option-add! ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option-add! m opt val) + (if (%markup? m) + (with-access::%markup m (options) + (set! options (cons (list opt val) options))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (markup-class m) + (%markup-class m)) + +;*---------------------------------------------------------------------*/ +;* container-env-get ... */ +;*---------------------------------------------------------------------*/ +(define (container-env-get m key) + (with-access::%container m (env) + (let ((c (assq key env))) + (and (pair? c) (cadr c))))) + +;*---------------------------------------------------------------------*/ +;* strip-ref-base ... */ +;*---------------------------------------------------------------------*/ +(define (strip-ref-base file) + (if (not (string? *skribe-ref-base*)) + file + (let ((l (string-length *skribe-ref-base*))) + (cond + ((not (>fx (string-length file) (+fx l 2))) + file) + ((not (substring=? file *skribe-ref-base* l)) + file) + ((not (char=? (string-ref file l) (file-separator))) + file) + (else + (substring file (+fx l 1) (string-length file))))))) + +;*---------------------------------------------------------------------*/ +;* ast->file-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format "~a:~a" (location-file l) (location-pos l)) + ""))) + +;*---------------------------------------------------------------------*/ +;* builtin-convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (builtin-convert-image from fmt dir) + (let* ((s (suffix from)) + (f (string-append (prefix (basename from)) "." fmt)) + (to (make-file-name dir f))) + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append "fig2dev -L " fmt " " from " > " to) + (string-append "convert " from " " to)))) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [converting image: " from " (" c ")]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [converting image: " from "]"))) + (if (=fx (system c) 0) to #f)))))) + +;*---------------------------------------------------------------------*/ +;* convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (convert-image file formats) + (let ((path (find-file/path file (skribe-image-path)))) + (if (not (string? path)) + (skribe-error 'image + (format "Can't find `~a' image file in path: " file) + (skribe-image-path)) + (let ((suf (suffix file))) + (if (member suf formats) + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + #f))) + (if dir + (let ((dest (basename path))) + (copy-file path (make-file-name dir dest)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + +;*---------------------------------------------------------------------*/ +;* html-string ... */ +;*---------------------------------------------------------------------*/ +(define (html-string str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (if (=fx nlen len) + str + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let ((c (string-ref-ur str r))) + (case c + ((#\<) + (blit-string! "<" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\>) + (blit-string! ">" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\&) + (blit-string! "&" 0 res w 5) + (loop (+fx r 1) (+fx w 5))) + ((#\") + (blit-string! """ 0 res w 6) + (loop (+fx r 1) (+fx w 6))) + (else + (string-set! res w c) + (loop (+fx r 1) (+fx w 1))))))))) + (case (string-ref-ur str r) + ((#\< #\>) + (loop (+fx r 1) (+fx nlen 3))) + ((#\&) + (loop (+fx r 1) (+fx nlen 4))) + ((#\") + (loop (+fx r 1) (+fx nlen 5))) + (else + (loop (+fx r 1) nlen))))))) + +;*---------------------------------------------------------------------*/ +;* make-generic-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-generic-string-replace lst) + (lambda (str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (let ((pl (string-length (cadr p)))) + (blit-string! (cadr p) 0 res w pl) + (loop (+fx r 1) (+fx w pl))) + (begin + (string-set! res w c) + (loop (+fx r 1) (+fx w 1)))))))) + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (loop (+fx r 1) + (+fx nlen (-fx (string-length (cadr p)) 1))) + (loop (+fx r 1) + nlen)))))))) + +;*---------------------------------------------------------------------*/ +;* make-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char ">"))) + html-string) + (else + (make-generic-string-replace lst))))) + +;*---------------------------------------------------------------------*/ +;* ast->string ... */ +;*---------------------------------------------------------------------*/ +(define-generic (ast->string ast) + (cond + ((string? ast) + ast) + ((number? ast) + (number->string ast)) + ((pair? ast) + (let* ((t (map ast->string ast)) + (res (make-string + (apply + -1 (length t) (map string-length t)) + #\space))) + (let loop ((t t) + (w 0)) + (if (null? t) + res + (let ((l (string-length (car t)))) + (blit-string! (car t) 0 res w l) + (loop (cdr t) (+ w l 1))))))) + (else + ""))) + +;*---------------------------------------------------------------------*/ +;* ast->string ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (ast->string ast::%node) + (ast->string (%node-body ast))) + +;*---------------------------------------------------------------------*/ +;* string-canonicalize ... */ +;*---------------------------------------------------------------------*/ +(define (string-canonicalize old) + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((=fx r l) + (cond + ((=fx w 0) + "") + ((char-whitespace? (string-ref new (-fx w 1))) + (substring new 0 (-fx w 1))) + ((=fx w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+fx r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (char=? (string-ref old r) #\,) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+fx r 1) (+fx w 1) #f)))))) + +;*---------------------------------------------------------------------*/ +;* unspecified? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unspecified? obj) + (eq? obj #unspecified)) + +;*---------------------------------------------------------------------*/ +;* base */ +;* ------------------------------------------------------------- */ +;* A base engine must pre-exist before anything is loaded. In */ +;* particular, this dummy base engine is used to load the */ +;* actual definition of base. */ +;*---------------------------------------------------------------------*/ +(make-engine 'base :version 'bootstrap) + diff --git a/legacy/bigloo/lisp.scm b/legacy/bigloo/lisp.scm new file mode 100644 index 0000000..65a8227 --- /dev/null +++ b/legacy/bigloo/lisp.scm @@ -0,0 +1,530 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Aug 29 08:14:59 2003 */ +;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Handling of lispish source files. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lisp + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export bigloo + scheme + lisp + skribe)) + +;*---------------------------------------------------------------------*/ +;* keys ... */ +;*---------------------------------------------------------------------*/ +(define *the-key* #f) +(define *bracket-highlight* #t) +(define *bigloo-key* #f) +(define *scheme-key* #f) +(define *lisp-key* #f) +(define *skribe-key* #f) + +;*---------------------------------------------------------------------*/ +;* init-bigloo-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-bigloo-fontifier!) + (if (not *bigloo-key*) + (begin + (set! *bigloo-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'symbol)) + '(set! if let cond case quote begin letrec let* + lambda export extern class generic inline + static import foreign type with-access instantiate + duplicate labels + match-case match-lambda + syntax-rules pragma widen! shrink! + wide-class profile profile/gc + regular-grammar lalr-grammar apply)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'define)) + '(define define-inline define-struct define-macro + define-generic define-method define-syntax + define-expander)) + ;; error + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'error)) + '(bind-exit unwind-protect call/cc error warning)) + ;; module + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'module)) + '(module import export library)) + ;; thread + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'thread)) + '(make-thread thread-start! thread-yield! + thread-await! thread-await*! + thread-sleep! thread-join! + thread-terminate! thread-suspend! + thread-resume! thread-yield! + thread-specific thread-specific-set! + thread-name thread-name-set! + scheduler-react! scheduler-start! + broadcast! scheduler-broadcast! + current-thread thread? + current-scheduler scheduler? make-scheduler + make-input-signal make-output-signal + make-connect-signal make-process-signal + make-accept-signal make-timer-signal + thread-get-values! thread-get-values*!))))) + +;*---------------------------------------------------------------------*/ +;* init-lisp-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-lisp-fontifier!) + (if (not *lisp-key*) + (begin + (set! *lisp-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'symbol)) + '(setq if let cond case else progn letrec let* + lambda labels try unwind-protect apply funcall)) + ;; defun + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'define)) + '(define defun defvar defmacro))))) + +;*---------------------------------------------------------------------*/ +;* init-skribe-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-skribe-fontifier!) + (if (not *skribe-key*) + (begin + (set! *skribe-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'symbol)) + '(set! bold it emph tt color ref index underline + figure center pre flush hrule linebreak + image kbd code var samp sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font lambda)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'define)) + '(define define-markup)) + ;; markup + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'markup)) + '(document chapter section subsection subsubsection + paragraph p handle resolve processor + abstract margin toc table-of-contents + current-document current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide))))) + +;*---------------------------------------------------------------------*/ +;* bigloo ... */ +;*---------------------------------------------------------------------*/ +(define bigloo + (new language + (name "bigloo") + (fontifier bigloo-fontifier) + (extractor bigloo-extractor))) + +;*---------------------------------------------------------------------*/ +;* scheme ... */ +;*---------------------------------------------------------------------*/ +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;*---------------------------------------------------------------------*/ +;* lisp ... */ +;*---------------------------------------------------------------------*/ +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;*---------------------------------------------------------------------*/ +;* bigloo-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-fontifier s) + (init-bigloo-fontifier!) + (set! *the-key* *bigloo-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* bigloo-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (eq? def fun)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* skribe ... */ +;*---------------------------------------------------------------------*/ +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;*---------------------------------------------------------------------*/ +;* skribe-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-fontifier s) + (init-skribe-fontifier!) + (set! *the-key* *skribe-key*) + (set! *bracket-highlight* #t) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* skribe-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + ((markup-output (quote ?mk) . ?-) + (eq? mk def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* scheme-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-fontifier s) s) + +;*---------------------------------------------------------------------*/ +;* scheme-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* lisp-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-fontifier s) + (init-lisp-fontifier!) + (set! *the-key* *lisp-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* lisp-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (eq? def fun)) + ((defvar ?var . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* definition-search ... */ +;* ------------------------------------------------------------- */ +;* This function seeks a Bigloo definition. If it finds it, it */ +;* returns two values the starting char number of the definition */ +;* and the stop char. */ +;*---------------------------------------------------------------------*/ +(define (definition-search ip tab semipred) + (cond-expand + (bigloo2.6 + (define (reader-current-line-number) + (let* ((port (open-input-string "(9)")) + (exp (read port #t))) + (close-input-port port) + (line-number exp))) + (define (line-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos ?line) + line)))) + (reader-reset!) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (line-number exp)) + (e (reader-current-line-number))) + (source-read-lines (input-port-name ip) b e tab))))))) + (else + (define (char-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos) + pos)))) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (char-number exp)) + (e (input-port-position ip))) + (source-read-chars (input-port-name ip) + b + e + tab))))))))) + + +;*---------------------------------------------------------------------*/ +;* fontify-lisp ... */ +;*---------------------------------------------------------------------*/ +(define (fontify-lisp port::input-port) + (let ((g (regular-grammar () + ((: ";;" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";*" (* all)) + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-string))) + (cons str (ignore)))) + ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-substring 1 (the-length)))) + (cons str (ignore)))) + ((+ #\Space) + ;; separators + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + (#\( + ;; open parenthesis + (let ((str (highlight (the-string)))) + (pupush-highlight) + (cons str (ignore)))) + (#\) + ;; close parenthesis + (let ((str (highlight (the-string) -1))) + (cons str (ignore)))) + ((+ (in "[]")) + ;; brackets + (let ((s (the-string))) + (if *bracket-highlight* + (let ((c (new markup + (markup '&source-bracket) + (body s)))) + (cons c (ignore))) + (cons s (ignore))))) + ((+ #\Tab) + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((: #\( (+ (out "; \t()[]:\"\n"))) + ;; keywords + (let* ((string (the-substring 1 (the-length))) + (symbol (string->symbol string)) + (key (getprop symbol *the-key*))) + (cons + "(" + (case key + ((symbol) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((define) + (let ((c (new markup + (markup '&source-define) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-define) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((error) + (let ((c (new markup + (markup '&source-error) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((module) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((markup) + (let ((c (new markup + (markup '&source-markup) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((thread) + (let ((c (new markup + (markup '&source-thread) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons (highlight string 1) (ignore))))))) + ((+ (out "; \t()[]:\"\n")) + (let ((string (the-string))) + (cons (highlight string 1) (ignore)))) + ((+ #\Newline) + ;; newline + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (ident (symbol->string (gensym))) + (body s)))) + str) + (ignore)))) + ((: "::" (+ (out ";\n \t()[]:\""))) + ;; type annotations + (let ((c (new markup + (markup '&source-type) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) + ;; keywords annotations + (let ((c (new markup + (markup '&source-key) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\: #\; #\")) + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + ((: #\# #\\ (+ (out " \n\t"))) + ;; characters + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(lisp)" "Unexpected character" c))))))) + (reset-highlight!) + (read/rp g port))) + +;*---------------------------------------------------------------------*/ +;* *highlight* ... */ +;*---------------------------------------------------------------------*/ +(define *highlight* '()) + +;*---------------------------------------------------------------------*/ +;* reset-highlight! ... */ +;*---------------------------------------------------------------------*/ +(define (reset-highlight!) + (set! *highlight* '())) + +;*---------------------------------------------------------------------*/ +;* push-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (push-highlight col pv) + (set! *highlight* (cons (cons col pv) *highlight*))) + +;*---------------------------------------------------------------------*/ +;* pupush-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pupush-highlight) + (if (pair? *highlight*) + (let ((c (car *highlight*))) + (set-cdr! c 100000)))) + +;*---------------------------------------------------------------------*/ +;* pop-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pop-highlight pv) + (case pv + ((-1) + (set! *highlight* (cdr *highlight*))) + ((0) + 'nop) + (else + (let ((c (car *highlight*))) + (if (>fx (cdr c) 1) + (set-cdr! c (-fx (cdr c) 1)) + (set! *highlight* (cdr *highlight*))))))) + +;*---------------------------------------------------------------------*/ +;* highlight ... */ +;*---------------------------------------------------------------------*/ +(define (highlight exp . pop) + (if (pair? *highlight*) + (let* ((c (car *highlight*)) + (r (if (>fx (cdr c) 0) + ((car c) exp) + exp))) + (if (pair? pop) (pop-highlight (car pop))) + r) + exp)) + + diff --git a/legacy/bigloo/main.scm b/legacy/bigloo/main.scm new file mode 100644 index 0000000..5b9e5e5 --- /dev/null +++ b/legacy/bigloo/main.scm @@ -0,0 +1,96 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/main.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:51:49 2003 */ +;* Last change : Wed May 18 15:45:27 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe main entry point */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_main + + (include "debug.sch") + + (import skribe_types + skribe_parse-args + skribe_param + skribe_lib + skribe_eval + skribe_read + skribe_engine + skribe_evapi) + + (main main)) + +;*---------------------------------------------------------------------*/ +;* main ... */ +;*---------------------------------------------------------------------*/ +(define (main args) + (with-debug 2 'main + (debug-item "parse env variables...") + (parse-env-variables) + + (debug-item "load rc file...") + (load-rc) + + (debug-item "parse command line...") + (parse-args args) + + (debug-item "load base...") + (skribe-load "base.skr" :engine 'base) + + (debug-item "preload... (" *skribe-engine* ")") + (for-each (lambda (f) + (skribe-load f :engine *skribe-engine*)) + *skribe-preload*) + + ;; Load the specified variants + (debug-item "variant... (" *skribe-variants* ")") + (for-each (lambda (x) + (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) + (reverse! *skribe-variants*)) + + (debug-item "body..." *skribe-engine*) + (if (string? *skribe-dest*) + (cond-expand + (bigloo2.6 + (try (with-output-to-file *skribe-dest* doskribe) + (lambda (e a b c) + (delete-file *skribe-dest*) + (let ((s (with-output-to-string + (lambda () (write c))))) + (notify-error a b s)) + (exit -1)))) + (else + (with-exception-handler + (lambda (e) + (if (&warning? e) + (raise e) + (begin + (delete-file *skribe-dest*) + (if (&error? e) + (error-notify e) + (raise e)) + (exit 1)))) + (lambda () + (with-output-to-file *skribe-dest* doskribe))))) + (doskribe)))) + +;*---------------------------------------------------------------------*/ +;* doskribe ... */ +;*---------------------------------------------------------------------*/ +(define (doskribe) + (let ((e (find-engine *skribe-engine*))) + (if (and (engine? e) (pair? *skribe-precustom*)) + (for-each (lambda (cv) + (engine-custom-set! e (car cv) (cdr cv))) + *skribe-precustom*)) + (if (pair? *skribe-src*) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) + *skribe-src*) + (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/legacy/bigloo/new.sch b/legacy/bigloo/new.sch new file mode 100644 index 0000000..16bb7d5 --- /dev/null +++ b/legacy/bigloo/new.sch @@ -0,0 +1,17 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/new.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 17 11:58:30 2003 */ +;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The new facility */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* new ... */ +;*---------------------------------------------------------------------*/ +(define-macro (new id . inits) + `(,(symbol-append 'instantiate::% id) ,@inits)) + diff --git a/legacy/bigloo/output.scm b/legacy/bigloo/output.scm new file mode 100644 index 0000000..4bc6271 --- /dev/null +++ b/legacy/bigloo/output.scm @@ -0,0 +1,167 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/output.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe engine */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_output + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (output ::obj ::%engine . w))) + +;*---------------------------------------------------------------------*/ +;* output ... */ +;*---------------------------------------------------------------------*/ +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (pair? writer) + (cond + ((%writer? (car writer)) + (out/writer node e (car writer))) + ((not (car writer)) + (skribe-error 'output + (format "Illegal `~a' user writer" (%engine-ident e)) + (if (markup? node) (%markup-markup node) node))) + (else + (skribe-error 'output "Illegal user writer" (car writer)))) + (out node e)))) + +;*---------------------------------------------------------------------*/ +;* out/writer ... */ +;*---------------------------------------------------------------------*/ +(define (out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" (find-runtime-type n) + " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (%engine-ident e)) + (debug-item "w=" (%writer-ident w)) + (if (%writer? w) + (with-access::%writer w (before action after) + (invoke before n e) + (invoke action n e) + (invoke after n e))))) + +;*---------------------------------------------------------------------*/ +;* out ... */ +;*---------------------------------------------------------------------*/ +(define-generic (out node e::%engine) + (cond + ((pair? node) + (out* node e)) + ((string? node) + (let ((f (%engine-filter e))) + (if (procedure? f) + (display (f node)) + (display node)))) + ((number? node) + (display node)) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* out ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (out n::%processor e::%engine) + (with-access::%processor n (combinator engine body procedure) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + +;*---------------------------------------------------------------------*/ +;* out ::%command ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%command e::%engine) + (with-access::%command node (fmt body) + (let ((lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (skribe-error '! + "Too few arguments provided" + node))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (skribe-error '! + "Too few arguments provided" + node)))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0)))))))) + +;*---------------------------------------------------------------------*/ +;* out ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%handle e::%engine) + #unspecified) + +;*---------------------------------------------------------------------*/ +;* out ::%unresolved ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%unresolved e::%engine) + (error 'output "Orphan unresolved" node)) + +;*---------------------------------------------------------------------*/ +;* out ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%markup e::%engine) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (out/writer node e w) + (output (%markup-body node) e)))) + +;*---------------------------------------------------------------------*/ +;* out* ... */ +;*---------------------------------------------------------------------*/ +(define (out* n+ e) + (let loop ((n* n+)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (error 'output "Illegal argument" n*))))) + + diff --git a/legacy/bigloo/param.bgl b/legacy/bigloo/param.bgl new file mode 100644 index 0000000..6ff6b42 --- /dev/null +++ b/legacy/bigloo/param.bgl @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 14:03:15 2003 */ +;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe parameters */ +;* ------------------------------------------------------------- */ +;* Implementation: @label param@ */ +;* bigloo: @path ../common/param.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_param + + (import skribe_configure) + + (export *skribe-verbose* + *skribe-warning* + *skribe-path* + *skribe-bib-path* + *skribe-source-path* + *skribe-image-path* + *load-rc* + + *skribe-src* + *skribe-dest* + *skribe-engine* + *skribe-variants* + *skribe-chapter-split* + + *skribe-ref-base* + + *skribe-rc-directory* + *skribe-rc-file* + *skribe-auto-mode-alist* + *skribe-auto-load-alist* + *skribe-preload* + *skribe-precustom* + + *skribebib-auto-mode-alist*)) + +;*---------------------------------------------------------------------*/ +;* *skribe-verbose* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-verbose* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-warning* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-warning* 5) + +;*---------------------------------------------------------------------*/ +;* *skribe-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-path* (skribe-default-path)) + +;*---------------------------------------------------------------------*/ +;* *skribe-bib-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-bib-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-source-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-source-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-image-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-image-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *load-rc* ... */ +;*---------------------------------------------------------------------*/ +(define *load-rc* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-src* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-src* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-dest* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-dest* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-engine* 'html) + +;*---------------------------------------------------------------------*/ +;* *skribe-variants* */ +;*---------------------------------------------------------------------*/ +(define *skribe-variants* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-chapter-split* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-chapter-split* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-ref-base* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-ref-base* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-rc-directory* ... */ +;* ------------------------------------------------------------- */ +;* The "runtime command" file directory. */ +;*---------------------------------------------------------------------*/ +(define *skribe-rc-directory* + (let ((home (getenv "HOME")) + (host (hostname))) + (let loop ((host (if (not (string? host)) (getenv "HOST") host))) + (if (string? host) + (let ((home/host (string-append home "/.skribe" host))) + (if (and (file-exists? home/host) (directory? home/host)) + home/host + (if (string=? (suffix host) "") + (let ((home/def (make-file-name home ".skribe"))) + (cond + ((and (file-exists? home/def) + (directory? home/def)) + home/def) + (else + home))) + (loop (prefix host))))))))) + diff --git a/legacy/bigloo/parseargs.scm b/legacy/bigloo/parseargs.scm new file mode 100644 index 0000000..4ce58c4 --- /dev/null +++ b/legacy/bigloo/parseargs.scm @@ -0,0 +1,186 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:52:53 2003 */ +;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Argument parsing */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_parse-args + + (include "debug.sch") + + (import skribe_configure + skribe_param + skribe_read + skribe_types + skribe_eval) + + (export (parse-env-variables) + (parse-args ::pair) + (load-rc))) + +;*---------------------------------------------------------------------*/ +;* parse-env-variables ... */ +;*---------------------------------------------------------------------*/ +(define (parse-env-variables) + (let ((e (getenv "SKRIBEPATH"))) + (if (string? e) + (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) + +;*---------------------------------------------------------------------*/ +;* parse-args ... */ +;*---------------------------------------------------------------------*/ +(define (parse-args args) + (define (usage args-parse-usage) + (print "usage: skribe [options] [input]") + (newline) + (args-parse-usage #f) + (newline) + (print "Rc file:") + (newline) + (print " *skribe-rc* (searched in \".\" then $HOME)") + (newline) + (print "Target formats:") + (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) + (newline) + (print "Shell Variables:") + (newline) + (for-each (lambda (var) + (print " - " (car var) " " (cdr var))) + '(("SKRIBEPATH" . "Skribe input path (all files)")))) + (define (version) + (print "skribe v" (skribe-release))) + (define (query) + (version) + (newline) + (for-each (lambda (x) + (let ((s (keyword->string (car x)))) + (printf " ~a: ~a\n" + (substring s 1 (string-length s)) + (cadr x)))) + (skribe-configure))) + (let ((np '()) + (engine #f)) + (args-parse (cdr args) + ((("-h" "--help") (help "This message")) + (usage args-parse-usage) + (exit 0)) + (("--options" (help "Display the skribe options and exit")) + (args-parse-usage #t) + (exit 0)) + (("--version" (help "The version of Skribe")) + (version) + (exit 0)) + ((("-q" "--query") (help "Display informations about the Skribe configuration")) + (query) + (exit 0)) + ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) + (let ((l (string-length key=val))) + (let loop ((i 0)) + (cond + ((= i l) + (skribe-error 'skribe "Illegal option" key=val)) + ((char=? (string-ref key=val i) #\=) + (let ((key (substring key=val 0 i)) + (val (substring key=val (+ i 1) l))) + (set! *skribe-precustom* + (cons (cons (string->symbol key) val) + *skribe-precustom*)))) + (else + (loop (+ i 1))))))) + (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) + (set! *skribe-verbose* (string->integer level)))) + (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-warning* (+fx 1 *skribe-warning*)) + (set! *skribe-warning* (string->integer level)))) + (("-g?level" (help "Increase or set debug level")) + (if (string=? level "") + (set! *skribe-debug* (+fx 1 *skribe-debug*)) + (let ((l (string->integer level))) + (if (= l 0) + (begin + (set! *skribe-debug* 1) + (set! *skribe-debug-symbols* + (cons (string->symbol level) + *skribe-debug-symbols*))) + (set! *skribe-debug* l))))) + (("--no-color" (help "Disable coloring for debug")) + (set! *skribe-debug-color* #f)) + ((("-t" "--target") ?e (help "The output target format")) + (set! engine (string->symbol e))) + (("-I" ?path (help "Add to skribe path")) + (set! np (cons path np))) + (("-B" ?path (help "Add to skribe bibliography path")) + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("-S" ?path (help "Add to skribe source path")) + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("-P" ?path (help "Add to skribe image path")) + (skribe-image-path-set! (cons path (skribe-image-path)))) + ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files")) + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("--eval" ?expr (help "Evaluate expression")) + (with-input-from-string expr + (lambda () + (eval (skribe-read))))) + (("--no-init-file" (help "Dont load rc Skribe file")) + (set! *load-rc* #f)) + ((("-p" "--preload") ?file (help "Preload file")) + (set! *skribe-preload* (cons file *skribe-preload*))) + ((("-u" "--use-variant") ?variant (help "use output format")) + (set! *skribe-variants* (cons variant *skribe-variants*))) + ((("-o" "--output") ?o (help "The output target name")) + (set! *skribe-dest* o) + (let* ((s (suffix o)) + (c (assoc s *skribe-auto-mode-alist*))) + (if (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks")) + (set! *skribe-ref-base* base)) + ;; skribe rc directory + ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory")) + (set! *skribe-rc-directory* dir)) + (else + (set! *skribe-src* (cons else *skribe-src*)))) + ;; we have to configure according to the environment variables + (if engine (set! *skribe-engine* engine)) + (set! *skribe-src* (reverse! *skribe-src*)) + (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH") + (reverse! np) + (skribe-path))))) + +;*---------------------------------------------------------------------*/ +;* build-path-from-shell-variable ... */ +;*---------------------------------------------------------------------*/ +(define (build-path-from-shell-variable var) + (let ((val (getenv var))) + (if (string? val) + (string-case val + ((+ (out #\:)) + (let* ((str (the-string)) + (res (ignore))) + (cons str res))) + (#\: + (ignore)) + (else + '())) + '()))) + +;*---------------------------------------------------------------------*/ +;* load-rc ... */ +;*---------------------------------------------------------------------*/ +(define (load-rc) + (if *load-rc* + (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*))) + (if (and (string? file) (file-exists? file)) + (loadq file))))) + diff --git a/legacy/bigloo/prog.scm b/legacy/bigloo/prog.scm new file mode 100644 index 0000000..baad0f0 --- /dev/null +++ b/legacy/bigloo/prog.scm @@ -0,0 +1,196 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Aug 27 09:14:28 2003 */ +;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe prog bigloo implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_prog + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (make-prog-body ::obj ::obj ::obj ::obj) + (resolve-line ::bstring))) + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (integer->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (multiple-value-bind (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((%node? line) + (multiple-value-bind (m l) + (extract-mark (%node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (%node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((=fx r2 l) + (if (=fx r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+fx r2 1) + (+fx r2 1) + (if (=fx r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+fx r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (integer->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (integer->string (+fx (if (integer? ldigit) + (max lnum (expt 10 (-fx ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (multiple-value-bind (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) diff --git a/legacy/bigloo/read.scm b/legacy/bigloo/read.scm new file mode 100644 index 0000000..91cd345 --- /dev/null +++ b/legacy/bigloo/read.scm @@ -0,0 +1,482 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/read.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Dec 27 11:16:00 1994 */ +;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ +;* ------------------------------------------------------------- */ +;* Skribe's reader */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Le module */ +;*---------------------------------------------------------------------*/ +(module skribe_read + (export (skribe-read . port))) + +;*---------------------------------------------------------------------*/ +;* Global counteurs ... */ +;*---------------------------------------------------------------------*/ +(define *par-open* 0) + +;*---------------------------------------------------------------------*/ +;* Parenthesis mismatch (or unclosing) errors. */ +;*---------------------------------------------------------------------*/ +(define *list-error-level* 20) +(define *list-errors* (make-vector *list-error-level* #unspecified)) +(define *vector-errors* (make-vector *list-error-level* #unspecified)) + +;*---------------------------------------------------------------------*/ +;* Control variables. */ +;*---------------------------------------------------------------------*/ +(define *end-of-list* (cons 0 0)) +(define *dotted-mark* (cons 1 1)) + +;*---------------------------------------------------------------------*/ +;* skribe-reader-reset! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-reader-reset!) + (set! *par-open* 0)) + +;*---------------------------------------------------------------------*/ +;* read-error ... */ +;*---------------------------------------------------------------------*/ +(define (read-error msg obj port) + (let* ((obj-loc (if (epair? obj) + (match-case (cer obj) + ((at ?fname ?pos ?-) + pos) + (else + #f)) + #f)) + (loc (if (number? obj-loc) + obj-loc + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (if (char (string->integer (the-substring 2 5)))))) + ((: "#\\" (or letter digit special (in "|#; []" quote paren))) + (string-ref (the-string) 2)) + ((: "#\\" (>= 2 letter)) + (let ((char-name (string->symbol + (string-upcase! + (the-substring 2 (the-length)))))) + (case char-name + ((NEWLINE) + #\Newline) + ((TAB) + #\tab) + ((SPACE) + #\space) + ((RETURN) + (integer->char 13)) + (else + (error/location "skribe-read" + "Illegal character" + (the-string) + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; ucs-2 characters + ((: "#u" (= 4 xdigit)) + (integer->ucs2 (string->integer (the-substring 2 6) 16))) + + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 1 (-fx (the-length) 1)))) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (escape-C-string str)))) + ;; ucs2 strings + ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 3 (-fx (the-length) 1)))) + (utf8-string->ucs2-string str))) + + ;; fixnums + ((: (? (in "-+")) (+ digit)) + (the-fixnum)) + ((: "#o" (? (in "-+")) (+ (in ("07")))) + (string->integer (the-substring 2 (the-length)) 8)) + ((: "#d" (? (in "-+")) (+ (in ("09")))) + (string->integer (the-substring 2 (the-length)) 10)) + ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af")))))) + (string->integer (the-substring 2 (the-length)) 16)) + ((: "#e" (? (in "-+")) (+ digit)) + (string->elong (the-substring 2 (the-length)) 10)) + ((: "#l" (? (in "-+")) (+ digit)) + (string->llong (the-substring 2 (the-length)) 10)) + + ;; flonum + ((: (? (in "-+")) + (or float + (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit)))) + (the-flonum)) + + ;; doted pairs + ("." + (if (<=fx *par-open* 0) + (error/location "read" + "Illegal token" + #\. + (input-port-name (the-port)) + (input-port-position (the-port))) + *dotted-mark*)) + + ;; unspecified and eof-object + ((: "#" (in "ue") (+ (in "nspecified-objt"))) + (let ((symbol (string->symbol + (string-upcase! + (the-substring 1 (the-length)))))) + (case symbol + ((UNSPECIFIED) + unspec) + ((EOF-OBJECT) + beof) + (else + (error/location "read" + "Illegal identifier" + symbol + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; booleans + ((: "#" (uncase #\t)) + #t) + ((: "#" (uncase #\f)) + #f) + + ;; keywords + ((or (: ":" kid) (: kid ":")) + ;; since the keyword expression is also matched by the id + ;; rule, keyword rule has to be placed before the id rule. + (the-keyword)) + + ;; identifiers + (id + ;; this rule has to be placed after the rule matching the `.' char + (the-symbol)) + ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|") + (if (=fx (the-length) 2) + (the-symbol) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (string->symbol (escape-C-string str))))) + + ;; quotations + ("'" + (read-quote 'quote (the-port) ignore)) + ("`" + (read-quote 'quasiquote (the-port) ignore)) + ("," + (read-quote 'unquote (the-port) ignore)) + (",@" + (read-quote 'unquote-splicing (the-port) ignore)) + + ;; lists + (#\( + ;; if possible, we store the opening parenthesis. + (if (and (vector? *list-errors*) + (vector (reverse! (collect-up-to ignore "vector" (the-port))))) + + ;; error or eof + (else + (let ((port (the-port)) + (char (the-failure))) + (if (eof-object? char) + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (skribe-reader-reset!) + (if (and (fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let loop ((c -1) + (s (readl (current-input-port))) + (r '())) + (let ((p (input-port-position (current-input-port)))) + (cond + ((eof-object? s) + (apply string-append (reverse! r))) + ((>=fx p stop) + (let* ((len (-fx (-fx stop start) c)) + (line (untabify (substring s 0 len) tab))) + (apply string-append + (reverse! (cons line r))))) + ((>=fx c 0) + (loop (+fx (string-length s) c) + (readl (current-input-port)) + (cons (untabify s tab) r))) + ((>=fx p start) + (let* ((len (string-length s)) + (nc (-fx p start))) + (if (>fx p stop) + (untabify + (substring s + (-fx len (-fx p start)) + (-fx (-fx p stop) 1)) + tab) + (loop nc + (readl (current-input-port)) + (list + (untabify + (substring s + (-fx len (-fx p start)) + len) + tab)))))) + (else + (loop c (readl (current-input-port)) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-file/path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) + (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+fx l 1) #t (read-line) r)) + (else + (loop (+fx l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((=fx i len) + (let ((nlen (-fx col 1))) + (if (=fx len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((=fx i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (*fx (/fx (+fx col tabl) + tabl) + tabl))) + (liip (+fx i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+fx i 1) (+fx j 1) (+fx col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+fx i 1) + (*fx (/fx (+fx col tabl) tabl) tabl))) + (else + (loop (+fx i 1) (+fx col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-file/path file (skribe-source-path)))) + (cond + ((not (%language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + lang)) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((%language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (%language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((=fx i l) + (if (=fx i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+fx i 1) + (+fx i 1) + (if (=fx i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #a013) + (url ::bstring ::obj ::obj ::pair-nil) + (sui-title::bstring ::pair-nil) + (sui-file::obj ::pair-nil) + (sui-key::obj ::pair-nil ::obj) + (sui-filter::pair-nil ::obj ::procedure ::procedure))) + diff --git a/legacy/bigloo/types.scm b/legacy/bigloo/types.scm new file mode 100644 index 0000000..b8babd4 --- /dev/null +++ b/legacy/bigloo/types.scm @@ -0,0 +1,685 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/types.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:40:42 2003 */ +;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The definition of the Skribe classes */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_types + + (export (abstract-class %ast + (parent (default #unspecified)) + (loc (default (evmeaning-location)))) + + (class %command::%ast + (fmt::bstring read-only) + (body (default #f))) + + (class %unresolved::%ast + (proc::procedure read-only)) + + (class %handle::%ast + (ast (default #f))) + + (abstract-class %node::%ast + (required-options::pair-nil read-only (default '())) + (options::pair-nil (default '())) + (body (default #f))) + + (class %processor::%node + (combinator (default (lambda (e1 e2) e1))) + (procedure::procedure (default (lambda (n e) n))) + engine) + + (class %markup::%node + (markup-init) + (ident (default #f)) + (class (default #f)) + (markup::symbol read-only)) + + (class %container::%markup + (env::pair-nil (default '()))) + + (class %document::%container) + + (class %engine + (ident::symbol read-only) + (format::bstring (default "raw")) + (info::pair-nil (default '())) + (version::obj read-only (default #unspecified)) + (delegate read-only (default #f)) + (writers::pair-nil (default '())) + (filter::obj (default #f)) + (customs::pair-nil (default '())) + (symbol-table::pair-nil (default '()))) + + (class %writer + (ident::symbol read-only) + (class read-only) + (pred::procedure read-only) + (upred read-only) + (options::obj read-only) + (verified?::bool (default #f)) + (validate (default #f)) + (before read-only) + (action read-only) + (after read-only)) + + (class %language + (name::bstring read-only) + (fontifier read-only (default #f)) + (extractor read-only (default #f))) + + (markup-init ::%markup) + (find-markups ::bstring) + + (inline ast?::bool ::obj) + (inline ast-parent::obj ::%ast) + (inline ast-loc::obj ::%ast) + (inline ast-loc-set!::obj ::%ast ::obj) + (ast-location::bstring ::%ast) + + (new-command . inits) + (inline command?::bool ::obj) + (inline command-fmt::bstring ::%command) + (inline command-body::obj ::%command) + + (new-unresolved . inits) + (inline unresolved?::bool ::obj) + (inline unresolved-proc::procedure ::%unresolved) + + (new-handle . inits) + (inline handle?::bool ::obj) + (inline handle-ast::obj ::%handle) + + (inline node?::bool ::obj) + (inline node-body::obj ::%node) + (inline node-options::pair-nil ::%node) + (inline node-loc::obj ::%node) + + (new-processor . inits) + (inline processor?::bool ::obj) + (inline processor-combinator::obj ::%processor) + (inline processor-engine::obj ::%processor) + + (new-markup . inits) + (inline markup?::bool ::obj) + (inline is-markup?::bool ::obj ::symbol) + (inline markup-markup::obj ::%markup) + (inline markup-ident::obj ::%markup) + (inline markup-body::obj ::%markup) + (inline markup-options::pair-nil ::%markup) + + (new-container . inits) + (inline container?::bool ::obj) + (inline container-ident::obj ::%container) + (inline container-body::obj ::%container) + (inline container-options::pair-nil ::%container) + + (new-document . inits) + (inline document?::bool ::obj) + (inline document-ident::bool ::%document) + (inline document-body::bool ::%document) + (inline document-options::pair-nil ::%document) + (inline document-env::pair-nil ::%document) + + (inline engine?::bool ::obj) + (inline engine-ident::obj ::obj) + (inline engine-format::obj ::obj) + (inline engine-customs::pair-nil ::obj) + (inline engine-filter::obj ::obj) + (inline engine-symbol-table::pair-nil ::%engine) + + (inline writer?::bool ::obj) + (inline writer-before::obj ::%writer) + (inline writer-action::obj ::%writer) + (inline writer-after::obj ::%writer) + (inline writer-options::obj ::%writer) + + (inline language?::bool ::obj) + (inline language-name::obj ::obj) + (inline language-fontifier::obj ::obj) + (inline language-extractor::obj ::obj) + + (new-language . inits) + + (location?::bool ::obj) + (location-file::bstring ::pair) + (location-pos::int ::pair))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate ... */ +;*---------------------------------------------------------------------*/ +(define-macro (skribe-instantiate type values . slots) + `(begin + (skribe-instantiate-check-values ',type ,values ',slots) + (,(symbol-append 'instantiate::% type) + ,@(map (lambda (slot) + (let ((id (if (pair? slot) (car slot) slot)) + (def (if (pair? slot) (cadr slot) #f))) + `(,id (new-get-value ',id ,values ,def)))) + slots)))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate-check-values ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-instantiate-check-values id values slots) + (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) + (when (pair? bs) + (for-each (lambda (b) + (error (symbol-append '|new | id) + "Illegal field" + b)) + bs)))) + +;*---------------------------------------------------------------------*/ +;* object-print ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-print obj::%ast port print-slot::procedure) + (let* ((class (object-class obj)) + (class-name (class-name class))) + (display "#|" port) + (display class-name port) + (display #\| port))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%ast ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%ast . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a>" + (find-runtime-type n))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a>" + (find-runtime-type n) + (markup-markup n))) + +;*---------------------------------------------------------------------*/ +;* object-write ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-write n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a:~a>" + (find-runtime-type n) + (markup-markup n) + (find-runtime-type (markup-body n)))) + +;*---------------------------------------------------------------------*/ +;* *node-table* */ +;* ------------------------------------------------------------- */ +;* A private hashtable that stores all the nodes of an ast. It */ +;* is used for retreiving a node from its identifier. */ +;*---------------------------------------------------------------------*/ +(define *node-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* ast? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast? obj) + (%ast? obj)) + +;*---------------------------------------------------------------------*/ +;* ast-parent ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-parent obj) + (%ast-parent obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc obj) + (%ast-loc obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc-set! ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc-set! obj loc) + (%ast-loc-set! obj loc)) + +;*---------------------------------------------------------------------*/ +;* ast-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast-location obj) + (with-access::%ast obj (loc) + (if (location? loc) + (let* ((fname (location-file loc)) + (char (location-pos loc)) + (pwd (pwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (and (>fx lenf len))) + (substring fname len (+fx 1 (string-length fname))) + fname))) + (format "~a, char ~a" file char)) + "no source location"))) + +;*---------------------------------------------------------------------*/ +;* new-command ... */ +;*---------------------------------------------------------------------*/ +(define (new-command . init) + (skribe-instantiate command init + (parent #unspecified) + (loc #f) + fmt + (body #f))) + +;*---------------------------------------------------------------------*/ +;* command? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command? obj) + (%command? obj)) + +;*---------------------------------------------------------------------*/ +;* command-fmt ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-fmt cmd) + (%command-fmt cmd)) + +;*---------------------------------------------------------------------*/ +;* command-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-body cmd) + (%command-body cmd)) + +;*---------------------------------------------------------------------*/ +;* new-unresolved ... */ +;*---------------------------------------------------------------------*/ +(define (new-unresolved . init) + (skribe-instantiate unresolved init + (parent #unspecified) + loc + proc)) + +;*---------------------------------------------------------------------*/ +;* unresolved? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved? obj) + (%unresolved? obj)) + +;*---------------------------------------------------------------------*/ +;* unresolved-proc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved-proc unr) + (%unresolved-proc unr)) + +;*---------------------------------------------------------------------*/ +;* new-handle ... */ +;*---------------------------------------------------------------------*/ +(define (new-handle . init) + (skribe-instantiate handle init + (parent #unspecified) + loc + (ast #f))) + +;*---------------------------------------------------------------------*/ +;* handle? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle? obj) + (%handle? obj)) + +;*---------------------------------------------------------------------*/ +;* handle-ast ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle-ast obj) + (%handle-ast obj)) + +;*---------------------------------------------------------------------*/ +;* node? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node? obj) + (%node? obj)) + +;*---------------------------------------------------------------------*/ +;* node-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-body obj) + (%node-body obj)) + +;*---------------------------------------------------------------------*/ +;* node-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-options obj) + (%node-options obj)) + +;*---------------------------------------------------------------------*/ +;* node-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-loc obj) + (%node-loc obj)) + +;*---------------------------------------------------------------------*/ +;* new-processor ... */ +;*---------------------------------------------------------------------*/ +(define (new-processor . init) + (skribe-instantiate processor init + (parent #unspecified) + loc + (combinator (lambda (e1 e2) e1)) + engine + (body #f))) + +;*---------------------------------------------------------------------*/ +;* processor? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor? obj) + (%processor? obj)) + +;*---------------------------------------------------------------------*/ +;* processor-combinator ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-combinator proc) + (%processor-combinator proc)) + +;*---------------------------------------------------------------------*/ +;* processor-engine ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-engine proc) + (%processor-engine proc)) + +;*---------------------------------------------------------------------*/ +;* new-markup ... */ +;*---------------------------------------------------------------------*/ +(define (new-markup . init) + (skribe-instantiate markup init + (parent #unspecified) + (loc #f) + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()))) + +;*---------------------------------------------------------------------*/ +;* markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup? obj) + (%markup? obj)) + +;*---------------------------------------------------------------------*/ +;* is-markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (is-markup? obj markup) + (and (markup? obj) (eq? (markup-markup obj) markup))) + +;*---------------------------------------------------------------------*/ +;* markup-init ... */ +;* ------------------------------------------------------------- */ +;* The markup constructor simply stores in the markup table the */ +;* news markups. */ +;*---------------------------------------------------------------------*/ +(define (markup-init markup) + (bind-markup! markup)) + +;*---------------------------------------------------------------------*/ +;* bind-markup! ... */ +;*---------------------------------------------------------------------*/ +(define (bind-markup! node) + (hashtable-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + +;*---------------------------------------------------------------------*/ +;* find-markups ... */ +;*---------------------------------------------------------------------*/ +(define (find-markups ident) + (hashtable-get *node-table* ident)) + +;*---------------------------------------------------------------------*/ +;* markup-markup ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-markup obj) + (%markup-markup obj)) + +;*---------------------------------------------------------------------*/ +;* markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-ident obj) + (%markup-ident obj)) + +;*---------------------------------------------------------------------*/ +;* markup-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-body obj) + (%markup-body obj)) + +;*---------------------------------------------------------------------*/ +;* markup-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-options obj) + (%markup-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-container ... */ +;*---------------------------------------------------------------------*/ +(define (new-container . init) + (skribe-instantiate container init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* container? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container? obj) + (%container? obj)) + +;*---------------------------------------------------------------------*/ +;* container-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-ident obj) + (%container-ident obj)) + +;*---------------------------------------------------------------------*/ +;* container-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-body obj) + (%container-body obj)) + +;*---------------------------------------------------------------------*/ +;* container-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-options obj) + (%container-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-document ... */ +;*---------------------------------------------------------------------*/ +(define (new-document . init) + (skribe-instantiate document init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* document? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document? obj) + (%document? obj)) + +;*---------------------------------------------------------------------*/ +;* document-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-options doc) + (%document-options doc)) + +;*---------------------------------------------------------------------*/ +;* document-env ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-env doc) + (%document-env doc)) + +;*---------------------------------------------------------------------*/ +;* document-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-ident doc) + (%document-ident doc)) + +;*---------------------------------------------------------------------*/ +;* document-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-body doc) + (%document-body doc)) + +;*---------------------------------------------------------------------*/ +;* engine? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine? obj) + (%engine? obj)) + +;*---------------------------------------------------------------------*/ +;* engine-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-ident obj) + (%engine-ident obj)) + +;*---------------------------------------------------------------------*/ +;* engine-format ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-format obj) + (%engine-format obj)) + +;*---------------------------------------------------------------------*/ +;* engine-customs ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-customs obj) + (%engine-customs obj)) + +;*---------------------------------------------------------------------*/ +;* engine-filter ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-filter obj) + (%engine-filter obj)) + +;*---------------------------------------------------------------------*/ +;* engine-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-symbol-table obj) + (%engine-symbol-table obj)) + +;*---------------------------------------------------------------------*/ +;* writer? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer? obj) + (%writer? obj)) + +;*---------------------------------------------------------------------*/ +;* writer-before ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-before obj) + (%writer-before obj)) + +;*---------------------------------------------------------------------*/ +;* writer-action ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-action obj) + (%writer-action obj)) + +;*---------------------------------------------------------------------*/ +;* writer-after ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-after obj) + (%writer-after obj)) + +;*---------------------------------------------------------------------*/ +;* writer-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-options obj) + (%writer-options obj)) + +;*---------------------------------------------------------------------*/ +;* language? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language? obj) + (%language? obj)) + +;*---------------------------------------------------------------------*/ +;* language-name ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-name lg) + (%language-name lg)) + +;*---------------------------------------------------------------------*/ +;* language-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-fontifier lg) + (%language-fontifier lg)) + +;*---------------------------------------------------------------------*/ +;* language-extractor ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-extractor lg) + (%language-extractor lg)) + +;*---------------------------------------------------------------------*/ +;* new-get-value ... */ +;*---------------------------------------------------------------------*/ +(define (new-get-value key init def) + (let ((c (assq key init))) + (match-case c + ((?- ?v) + v) + (else + def)))) + +;*---------------------------------------------------------------------*/ +;* new-language ... */ +;*---------------------------------------------------------------------*/ +(define (new-language . init) + (skribe-instantiate language init name fontifier extractor)) + +;*---------------------------------------------------------------------*/ +;* location? ... */ +;*---------------------------------------------------------------------*/ +(define (location? o) + (match-case o + ((at ?- ?-) + #t) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* location-file ... */ +;*---------------------------------------------------------------------*/ +(define (location-file o) + (match-case o + ((at ?fname ?-) + fname) + (else + (error 'location-file "Illegal location" o)))) + +;*---------------------------------------------------------------------*/ +;* location-pos ... */ +;*---------------------------------------------------------------------*/ +(define (location-pos o) + (match-case o + ((at ?- ?loc) + loc) + (else + (error 'location-pos "Illegal location" o)))) diff --git a/legacy/bigloo/verify.scm b/legacy/bigloo/verify.scm new file mode 100644 index 0000000..602a951 --- /dev/null +++ b/legacy/bigloo/verify.scm @@ -0,0 +1,143 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jul 25 09:54:55 2003 */ +;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe verification stage */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_verify + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (generic verify ::obj ::%engine))) + +;*---------------------------------------------------------------------*/ +;* check-required-options ... */ +;*---------------------------------------------------------------------*/ +(define (check-required-options n::%markup w::%writer e::%engine) + (with-access::%markup n (required-options) + (with-access::%writer w (ident options verified?) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (%engine-ident e) + (format "Option unsupported: ~a, supported options: ~a" o options) + n))) + required-options) + (set! verified? #t)))))) + +;*---------------------------------------------------------------------*/ +;* check-options ... */ +;* ------------------------------------------------------------- */ +;* Only keywords are checked, symbols are voluntary left unchecked. */ +;*---------------------------------------------------------------------*/ +(define (check-options eo*::pair-nil m::%markup e::%engine) + (with-debug 6 'check-options + (debug-item "markup=" (%markup-markup m)) + (debug-item "options=" (%markup-options m)) + (debug-item "eo*=" eo*) + (for-each (lambda (o2) + (for-each (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o eo*))) + (skribe-warning/ast + 3 + m + 'verify + (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" + (%engine-ident e) + (%markup-markup m) + o + (markup-option m o))))) + o2)) + (%markup-options m)))) + +;*---------------------------------------------------------------------*/ +;* verify :: ... */ +;*---------------------------------------------------------------------*/ +(define-generic (verify node e) + (if (pair? node) + (for-each (lambda (n) (verify n e)) node)) + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify n::%processor e) + (with-access::%processor n (combinator engine body) + (verify body (processor-get-engine combinator engine e)) + n)) + +;*---------------------------------------------------------------------*/ +;* verify ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%node e) + (with-access::%node node (body options) + (verify body e) + (for-each (lambda (o) (verify (cadr o) e)) options) + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%markup e) + (with-debug 5 'verify::%markup + (debug-item "node=" (%markup-markup node)) + (debug-item "options=" (%markup-options node)) + (debug-item "e=" (%engine-ident e)) + (call-next-method) + (let ((w (lookup-markup-writer node e))) + (if (%writer? w) + (begin + (check-required-options node w e) + (if (pair? (%writer-options w)) + (check-options (%writer-options w) node e)) + (let ((validate (%writer-validate w))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format "Node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)) + node))))))) + ;; return the node + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%document ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%document e) + (call-next-method) + ;; verify the engine custom + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (%engine-customs e)) + ;; return the node + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%handle e) + node) + diff --git a/legacy/bigloo/writer.scm b/legacy/bigloo/writer.scm new file mode 100644 index 0000000..ce515bf --- /dev/null +++ b/legacy/bigloo/writer.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 06:19:57 2003 */ +;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe writer management */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_writer + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_engine + skribe_output + skribe_lib) + + (export (invoke proc node e) + + (lookup-markup-writer ::%markup ::%engine) + + (markup-writer ::obj #!optional e #!key p class opt va bef aft act) + (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) + (markup-writer-get ::obj #!optional e #!key class pred) + (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) + +;*---------------------------------------------------------------------*/ +;* invoke ... */ +;*---------------------------------------------------------------------*/ +(define (invoke proc node e) + (let ((id (if (markup? node) + (string->symbol + (format "~a#~a" + (%engine-ident e) + (%markup-markup node))) + (%engine-ident e)))) + (with-push-trace id + (with-debug 5 'invoke + (debug-item "e=" (%engine-ident e)) + (debug-item "node=" (find-runtime-type node) + " " (if (markup? node) (%markup-markup node) "")) + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))))) + +;*---------------------------------------------------------------------*/ +;* lookup-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (lookup-markup-writer node e) + (with-access::%engine e (writers delegate) + (let loop ((w* writers)) + (cond + ((pair? w*) + (with-access::%writer (car w*) (pred) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* make-writer-predicate ... */ +;*---------------------------------------------------------------------*/ +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (%markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (correct-arity? predicate 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;*---------------------------------------------------------------------*/ +;* markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (markup-writer markup + #!optional + engine + #!key + (predicate #f) + (class #f) + (options '()) + (validate #f) + (before #f) + (action #unspecified) + (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action #unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action #unspecified) + (lambda (n e) + (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + +;*---------------------------------------------------------------------*/ +;* copy-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (copy-markup-writer markup old-engine + #!optional new-engine + #!key + (predicate #unspecified) + (class #unspecified) + (options #unspecified) + (validate #unspecified) + (before #unspecified) + (action #unspecified) + (after #unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) + (%writer-pred old) + predicate) + :class (if (unspecified? class) + (%writer-class old) + class) + :options (if (unspecified? options) + (%writer-options old) + options) + :validate (if (unspecified? validate) + (%writer-validate old) + validate) + :before (if (unspecified? before) + (%writer-before old) + before) + :action (if (unspecified? action) + (%writer-action old) + action) + :after (if (unspecified? after) + (%writer-after old) after)))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get ... */ +;* ------------------------------------------------------------- */ +;* Finds the writer that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (%engine-writers e))) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class) + (or (eq? pred #unspecified) + (eq? (%writer-upred (car w*)) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get* ... */ +;* ------------------------------------------------------------- */ +;* Finds alll writers that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get* markup #!optional engine #!key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (%engine-writers e)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e) res)) + (else + (reverse! res))))))))) diff --git a/legacy/bigloo/xml.scm b/legacy/bigloo/xml.scm new file mode 100644 index 0000000..d4c662e --- /dev/null +++ b/legacy/bigloo/xml.scm @@ -0,0 +1,92 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Mon May 17 10:14:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* XML fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_xml + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export xml)) + +;*---------------------------------------------------------------------*/ +;* xml ... */ +;*---------------------------------------------------------------------*/ +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* xml-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (xml-fontifier s) + (let ((g (regular-grammar () + ((: #\; (in "") + ;; italic comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>) + ;; markup + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-module) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\< #\> #\Space #\Tab #\= #\")) + ;; regular text + (let ((string (the-string))) + (cons string (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((in "\"=") + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(xml)" "Unexpected character" c))))))) + (with-input-from-string s + (lambda () + (read/rp g (current-input-port)))))) + diff --git a/legacy/stklos/Makefile.in b/legacy/stklos/Makefile.in new file mode 100644 index 0000000..80a26de --- /dev/null +++ b/legacy/stklos/Makefile.in @@ -0,0 +1,110 @@ +# +# Makefile.in -- Skribe Src Makefile +# +# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +# +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +# USA. +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 10-Aug-2003 20:26 (eg) +# Last file update: 6-Mar-2004 16:00 (eg) +# +include ../../etc/stklos/Makefile.skb + +prefix=@PREFIX@ + +SKR = $(wildcard ../../skr/*.skr) + +DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ + ../common/index.scm ../common/bib.scm ../common/lib.scm + +SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ + eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ + resolve.stk runtime.stk source.stk types.stk vars.stk \ + verify.stk writer.stk xml.stk + +LEXFILES = c-lex.l lisp-lex.l xml-lex.l + +LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk + +BINDIR=../../bin + +EXE= $(BINDIR)/skribe.stklos + +PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) + +SFLAGS= + +all: $(EXE) + +Makefile: Makefile.in + (cd ../../etc/stklos; autoconf; configure) + +$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) + stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ + chmod $(BMASK) $(EXE) + +# +# Lex files +# +lisp-lex.stk: lisp-lex.l + stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex + +xml-lex.stk: xml-lex.l + stklos-genlex xml-lex.l xml-lex.stk xml-lex + +c-lex.stk: c-lex.l + stklos-genlex c-lex.l c-lex.stk c-lex + + +install: $(INSTALL_BINDIR) + cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ + && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos + rm -f $(INSTALL_BINDIR)/skribe + ln -s skribe.stklos $(INSTALL_BINDIR)/skribe + +uninstall: + rm $(INSTALL_BINDIR)/skribe + rm $(INSTALL_BINDIR)/skribe.stklos + +$(BINDIR): + mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) + +$(INSTALL_BINDIR): + mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) + +## +## Services +## +tags: TAGS + +TAGS: $(SRCS) + etags -l scheme $(SRCS) + +pop: + @echo $(PRCS_FILES:%=src/stklos/%) + +links: + ln -s $(DEPS) . + ln -s $(SKR) . + +clean: + /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr + +distclean: clean + /bin/rm -f Makefile + /bin/rm -f ../common/configure.scm diff --git a/legacy/stklos/biblio.stk b/legacy/stklos/biblio.stk new file mode 100644 index 0000000..5691588 --- /dev/null +++ b/legacy/stklos/biblio.stk @@ -0,0 +1,161 @@ +;;;; +;;;; biblio.stk -- Bibliography functions +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA.main.st +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 31-Aug-2003 22:07 (eg) +;;;; Last file update: 28-Oct-2004 21:19 (eg) +;;;; + + + +(define-module SKRIBE-BIBLIO-MODULE + (import SKRIBE-RUNTIME-MODULE) + (export bib-tables? make-bib-table default-bib-table + bib-load! resolve-bib resolve-the-bib + bib-sort/authors bib-sort/idents bib-sort/dates) + +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + +(include "../common/bib.scm") + +;;;; ====================================================================== +;;;; +;;;; Utilities +;;;; +;;;; ====================================================================== + +(define (make-bib-table ident) + (make-hashtable)) + +(define (bib-table? obj) + (hashtable? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;; +;; Utilities +;; +(define (%bib-error who entry) + (let ((msg "bibliography syntax error on entry")) + (if (%epair? entry) + (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) + (skribe-error who msg entry)))) + +;;;; ====================================================================== +;;;; +;;;; BIB-DUPLICATE +;;;; +;;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + + +;;;; ====================================================================== +;;;; +;;;; PARSE-BIB +;;;; +;;;; ====================================================================== +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-file-name port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table key))) + (if old + (bib-duplicate ident from old) + (hash-table-put! table + key + (make-bib-entry kind key fields from))) + (Loop (read port)))) + (else + (%bib-error 'bib-parse entry)))))))) + + +;;;; ====================================================================== +;;;; +;;;; BIB-ADD! +;;;; +;;;; ====================================================================== +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate key #f old) + (hash-table-put! table + key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + + +;;;; ====================================================================== +;;;; +;;;; SKRIBE-OPEN-BIB-FILE +;;;; +;;;; ====================================================================== +;; FIXME: Factoriser +(define (skribe-open-bib-file file command) + (let ((path (find-path file *skribe-bib-path*))) + (if (string? path) + (begin + (when (> *skribe-verbose* 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format command path)) + path))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) + +) diff --git a/legacy/stklos/c-lex.l b/legacy/stklos/c-lex.l new file mode 100644 index 0000000..a5b337e --- /dev/null +++ b/legacy/stklos/c-lex.l @@ -0,0 +1,67 @@ +;;;; +;;;; c-lex.l -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:10 (eg) +;;;; + +space [ \n\9] +letter [_a-zA-Z] +alphanum [_a-zA-Z0-9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +;;Comments +/\*.*\*/ (new markup + (markup '&source-line-comment) + (body yytext)) +//.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) +[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text +[^\"a-zA-Z]+ (begin yytext) + + + +<> 'eof +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + + + + + + \ No newline at end of file diff --git a/legacy/stklos/c.stk b/legacy/stklos/c.stk new file mode 100644 index 0000000..265c421 --- /dev/null +++ b/legacy/stklos/c.stk @@ -0,0 +1,95 @@ +;;;; +;;;; c.stk -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:12 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module SKRIBE-C-MODULE + (export c java) + (import SKRIBE-SOURCE-MODULE) + +(include "c-lex.stk") ;; SILex generated + + +(define *the-keys* #f) + +(define *c-keys* #f) +(define *java-keys* #f) + + +(define (fontifier s) + (let ((lex (c-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; C +;;;; +;;;; ====================================================================== +(define (init-c-keys) + (unless *c-keys* + (set! *c-keys* '(for while return break continue void + do if else typedef struct union goto switch case + static extern default))) + *c-keys*) + +(define (c-fontifier s) + (fluid-let ((*the-keys* (init-c-keys))) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;;;; ====================================================================== +;;;; +;;;; JAVA +;;;; +;;;; ====================================================================== +(define (init-java-keys) + (unless *java-keys* + (set! *java-keys* (append (init-c-keys) + '(public final class throw catch)))) + *java-keys*) + +(define (java-fontifier s) + (fluid-let ((*the-keys* (init-java-keys))) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) + +) + diff --git a/legacy/stklos/color.stk b/legacy/stklos/color.stk new file mode 100644 index 0000000..0cb829f --- /dev/null +++ b/legacy/stklos/color.stk @@ -0,0 +1,622 @@ +;;;; +;;;; color.stk -- Skribe Color Management +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 25-Oct-2003 00:10 (eg) +;;;; Last file update: 12-Feb-2004 18:24 (eg) +;;;; + +(define-module SKRIBE-COLOR-MODULE + (export skribe-color->rgb skribe-get-used-colors skribe-use-color!) + +(define *used-colors* '()) + +(define *skribe-rgb-alist* '( + ("snow" . "255 250 250") + ("ghostwhite" . "248 248 255") + ("whitesmoke" . "245 245 245") + ("gainsboro" . "220 220 220") + ("floralwhite" . "255 250 240") + ("oldlace" . "253 245 230") + ("linen" . "250 240 230") + ("antiquewhite" . "250 235 215") + ("papayawhip" . "255 239 213") + ("blanchedalmond" . "255 235 205") + ("bisque" . "255 228 196") + ("peachpuff" . "255 218 185") + ("navajowhite" . "255 222 173") + ("moccasin" . "255 228 181") + ("cornsilk" . "255 248 220") + ("ivory" . "255 255 240") + ("lemonchiffon" . "255 250 205") + ("seashell" . "255 245 238") + ("honeydew" . "240 255 240") + ("mintcream" . "245 255 250") + ("azure" . "240 255 255") + ("aliceblue" . "240 248 255") + ("lavender" . "230 230 250") + ("lavenderblush" . "255 240 245") + ("mistyrose" . "255 228 225") + ("white" . "255 255 255") + ("black" . "0 0 0") + ("darkslategrey" . "47 79 79") + ("dimgrey" . "105 105 105") + ("slategrey" . "112 128 144") + ("lightslategrey" . "119 136 153") + ("grey" . "190 190 190") + ("lightgrey" . "211 211 211") + ("midnightblue" . "25 25 112") + ("navy" . "0 0 128") + ("navyblue" . "0 0 128") + ("cornflowerblue" . "100 149 237") + ("darkslateblue" . "72 61 139") + ("slateblue" . "106 90 205") + ("mediumslateblue" . "123 104 238") + ("lightslateblue" . "132 112 255") + ("mediumblue" . "0 0 205") + ("royalblue" . "65 105 225") + ("blue" . "0 0 255") + ("dodgerblue" . "30 144 255") + ("deepskyblue" . "0 191 255") + ("skyblue" . "135 206 235") + ("lightskyblue" . "135 206 250") + ("steelblue" . "70 130 180") + ("lightsteelblue" . "176 196 222") + ("lightblue" . "173 216 230") + ("powderblue" . "176 224 230") + ("paleturquoise" . "175 238 238") + ("darkturquoise" . "0 206 209") + ("mediumturquoise" . "72 209 204") + ("turquoise" . "64 224 208") + ("cyan" . "0 255 255") + ("lightcyan" . "224 255 255") + ("cadetblue" . "95 158 160") + ("mediumaquamarine" . "102 205 170") + ("aquamarine" . "127 255 212") + ("darkgreen" . "0 100 0") + ("darkolivegreen" . "85 107 47") + ("darkseagreen" . "143 188 143") + ("seagreen" . "46 139 87") + ("mediumseagreen" . "60 179 113") + ("lightseagreen" . "32 178 170") + ("palegreen" . "152 251 152") + ("springgreen" . "0 255 127") + ("lawngreen" . "124 252 0") + ("green" . "0 255 0") + ("chartreuse" . "127 255 0") + ("mediumspringgreen" . "0 250 154") + ("greenyellow" . "173 255 47") + ("limegreen" . "50 205 50") + ("yellowgreen" . "154 205 50") + ("forestgreen" . "34 139 34") + ("olivedrab" . "107 142 35") + ("darkkhaki" . "189 183 107") + ("khaki" . "240 230 140") + ("palegoldenrod" . "238 232 170") + ("lightgoldenrodyellow" . "250 250 210") + ("lightyellow" . "255 255 224") + ("yellow" . "255 255 0") + ("gold" . "255 215 0") + ("lightgoldenrod" . "238 221 130") + ("goldenrod" . "218 165 32") + ("darkgoldenrod" . "184 134 11") + ("rosybrown" . "188 143 143") + ("indianred" . "205 92 92") + ("saddlebrown" . "139 69 19") + ("sienna" . "160 82 45") + ("peru" . "205 133 63") + ("burlywood" . "222 184 135") + ("beige" . "245 245 220") + ("wheat" . "245 222 179") + ("sandybrown" . "244 164 96") + ("tan" . "210 180 140") + ("chocolate" . "210 105 30") + ("firebrick" . "178 34 34") + ("brown" . "165 42 42") + ("darksalmon" . "233 150 122") + ("salmon" . "250 128 114") + ("lightsalmon" . "255 160 122") + ("orange" . "255 165 0") + ("darkorange" . "255 140 0") + ("coral" . "255 127 80") + ("lightcoral" . "240 128 128") + ("tomato" . "255 99 71") + ("orangered" . "255 69 0") + ("red" . "255 0 0") + ("hotpink" . "255 105 180") + ("deeppink" . "255 20 147") + ("pink" . "255 192 203") + ("lightpink" . "255 182 193") + ("palevioletred" . "219 112 147") + ("maroon" . "176 48 96") + ("mediumvioletred" . "199 21 133") + ("violetred" . "208 32 144") + ("magenta" . "255 0 255") + ("violet" . "238 130 238") + ("plum" . "221 160 221") + ("orchid" . "218 112 214") + ("mediumorchid" . "186 85 211") + ("darkorchid" . "153 50 204") + ("darkviolet" . "148 0 211") + ("blueviolet" . "138 43 226") + ("purple" . "160 32 240") + ("mediumpurple" . "147 112 219") + ("thistle" . "216 191 216") + ("snow1" . "255 250 250") + ("snow2" . "238 233 233") + ("snow3" . "205 201 201") + ("snow4" . "139 137 137") + ("seashell1" . "255 245 238") + ("seashell2" . "238 229 222") + ("seashell3" . "205 197 191") + ("seashell4" . "139 134 130") + ("antiquewhite1" . "255 239 219") + ("antiquewhite2" . "238 223 204") + ("antiquewhite3" . "205 192 176") + ("antiquewhite4" . "139 131 120") + ("bisque1" . "255 228 196") + ("bisque2" . "238 213 183") + ("bisque3" . "205 183 158") + ("bisque4" . "139 125 107") + ("peachpuff1" . "255 218 185") + ("peachpuff2" . "238 203 173") + ("peachpuff3" . "205 175 149") + ("peachpuff4" . "139 119 101") + ("navajowhite1" . "255 222 173") + ("navajowhite2" . "238 207 161") + ("navajowhite3" . "205 179 139") + ("navajowhite4" . "139 121 94") + ("lemonchiffon1" . "255 250 205") + ("lemonchiffon2" . "238 233 191") + ("lemonchiffon3" . "205 201 165") + ("lemonchiffon4" . "139 137 112") + ("cornsilk1" . "255 248 220") + ("cornsilk2" . "238 232 205") + ("cornsilk3" . "205 200 177") + ("cornsilk4" . "139 136 120") + ("ivory1" . "255 255 240") + ("ivory2" . "238 238 224") + ("ivory3" . "205 205 193") + ("ivory4" . "139 139 131") + ("honeydew1" . "240 255 240") + ("honeydew2" . "224 238 224") + ("honeydew3" . "193 205 193") + ("honeydew4" . "131 139 131") + ("lavenderblush1" . "255 240 245") + ("lavenderblush2" . "238 224 229") + ("lavenderblush3" . "205 193 197") + ("lavenderblush4" . "139 131 134") + ("mistyrose1" . "255 228 225") + ("mistyrose2" . "238 213 210") + ("mistyrose3" . "205 183 181") + ("mistyrose4" . "139 125 123") + ("azure1" . "240 255 255") + ("azure2" . "224 238 238") + ("azure3" . "193 205 205") + ("azure4" . "131 139 139") + ("slateblue1" . "131 111 255") + ("slateblue2" . "122 103 238") + ("slateblue3" . "105 89 205") + ("slateblue4" . "71 60 139") + ("royalblue1" . "72 118 255") + ("royalblue2" . "67 110 238") + ("royalblue3" . "58 95 205") + ("royalblue4" . "39 64 139") + ("blue1" . "0 0 255") + ("blue2" . "0 0 238") + ("blue3" . "0 0 205") + ("blue4" . "0 0 139") + ("dodgerblue1" . "30 144 255") + ("dodgerblue2" . "28 134 238") + ("dodgerblue3" . "24 116 205") + ("dodgerblue4" . "16 78 139") + ("steelblue1" . "99 184 255") + ("steelblue2" . "92 172 238") + ("steelblue3" . "79 148 205") + ("steelblue4" . "54 100 139") + ("deepskyblue1" . "0 191 255") + ("deepskyblue2" . "0 178 238") + ("deepskyblue3" . "0 154 205") + ("deepskyblue4" . "0 104 139") + ("skyblue1" . "135 206 255") + ("skyblue2" . "126 192 238") + ("skyblue3" . "108 166 205") + ("skyblue4" . "74 112 139") + ("lightskyblue1" . "176 226 255") + ("lightskyblue2" . "164 211 238") + ("lightskyblue3" . "141 182 205") + ("lightskyblue4" . "96 123 139") + ("lightsteelblue1" . "202 225 255") + ("lightsteelblue2" . "188 210 238") + ("lightsteelblue3" . "162 181 205") + ("lightsteelblue4" . "110 123 139") + ("lightblue1" . "191 239 255") + ("lightblue2" . "178 223 238") + ("lightblue3" . "154 192 205") + ("lightblue4" . "104 131 139") + ("lightcyan1" . "224 255 255") + ("lightcyan2" . "209 238 238") + ("lightcyan3" . "180 205 205") + ("lightcyan4" . "122 139 139") + ("paleturquoise1" . "187 255 255") + ("paleturquoise2" . "174 238 238") + ("paleturquoise3" . "150 205 205") + ("paleturquoise4" . "102 139 139") + ("cadetblue1" . "152 245 255") + ("cadetblue2" . "142 229 238") + ("cadetblue3" . "122 197 205") + ("cadetblue4" . "83 134 139") + ("turquoise1" . "0 245 255") + ("turquoise2" . "0 229 238") + ("turquoise3" . "0 197 205") + ("turquoise4" . "0 134 139") + ("cyan1" . "0 255 255") + ("cyan2" . "0 238 238") + ("cyan3" . "0 205 205") + ("cyan4" . "0 139 139") + ("aquamarine1" . "127 255 212") + ("aquamarine2" . "118 238 198") + ("aquamarine3" . "102 205 170") + ("aquamarine4" . "69 139 116") + ("darkseagreen1" . "193 255 193") + ("darkseagreen2" . "180 238 180") + ("darkseagreen3" . "155 205 155") + ("darkseagreen4" . "105 139 105") + ("seagreen1" . "84 255 159") + ("seagreen2" . "78 238 148") + ("seagreen3" . "67 205 128") + ("seagreen4" . "46 139 87") + ("palegreen1" . "154 255 154") + ("palegreen2" . "144 238 144") + ("palegreen3" . "124 205 124") + ("palegreen4" . "84 139 84") + ("springgreen1" . "0 255 127") + ("springgreen2" . "0 238 118") + ("springgreen3" . "0 205 102") + ("springgreen4" . "0 139 69") + ("green1" . "0 255 0") + ("green2" . "0 238 0") + ("green3" . "0 205 0") + ("green4" . "0 139 0") + ("chartreuse1" . "127 255 0") + ("chartreuse2" . "118 238 0") + ("chartreuse3" . "102 205 0") + ("chartreuse4" . "69 139 0") + ("olivedrab1" . "192 255 62") + ("olivedrab2" . "179 238 58") + ("olivedrab3" . "154 205 50") + ("olivedrab4" . "105 139 34") + ("darkolivegreen1" . "202 255 112") + ("darkolivegreen2" . "188 238 104") + ("darkolivegreen3" . "162 205 90") + ("darkolivegreen4" . "110 139 61") + ("khaki1" . "255 246 143") + ("khaki2" . "238 230 133") + ("khaki3" . "205 198 115") + ("khaki4" . "139 134 78") + ("lightgoldenrod1" . "255 236 139") + ("lightgoldenrod2" . "238 220 130") + ("lightgoldenrod3" . "205 190 112") + ("lightgoldenrod4" . "139 129 76") + ("lightyellow1" . "255 255 224") + ("lightyellow2" . "238 238 209") + ("lightyellow3" . "205 205 180") + ("lightyellow4" . "139 139 122") + ("yellow1" . "255 255 0") + ("yellow2" . "238 238 0") + ("yellow3" . "205 205 0") + ("yellow4" . "139 139 0") + ("gold1" . "255 215 0") + ("gold2" . "238 201 0") + ("gold3" . "205 173 0") + ("gold4" . "139 117 0") + ("goldenrod1" . "255 193 37") + ("goldenrod2" . "238 180 34") + ("goldenrod3" . "205 155 29") + ("goldenrod4" . "139 105 20") + ("darkgoldenrod1" . "255 185 15") + ("darkgoldenrod2" . "238 173 14") + ("darkgoldenrod3" . "205 149 12") + ("darkgoldenrod4" . "139 101 8") + ("rosybrown1" . "255 193 193") + ("rosybrown2" . "238 180 180") + ("rosybrown3" . "205 155 155") + ("rosybrown4" . "139 105 105") + ("indianred1" . "255 106 106") + ("indianred2" . "238 99 99") + ("indianred3" . "205 85 85") + ("indianred4" . "139 58 58") + ("sienna1" . "255 130 71") + ("sienna2" . "238 121 66") + ("sienna3" . "205 104 57") + ("sienna4" . "139 71 38") + ("burlywood1" . "255 211 155") + ("burlywood2" . "238 197 145") + ("burlywood3" . "205 170 125") + ("burlywood4" . "139 115 85") + ("wheat1" . "255 231 186") + ("wheat2" . "238 216 174") + ("wheat3" . "205 186 150") + ("wheat4" . "139 126 102") + ("tan1" . "255 165 79") + ("tan2" . "238 154 73") + ("tan3" . "205 133 63") + ("tan4" . "139 90 43") + ("chocolate1" . "255 127 36") + ("chocolate2" . "238 118 33") + ("chocolate3" . "205 102 29") + ("chocolate4" . "139 69 19") + ("firebrick1" . "255 48 48") + ("firebrick2" . "238 44 44") + ("firebrick3" . "205 38 38") + ("firebrick4" . "139 26 26") + ("brown1" . "255 64 64") + ("brown2" . "238 59 59") + ("brown3" . "205 51 51") + ("brown4" . "139 35 35") + ("salmon1" . "255 140 105") + ("salmon2" . "238 130 98") + ("salmon3" . "205 112 84") + ("salmon4" . "139 76 57") + ("lightsalmon1" . "255 160 122") + ("lightsalmon2" . "238 149 114") + ("lightsalmon3" . "205 129 98") + ("lightsalmon4" . "139 87 66") + ("orange1" . "255 165 0") + ("orange2" . "238 154 0") + ("orange3" . "205 133 0") + ("orange4" . "139 90 0") + ("darkorange1" . "255 127 0") + ("darkorange2" . "238 118 0") + ("darkorange3" . "205 102 0") + ("darkorange4" . "139 69 0") + ("coral1" . "255 114 86") + ("coral2" . "238 106 80") + ("coral3" . "205 91 69") + ("coral4" . "139 62 47") + ("tomato1" . "255 99 71") + ("tomato2" . "238 92 66") + ("tomato3" . "205 79 57") + ("tomato4" . "139 54 38") + ("orangered1" . "255 69 0") + ("orangered2" . "238 64 0") + ("orangered3" . "205 55 0") + ("orangered4" . "139 37 0") + ("red1" . "255 0 0") + ("red2" . "238 0 0") + ("red3" . "205 0 0") + ("red4" . "139 0 0") + ("deeppink1" . "255 20 147") + ("deeppink2" . "238 18 137") + ("deeppink3" . "205 16 118") + ("deeppink4" . "139 10 80") + ("hotpink1" . "255 110 180") + ("hotpink2" . "238 106 167") + ("hotpink3" . "205 96 144") + ("hotpink4" . "139 58 98") + ("pink1" . "255 181 197") + ("pink2" . "238 169 184") + ("pink3" . "205 145 158") + ("pink4" . "139 99 108") + ("lightpink1" . "255 174 185") + ("lightpink2" . "238 162 173") + ("lightpink3" . "205 140 149") + ("lightpink4" . "139 95 101") + ("palevioletred1" . "255 130 171") + ("palevioletred2" . "238 121 159") + ("palevioletred3" . "205 104 137") + ("palevioletred4" . "139 71 93") + ("maroon1" . "255 52 179") + ("maroon2" . "238 48 167") + ("maroon3" . "205 41 144") + ("maroon4" . "139 28 98") + ("violetred1" . "255 62 150") + ("violetred2" . "238 58 140") + ("violetred3" . "205 50 120") + ("violetred4" . "139 34 82") + ("magenta1" . "255 0 255") + ("magenta2" . "238 0 238") + ("magenta3" . "205 0 205") + ("magenta4" . "139 0 139") + ("orchid1" . "255 131 250") + ("orchid2" . "238 122 233") + ("orchid3" . "205 105 201") + ("orchid4" . "139 71 137") + ("plum1" . "255 187 255") + ("plum2" . "238 174 238") + ("plum3" . "205 150 205") + ("plum4" . "139 102 139") + ("mediumorchid1" . "224 102 255") + ("mediumorchid2" . "209 95 238") + ("mediumorchid3" . "180 82 205") + ("mediumorchid4" . "122 55 139") + ("darkorchid1" . "191 62 255") + ("darkorchid2" . "178 58 238") + ("darkorchid3" . "154 50 205") + ("darkorchid4" . "104 34 139") + ("purple1" . "155 48 255") + ("purple2" . "145 44 238") + ("purple3" . "125 38 205") + ("purple4" . "85 26 139") + ("mediumpurple1" . "171 130 255") + ("mediumpurple2" . "159 121 238") + ("mediumpurple3" . "137 104 205") + ("mediumpurple4" . "93 71 139") + ("thistle1" . "255 225 255") + ("thistle2" . "238 210 238") + ("thistle3" . "205 181 205") + ("thistle4" . "139 123 139") + ("grey0" . "0 0 0") + ("grey1" . "3 3 3") + ("grey2" . "5 5 5") + ("grey3" . "8 8 8") + ("grey4" . "10 10 10") + ("grey5" . "13 13 13") + ("grey6" . "15 15 15") + ("grey7" . "18 18 18") + ("grey8" . "20 20 20") + ("grey9" . "23 23 23") + ("grey10" . "26 26 26") + ("grey11" . "28 28 28") + ("grey12" . "31 31 31") + ("grey13" . "33 33 33") + ("grey14" . "36 36 36") + ("grey15" . "38 38 38") + ("grey16" . "41 41 41") + ("grey17" . "43 43 43") + ("grey18" . "46 46 46") + ("grey19" . "48 48 48") + ("grey20" . "51 51 51") + ("grey21" . "54 54 54") + ("grey22" . "56 56 56") + ("grey23" . "59 59 59") + ("grey24" . "61 61 61") + ("grey25" . "64 64 64") + ("grey26" . "66 66 66") + ("grey27" . "69 69 69") + ("grey28" . "71 71 71") + ("grey29" . "74 74 74") + ("grey30" . "77 77 77") + ("grey31" . "79 79 79") + ("grey32" . "82 82 82") + ("grey33" . "84 84 84") + ("grey34" . "87 87 87") + ("grey35" . "89 89 89") + ("grey36" . "92 92 92") + ("grey37" . "94 94 94") + ("grey38" . "97 97 97") + ("grey39" . "99 99 99") + ("grey40" . "102 102 102") + ("grey41" . "105 105 105") + ("grey42" . "107 107 107") + ("grey43" . "110 110 110") + ("grey44" . "112 112 112") + ("grey45" . "115 115 115") + ("grey46" . "117 117 117") + ("grey47" . "120 120 120") + ("grey48" . "122 122 122") + ("grey49" . "125 125 125") + ("grey50" . "127 127 127") + ("grey51" . "130 130 130") + ("grey52" . "133 133 133") + ("grey53" . "135 135 135") + ("grey54" . "138 138 138") + ("grey55" . "140 140 140") + ("grey56" . "143 143 143") + ("grey57" . "145 145 145") + ("grey58" . "148 148 148") + ("grey59" . "150 150 150") + ("grey60" . "153 153 153") + ("grey61" . "156 156 156") + ("grey62" . "158 158 158") + ("grey63" . "161 161 161") + ("grey64" . "163 163 163") + ("grey65" . "166 166 166") + ("grey66" . "168 168 168") + ("grey67" . "171 171 171") + ("grey68" . "173 173 173") + ("grey69" . "176 176 176") + ("grey70" . "179 179 179") + ("grey71" . "181 181 181") + ("grey72" . "184 184 184") + ("grey73" . "186 186 186") + ("grey74" . "189 189 189") + ("grey75" . "191 191 191") + ("grey76" . "194 194 194") + ("grey77" . "196 196 196") + ("grey78" . "199 199 199") + ("grey79" . "201 201 201") + ("grey80" . "204 204 204") + ("grey81" . "207 207 207") + ("grey82" . "209 209 209") + ("grey83" . "212 212 212") + ("grey84" . "214 214 214") + ("grey85" . "217 217 217") + ("grey86" . "219 219 219") + ("grey87" . "222 222 222") + ("grey88" . "224 224 224") + ("grey89" . "227 227 227") + ("grey90" . "229 229 229") + ("grey91" . "232 232 232") + ("grey92" . "235 235 235") + ("grey93" . "237 237 237") + ("grey94" . "240 240 240") + ("grey95" . "242 242 242") + ("grey96" . "245 245 245") + ("grey97" . "247 247 247") + ("grey98" . "250 250 250") + ("grey99" . "252 252 252") + ("grey100" . "255 255 255") + ("darkgrey" . "169 169 169") + ("darkblue" . "0 0 139") + ("darkcyan" . "0 139 139") + ("darkmagenta" . "139 0 139") + ("darkred" . "139 0 0") + ("lightgreen" . "144 238 144"))) + + +(define (%convert-color str) + (let ((col (assoc str *skribe-rgb-alist*))) + (cond + (col + (let* ((p (open-input-string (cdr col))) + (r (read p)) + (g (read p)) + (b (read p))) + (values r g b))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7)) + (values (string->number (substring str 1 3) 16) + (string->number (substring str 3 5) 16) + (string->number (substring str 5 7) 16))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13)) + (values (string->number (substring str 1 5) 16) + (string->number (substring str 5 9) 16) + (string->number (substring str 9 13) 16))) + (else + (values 0 0 0))))) + +;;; +;;; SKRIBE-COLOR->RGB +;;; +(define (skribe-color->rgb spec) + (cond + ((string? spec) (%convert-color spec)) + ((integer? spec) + (values (bit-and #xff (bit-shift spec -16)) + (bit-and #xff (bit-shift spec -8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;;; +;;; SKRIBE-GET-USED-COLORS +;;; +(define (skribe-get-used-colors) + *used-colors*) + +;;; +;;; SKRIBE-USE-COLOR! +;;; +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) + +) \ No newline at end of file diff --git a/legacy/stklos/configure.stk b/legacy/stklos/configure.stk new file mode 100644 index 0000000..ece7abc --- /dev/null +++ b/legacy/stklos/configure.stk @@ -0,0 +1,90 @@ +;;;; +;;;; configure.stk -- Skribe configuration options +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 10-Feb-2004 11:47 (eg) +;;;; Last file update: 17-Feb-2004 09:43 (eg) +;;;; + +(define-module SKRIBE-CONFIGURE-MODULE + (export skribe-configure skribe-enforce-configure) + + +(define %skribe-conf + `((:release ,(skribe-release)) + (:scheme ,(skribe-scheme)) + (:url ,(skribe-url)) + (:doc-dir ,(skribe-doc-dir)) + (:ext-dir ,(skribe-ext-dir)) + (:default-path ,(skribe-default-path)))) + +;;; +;;; SKRIBE-CONFIGURE +;;; +(define (skribe-configure . opt) + (let ((conf %skribe-conf)) + (cond + ((null? opt) + conf) + ((null? (cdr opt)) + (let ((cell (assq (car opt) conf))) + (if (pair? cell) + (cadr cell) + 'void))) + (else + (let loop ((opt opt)) + (cond + ((null? opt) + #t) + ((not (keyword? (car opt))) + #f) + ((or (null? (cdr opt)) (keyword? (cadr opt))) + #f) + (else + (let ((cell (assq (car opt) conf))) + (if (and (pair? cell) + (if (procedure? (cadr opt)) + ((cadr opt) (cadr cell)) + (equal? (cadr opt) (cadr cell)))) + (loop (cddr opt)) + #f))))))))) +;;; +;;; SKRIBE-ENFORCE-CONFIGURE ... +;;; +(define (skribe-enforce-configure . opt) + (let loop ((o opt)) + (when (pair? o) + (cond + ((or (not (keyword? (car o))) + (null? (cdr o))) + (skribe-error 'skribe-enforce-configure "Illegal enforcement" opt)) + ((skribe-configure (car o) (cadr o)) + (loop (cddr o))) + (else + (skribe-error 'skribe-enforce-configure + (format "Configuration mismatch: ~a" (car o)) + (if (procedure? (cadr o)) + (format "provided `~a'" + (skribe-configure (car o))) + (format "provided `~a', required `~a'" + (skribe-configure (car o)) + (cadr o))))))))) +) \ No newline at end of file diff --git a/legacy/stklos/debug.stk b/legacy/stklos/debug.stk new file mode 100644 index 0000000..a9fefde --- /dev/null +++ b/legacy/stklos/debug.stk @@ -0,0 +1,161 @@ +;;;; +;;;; debug.stk -- Debug Facilities (stolen to Manuel Serrano) +;;;; +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 10-Aug-2003 20:45 (eg) +;;;; Last file update: 28-Oct-2004 13:16 (eg) +;;;; + + +(define-module SKRIBE-DEBUG-MODULE + (export debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol + no-debug-color) + +(define *skribe-debug* 0) +(define *skribe-debug-symbols* '()) +(define *skribe-debug-color* #t) +(define *skribe-debug-item* #f) +(define *debug-port* (current-error-port)) +(define *debug-depth* 0) +(define *debug-margin* "") +(define *skribe-margin-debug-level* 0) + + +(define (set-skribe-debug! val) + (set! *skribe-debug* val)) + +(define (add-skribe-debug-symbol s) + (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*))) + + +(define (no-debug-color) + (set! *skribe-debug-color* #f)) + +(define (skribe-debug) + *skribe-debug*) + +;; +;; debug-port +;; +; (define (debug-port . o) +; (cond +; ((null? o) +; *debug-port*) +; ((output-port? (car o)) +; (set! *debug-port* o) +; o) +; (else +; (error 'debug-port "Illegal debug port" (car o))))) +; + +;;; +;;; debug-color +;;; +(define (debug-color col . o) + (with-output-to-string + (if (and *skribe-debug-color* + (equal? (getenv "TERM") "xterm") + (interactive-port? *debug-port*)) + (lambda () + (format #t "[1;~Am" (+ 31 col)) + (for-each display o) + (display "")) + (lambda () + (for-each display o))))) + +;;; +;;; debug-bold +;;; +(define (debug-bold . o) + (apply debug-color -30 o)) + +;;; +;;; debug-item +;;; +(define (debug-item . args) + (when (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (display *debug-margin* *debug-port*) + (display (debug-color (- *debug-depth* 1) "- ") *debug-port*) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*))) + +;;(define-macro (debug-item . args) +;; `()) + +;;; +;;; %with-debug-margin +;;; +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+ *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (- *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;;; +;;; %with-debug +;; +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (begin + (display *debug-margin* *debug-port*) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl)) + *debug-port*) + (newline *debug-port*) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk)) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +(define-macro (with-debug level label . body) + `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body))) + +;;(define-macro (with-debug level label . body) +;; `(begin ,@body)) + +) + +#| +Example: + +(with-debug 0 'foo1.1 + (debug-item 'foo2.1) + (debug-item 'foo2.2) + (with-debug 0 'foo2.3 + (debug-item 'foo3.1) + (with-debug 0 'foo3.2 + (debug-item 'foo4.1) + (debug-item 'foo4.2)) + (debug-item 'foo3.3)) + (debug-item 'foo2.4)) +|# diff --git a/legacy/stklos/engine.stk b/legacy/stklos/engine.stk new file mode 100644 index 0000000..a13ed0f --- /dev/null +++ b/legacy/stklos/engine.stk @@ -0,0 +1,242 @@ +;;;; +;;;; engines.stk -- Skribe Engines Stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 :ident ident :version version :format format + :filter filter :delegate delegate + :symbol-table symbol-table + :custom custom :info info))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + + +;;; +;;; COPY-ENGINE +;;; +(define (copy-engine ident e :key (version 'unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((new (shallow-clone e))) + (slot-set! new 'ident ident) + (slot-set! new 'version version) + (slot-set! new 'filter (or filter (slot-ref e 'filter))) + (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) + (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) + (slot-set! new 'customs (or custom (slot-ref e 'customs))) + + (set! *engines* (cons new *engines*)) + new)) + + +;;; +;;; FIND-ENGINE +;;; +(define (%find-loaded-engine id version) + (let Loop ((es *engines*)) + (cond + ((null? es) #f) + ((eq? (slot-ref (car es) 'ident) id) + (cond + ((eq? version 'unspecified) (car es)) + ((eq? version (slot-ref (car es) 'version)) (car es)) + (else (Loop (cdr es))))) + (else (loop (cdr es)))))) + + +(define (find-engine id :key (version 'unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + + (or (%find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and c (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (%find-loaded-engine id version)) + #f))))) + +;;; +;;; ENGINE-CUSTOM +;;; +(define (engine-custom e id) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (cadr c) + 'unspecified))) + + +;;; +;;; ENGINE-CUSTOM-SET! +;;; +(define (engine-custom-set! e id val) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (slot-set! e 'customs (cons (list id val) customs))))) + + +;;; +;;; ENGINE-ADD-WRITER! +;;; +(define (engine-add-writer! e ident pred upred opt before action after class valid) + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (unless (is-a? e ) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (unless (or (eq? opt 'all) (list? opt)) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (check-procedure "predicate" pred 2) + + ;; check the correctness of the validation proc + (when valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (slot-set! e 'writers (cons n (slot-ref e 'writers))) + n)) + +;;;; ====================================================================== +;;;; +;;;; I N I T S +;;;; +;;;; ====================================================================== + +;; A base engine must pre-exist before anything is loaded. In +;; particular, this dummy base engine is used to load the actual +;; definition of base. + +(make-engine 'base :version 'bootstrap) + + +(select-module STklos) diff --git a/legacy/stklos/eval.stk b/legacy/stklos/eval.stk new file mode 100644 index 0000000..3acace9 --- /dev/null +++ b/legacy/stklos/eval.stk @@ -0,0 +1,149 @@ +;;;; +;;;; eval.stk -- Skribe Evaluator +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 )) + (skribe-error 'skribe-eval-port "Cannot find engine" engine) + (let loop ((exp (read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (skribe-eval (%evaluate exp) e :env env) + (loop (read port)))))))) + +;;; +;;; SKRIBE-LOAD +;;; +(define *skribe-load-options* '()) + +(define (skribe-load-options) + *skribe-load-options*) + +(define (skribe-load file :rest opt :key engine path) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + + (let* ((ei (cond + ((not engine) *skribe-engine*) + ((engine? engine) engine) + ((not (symbol? engine)) (skribe-error 'skribe-load + "Illegal engine" engine)) + (else engine))) + (path (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else path))) + (filep (find-path file path))) + + (set! *skribe-load-options* opt) + + (unless (and (string? filep) (file-exists? filep)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + *skribe-path*)) + + ;; Load this file if not already done + (unless (member filep *skribe-loaded*) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + ;; Load it + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))) + (set! *skribe-loaded* (cons filep *skribe-loaded*)))))) + +;;; +;;; SKRIBE-INCLUDE +;;; +(define (skribe-include file :optional (path (skribe-path))) + (unless (every string? path) + (skribe-error 'skribe-include "Illegal path" path)) + + (let ((path (find-path file path))) + (unless (and (string? path) (file-exists? path)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + path)) + (when (> *skribe-verbose* 0) + (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path + (lambda () + (let Loop ((exp (read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (read (current-input-port)) + (cons (%evaluate exp) res)))))))) +) \ No newline at end of file diff --git a/legacy/stklos/lib.stk b/legacy/stklos/lib.stk new file mode 100644 index 0000000..3c3b9f0 --- /dev/null +++ b/legacy/stklos/lib.stk @@ -0,0 +1,317 @@ +;;;; +;;;; lib.stk -- Utilities +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 11-Aug-2003 20:29 (eg) +;;;; Last file update: 27-Oct-2004 12:41 (eg) +;;;; + +;;; +;;; NEW +;;; +(define (maybe-copy obj) + (if (pair-mutable? obj) + obj + (copy-tree obj))) + +(define-macro (new class . parameters) + `(make ,(string->symbol (format "<~a>" class)) + ,@(apply append (map (lambda (x) + `(,(make-keyword (car x)) (maybe-copy ,(cadr x)))) + parameters)))) + +;;; +;;; DEFINE-MARKUP +;;; +(define-macro (define-markup bindings . body) + ;; This is just a STklos extended lambda. Nothing to do + `(define ,bindings ,@body)) + + +;;; +;;; DEFINE-SIMPLE-MARKUP +;;; +(define-macro (define-simple-markup markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-SIMPLE-CONTAINER +;;; +(define-macro (define-simple-container markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-PROCESSOR-MARKUP +;;; +(define-macro (define-processor-markup proc) + `(define-markup (,proc #!rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + + +;;; +;;; SKRIBE-EVAL-LOCATION ... +;;; +(define (skribe-eval-location) + (format (current-error-port) + "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n") + #f) + +;;; +;;; SKRIBE-ERROR +;;; +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (markup? obj) (markup-markup obj) obj))) + (if (location? l) + (error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape) + (error "~a: ~a ~s " proc msg shape)))) + +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error proc msg obj))) + + +;;; +;;; SKRIBE-TYPE-ERROR +;;; +(define (skribe-type-error proc msg obj etype) + (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f)) + + + +;;; FIXME: Peut-être virée maintenant +(define (skribe-line-error file line proc msg obj) + (error (format "%a:%a: ~a:~a ~S" file line proc msg obj))) + + +;;; +;;; SKRIBE-WARNING & SKRIBE-WARNING/AST +;;; +(define (%skribe-warn level file line lst) + (let ((port (current-error-port))) + (format port "**** WARNING:\n") + (when (and file line) (format port "~a: ~a: " file line)) + (for-each (lambda (x) (format port "~a " x)) lst) + (newline port))) + + +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (%skribe-warn level #f #f obj))) + + +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (ast-loc ast))) + (if (location? l) + (%skribe-warn level (location-file l) (location-pos l) obj) + (%skribe-warn level #f #f obj))))) + +;;; +;;; SKRIBE-MESSAGE +;;; +(define (skribe-message fmt . obj) + (when (> *skribe-verbose* 0) + (apply format (current-error-port) fmt obj))) + +;;; +;;; FILE-PREFIX / FILE-SUFFIX +;;; +(define (file-prefix fn) + (if fn + (let ((match (regexp-match "(.*)\\.([^/]*$)" fn))) + (if match + (cadr match) + fn)) + "./SKRIBE-OUTPUT")) + +(define (file-suffix s) + ;; Not completely correct, but sufficient here + (let* ((basename (regexp-replace "^(.*)/(.*)$" s "\\2")) + (split (string-split basename "."))) + (if (> (length split) 1) + (car (reverse! split)) + ""))) + + +;;; +;;; KEY-GET +;;; +;;; We need to redefine the standard key-get to be more permissive. In +;;; STklos key-get accepts a list which is formed only of keywords. In +;;; Skribe, parameter lists are of the form +;;; (:title "..." :option "...." body1 body2 body3) +;;; So is we find an element which is not a keyword, we skip it (unless it +;;; follows a keyword of course). Since the compiler of extended lambda +;;; uses the function key-get, it will now accept Skribe markups +(define (key-get lst key :optional (default #f default?)) + (define (not-found) + (if default? + default + (error 'key-get "value ~S not found in list ~S" key lst))) + (let Loop ((l lst)) + (cond + ((null? l) + (not-found)) + ((not (pair? l)) + (error 'key-get "bad list ~S" lst)) + ((keyword? (car l)) + (if (null? (cdr l)) + (error 'key-get "bad keyword list ~S" lst) + (if (eq? (car l) key) + (cadr l) + (Loop (cddr l))))) + (else + (Loop (cdr l)))))) + + +;;; +;;; UNSPECIFIED? +;;; +(define (unspecified? obj) + (eq? obj 'unspecified)) + +;;;; ====================================================================== +;;;; +;;;; A C C E S S O R S +;;;; +;;;; ====================================================================== + +;; SKRIBE-PATH +(define (skribe-path) *skribe-path*) + +(define (skribe-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;; SKRIBE-IMAGE-PATH +(define (skribe-image-path) *skribe-image-path*) + +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;; SKRIBE-BIB-PATH +(define (skribe-bib-path) *skribe-bib-path*) + +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;; SKRBE-SOURCE-PATH +(define (skribe-source-path) *skribe-source-path*) + +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) + +;;;; ====================================================================== +;;;; +;;;; Compatibility with Bigloo +;;;; +;;;; ====================================================================== + +(define (substring=? s1 s2 len) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (let Loop ((i 0)) + (cond + ((= i len) #t) + ((= i l1) #f) + ((= i l2) #f) + ((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1))) + (else #f))))) + +(define (directory->list str) + (map basename (glob (string-append str "/*") (string-append "/.*")))) + +(define-macro (printf . args) `(format #t ,@args)) +(define fprintf format) + +(define (symbol-append . l) + (string->symbol (apply string-append (map symbol->string l)))) + + +(define (make-list n . fill) + (let ((fill (if (null? fill) (void) (car fill)))) + (let Loop ((i n) (res '())) + (if (zero? i) + res + (Loop (- i 1) (cons fill res)))))) + + +(define string-capitalize string-titlecase) +(define prefix file-prefix) +(define suffix file-suffix) +(define system->string exec) +(define any? any) +(define every? every) +(define cons* list*) +(define find-file/path find-path) +(define process-input-port process-input) +(define process-output-port process-output) +(define process-error-port process-error) + +;;; +;;; h a s h t a b l e s +;;; +(define make-hashtable (lambda () (make-hash-table equal?))) +(define hashtable? hash-table?) +(define hashtable-get (lambda (h k) (hash-table-get h k #f))) +(define hashtable-put! hash-table-put!) +(define hashtable-update! hash-table-update!) +(define hashtable->list (lambda (h) + (map cdr (hash-table->list h)))) + +(define find-runtime-type (lambda (obj) obj)) + +(define-macro (unwind-protect expr1 expr2) + ;; This is no completely correct. + `(dynamic-wind + (lambda () #f) + (lambda () ,expr1) + (lambda () ,expr2))) diff --git a/legacy/stklos/lisp-lex.l b/legacy/stklos/lisp-lex.l new file mode 100644 index 0000000..efad24b --- /dev/null +++ b/legacy/stklos/lisp-lex.l @@ -0,0 +1,91 @@ +;;;; -*- Scheme -*- +;;;; +;;;; lisp-lex.l -- SILex input for the Lisp Languages +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 5-Jan-2004 18:24 (eg) +;;;; + +space [ \n\9] +letter [#?!_:a-zA-Z\-] +digit [0-9] + + +%% +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +\;.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) +\[|\] (if *bracket-highlight* + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis +[ \n\9\(\)]+ (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) +[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if *class-highlight* + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + *the-keys*))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + + +<> 'eof +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/legacy/stklos/lisp.stk b/legacy/stklos/lisp.stk new file mode 100644 index 0000000..9bfe75a --- /dev/null +++ b/legacy/stklos/lisp.stk @@ -0,0 +1,294 @@ +;;;; +;;;; lisp.stk -- Lisp Family Fontification +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 16-Oct-2003 22:17 (eg) +;;;; Last file update: 28-Oct-2004 21:14 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module SKRIBE-LISP-MODULE + (export skribe scheme stklos bigloo lisp) + (import SKRIBE-SOURCE-MODULE) + +(include "lisp-lex.stk") ;; SILex generated + +(define *bracket-highlight* #f) +(define *class-highlight* #f) +(define *the-keys* #f) + +(define *lisp-keys* #f) +(define *scheme-keys* #f) +(define *skribe-keys* #f) +(define *stklos-keys* #f) +(define *lisp-keys* #f) + + +;;; +;;; DEFINITION-SEARCH +;;; +(define (definition-search inp tab test) + (let Loop ((exp (%read inp))) + (unless (eof-object? exp) + (if (test exp) + (let ((start (and (%epair? exp) (%epair-line exp))) + (stop (port-current-line inp))) + (source-read-lines (port-file-name inp) start stop tab)) + (Loop (%read inp)))))) + + +(define (lisp-family-fontifier s) + (let ((lex (lisp-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; LISP +;;;; +;;;; ====================================================================== +(define (lisp-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (and (eq? def fun) exp)) + ((defvar ?var . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define (init-lisp-keys) + (unless *lisp-keys* + (set! *lisp-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(setq if let let* letrec cond case else progn lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(defun defclass defmacro))))) + *lisp-keys*) + +(define (lisp-fontifier s) + (fluid-let ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SCHEME +;;;; +;;;; ====================================================================== +(define (scheme-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-scheme-keys) + (unless *scheme-keys* + (set! *scheme-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(set! if let let* letrec quote cond case else begin do lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(define define-syntax))))) + *scheme-keys*) + + +(define (scheme-fontifier s) + (fluid-let ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;;;; ====================================================================== +;;;; +;;;; STKLOS +;;;; +;;;; ====================================================================== +(define (stklos-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-generic define-method define-macro) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-module) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-stklos-keys) + (unless *stklos-keys* + (init-scheme-keys) + (set! *stklos-keys* (append *scheme-keys* + ;; Markups + (map (lambda (x) (cons x '&source-key)) + '(select-module import export)) + ;; Key + (map (lambda (x) (cons x '&source-keyword)) + '(case-lambda dotimes match-case match-lambda)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-generic define-class + define-macro define-method define-module)) + ;; error + (map (lambda (x) (cons x '&source-error)) + '(error call/cc))))) + *stklos-keys*) + + +(define (stklos-fontifier s) + (fluid-let ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define stklos + (new language + (name "stklos") + (fontifier stklos-fontifier) + (extractor stklos-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SKRIBE +;;;; +;;;; ====================================================================== +(define (skribe-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + ((markup-output (quote ?mk) . ?-) + (and (eq? mk def) exp)) + (else + #f))))) + + +(define (init-skribe-keys) + (unless *skribe-keys* + (init-stklos-keys) + (set! *skribe-keys* (append *stklos-keys* + ;; Markups + (map (lambda (x) (cons x '&source-markup)) + '(bold it emph tt color ref index underline + roman figure center pre flush hrule + linebreak image kbd code var samp + sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font + document chapter section subsection + subsubsection paragraph p handle resolve + processor abstract margin toc + table-of-contents current-document + current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-markup))))) + *skribe-keys*) + + +(define (skribe-fontifier s) + (fluid-let ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;;;; ====================================================================== +;;;; +;;;; BIGLOO +;;;; +;;;; ====================================================================== +(define (bigloo-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) + +) diff --git a/legacy/stklos/main.stk b/legacy/stklos/main.stk new file mode 100644 index 0000000..4905423 --- /dev/null +++ b/legacy/stklos/main.stk @@ -0,0 +1,264 @@ +;;;; +;;;; skribe.stk -- Skribe Main +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 ") + (set! engine (string->symbol target))) + (("I" :arg path :help "adds to Skribe path") + (set! paths (cons path paths))) + (("B" :arg path :help "adds to bibliography path") + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("S" :arg path :help "adds to source path") + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("P" :arg path :help "adds to image path") + (skribe-image-path-set! (cons path (skribe-image-path)))) + (("split-chapters" :alternate "C" :arg chapter + :help "emit chapter's sections in separate files") + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("preload" :arg file :help "preload ") + (set! *skribe-preload* (cons file *skribe-preload*))) + (("use-variant" :alternate "u" :arg variant + :help "use output format") + (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
") + (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 ") + (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 . 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 . 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 ") + (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 ") + (with-input-from-string expr + (lambda () (eval (read))))) + (else + (set! *skribe-src* other-arguments))) + + ;; we have to configure Skribe path according to the environment variable + (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH"))) + (if path + (string-split path ":") + '())) + (reverse! paths) + (skribe-default-path))) + ;; Final initializations + (when engine + (set! *skribe-engine* engine)))) + +;;;; ====================================================================== +;;;; +;;;; L O A D - R C +;;;; +;;;; ====================================================================== +(define (load-rc) + (when *load-rc* + (let ((file (make-path *skribe-rc-directory* *skribe-rc-file*))) + (when (and file (file-exists? file)) + (load file))))) + + + +;;;; ====================================================================== +;;;; +;;;; S K R I B E +;;;; +;;;; ====================================================================== +(define (doskribe) + (let ((e (find-engine *skribe-engine*))) + (if (and (engine? e) (pair? *skribe-precustom*)) + (for-each (lambda (cv) + (engine-custom-set! e (car cv) (cdr cv))) + *skribe-precustom*)) + (if (pair? *skribe-src*) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) + *skribe-src*) + (skribe-eval-port (current-input-port) *skribe-engine*)))) + + +;;;; ====================================================================== +;;;; +;;;; M A I N +;;;; +;;;; ====================================================================== +(define (main args) + ;; Load the user rc file + (load-rc) + + ;; Parse command line + (parse-args args) + + ;; Load the base file to bootstrap the system as well as the files + ;; that are in the *skribe-preload* variable + (skribe-load "base.skr" :engine 'base) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) *skribe-preload*) + + ;; Load the specified variants + (for-each (lambda (x) (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) + (reverse! *skribe-variants*)) + +;; (if (string? *skribe-dest*) +;; (with-handler (lambda (kind loc msg) +;; (remove-file *skribe-dest*) +;; (error loc msg)) +;; (with-output-to-file *skribe-dest* doskribe)) +;; (doskribe)) +(if (string? *skribe-dest*) + (with-output-to-file *skribe-dest* doskribe) + (doskribe)) + + 0) diff --git a/legacy/stklos/output.stk b/legacy/stklos/output.stk new file mode 100644 index 0000000..3c00323 --- /dev/null +++ b/legacy/stklos/output.stk @@ -0,0 +1,158 @@ +;;;; +;;;; output.stk -- Skribe Output Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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) ) + (%out/writer node e (car writer))) + ((not (car writer)) + (skribe-error 'output + (format "Illegal ~A user writer" (engine-ident e)) + (if (markup? node) (markup-markup node) node))) + (else + (skribe-error 'output "Illegal user writer" (car writer))))))) + + +;;; +;;; OUT implementations +;;; +(define-method out (node e) + #f) + + +(define-method out ((node ) e) + (let Loop ((n* node)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (skribe-error 'out "Illegal argument" n*))))) + + +(define-method out ((node ) e) + (let ((f (slot-ref e 'filter))) + (if (procedure? f) + (display (f node)) + (display node)))) + + +(define-method out ((node ) e) + (out (number->string node) e)) + + +(define-method out ((n ) e) + (let ((combinator (slot-ref n 'combinator)) + (engine (slot-ref n 'engine)) + (body (slot-ref n 'body)) + (procedure (slot-ref n 'procedure))) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + + +(define-method out ((n ) e) + (let* ((fmt (slot-ref n 'fmt)) + (body (slot-ref n 'body)) + (lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (skribe-error '! "Too few arguments provided" n))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (skribe-error '! "Too few arguments provided" n)))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0))))))) + + +(define-method out ((n ) e) + 'unspecified) + + +(define-method out ((n ) e) + (skribe-error 'output "Orphan unresolved" n)) + + +(define-method out ((node ) e) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (%out/writer node e w) + (output (slot-ref node 'body) e)))) +) diff --git a/legacy/stklos/prog.stk b/legacy/stklos/prog.stk new file mode 100644 index 0000000..6301ece --- /dev/null +++ b/legacy/stklos/prog.stk @@ -0,0 +1,219 @@ +;;;; +;;;; prog.stk -- All the stuff for the prog markup +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 31-Aug-2003 23:42 (eg) +;;;; Last file update: 22-Oct-2003 19:35 (eg) +;;;; + +(define-module SKRIBE-PROG-MODULE + (export make-prog-body resolve-line) + +;;; ====================================================================== +;;; +;;; COMPATIBILITY +;;; +;;; ====================================================================== +(define pregexp-match regexp-match) +(define pregexp-replace regexp-replace) +(define pregexp-quote regexp-quote) + + +(define (node-body-set! b v) + (slot-set! b 'body v)) + +;;; +;;; FIXME: Tout le module peut se factoriser +;;; définir en bigloo node-body-set + + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (number->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (receive (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((node? line) + (receive (m l) + (extract-mark (node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((= r2 l) + (if (= r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+ r2 1) + (+ r2 1) + (if (= r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+ r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (number->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (number->string (+ (if (integer? ldigit) + (max lnum (expt 10 (- ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (receive (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) + +) \ No newline at end of file diff --git a/legacy/stklos/reader.stk b/legacy/stklos/reader.stk new file mode 100644 index 0000000..bd38562 --- /dev/null +++ b/legacy/stklos/reader.stk @@ -0,0 +1,136 @@ +;;;; +;;;; reader.stk -- Reader hook for the open bracket +;;;; +;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@unice.fr] +;;;; Creation date: 6-Dec-2001 22:59 (eg) +;;;; Last file update: 28-Feb-2004 10:22 (eg) +;;;; + +;; Examples of ISO-2022-JP (here for cut'n paste tests, since my japanese +;; is *very* limited ;-). +;; +;; "Japan" $BF|K\(B +;; "China and Chinese music" $BCf9q$HCf9q$N2;3Z(B + + +;; +;; This function is a hook for the standard reader. After defining, +;; %read-bracket, the reader calls it when it encounters an open +;; bracket + + +(define (%read-bracket in) + + (define (read-japanese in) + ;; This function reads an ISO-2022-JP sequence. Susch s sequence is coded + ;; as "^[$B......^[(B" . When entering in this function the current + ;; character is 'B' (the opening sequence one). Function reads until the + ;; end of the sequence and return it as a string + (read-char in) ;; to skip the starting #\B + (let ((res (open-output-string))) + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + ((char=? c #\escape) + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\() + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (read-char in) + (format "\033$B~A\033(B" (get-output-string res))) + (begin + (format res "\033~A" next1) + (Loop next2))))) + (begin + (display #\escape res) + (Loop next1))))) + (else (display (read-char in) res) + (Loop (peek-char in))))))) + ;; + ;; Body of %read-bracket starts here + ;; + (let ((out (open-output-string)) + (res '()) + (in-string? #f)) + + (read-char in) ; skip open bracket + + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + + ((char=? c #\escape) ;; ISO-2022-JP string? + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\$) + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (set! res + (append! res + (list (get-output-string out) + (list 'unquote + (list 'jp + (read-japanese in)))))) + (set! out (open-output-string))) + (format out "\033~A" next1)))) + (display #\escape out))) + (Loop (peek-char in))) + + ((char=? c #\\) ;; Quote char + (read-char in) + (display (read-char in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\,)) ;; Comma + (read-char in) + (let ((next (peek-char in))) + (if (char=? next #\() + (begin + (set! res (append! res (list (get-output-string out) + (list 'unquote + (read in))))) + (set! out (open-output-string))) + (display #\, out)) + (Loop (peek-char in)))) + + ((and (not in-string?) (char=? c #\[)) ;; Open bracket + (display (%read-bracket in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\])) ;; Close bracket + (read-char in) + (let ((str (get-output-string out))) + (list 'quasiquote + (append! res (if (string=? str "") '() (list str)))))) + + (else (when (char=? c #\") (set! in-string? (not in-string?))) + (display (read-char in) out) + (Loop (peek-char in))))))) + diff --git a/legacy/stklos/resolve.stk b/legacy/stklos/resolve.stk new file mode 100644 index 0000000..91dc965 --- /dev/null +++ b/legacy/stklos/resolve.stk @@ -0,0 +1,255 @@ +;;;; +;;;; resolve.stk -- Skribe Resolve Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 ) engine env) + (let Loop ((n* ast)) + (cond + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (Loop (cdr n*))) + ((not (null? n*)) + (error 'do-resolve "Illegal argument" n*)) + (else + ast)))) + + +(define-method do-resolve! ((node ) engine env) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve + (debug-item "body=" body) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options)))) + (slot-set! node 'body (do-resolve! body engine env)) + node))) + + + +(define-method do-resolve! ((node ) engine env0) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (env (slot-ref node 'env)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" body) + (debug-item "env0=" env0) + (debug-item "env=" env) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env0))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))) + (let ((e `((parent ,node) ,@env ,@env0))) + (slot-set! node 'body (do-resolve! body engine e))))) + node))) + + +(define-method do-resolve! ((node ) engine env0) + (next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (slot-ref engine 'customs))) + node) + + +(define-method do-resolve! ((node ) engine env) + (with-debug 5 'do-resolve + (debug-item "node=" node) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + + (let* ((proc (slot-ref node 'proc)) + (res (resolve! (proc node engine env) engine env)) + (loc (ast-loc node))) + (when (ast? res) + (ast-loc-set! res loc)) + (debug-item "res=" res) + (set! *unresolved* #t) + res))) + + +(define-method do-resolve! ((node ) engine env) + node) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (is-a? n )) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (slot-ref n 'parent) 'unspecified) + (skribe-error 'resolve-parent "Orphan node" n)) + (else + (slot-ref n 'parent))))) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-SEARCH-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" n) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" p " " + (if (is-a? p 'markup) (slot-ref p 'markup) "???")) + (cond + ((pred p) p) + ((is-a? p ) p) + ((not p) #f) + (else (resolve-search-parent p e pred)))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-COUNTER +;;;; +;;;; ====================================================================== +;;FIXME: factoriser +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-IDENT +;;;; +;;;; ====================================================================== +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) + +) diff --git a/legacy/stklos/runtime.stk b/legacy/stklos/runtime.stk new file mode 100644 index 0000000..58d0d45 --- /dev/null +++ b/legacy/stklos/runtime.stk @@ -0,0 +1,456 @@ +;;;; +;;;; runtime.stk -- Skribe runtime system +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 )) +;; (skribe-error 'markup-writer "illegal engine" e)) +;; ((and (not before) +;; (not action) +;; (not after)) +;; (%find-markup-output e markup)) +;; (else +;; (let ((mp (if (procedure? predicate) +;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) +;; (lambda (n e) (is-markup? n markup))))) +;; (engine-output e markup mp options +;; (or before (slot-ref e 'default-before)) +;; (or action (slot-ref e 'default-action)) +;; (or after (slot-ref e 'default-after)))))))) + +(define (markup-option m opt) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (and (pair? c) (pair? (cdr c)) + (cadr c))) + (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + + +(define (markup-option-add! m opt val) + (if (markup? m) + (slot-set! m 'options (cons (list opt val) + (slot-ref m 'options))) + (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + +;;;; ====================================================================== +;;;; +;;;; C O N T A I N E R S +;;;; +;;;; ====================================================================== +(define (container-env-get m key) + (let ((c (assq key (slot-ref m 'env)))) + (and (pair? c) (cadr c)))) + + +;;;; ====================================================================== +;;;; +;;;; I M A G E S +;;;; +;;;; ====================================================================== +(define (builtin-convert-image from fmt dir) + (let* ((s (suffix from)) + (f (string-append (prefix (basename from)) "." fmt)) + (to (string-append dir "/" f))) ;; FIXME: + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append "fig2dev -L " fmt " " from " > " to) + (string-append "convert " from " " to)))) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [converting image: ~S (~S)]" from c)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [converting image: ~S]" from))) + (and (zero? (system c)) + to)))))) + +(define (convert-image file formats) + (let ((path (find-path file (skribe-image-path)))) + (if (not path) + (skribe-error 'convert-image + (format "Can't find `~a' image file in path: " file) + (skribe-image-path)) + (let ((suf (suffix file))) + (if (member suf formats) + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + #f))) + (if dir + (let ((dest (basename path))) + (copy-file path (make-path dir dest)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + +;;;; ====================================================================== +;;;; +;;;; S T R I N G - W R I T I N G +;;;; +;;;; ====================================================================== + +;; +;; (define (%make-html-replace) +;; ;; Ad-hoc version for HTML, a little bit faster than the +;; ;; make-general-string-replace define later (particularily if there +;; ;; is nothing to replace since, it does not allocate a new string +;; (let ((specials (string->regexp "&|\"|<|>"))) +;; (lambda (str) +;; (if (regexp-match specials str) +;; (begin +;; (let ((out (open-output-string))) +;; (dotimes (i (string-length str)) +;; (let ((ch (string-ref str i))) +;; (case ch +;; ((#\") (display """ out)) +;; ((#\&) (display "&" out)) +;; ((#\<) (display "<" out)) +;; ((#\>) (display ">" out)) +;; (else (write-char ch out))))) +;; (get-output-string out))) +;; str)))) + + +(define (%make-general-string-replace lst) + ;; The general version + (lambda (str) + (let ((out (open-output-string))) + (dotimes (i (string-length str)) + (let* ((ch (string-ref str i)) + (res (assq ch lst))) + (display (if res (cadr res) ch) out))) + (get-output-string out)))) + + +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char ">"))) + string->html) + (else + (%make-general-string-replace lst))))) + + + + +;;;; ====================================================================== +;;;; +;;;; O P T I O N S +;;;; +;;;; ====================================================================== + +;;NEW ;; +;;NEW ;; GET-OPTION +;;NEW ;; +;;NEW (define (get-option obj key) +;;NEW ;; This function either searches inside an a-list or a markup. +;;NEW (cond +;;NEW ((pair? obj) (let ((c (assq key obj))) +;;NEW (and (pair? c) (pair? (cdr c)) (cadr c)))) +;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key)) +;;NEW (else #f))) +;;NEW +;;NEW ;; +;;NEW ;; BIND-OPTION! +;;NEW ;; +;;NEW (define (bind-option! obj key value) +;;NEW (slot-set! obj 'option* (cons (list key value) +;;NEW (slot-ref obj 'option*)))) +;;NEW +;;NEW +;;NEW ;; +;;NEW ;; GET-ENV +;;NEW ;; +;;NEW (define (get-env obj key) +;;NEW ;; This function either searches inside an a-list or a container +;;NEW (cond +;;NEW ((pair? obj) (let ((c (assq key obj))) +;;NEW (and (pair? c) (cadr c)))) +;;NEW ((container? obj) (get-env (slot-ref obj 'env) key)) +;;NEW (else #f))) +;;NEW + + + + +;;;; ====================================================================== +;;;; +;;;; A S T +;;;; +;;;; ====================================================================== + +(define-generic ast->string) + + +(define-method ast->string ((ast )) "") +(define-method ast->string ((ast )) ast) +(define-method ast->string ((ast )) (number->string ast)) + +(define-method ast->string ((ast )) + (let ((out (open-output-string))) + (let Loop ((lst ast)) + (cond + ((null? lst) + (get-output-string out)) + (else + (display (ast->string (car lst)) out) + (unless (null? (cdr lst)) + (display #\space out)) + (Loop (cdr lst))))))) + +(define-method ast->string ((ast )) + (ast->string (slot-ref ast 'body))) + + +;;NEW ;; +;;NEW ;; AST-PARENT +;;NEW ;; +;;NEW (define (ast-parent n) +;;NEW (slot-ref n 'parent)) +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-PARENT +;;NEW ;; +;;NEW (define (markup-parent m) +;;NEW (let ((p (slot-ref m 'parent))) +;;NEW (if (eq? p 'unspecified) +;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m) +;;NEW p))) +;;NEW +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-DOCUMENT +;;NEW ;; +;;NEW (define (markup-document m) +;;NEW (let Loop ((p m) +;;NEW (l #f)) +;;NEW (cond +;;NEW ((is-markup? p 'document) p) +;;NEW ((or (eq? p 'unspecified) (not p)) l) +;;NEW (else (Loop (slot-ref p 'parent) p))))) +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-CHAPTER +;;NEW ;; +;;NEW (define (markup-chapter m) +;;NEW (let loop ((p m) +;;NEW (l #f)) +;;NEW (cond +;;NEW ((is-markup? p 'chapter) p) +;;NEW ((or (eq? p 'unspecified) (not p)) l) +;;NEW (else (loop (slot-ref p 'parent) p))))) +;;NEW +;;NEW +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; H A N D L E S +;;NEW ;;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (handle-body h) +;;NEW (slot-ref h 'body)) +;;NEW +;;NEW +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; F I N D +;;NEW ;;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (find pred obj) +;;NEW (with-debug 4 'find +;;NEW (debug-item "obj=" obj) +;;NEW (let loop ((obj (if (is-a? obj ) (container-body obj) obj))) +;;NEW (cond +;;NEW ((pair? obj) +;;NEW (apply append (map (lambda (o) (loop o)) obj))) +;;NEW ((is-a? obj ) +;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident)) +;;NEW (if (pred obj) +;;NEW (list (cons obj (loop (container-body obj)))) +;;NEW '())) +;;NEW (else +;;NEW (if (pred obj) +;;NEW (list obj) +;;NEW '())))))) +;;NEW + +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G +;;NEW ;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (the-body opt) +;;NEW ;; Filter out the options +;;NEW (let loop ((opt* opt) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-body "Illegal body" opt)) +;;NEW ((keyword? (car opt*)) +;;NEW (if (null? (cdr opt*)) +;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) +;;NEW (loop (cddr opt*) res))) +;;NEW (else +;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) +;;NEW +;;NEW +;;NEW +;;NEW (define (the-options opt+ . out) +;;NEW ;; Returns an list made of options.The OUT argument contains +;;NEW ;; keywords that are filtered out. +;;NEW (let loop ((opt* opt+) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-options "Illegal options" opt*)) +;;NEW ((keyword? (car opt*)) +;;NEW (cond +;;NEW ((null? (cdr opt*)) +;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) +;;NEW ((memq (car opt*) out) +;;NEW (loop (cdr opt*) res)) +;;NEW (else +;;NEW (loop (cdr opt*) +;;NEW (cons (list (car opt*) (cadr opt*)) res))))) +;;NEW (else +;;NEW (loop (cdr opt*) res))))) +;;NEW + + +) diff --git a/legacy/stklos/source.stk b/legacy/stklos/source.stk new file mode 100644 index 0000000..a3102c1 --- /dev/null +++ b/legacy/stklos/source.stk @@ -0,0 +1,191 @@ +;;;; +;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 3-Sep-2003 12:22 (eg) +;;;; Last file update: 27-Oct-2004 20:09 (eg) +;;;; + + + +(define-module SKRIBE-SOURCE-MODULE + (export source-read-lines source-read-definition source-fontify) + + +;; Temporary solution +(define (language-extractor lang) + (slot-ref lang 'extractor)) + +(define (language-fontifier lang) + (slot-ref lang 'fontifier)) + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+ l 1) #t (read-line) r)) + (else + (loop (+ l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((= i len) + (let ((nlen (- col 1))) + (if (= len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((= i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (* (/ (+ col tabl) + tabl) + tabl))) + (liip (+ i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+ i 1) (+ j 1) (+ col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+ i 1) + (* (/ (+ col tabl) tabl) tabl))) + (else + (loop (+ i 1) (+ col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-path file (skribe-source-path)))) + (cond + ((not (language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + (slot-ref lang 'name))) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\Newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) + +) diff --git a/legacy/stklos/types.stk b/legacy/stklos/types.stk new file mode 100644 index 0000000..fb16230 --- /dev/null +++ b/legacy/stklos/types.stk @@ -0,0 +1,294 @@ +;;;; +;;;; types.stk -- Definition of Skribe classes +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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. + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +;;FIXME: set! location in +(define-class () + ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) + (loc :init-form #f))) + +(define (ast? obj) (is-a? obj )) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((fmt :init-keyword :fmt) + (body :init-keyword :body))) + +(define (command? obj) (is-a? obj )) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((proc :init-keyword :proc))) + +(define (unresolved? obj) (is-a? obj )) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ast :init-keyword :ast :init-form #f :getter handle-ast))) + +(define (handle? obj) (is-a? obj )) +(define (handle-ast obj) (slot-ref obj 'ast)) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((required-options :init-keyword :required-options :init-form '()) + (options :init-keyword :options :init-form '()) + (body :init-keyword :body :init-form #f + :getter node-body))) + +(define (node? obj) (is-a? obj )) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-form 'unspecified) + (procedure :init-keyword :procedure :init-form (lambda (n e) n)))) + +(define (processor? obj) (is-a? obj )) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :getter markup-ident :init-form #f) + (class :init-keyword :class :getter markup-class :init-form #f) + (markup :init-keyword :markup :getter markup-markup))) + + +(define (bind-markup! node) + (hash-table-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + + +(define-method initialize ((self ) initargs) + (next-method) + (bind-markup! self)) + + +(define (markup? obj) (is-a? obj )) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) + + +(define (is-markup? obj markup) + (and (is-a? obj ) + (eq? (slot-ref obj 'markup) markup))) + + + +(define (find-markups ident) + (hash-table-get *node-table* ident #f)) + + +(define-method write-object ((obj ) port) + (format port "#[~A (~A/~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((env :init-keyword :env :init-form '()))) + +(define (container? obj) (is-a? obj )) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ()) + +(define (document? obj) (is-a? obj )) +(define (document-ident obj) (slot-ref obj 'ident)) +(define (document-body obj) (slot-ref obj 'body)) +(define document-options markup-options) +(define document-env container-env) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :init-form '???) + (format :init-keyword :format :init-form "raw") + (info :init-keyword :info :init-form '()) + (version :init-keyword :version :init-form 'unspecified) + (delegate :init-keyword :delegate :init-form #f) + (writers :init-keyword :writers :init-form '()) + (filter :init-keyword :filter :init-form #f) + (customs :init-keyword :custom :init-form '()) + (symbol-table :init-keyword :symbol-table :init-form '()))) + + + +(define (engine? obj) + (is-a? obj )) + +(define (engine-ident obj) ;; Define it here since the doc searches it + (slot-ref obj 'ident)) + +(define (engine-format obj) ;; Define it here since the doc searches it + (slot-ref obj 'format)) + +(define (engine-customs obj) ;; Define it here since the doc searches it + (slot-ref obj 'customs)) + +(define (engine-filter obj) ;; Define it here since the doc searches it + (slot-ref obj 'filter)) + +(define (engine-symbol-table obj) ;; Define it here since the doc searches it + (slot-ref obj 'symbol-table)) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :init-form '??? :getter writer-ident) + (class :init-keyword :class :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 )) + +(define-method write-object ((obj ) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((name :init-keyword :name :init-form #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier) + (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))) + +(define (language? obj) + (is-a? obj )) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((file :init-keyword :file :getter location-file) + (pos :init-keyword :pos :getter location-pos) + (line :init-keyword :line :getter location-line))) + +(define (location? obj) + (is-a? obj )) + +(define (ast-location obj) + (let ((loc (slot-ref obj 'loc))) + (if (location? loc) + (let* ((fname (location-file loc)) + (line (location-line loc)) + (pwd (getcwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (> lenf len)) + (substring fname len (+ 1 (string-length fname))) + fname))) + (format "~a, line ~a" file line)) + "no source location"))) diff --git a/legacy/stklos/vars.stk b/legacy/stklos/vars.stk new file mode 100644 index 0000000..1c875f8 --- /dev/null +++ b/legacy/stklos/vars.stk @@ -0,0 +1,82 @@ +;;;; +;;;; vars.stk -- Skribe Globals +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 11-Aug-2003 16:18 (eg) +;;;; Last file update: 26-Feb-2004 20:36 (eg) +;;;; + + +;;; +;;; Switches +;;; +(define *skribe-verbose* 0) +(define *skribe-warning* 5) +(define *load-rc* #t) + +;;; +;;; PATH variables +;;; +(define *skribe-path* #f) +(define *skribe-bib-path* '(".")) +(define *skribe-source-path* '(".")) +(define *skribe-image-path* '(".")) + + +(define *skribe-rc-directory* + (make-path (getenv "HOME") ".skribe")) + + +;;; +;;; In and out ports +;;; +(define *skribe-src* '()) +(define *skribe-dest* #f) + +;;; +;;; Engine +;;; +(define *skribe-engine* 'html) ;; Use HTML by default + +;;; +;;; Misc +;;; +(define *skribe-chapter-split* '()) +(define *skribe-ref-base* #f) +(define *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter +(define *skribe-variants* '()) + + + + +;;; Forward definitions (to avoid warnings when compiling Skribe) +;;; This is a KLUDGE. +(define mark #f) +(define ref #f) +;;(define invoke 3) +(define lookup-markup-writer #f) + +(define-module SKRIBE-ENGINE-MODULE + (define find-engine #f)) + +(define-module SKRIBE-OUTPUT-MODULE) + +(define-module SKRIBE-RUNTIME-MODULE) diff --git a/legacy/stklos/verify.stk b/legacy/stklos/verify.stk new file mode 100644 index 0000000..da9b132 --- /dev/null +++ b/legacy/stklos/verify.stk @@ -0,0 +1,157 @@ +;;;; +;;;; verify.stk -- Skribe Verification Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 ) e) + obj) + +;;; PAIR +(define-method verify ((obj ) e) + (for-each (lambda (x) (verify x e)) obj) + obj) + +;;; PROCESSOR +(define-method verify ((obj ) e) + (let ((combinator (slot-ref obj 'combinator)) + (engine (slot-ref obj 'engine)) + (body (slot-ref obj 'body))) + (verify body (processor-get-engine combinator engine e)) + obj)) + +;;; NODE +(define-method verify ((node ) e) + ;; Verify body + (verify (slot-ref node 'body) e) + ;; Verify options + (for-each (lambda (o) (verify (cadr o) e)) + (slot-ref node 'options)) + node) + +;;; MARKUP +(define-method verify ((node ) e) + (with-debug 5 'verify:: + (debug-item "node=" (markup-markup node)) + (debug-item "options=" (slot-ref node 'options)) + (debug-item "e=" (engine-ident e)) + + (next-method) + + (let ((w (lookup-markup-writer node e))) + (when (writer? w) + (check-required-options node w e) + (when (pair? (writer-options w)) + (check-options (slot-ref w 'options) node e)) + (let ((validate (slot-ref w 'validate))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format "Node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)))))))) + node)) + + +;;; DOCUMENT +(define-method verify ((node ) e) + (next-method) + + ;; verify the engine customs + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (slot-ref e 'customs)) + + node) + + +) + diff --git a/legacy/stklos/writer.stk b/legacy/stklos/writer.stk new file mode 100644 index 0000000..2b0f91c --- /dev/null +++ b/legacy/stklos/writer.stk @@ -0,0 +1,211 @@ +;;;; +;;;; writer.stk -- Skribe Writer Stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 15-Sep-2003 22:21 (eg) +;;;; Last file update: 4-Mar-2004 10:48 (eg) +;;;; + + +(define-module SKRIBE-WRITER-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-OUTPUT-MODULE) + (export invoke markup-writer markup-writer-get markup-writer-get* + lookup-markup-writer copy-markup-writer) + +;;;; ====================================================================== +;;;; +;;;; INVOKE +;;;; +;;;; ====================================================================== +(define (invoke proc node e) + (with-debug 5 'invoke + (debug-item "e=" (engine-ident e)) + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))) + + +;;;; ====================================================================== +;;;; +;;;; LOOKUP-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (lookup-markup-writer node e) + (let ((writers (slot-ref e 'writers)) + (delegate (slot-ref e 'delegate))) + (let Loop ((w* writers)) + (cond + ((pair? w*) + (let ((pred (slot-ref (car w*) 'pred))) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;;;; ====================================================================== +;;;; +;;;; MAKE-WRITER-PREDICATE +;;;; +;;;; ====================================================================== +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (eq? (%procedure-arity predicate) 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (markup-writer markup :optional engine + :key (predicate #f) (class #f) (options '()) + (validate #f) + (before #f) (action 'unspecified) (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action 'unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action 'unspecified) + (lambda (n e) (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET +;;;; +;;;; ====================================================================== +(define (markup-writer-get markup :optional engine :key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer-get "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer-get "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (slot-ref e 'writers))) + (cond + ((pair? w*) + (if (and (eq? (writer-ident (car w*)) markup) + (equal? (writer-class (car w*)) class) + (or (unspecified? pred) + (eq? (slot-ref (car w*) 'upred) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate))) + (else + #f)))))))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET* +;;;; +;;;; ====================================================================== + +;; Finds all writers that matches MARKUP with optional CLASS attribute. + +(define (markup-writer-get* markup #!optional engine #!key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (slot-ref e 'writers)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (slot-ref (car w*) 'ident) markup) + (equal? (slot-ref (car w*) 'class) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate) res)) + (else + (reverse! res))))))))) + +;;; ====================================================================== +;;;; +;;;; COPY-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (copy-markup-writer markup old-engine :optional new-engine + :key (predicate 'unspecified) + (class 'unspecified) + (options 'unspecified) + (validate 'unspecified) + (before 'unspecified) + (action 'unspecified) + (after 'unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate) + :class (if (unspecified? class) (slot-ref old 'class) class) + :options (if (unspecified? options) (slot-ref old 'options) options) + :validate (if (unspecified? validate) (slot-ref old 'validate) validate) + :before (if (unspecified? before) (slot-ref old 'before) before) + :action (if (unspecified? action) (slot-ref old 'action) action) + :after (if (unspecified? after) (slot-ref old 'after) after)))) + +) diff --git a/legacy/stklos/xml-lex.l b/legacy/stklos/xml-lex.l new file mode 100644 index 0000000..5d9a8d9 --- /dev/null +++ b/legacy/stklos/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 21-Dec-2003 22:38 (eg) +;;;; + +space [ \n\9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +'[^']*' (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<> 'eof +<> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + + \ No newline at end of file diff --git a/legacy/stklos/xml.stk b/legacy/stklos/xml.stk new file mode 100644 index 0000000..47dd46f --- /dev/null +++ b/legacy/stklos/xml.stk @@ -0,0 +1,52 @@ +;;;; +;;;; xml.stk -- XML Fontification stuff +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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))) +) diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index 09e96d5..0000000 --- a/src/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:15:57 2003 */ -#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The meta Makefile for the sources */ -#*=====================================================================*/ -include ../etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo src/Makefile - @ (cd bigloo && $(MAKE) pop) - @ (cd stklos && $(MAKE) pop) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - (cd $(SYSTEM) && $(MAKE) install) - -uninstall: - (cd $(SYSTEM) && $(MAKE) uninstall) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - (cd $(SYSTEM) && $(MAKE) clean) - diff --git a/src/bigloo/Makefile b/src/bigloo/Makefile deleted file mode 100644 index 02d2b6a..0000000 --- a/src/bigloo/Makefile +++ /dev/null @@ -1,271 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/bigloo/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Mon Jul 21 18:21:11 2003 */ -#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Bigloo API */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* General inclusion */ -#*---------------------------------------------------------------------*/ -include ../../etc/bigloo/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compilers and tools */ -#*---------------------------------------------------------------------*/ -BSKBFLAGS = -I $(SRCDIR)/bigloo - -#*---------------------------------------------------------------------*/ -#* Targets ... */ -#*---------------------------------------------------------------------*/ -PROJECT = skribe -CTARGET = $(SKRIBEBINDIR)/skribe.bigloo -JVMTARGET = $(SKRIBEBINDIR)/skribe.zip - -PBASE = bigloo.$(PROJECT) -ODIR = o -CLASSDIR = class_s/bigloo/$(PROJECT) -OBJDIR = obj/bigloo/$(PROJECT) - -#*---------------------------------------------------------------------*/ -#* Objects */ -#*---------------------------------------------------------------------*/ -SRCDIR = .. -SKRIBECOMMON = param api bib index lib sui -SKRIBEBGL = types parseargs main eval evapi \ - output resolve verify debug read prog source \ - lisp xml c asm engine writer color -SKRIBEINCLUDE = api new debug - -MODULES = $(SKRIBEBGL:%=%.scm) \ - $(SKRIBECOMMON:%=%.bgl) \ - configure.bgl -INCLUDES = $(SKRIBEINCLUDE:%=%.sch) -SOURCES = $(MODULES) \ - $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ - $(SRCDIR)/common/configure.scm \ - $(INCLUDES) -OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure -COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) -JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) - -#*---------------------------------------------------------------------*/ -#* Population */ -#*---------------------------------------------------------------------*/ -POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile -POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .scm .bgl .class .o .obj - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -.PHONY: c jvm dotnet - -all: $(TARGET) - -c: $(CTARGET) -jvm: $(JVMTARGET) -dotnet: - echo "Not implemented yet" - -#*--- c ---------------------------------------------------------------*/ -$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) - $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) - -#*--- jvm -------------------------------------------------------------*/ -$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) - $(RM) -f $(JVMTARGET) - (cd $(ODIR)/class_s && \ - $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) - -$(SKRIBEBINDIR): - mkdir -p $(SKRIBEBINDIR) - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATIONSCM:%=src/common/%) - @ echo $(POPULATIONBGL:%=src/bigloo/%) - -#*---------------------------------------------------------------------*/ -#* ude */ -#*---------------------------------------------------------------------*/ -.PHONY: ude .etags .afile - -ude: - @ $(MAKE) -f Makefile .afile .etags dep - -.afile: - @ $(AFILE) -o .afile $(MODULES) - -.jfile: - @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) - -.etags: - @ $(BTAGS) -o .etags $(SOURCES) - -dep: - @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ - head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) - @ $(BDEPEND) -search-path ../common \ - -search-path ../bigloo \ - -strict-obj-dir $(ODIR) \ - -strict-class-dir $(CLASSDIR) \ - -fno-mco $(SOURCES) >> /tmp/Makefile.aux - @ mv /tmp/Makefile.aux Makefile - -getbinary: - @ echo $(PROJECT) - -getsources: - @ echo $(SOURCES) - -#*---------------------------------------------------------------------*/ -#* The implicit rules */ -#*---------------------------------------------------------------------*/ -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ - $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(OBJDIR)/%.obj: src/%.scm - $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ - -#*---------------------------------------------------------------------*/ -#* Ad hoc rules */ -#*---------------------------------------------------------------------*/ -$(ODIR): - mkdir -p $(ODIR) - -$(CLASSDIR): - mkdir -p $(CLASSDIR) - -$(OBJDIR): - mkdir -p $(OBJDIR) - - -#*---------------------------------------------------------------------*/ -#* install/uninstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm - -install: - $(MAKE) install-$(TARGET) - -uninstall: - $(MAKE) uninstall-$(TARGET) - -install-c: $(DESTDIR)$(INSTALL_BINDIR) - cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe - -uninstall-c: - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - -install-jvm: $(DESTDIR)$(INSTALL_FILDIR) - cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) - -uninstall-jvm: - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip - -$(DESTDIR)$(INSTALL_BINDIR): - mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) - -$(DESTDIR)$(INSTALL_FILDIR): - mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -clean: - $(RM) -f .afile - $(RM) -f .jfile - $(RM) -rf $(ODIR) - $(RM) -f $(CTARGET) - $(RM) -f $(JVMTARGET) - -#*---------------------------------------------------------------------*/ -#* Cleanall */ -#*---------------------------------------------------------------------*/ -cleanall: clean - -#*---------------------------------------------------------------------*/ -#* Manual dependency */ -#*---------------------------------------------------------------------*/ -o/eval.o o/class/bigloo/skribe/eval.class: \ - $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm - -#bdepend start (don't edit) -#*---------------------------------------------------------------------*/ -#* Dependencies ... */ -#*---------------------------------------------------------------------*/ -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch - -#bdepend stop diff --git a/src/bigloo/api.bgl b/src/bigloo/api.bgl deleted file mode 100644 index 55493b0..0000000 --- a/src/bigloo/api.bgl +++ /dev/null @@ -1,117 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:21:34 2003 */ -;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo header for the API. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../common/api.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_api - - (include "new.sch" - "api.sch") - - (import skribe_param - skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_bib - skribe_index - skribe_prog - skribe_source - skribe_engine - skribe_color - skribe_sui) - - (export (include string) - - (document::%markup . opts) - (author::%markup . opts) - (toc::%markup . opts) - - (chapter::%markup . opts) - (section::%markup . opts) - (subsection::%markup . opts) - (subsubsection::%markup . opts) - (paragraph::%markup . opts) - - (footnote::%markup . opts) - - (linebreak . opts) - (hrule::%markup . opts) - - (color::%markup . opts) - (frame::%markup . opts) - (font::%markup . opts) - - (flush::%markup . opts) - (center::%markup . opts) - (pre::%markup . opts) - (prog::%markup . opts) - (source::obj . opts) - (language::obj . opts) - - (itemize::%markup . opts) - (enumerate::%markup . opts) - (description::%markup . opts) - (item::%markup . opts) - - (figure::%markup . opts) - - (table::%markup . opts) - (tr::%markup . opts) - (td::%markup . opts) - (th::%markup . opts) - - (image::%markup . opts) - - (blockquote::%markup . opts) - - (roman::%markup . opts) - (bold::%markup . opts) - (underline::%markup . opts) - (strike::%markup . opts) - (emph::%markup . opts) - (kbd::%markup . opts) - (it::%markup . opts) - (tt::%markup . opts) - (code::%markup . opts) - (var::%markup . opts) - (samp::%markup . opts) - (sf::%markup . opts) - (sc::%markup . opts) - (sub::%markup . opts) - (sup::%markup . opts) - - (mailto::%markup . opts) - (mark::%markup . opts) - - (handle . obj) - (ref::%ast . obj) - (resolve::%ast ::procedure) - - (bibliography . files) - (the-bibliography . opts) - - (make-index ::bstring) - (index . args) - (the-index . args) - - (char::bstring char) - (symbol::%markup symbol) - (!::%command string . args) - - (processor::%processor . opts) - - (html-processor::%processor . opts) - (tex-processor::%processor . opts))) diff --git a/src/bigloo/api.sch b/src/bigloo/api.sch deleted file mode 100644 index 390b8fa..0000000 --- a/src/bigloo/api.sch +++ /dev/null @@ -1,91 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:15:25 2003 */ -;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo macros for the API implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* define-pervasive-macro ... */ -;*---------------------------------------------------------------------*/ -(define-macro (define-pervasive-macro proto . body) - `(begin - (eval '(define-macro ,proto ,@body)) - (define-macro ,proto ,@body))) - -;*---------------------------------------------------------------------*/ -;* define-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-markup proto . body) - (define (s2k symbol) - (string->keyword (string-append ":" (symbol->string symbol)))) - (if (not (pair? proto)) - (error 'define-markup "Illegal markup definition" proto) - (let* ((id (car proto)) - (args (cdr proto)) - (dargs (dsssl-formals->scheme-formals args error))) - `(begin - ,(if (and (memq #!key args) - (memq '&skribe-eval-location args)) - `(define-expander ,id - (lambda (x e) - (append - (cons ',id (map (lambda (x) (e x e)) (cdr x))) - (list :&skribe-eval-location - '(skribe-eval-location))))) - #unspecified) - (define ,(cons id dargs) - ,(make-dsssl-function-prelude proto - args `(begin ,@body) - error s2k)))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-markup markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new markup - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-container ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-container markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new container - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-processor-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-processor-markup proc) - `(define-markup (,proc #!rest opts) - (new processor - (engine (find-engine ',proc)) - (body (the-body opts)) - (options (the-options opts))))) - -;*---------------------------------------------------------------------*/ -;* new (at runtime) */ -;*---------------------------------------------------------------------*/ -(eval '(define-macro (new id . inits) - (cons (symbol-append 'new- id) - (map (lambda (i) - (list 'list (list 'quote (car i)) (cadr i))) - inits)))) diff --git a/src/bigloo/asm.scm b/src/bigloo/asm.scm deleted file mode 100644 index 03196ac..0000000 --- a/src/bigloo/asm.scm +++ /dev/null @@ -1,99 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* ASM fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_asm - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export asm)) - -;*---------------------------------------------------------------------*/ -;* asm ... */ -;*---------------------------------------------------------------------*/ -(define asm - (new language - (name "asm") - (fontifier asm-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* asm-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (asm-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "#" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((: (* (in #\tab #\space)) - (+ (out #\: #\Space #\Tab #\Newline)) #\:) - ;; labels - (let ((c (new markup - (markup '&source-define) - (body (the-string))))) - (cons c (ignore)))) - ((or (in "<>=!/\\+*-([])") - #\/ - (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(asm)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/src/bigloo/bib.bgl b/src/bigloo/bib.bgl deleted file mode 100644 index 6b0f7dd..0000000 --- a/src/bigloo/bib.bgl +++ /dev/null @@ -1,161 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../common/bib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_bib - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_read) - - (export (bib-table?::bool ::obj) - (make-bib-table ::bstring) - (default-bib-table) - (bib-load! ::obj ::bstring ::obj) - (bib-add! ::obj . entries) - (resolve-bib ::obj ::obj) - (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) - (bib-sort/authors::pair-nil ::pair-nil) - (bib-sort/idents::pair-nil ::pair-nil) - (bib-sort/dates::pair-nil ::pair-nil))) - -;*---------------------------------------------------------------------*/ -;* bib-table? ... */ -;*---------------------------------------------------------------------*/ -(define (bib-table? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *bib-table* ... */ -;*---------------------------------------------------------------------*/ -(define *bib-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (default-bib-table) - (if (not *bib-table*) - (set! *bib-table* (make-bib-table "default-bib-table"))) - *bib-table*) - -;*---------------------------------------------------------------------*/ -;* bib-parse-error ... */ -;*---------------------------------------------------------------------*/ -(define (bib-parse-error entry) - (if (epair? entry) - (match-case (cer entry) - ((at ?fname ?pos ?-) - (error/location "parse-biblio" - "bibliography syntax error" - entry - fname - pos)) - (else - (error 'bib-parse "bibliography syntax error" entry))) - (error 'bib-parse "bibliography syntax error" entry))) - -;*---------------------------------------------------------------------*/ -;* bib-duplicate ... */ -;*---------------------------------------------------------------------*/ -(define (bib-duplicate ident from old) - (let ((ofrom (markup-option old 'from))) - (skribe-warning 2 - 'bib - (format "Duplicated bibliographic entry ~a'.\n" ident) - (if ofrom - (format " Using version of `~a'.\n" ofrom) - "") - (if from - (format " Ignoring version of `~a'." from) - " Ignoring redefinition.")))) - -;*---------------------------------------------------------------------*/ -;* parse-bib ... */ -;*---------------------------------------------------------------------*/ -(define (parse-bib table port) - (if (not (bib-table? table)) - (skribe-error 'parse-bib "Illegal bibliography table" table) - (let ((from (input-port-name port))) - (let loop ((entry (skribe-read port))) - (if (not (eof-object? entry)) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (else - (bib-parse-error entry)))))))) - -;*---------------------------------------------------------------------*/ -;* bib-add! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-add! table . entries) - (if (not (bib-table? table)) - (skribe-error 'bib-add! "Illegal bibliography table" table) - (for-each (lambda (entry) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (else - (bib-parse-error entry)))) - entries))) - - - diff --git a/src/bigloo/c.scm b/src/bigloo/c.scm deleted file mode 100644 index 07290ce..0000000 --- a/src/bigloo/c.scm +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/c.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Thu May 27 10:11:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* C fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_c - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export C)) - -;*---------------------------------------------------------------------*/ -;* C stamps */ -;*---------------------------------------------------------------------*/ -(define *keyword* (gensym)) -(define *cpp* (gensym)) - -;*---------------------------------------------------------------------*/ -;* C keywords */ -;*---------------------------------------------------------------------*/ -(for-each (lambda (symbol) - (putprop! symbol *keyword* #t)) - '(for class template while return try catch break continue - do if else typedef struct union goto switch case - static extern default finally throw)) -(let ((sharp (string->symbol "#"))) - (for-each (lambda (symbol) - (putprop! (symbol-append sharp symbol) *cpp* #t)) - '(include define if ifdef ifdef else endif))) - -;*---------------------------------------------------------------------*/ -;* C ... */ -;*---------------------------------------------------------------------*/ -(define C - (new language - (name "C") - (fontifier c-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* c-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (c-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-line-comment) - (body s)))) - str) - (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((in "{}") - ;; brackets - (let ((str (the-string))) - (let ((c (new markup - (markup '&source-bracket) - (body (the-string))))) - (cons c (ignore))))) - ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) - ;; keywords - (let* ((string (the-string)) - (symbol (the-symbol))) - (cond - ((getprop symbol *keyword*) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((getprop symbol *cpp*) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons string (ignore)))))) - ((in "<>=!/\\+*-([])") - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(C)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/src/bigloo/color.scm b/src/bigloo/color.scm deleted file mode 100644 index e481d65..0000000 --- a/src/bigloo/color.scm +++ /dev/null @@ -1,702 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/color.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Apr 10 13:46:50 2002 */ -;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Tex color manager */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_color - (import skribe_configure) - (export (skribe-color->rgb ::obj) - (skribe-get-used-colors) - (skribe-use-color! color))) - -;*---------------------------------------------------------------------*/ -;* *skribe-rgb-string* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-rgb-string* - "255 250 250 snow -248 248 255 ghostwhite -245 245 245 whitesmoke -220 220 220 gainsboro -255 250 240 floralwhite -253 245 230 oldlace -250 240 230 linen -250 235 215 antiquewhite -255 239 213 papayawhip -255 235 205 blanchedalmond -255 228 196 bisque -255 218 185 peachpuff -255 222 173 navajowhite -255 228 181 moccasin -255 248 220 cornsilk -255 255 240 ivory -255 250 205 lemonchiffon -255 245 238 seashell -240 255 240 honeydew -245 255 250 mintcream -240 255 255 azure -240 248 255 aliceblue -230 230 250 lavender -255 240 245 lavenderblush -255 228 225 mistyrose -255 255 255 white -0 0 0 black -47 79 79 darkslategrey -105 105 105 dimgrey -112 128 144 slategrey -119 136 153 lightslategrey -190 190 190 grey -211 211 211 lightgrey -25 25 112 midnightblue -0 0 128 navy -0 0 128 navyblue -100 149 237 cornflowerblue -72 61 139 darkslateblue -106 90 205 slateblue -123 104 238 mediumslateblue -132 112 255 lightslateblue -0 0 205 mediumblue -65 105 225 royalblue -0 0 255 blue -30 144 255 dodgerblue -0 191 255 deepskyblue -135 206 235 skyblue -135 206 250 lightskyblue -70 130 180 steelblue -176 196 222 lightsteelblue -173 216 230 lightblue -176 224 230 powderblue -175 238 238 paleturquoise -0 206 209 darkturquoise -72 209 204 mediumturquoise -64 224 208 turquoise -0 255 255 cyan -224 255 255 lightcyan -95 158 160 cadetblue -102 205 170 mediumaquamarine -127 255 212 aquamarine -0 100 0 darkgreen -85 107 47 darkolivegreen -143 188 143 darkseagreen -46 139 87 seagreen -60 179 113 mediumseagreen -32 178 170 lightseagreen -152 251 152 palegreen -0 255 127 springgreen -124 252 0 lawngreen -0 255 0 green -127 255 0 chartreuse -0 250 154 mediumspringgreen -173 255 47 greenyellow -50 205 50 limegreen -154 205 50 yellowgreen -34 139 34 forestgreen -107 142 35 olivedrab -189 183 107 darkkhaki -240 230 140 khaki -238 232 170 palegoldenrod -250 250 210 lightgoldenrodyellow -255 255 224 lightyellow -255 255 0 yellow -255 215 0 gold -238 221 130 lightgoldenrod -218 165 32 goldenrod -184 134 11 darkgoldenrod -188 143 143 rosybrown -205 92 92 indianred -139 69 19 saddlebrown -160 82 45 sienna -205 133 63 peru -222 184 135 burlywood -245 245 220 beige -245 222 179 wheat -244 164 96 sandybrown -210 180 140 tan -210 105 30 chocolate -178 34 34 firebrick -165 42 42 brown -233 150 122 darksalmon -250 128 114 salmon -255 160 122 lightsalmon -255 165 0 orange -255 140 0 darkorange -255 127 80 coral -240 128 128 lightcoral -255 99 71 tomato -255 69 0 orangered -255 0 0 red -255 105 180 hotpink -255 20 147 deeppink -255 192 203 pink -255 182 193 lightpink -219 112 147 palevioletred -176 48 96 maroon -199 21 133 mediumvioletred -208 32 144 violetred -255 0 255 magenta -238 130 238 violet -221 160 221 plum -218 112 214 orchid -186 85 211 mediumorchid -153 50 204 darkorchid -148 0 211 darkviolet -138 43 226 blueviolet -160 32 240 purple -147 112 219 mediumpurple -216 191 216 thistle -255 250 250 snow1 -238 233 233 snow2 -205 201 201 snow3 -139 137 137 snow4 -255 245 238 seashell1 -238 229 222 seashell2 -205 197 191 seashell3 -139 134 130 seashell4 -255 239 219 antiquewhite1 -238 223 204 antiquewhite2 -205 192 176 antiquewhite3 -139 131 120 antiquewhite4 -255 228 196 bisque1 -238 213 183 bisque2 -205 183 158 bisque3 -139 125 107 bisque4 -255 218 185 peachpuff1 -238 203 173 peachpuff2 -205 175 149 peachpuff3 -139 119 101 peachpuff4 -255 222 173 navajowhite1 -238 207 161 navajowhite2 -205 179 139 navajowhite3 -139 121 94 navajowhite4 -255 250 205 lemonchiffon1 -238 233 191 lemonchiffon2 -205 201 165 lemonchiffon3 -139 137 112 lemonchiffon4 -255 248 220 cornsilk1 -238 232 205 cornsilk2 -205 200 177 cornsilk3 -139 136 120 cornsilk4 -255 255 240 ivory1 -238 238 224 ivory2 -205 205 193 ivory3 -139 139 131 ivory4 -240 255 240 honeydew1 -224 238 224 honeydew2 -193 205 193 honeydew3 -131 139 131 honeydew4 -255 240 245 lavenderblush1 -238 224 229 lavenderblush2 -205 193 197 lavenderblush3 -139 131 134 lavenderblush4 -255 228 225 mistyrose1 -238 213 210 mistyrose2 -205 183 181 mistyrose3 -139 125 123 mistyrose4 -240 255 255 azure1 -224 238 238 azure2 -193 205 205 azure3 -131 139 139 azure4 -131 111 255 slateblue1 -122 103 238 slateblue2 -105 89 205 slateblue3 -71 60 139 slateblue4 -72 118 255 royalblue1 -67 110 238 royalblue2 -58 95 205 royalblue3 -39 64 139 royalblue4 -0 0 255 blue1 -0 0 238 blue2 -0 0 205 blue3 -0 0 139 blue4 -30 144 255 dodgerblue1 -28 134 238 dodgerblue2 -24 116 205 dodgerblue3 -16 78 139 dodgerblue4 -99 184 255 steelblue1 -92 172 238 steelblue2 -79 148 205 steelblue3 -54 100 139 steelblue4 -0 191 255 deepskyblue1 -0 178 238 deepskyblue2 -0 154 205 deepskyblue3 -0 104 139 deepskyblue4 -135 206 255 skyblue1 -126 192 238 skyblue2 -108 166 205 skyblue3 -74 112 139 skyblue4 -176 226 255 lightskyblue1 -164 211 238 lightskyblue2 -141 182 205 lightskyblue3 -96 123 139 lightskyblue4 -202 225 255 lightsteelblue1 -188 210 238 lightsteelblue2 -162 181 205 lightsteelblue3 -110 123 139 lightsteelblue4 -191 239 255 lightblue1 -178 223 238 lightblue2 -154 192 205 lightblue3 -104 131 139 lightblue4 -224 255 255 lightcyan1 -209 238 238 lightcyan2 -180 205 205 lightcyan3 -122 139 139 lightcyan4 -187 255 255 paleturquoise1 -174 238 238 paleturquoise2 -150 205 205 paleturquoise3 -102 139 139 paleturquoise4 -152 245 255 cadetblue1 -142 229 238 cadetblue2 -122 197 205 cadetblue3 -83 134 139 cadetblue4 -0 245 255 turquoise1 -0 229 238 turquoise2 -0 197 205 turquoise3 -0 134 139 turquoise4 -0 255 255 cyan1 -0 238 238 cyan2 -0 205 205 cyan3 -0 139 139 cyan4 -127 255 212 aquamarine1 -118 238 198 aquamarine2 -102 205 170 aquamarine3 -69 139 116 aquamarine4 -193 255 193 darkseagreen1 -180 238 180 darkseagreen2 -155 205 155 darkseagreen3 -105 139 105 darkseagreen4 -84 255 159 seagreen1 -78 238 148 seagreen2 -67 205 128 seagreen3 -46 139 87 seagreen4 -154 255 154 palegreen1 -144 238 144 palegreen2 -124 205 124 palegreen3 -84 139 84 palegreen4 -0 255 127 springgreen1 -0 238 118 springgreen2 -0 205 102 springgreen3 -0 139 69 springgreen4 -0 255 0 green1 -0 238 0 green2 -0 205 0 green3 -0 139 0 green4 -127 255 0 chartreuse1 -118 238 0 chartreuse2 -102 205 0 chartreuse3 -69 139 0 chartreuse4 -192 255 62 olivedrab1 -179 238 58 olivedrab2 -154 205 50 olivedrab3 -105 139 34 olivedrab4 -202 255 112 darkolivegreen1 -188 238 104 darkolivegreen2 -162 205 90 darkolivegreen3 -110 139 61 darkolivegreen4 -255 246 143 khaki1 -238 230 133 khaki2 -205 198 115 khaki3 -139 134 78 khaki4 -255 236 139 lightgoldenrod1 -238 220 130 lightgoldenrod2 -205 190 112 lightgoldenrod3 -139 129 76 lightgoldenrod4 -255 255 224 lightyellow1 -238 238 209 lightyellow2 -205 205 180 lightyellow3 -139 139 122 lightyellow4 -255 255 0 yellow1 -238 238 0 yellow2 -205 205 0 yellow3 -139 139 0 yellow4 -255 215 0 gold1 -238 201 0 gold2 -205 173 0 gold3 -139 117 0 gold4 -255 193 37 goldenrod1 -238 180 34 goldenrod2 -205 155 29 goldenrod3 -139 105 20 goldenrod4 -255 185 15 darkgoldenrod1 -238 173 14 darkgoldenrod2 -205 149 12 darkgoldenrod3 -139 101 8 darkgoldenrod4 -255 193 193 rosybrown1 -238 180 180 rosybrown2 -205 155 155 rosybrown3 -139 105 105 rosybrown4 -255 106 106 indianred1 -238 99 99 indianred2 -205 85 85 indianred3 -139 58 58 indianred4 -255 130 71 sienna1 -238 121 66 sienna2 -205 104 57 sienna3 -139 71 38 sienna4 -255 211 155 burlywood1 -238 197 145 burlywood2 -205 170 125 burlywood3 -139 115 85 burlywood4 -255 231 186 wheat1 -238 216 174 wheat2 -205 186 150 wheat3 -139 126 102 wheat4 -255 165 79 tan1 -238 154 73 tan2 -205 133 63 tan3 -139 90 43 tan4 -255 127 36 chocolate1 -238 118 33 chocolate2 -205 102 29 chocolate3 -139 69 19 chocolate4 -255 48 48 firebrick1 -238 44 44 firebrick2 -205 38 38 firebrick3 -139 26 26 firebrick4 -255 64 64 brown1 -238 59 59 brown2 -205 51 51 brown3 -139 35 35 brown4 -255 140 105 salmon1 -238 130 98 salmon2 -205 112 84 salmon3 -139 76 57 salmon4 -255 160 122 lightsalmon1 -238 149 114 lightsalmon2 -205 129 98 lightsalmon3 -139 87 66 lightsalmon4 -255 165 0 orange1 -238 154 0 orange2 -205 133 0 orange3 -139 90 0 orange4 -255 127 0 darkorange1 -238 118 0 darkorange2 -205 102 0 darkorange3 -139 69 0 darkorange4 -255 114 86 coral1 -238 106 80 coral2 -205 91 69 coral3 -139 62 47 coral4 -255 99 71 tomato1 -238 92 66 tomato2 -205 79 57 tomato3 -139 54 38 tomato4 -255 69 0 orangered1 -238 64 0 orangered2 -205 55 0 orangered3 -139 37 0 orangered4 -255 0 0 red1 -238 0 0 red2 -205 0 0 red3 -139 0 0 red4 -255 20 147 deeppink1 -238 18 137 deeppink2 -205 16 118 deeppink3 -139 10 80 deeppink4 -255 110 180 hotpink1 -238 106 167 hotpink2 -205 96 144 hotpink3 -139 58 98 hotpink4 -255 181 197 pink1 -238 169 184 pink2 -205 145 158 pink3 -139 99 108 pink4 -255 174 185 lightpink1 -238 162 173 lightpink2 -205 140 149 lightpink3 -139 95 101 lightpink4 -255 130 171 palevioletred1 -238 121 159 palevioletred2 -205 104 137 palevioletred3 -139 71 93 palevioletred4 -255 52 179 maroon1 -238 48 167 maroon2 -205 41 144 maroon3 -139 28 98 maroon4 -255 62 150 violetred1 -238 58 140 violetred2 -205 50 120 violetred3 -139 34 82 violetred4 -255 0 255 magenta1 -238 0 238 magenta2 -205 0 205 magenta3 -139 0 139 magenta4 -255 131 250 orchid1 -238 122 233 orchid2 -205 105 201 orchid3 -139 71 137 orchid4 -255 187 255 plum1 -238 174 238 plum2 -205 150 205 plum3 -139 102 139 plum4 -224 102 255 mediumorchid1 -209 95 238 mediumorchid2 -180 82 205 mediumorchid3 -122 55 139 mediumorchid4 -191 62 255 darkorchid1 -178 58 238 darkorchid2 -154 50 205 darkorchid3 -104 34 139 darkorchid4 -155 48 255 purple1 -145 44 238 purple2 -125 38 205 purple3 -85 26 139 purple4 -171 130 255 mediumpurple1 -159 121 238 mediumpurple2 -137 104 205 mediumpurple3 -93 71 139 mediumpurple4 -255 225 255 thistle1 -238 210 238 thistle2 -205 181 205 thistle3 -139 123 139 thistle4 -0 0 0 grey0 -3 3 3 grey1 -5 5 5 grey2 -8 8 8 grey3 -10 10 10 grey4 -13 13 13 grey5 -15 15 15 grey6 -18 18 18 grey7 -20 20 20 grey8 -23 23 23 grey9 -26 26 26 grey10 -28 28 28 grey11 -31 31 31 grey12 -33 33 33 grey13 -36 36 36 grey14 -38 38 38 grey15 -41 41 41 grey16 -43 43 43 grey17 -46 46 46 grey18 -48 48 48 grey19 -51 51 51 grey20 -54 54 54 grey21 -56 56 56 grey22 -59 59 59 grey23 -61 61 61 grey24 -64 64 64 grey25 -66 66 66 grey26 -69 69 69 grey27 -71 71 71 grey28 -74 74 74 grey29 -77 77 77 grey30 -79 79 79 grey31 -82 82 82 grey32 -84 84 84 grey33 -87 87 87 grey34 -89 89 89 grey35 -92 92 92 grey36 -94 94 94 grey37 -97 97 97 grey38 -99 99 99 grey39 -102 102 102 grey40 -105 105 105 grey41 -107 107 107 grey42 -110 110 110 grey43 -112 112 112 grey44 -115 115 115 grey45 -117 117 117 grey46 -120 120 120 grey47 -122 122 122 grey48 -125 125 125 grey49 -127 127 127 grey50 -130 130 130 grey51 -133 133 133 grey52 -135 135 135 grey53 -138 138 138 grey54 -140 140 140 grey55 -143 143 143 grey56 -145 145 145 grey57 -148 148 148 grey58 -150 150 150 grey59 -153 153 153 grey60 -156 156 156 grey61 -158 158 158 grey62 -161 161 161 grey63 -163 163 163 grey64 -166 166 166 grey65 -168 168 168 grey66 -171 171 171 grey67 -173 173 173 grey68 -176 176 176 grey69 -179 179 179 grey70 -181 181 181 grey71 -184 184 184 grey72 -186 186 186 grey73 -189 189 189 grey74 -191 191 191 grey75 -194 194 194 grey76 -196 196 196 grey77 -199 199 199 grey78 -201 201 201 grey79 -204 204 204 grey80 -207 207 207 grey81 -209 209 209 grey82 -212 212 212 grey83 -214 214 214 grey84 -217 217 217 grey85 -219 219 219 grey86 -222 222 222 grey87 -224 224 224 grey88 -227 227 227 grey89 -229 229 229 grey90 -232 232 232 grey91 -235 235 235 grey92 -237 237 237 grey93 -240 240 240 grey94 -242 242 242 grey95 -245 245 245 grey96 -247 247 247 grey97 -250 250 250 grey98 -252 252 252 grey99 -255 255 255 grey100 -169 169 169 darkgrey -0 0 139 darkblue -0 139 139 darkcyan -139 0 139 darkmagenta -139 0 0 darkred -144 238 144 lightgreen") - -;*---------------------------------------------------------------------*/ -;* *rgb-port* ... */ -;*---------------------------------------------------------------------*/ -(define *rgb-port* #unspecified) - -;*---------------------------------------------------------------------*/ -;* same-color? ... */ -;*---------------------------------------------------------------------*/ -(define (same-color? s1 s2) - (define (skip-rgb s) - (let ((l (string-length s))) - (let loop ((i 0)) - (if (=fx i l) - l - (let ((c (string-ref s i))) - (if (or (char-numeric? c) (char-whitespace? c)) - (loop (+fx i 1)) - i)))))) - (let ((l1 (string-length s1)) - (l2 (string-length s2))) - (if (>fx l1 l2) - (let ((lc (skip-rgb s1))) - (and (=fx (-fx l1 lc) l2) - (let loop ((i1 (-fx l1 l2)) - (i2 0)) - (cond - ((=fx i1 l1) - #t) - ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) - (loop (+fx i1 1) (+fx i2 1))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* rgb-grep ... */ -;*---------------------------------------------------------------------*/ -(define (rgb-grep symbol) - (let ((parser (regular-grammar () - ((bol (: #\! (* all))) - (ignore)) - ((+ #\Newline) - (ignore)) - ((: (* (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ all)) - (let ((s (the-string))) - (if (same-color? s symbol) - (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) - (values (string->number (cadr m)) - (string->number (caddr m)) - (string->number (cadddr m)))) - (ignore)))) - (else - (values 0 0 0))))) - ;; initialization the port reading rgb.txt file - (with-input-from-string *skribe-rgb-string* - (lambda () - (read/rp parser (current-input-port)))))) - -;*---------------------------------------------------------------------*/ -;* *color-parser* ... */ -;*---------------------------------------------------------------------*/ -(define *color-parser* - (regular-grammar ((blank* (* blank)) - (blank+ (+ blank))) - - ;; rgb color - ((: #\# (+ xdigit)) - (let ((val (the-substring 1 (the-length)))) - (cond - ((=fx (string-length val) 6) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 2 4) 16) - (string->integer (substring val 4 6) 16))) - ((=fx (string-length val) 12) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 4 6) 16) - (string->integer (substring val 8 10) 16))) - (else - (values 0 0 0))))) - - ;; symbolic names - ((+ (out #\Newline)) - (let ((name (the-string))) - (cond - ((string-ci=? name "none") - (values 0 0 0)) - ((string-ci=? name "black") - (values 0 0 0)) - ((string-ci=? name "white") - (values #xff #xff #xff)) - (else - (rgb-grep name))))) - - ;; error - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->rgb spec) - (cond - ((string? spec) - (with-input-from-string spec - (lambda () - (read/rp *color-parser* (current-input-port))))) - ((fixnum? spec) - (values (bit-and #xff (bit-rsh spec 16)) - (bit-and #xff (bit-rsh spec 8)) - (bit-and #xff spec))) - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* *used-colors* ... */ -;*---------------------------------------------------------------------*/ -(define *used-colors* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-get-used-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-used-colors) - *used-colors*) - -;*---------------------------------------------------------------------*/ -;* skribe-use-color! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-use-color! color) - (set! *used-colors* (cons color *used-colors*)) - color) diff --git a/src/bigloo/configure.bgl b/src/bigloo/configure.bgl deleted file mode 100644 index e100d8d..0000000 --- a/src/bigloo/configure.bgl +++ /dev/null @@ -1,90 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:42:21 2003 */ -;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The general configuration options. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_configure - (export (skribe-release) - (skribe-url) - (skribe-doc-dir) - (skribe-ext-dir) - (skribe-default-path) - (skribe-scheme) - - (skribe-configure . opt) - (skribe-enforce-configure . opt))) - -;*---------------------------------------------------------------------*/ -;* skribe-configuration ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configuration) - `((:release ,(skribe-release)) - (:scheme ,(skribe-scheme)) - (:url ,(skribe-url)) - (:doc-dir ,(skribe-doc-dir)) - (:ext-dir ,(skribe-ext-dir)) - (:default-path ,(skribe-default-path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configure . opt) - (let ((conf (skribe-configuration))) - (cond - ((null? opt) - conf) - ((null? (cdr opt)) - (let ((cell (assq (car opt) conf))) - (if (pair? cell) - (cadr cell) - 'void))) - (else - (let loop ((opt opt)) - (cond - ((null? opt) - #t) - ((not (keyword? (car opt))) - #f) - ((or (null? (cdr opt)) (keyword? (cadr opt))) - #f) - (else - (let ((cell (assq (car opt) conf))) - (if (and (pair? cell) - (if (procedure? (cadr opt)) - ((cadr opt) (cadr cell)) - (equal? (cadr opt) (cadr cell)))) - (loop (cddr opt)) - #f))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-enforce-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-enforce-configure . opt) - (let loop ((o opt)) - (when (pair? o) - (cond - ((or (not (keyword? (car o))) - (null? (cdr o))) - (error 'skribe-enforce-configure - "Illegal enforcement" - opt)) - ((skribe-configure (car o) (cadr o)) - (loop (cddr o))) - (else - (error 'skribe-enforce-configure - (format "Configuration mismatch: ~a" (car o)) - (if (procedure? (cadr o)) - (format "provided `~a'" - (skribe-configure (car o))) - (format "provided `~a', required `~a'" - (skribe-configure (car o)) - (cadr o))))))))) diff --git a/src/bigloo/debug.sch b/src/bigloo/debug.sch deleted file mode 100644 index 9b53c84..0000000 --- a/src/bigloo/debug.sch +++ /dev/null @@ -1,54 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu May 29 06:46:33 2003 */ -;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* directives */ -;*---------------------------------------------------------------------*/ -(directives - (import skribe_debug)) - -;*---------------------------------------------------------------------*/ -;* when-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (when-debug level . exp) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(if (>= *skribe-debug* ,level) (begin ,@exp)) - #unspecified)) - -;*---------------------------------------------------------------------*/ -;* with-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-debug level lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* with-push-trace ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-push-trace lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - (let ((r (gensym))) - `(let () - (c-push-trace ,lbl) - (let ((,r ,@arg*)) - (c-pop-trace) - ,r))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* debug-item ... */ -;*---------------------------------------------------------------------*/ -(define-expander debug-item - (lambda (x e) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) - #unspecified))) diff --git a/src/bigloo/debug.scm b/src/bigloo/debug.scm deleted file mode 100644 index 8f1691c..0000000 --- a/src/bigloo/debug.scm +++ /dev/null @@ -1,188 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jun 11 10:01:47 2003 */ -;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_debug - - (export *skribe-debug* - *skribe-debug-symbols* - *skribe-debug-color* - - (skribe-debug::int) - (debug-port::output-port . ::obj) - (debug-margin::bstring) - (debug-color::bstring ::int . ::obj) - (debug-bold::bstring . ::obj) - (debug-string ::obj) - (debug-item . ::obj) - - (%with-debug ::obj ::obj ::procedure))) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-symbols* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-symbols* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-color* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-color* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-item* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-item* #f) - -;*---------------------------------------------------------------------*/ -;* *debug-port* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-port* (current-error-port)) - -;*---------------------------------------------------------------------*/ -;* *debug-depth* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-depth* 0) - -;*---------------------------------------------------------------------*/ -;* *debug-margin* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-margin* "") - -;*---------------------------------------------------------------------*/ -;* *skribe-margin-debug-level* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-margin-debug-level* 0) - -;*---------------------------------------------------------------------*/ -;* skribe-debug ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-debug) - *skribe-debug*) - -;*---------------------------------------------------------------------*/ -;* debug-port ... */ -;*---------------------------------------------------------------------*/ -(define (debug-port . o) - (cond - ((null? o) - *debug-port*) - ((output-port? (car o)) - (set! *debug-port* o) - o) - (else - (error 'debug-port "Illegal debug port" (car o))))) - -;*---------------------------------------------------------------------*/ -;* debug-margin ... */ -;*---------------------------------------------------------------------*/ -(define (debug-margin) - *debug-margin*) - -;*---------------------------------------------------------------------*/ -;* debug-color ... */ -;*---------------------------------------------------------------------*/ -(define (debug-color col::int . o) - (with-output-to-string - (if *skribe-debug-color* - (lambda () - (display* "[1;" (+ 31 col) "m") - (apply display* o) - (display "")) - (lambda () - (apply display* o))))) - -;*---------------------------------------------------------------------*/ -;* debug-bold ... */ -;*---------------------------------------------------------------------*/ -(define (debug-bold . o) - (apply debug-color -30 o)) - -;*---------------------------------------------------------------------*/ -;* debug-item ... */ -;*---------------------------------------------------------------------*/ -(define (debug-item . args) - (if (or (>= *skribe-debug* *skribe-margin-debug-level*) - *skribe-debug-item*) - (begin - (display (debug-margin) *debug-port*) - (display (debug-color (-fx *debug-depth* 1) "- ")) - (for-each (lambda (a) (display a *debug-port*)) args) - (newline *debug-port*)))) - -;*---------------------------------------------------------------------*/ -;* %with-debug-margin ... */ -;*---------------------------------------------------------------------*/ -(define (%with-debug-margin margin thunk) - (let ((om *debug-margin*)) - (set! *debug-depth* (+fx *debug-depth* 1)) - (set! *debug-margin* (string-append om margin)) - (let ((res (thunk))) - (set! *debug-depth* (-fx *debug-depth* 1)) - (set! *debug-margin* om) - res))) - -;*---------------------------------------------------------------------*/ -;* %with-debug ... */ -;*---------------------------------------------------------------------*/ -(define (%with-debug lvl lbl thunk) - (let ((ol *skribe-margin-debug-level*) - (oi *skribe-debug-item*)) - (set! *skribe-margin-debug-level* lvl) - (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) - (and (symbol? lbl) - (memq lbl *skribe-debug-symbols*) - (set! *skribe-debug-item* #t))) - (with-output-to-port *debug-port* - (lambda () - (display (debug-margin)) - (display (if (= *debug-depth* 0) - (debug-color *debug-depth* "+ " lbl) - (debug-color *debug-depth* "--+ " lbl))) - (newline) - (%with-debug-margin (debug-color *debug-depth* " |") - thunk))) - (thunk)))) - (set! *skribe-debug-item* oi) - (set! *skribe-margin-debug-level* ol) - r))) - -;*---------------------------------------------------------------------*/ -;* debug-string ... */ -;*---------------------------------------------------------------------*/ -(define (debug-string o) - (with-output-to-string - (lambda () - (write o)))) - -;*---------------------------------------------------------------------*/ -;* example */ -;*---------------------------------------------------------------------*/ -;; (%with-debug 0 'foo1.1 -;; (lambda () -;; (debug-item 'foo2.1) -;; (debug-item 'foo2.2) -;; (%with-debug 0 'foo2.3 -;; (lambda () -;; (debug-item 'foo3.1) -;; (%with-debug 0 'foo3.2 -;; (lambda () -;; (debug-item 'foo4.1) -;; (debug-item 'foo4.2))) -;; (debug-item 'foo3.3))) -;; (debug-item 'foo2.4))) - diff --git a/src/bigloo/engine.scm b/src/bigloo/engine.scm deleted file mode 100644 index bd8a027..0000000 --- a/src/bigloo/engine.scm +++ /dev/null @@ -1,262 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 08:01:30 2003 */ -;* Last change : Fri May 21 16:12:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe engines */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_engine - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output) - - (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) - (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) - (find-engine ::symbol #!key version) - - (default-engine::obj) - (default-engine-set! ::%engine) - (push-default-engine ::%engine) - (pop-default-engine) - - (processor-get-engine ::obj ::obj ::%engine) - - (engine-format? ::bstring . e) - - (engine-custom::obj ::%engine ::symbol) - (engine-custom-set! ::%engine ::symbol ::obj) - - (engine-add-writer! ::%engine ::obj ::procedure ::obj - ::obj ::obj ::obj ::obj ::obj ::obj))) - -;*---------------------------------------------------------------------*/ -;* *engines* ... */ -;*---------------------------------------------------------------------*/ -(define *engines* '()) - -;*---------------------------------------------------------------------*/ -;* *default-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *default-engine* #f) -(define *default-engines* '()) - -;*---------------------------------------------------------------------*/ -;* default-engine-set! ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine-set! e) - (if (not (engine? e)) - (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) - (begin - (set! *default-engine* e) - (set! *default-engines* (cons *default-engine* *default-engines*)) - e))) - -;*---------------------------------------------------------------------*/ -;* default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine) - *default-engine*) - -;*---------------------------------------------------------------------*/ -;* push-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (push-default-engine e) - (set! *default-engines* (cons e *default-engines*)) - (default-engine-set! e)) - -;*---------------------------------------------------------------------*/ -;* pop-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (pop-default-engine) - (if (null? *default-engines*) - (skribe-error 'pop-default-engine "Empty engine stack" '()) - (begin - (set! *default-engines* (cdr *default-engines*)) - (if (pair? *default-engines*) - (default-engine-set! (car *default-engines*)) - (set! *default-engine* #f))))) - -;*---------------------------------------------------------------------*/ -;* processor-get-engine ... */ -;*---------------------------------------------------------------------*/ -(define (processor-get-engine combinator newe olde) - (cond - ((procedure? combinator) - (combinator newe olde)) - ((engine? newe) - newe) - (else - olde))) - -;*---------------------------------------------------------------------*/ -;* engine-format? ... */ -;*---------------------------------------------------------------------*/ -(define (engine-format? fmt . e) - (let ((e (cond - ((pair? e) (car e)) - ((%engine? *skribe-engine*) *skribe-engine*) - (else (find-engine *skribe-engine*))))) - (if (not (%engine? e)) - (skribe-error 'engine-format? "No engine" e) - (string=? fmt (%engine-format e))))) - -;*---------------------------------------------------------------------*/ -;* make-engine ... */ -;*---------------------------------------------------------------------*/ -(define (make-engine ident - #!key - (version #unspecified) - (format "raw") - (filter #f) - (delegate #f) - (symbol-table '()) - (custom '()) - (info '())) - (let ((e (instantiate::%engine - (ident ident) - (version version) - (format format) - (filter filter) - (delegate delegate) - (symbol-table symbol-table) - (customs custom) - (info info)))) - ;; store the engine in the global table - (set! *engines* (cons e *engines*)) - ;; return it - e)) - -;*---------------------------------------------------------------------*/ -;* copy-engine ... */ -;*---------------------------------------------------------------------*/ -(define (copy-engine ident - e - #!key - (version #unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) - (let ((e (duplicate::%engine e - (ident ident) - (version version) - (filter (or filter (%engine-filter e))) - (delegate (or delegate (%engine-delegate e))) - (symbol-table (or symbol-table (%engine-symbol-table e))) - (customs (or custom (%engine-customs e)))))) - (set! *engines* (cons e *engines*)) - e)) - -;*---------------------------------------------------------------------*/ -;* find-loaded-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-loaded-engine id version) - (let loop ((es *engines*)) - (cond - ((null? es) - #f) - ((eq? (%engine-ident (car es)) id) - (cond - ((eq? version #unspecified) - (car es)) - ((eq? version (%engine-version (car es))) - (car es)) - (else - (loop (cdr es))))) - (else - (loop (cdr es)))))) - -;*---------------------------------------------------------------------*/ -;* find-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-engine id #!key (version #unspecified)) - (with-debug 5 'find-engine - (debug-item "id=" id " version=" version) - (or (find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and (pair? c) (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (find-loaded-engine id version)) - #f))))) - -;*---------------------------------------------------------------------*/ -;* engine-custom ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom e id) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (cadr c) - #unspecified)))) - -;*---------------------------------------------------------------------*/ -;* engine-custom-set! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-set! e id val) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (set-car! (cdr c) val) - (set! customs (cons (list id val) customs)))))) - -;*---------------------------------------------------------------------*/ -;* engine-add-writer! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-add-writer! e id pred upred opt before action after class va) - ;; check the arity of a procedure - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error id "Illegal procedure" proc)) - ((not (correct-arity? proc arity)) - (skribe-error id - (string-append "Illegal `" name "'procedure") - proc)))) - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) - ;; check the engine - (if (not (engine? e)) - (skribe-error id "Illegal engine" e)) - ;; check the options - (if (not (or (eq? opt 'all) (list? opt))) - (skribe-error id "Illegal options" opt)) - ;; check the correctness of the predicate and the validator - (check-procedure "predicate" pred 2) - (when va (check-procedure "validate" va 2)) - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - ;; create a new writer... - (let ((n (instantiate::%writer - (ident (if (symbol? id) id 'all)) - (class class) - (pred pred) - (upred upred) - (options opt) - (before before) - (action action) - (after after) - (validate va)))) - ;; ...and bind it - (with-access::%engine e (writers) - (set! writers (cons n writers)) - n))) diff --git a/src/bigloo/eval.scm b/src/bigloo/eval.scm deleted file mode 100644 index b5c6548..0000000 --- a/src/bigloo/eval.scm +++ /dev/null @@ -1,335 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed May 18 15:52:01 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe evaluator */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_eval - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_param - skribe_types - skribe_resolve - skribe_verify - skribe_output - skribe_read - skribe_lib - skribe_engine) - - (export (skribe-eval-location) - (skribe-error ::obj ::obj ::obj) - (skribe-type-error ::obj ::obj ::obj ::bstring) - (skribe-warning ::int . obj) - (skribe-warning/ast ::int ::%ast . obj) - (skribe-message ::bstring . obj) - (skribe-load ::bstring #!rest opt #!key engine path) - (skribe-load-options) - (skribe-include ::bstring . rest) - (skribe-open-bib-file ::bstring ::obj) - (skribe-eval-port ::input-port ::obj #!key env) - (skribe-eval ::obj ::%engine #!key env) - (skribe-path::pair-nil) - (skribe-path-set! ::obj) - (skribe-image-path::pair-nil) - (skribe-image-path-set! ::obj) - (skribe-bib-path::pair-nil) - (skribe-bib-path-set! ::obj) - (skribe-source-path::pair-nil) - (skribe-source-path-set! ::obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-location ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-location) - (evmeaning-location)) - -;*---------------------------------------------------------------------*/ -;* skribe-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-error proc msg obj) - (if (ast? obj) - (skribe-ast-error proc msg obj) - (error/evloc proc msg obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-type-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-type-error proc msg obj etype) - (let ((ty (if (%markup? obj) - (format "~a#~a" (markup-markup obj) (markup-ident obj)) - (find-runtime-type obj)))) - (skribe-error proc - (bigloo-type-error-msg msg etype ty) - obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-ast-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-ast-error proc msg obj) - (let ((l (ast-loc obj)) - (shape (if (%markup? obj) - (%markup-markup obj) - (find-runtime-type obj)))) - (if (location? l) - (error/location proc msg shape (location-file l) (location-pos l)) - (error/evloc proc msg shape)))) - -;*---------------------------------------------------------------------*/ -;* error/evloc ... */ -;*---------------------------------------------------------------------*/ -(define (error/evloc proc msg obj) - (let ((l (evmeaning-location))) - (if (location? l) - (error/location proc msg obj (location-file l) (location-pos l)) - ((begin error) proc msg obj)))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning level . obj) - (if (>= *skribe-warning* level) - (let ((l (evmeaning-location))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply warning obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning/ast ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning/ast level ast . obj) - (if (>= *skribe-warning* level) - (let ((l (%ast-loc ast))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply skribe-warning level obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-message ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-message fmt . obj) - (if (> *skribe-verbose* 0) - (apply fprintf (current-error-port) fmt obj))) - -;*---------------------------------------------------------------------*/ -;* *skribe-loaded* ... */ -;* ------------------------------------------------------------- */ -;* This hash table stores the list of loaded files in order */ -;* to avoid one file to be loaded twice. */ -;*---------------------------------------------------------------------*/ -(define *skribe-loaded* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* *skribe-load-options* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-load-options* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-load ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load file #!rest opt #!key engine path) - (with-debug 4 'skribe-load - (debug-item " engine=" engine) - (debug-item " path=" path) - (debug-item " opt" opt) - (let* ((ei (cond - ((not engine) - *skribe-engine*) - ((engine? engine) - engine) - ((not (symbol? engine)) - (skribe-error 'skribe-load "Illegal engine" engine)) - (else - engine))) - (path (cond - ((not path) - (skribe-path)) - ((string? path) - (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else - path))) - (filep (find-file/path file path))) - (set! *skribe-load-options* opt) - (if (and (string? filep) (file-exists? filep)) - (if (not (hashtable-get *skribe-loaded* filep)) - (begin - (hashtable-put! *skribe-loaded* filep #t) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [loading file: " filep " " opt "]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [loading file: " filep "]"))) - (with-input-from-file filep - (lambda () - (skribe-eval-port (current-input-port) ei))))) - (skribe-error 'skribe-load - (format "Can't find file `~a' in path" file) - path))))) - -;*---------------------------------------------------------------------*/ -;* skribe-load-options ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load-options) - *skribe-load-options*) - -;*---------------------------------------------------------------------*/ -;* evaluate ... */ -;*---------------------------------------------------------------------*/ -(define (evaluate exp) - (try (eval exp) - (lambda (a p m o) - (evmeaning-notify-error p m o) - (flush-output-port (current-error-port))))) - -;*---------------------------------------------------------------------*/ -;* skribe-include ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-include file . rest) - (let* ((path (cond - ((or (null? rest) (null? (cdr rest))) - (skribe-path)) - ((not (every? string? (cdr rest))) - (skribe-error 'skribe-include "Illegal path" (cdr rest))) - (else - (cdr rest)))) - (filep (find-file/path file (if (null? path) (skribe-path) path)))) - (if (and (string? filep) (file-exists? filep)) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [including file: " filep "]")) - (with-input-from-file filep - (lambda () - (let loop ((exp (skribe-read (current-input-port))) - (res '())) - (if (eof-object? exp) - (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (loop (skribe-read (current-input-port)) - (cons (evaluate exp) res))))))) - (skribe-error 'skribe-include - (format "Can't find file `~a 'in path" file) - path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-open-bib-file ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-open-bib-file file command) - (let ((filep (find-file/path file *skribe-bib-path*))) - (if (string? filep) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [loading bib: " filep "]")) - (open-input-file (if (string? command) - (string-append "| " - (format command filep)) - filep))) - (begin - (skribe-warning 1 - 'bibliography - "Can't find bibliography -- " file) - #f)))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-port ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-port port ei #!key (env '())) - (with-debug 2 'skribe-eval-port - (debug-item "ei=" ei) - (let ((e (if (symbol? ei) (find-engine ei) ei))) - (debug-item "e=" e) - (if (not (%engine? e)) - (skribe-error 'find-engine "Can't find engine" ei) - (let loop ((exp (skribe-read port))) - (with-debug 10 'skribe-eval-port - (debug-item "exp=" exp)) - (if (not (eof-object? exp)) - (begin - (skribe-eval (evaluate exp) e :env env) - (loop (skribe-read port))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval a e #!key (env '())) - (with-debug 2 'skribe-eval - (debug-item "a=" a " e=" (%engine-ident e)) - (let ((a2 (resolve! a e env))) - (debug-item "resolved a=" a) - (let ((a3 (verify a2 e))) - (debug-item "verified a=" a3) - (output a3 e))))) - -;*---------------------------------------------------------------------*/ -;* skribe-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path) - *skribe-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-path-set! "Illegal path" path) - (set! *skribe-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path) - *skribe-image-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-image-path-set! "Illegal path" path) - (set! *skribe-image-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path) - *skribe-bib-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-bib-path-set! "Illegal path" path) - (set! *skribe-bib-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path) - *skribe-source-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-source-path-set! "Illegal path" path) - (set! *skribe-source-path* path))) diff --git a/src/bigloo/evapi.scm b/src/bigloo/evapi.scm deleted file mode 100644 index 6f0d49e..0000000 --- a/src/bigloo/evapi.scm +++ /dev/null @@ -1,39 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:57:09 2003 */ -;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo eval declarations */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_evapi - (import skribe_types - skribe_lib - skribe_api - skribe_engine - skribe_writer - skribe_output - skribe_eval - skribe_read - skribe_resolve - skribe_param - skribe_source - skribe_index - skribe_configure - skribe_lisp - skribe_xml - skribe_c - skribe_asm - skribe_bib - skribe_color - skribe_sui - skribe_debug) - (eval (export-all))) - - diff --git a/src/bigloo/index.bgl b/src/bigloo/index.bgl deleted file mode 100644 index 9697981..0000000 --- a/src/bigloo/index.bgl +++ /dev/null @@ -1,32 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes Bigloo module declaration */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../common/index.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_index - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (index?::bool ::obj) - (default-index) - (make-index-table ::bstring) - (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) - diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl deleted file mode 100644 index 6dd6d37..0000000 --- a/src/bigloo/lib.bgl +++ /dev/null @@ -1,340 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe runtime (i.e., the style user functions). */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../common/lib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lib - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output - skribe_engine) - - (export (markup-option ::%markup ::obj) - (markup-option-add! ::%markup ::obj ::obj) - (markup-class ::%markup) - - (container-env-get ::%container ::symbol) - (container-search-down::pair-nil ::procedure ::%container) - (search-down::pair-nil ::procedure ::obj) - - (find-markup-ident::pair-nil ::bstring) - - (find-down::pair-nil ::procedure ::obj) - (find1-down::obj ::procedure ::obj) - (find-up::pair-nil ::procedure ::obj) - (find1-up::obj ::procedure ::obj) - - (ast-document ::%ast) - (ast-chapter ::%ast) - (ast-section ::%ast) - - (the-body ::pair-nil) - (the-options ::pair-nil . rest) - - (list-split::pair-nil ::pair-nil ::int . ::obj) - - (generic ast->string::bstring ::obj) - - (strip-ref-base ::bstring) - (ast->file-location ::%ast) - - (convert-image ::bstring ::pair-nil) - - (make-string-replace ::pair-nil) - (string-canonicalize::bstring ::bstring) - (inline unspecified?::bool ::obj))) - -;*---------------------------------------------------------------------*/ -;* markup-option ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option m opt) - (if (%markup? m) - (with-access::%markup m (options) - (let ((c (assq opt options))) - (and (pair? c) (pair? (cdr c)) (cadr c)))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-option-add! ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option-add! m opt val) - (if (%markup? m) - (with-access::%markup m (options) - (set! options (cons (list opt val) options))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (markup-class m) - (%markup-class m)) - -;*---------------------------------------------------------------------*/ -;* container-env-get ... */ -;*---------------------------------------------------------------------*/ -(define (container-env-get m key) - (with-access::%container m (env) - (let ((c (assq key env))) - (and (pair? c) (cadr c))))) - -;*---------------------------------------------------------------------*/ -;* strip-ref-base ... */ -;*---------------------------------------------------------------------*/ -(define (strip-ref-base file) - (if (not (string? *skribe-ref-base*)) - file - (let ((l (string-length *skribe-ref-base*))) - (cond - ((not (>fx (string-length file) (+fx l 2))) - file) - ((not (substring=? file *skribe-ref-base* l)) - file) - ((not (char=? (string-ref file l) (file-separator))) - file) - (else - (substring file (+fx l 1) (string-length file))))))) - -;*---------------------------------------------------------------------*/ -;* ast->file-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast->file-location ast) - (let ((l (ast-loc ast))) - (if (location? l) - (format "~a:~a" (location-file l) (location-pos l)) - ""))) - -;*---------------------------------------------------------------------*/ -;* builtin-convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) - (to (make-file-name dir f))) - (cond - ((string=? s fmt) - to) - ((file-exists? to) - to) - (else - (let ((c (if (string=? s "fig") - (string-append "fig2dev -L " fmt " " from " > " to) - (string-append "convert " from " " to)))) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [converting image: " from " (" c ")]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [converting image: " from "]"))) - (if (=fx (system c) 0) to #f)))))) - -;*---------------------------------------------------------------------*/ -;* convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (convert-image file formats) - (let ((path (find-file/path file (skribe-image-path)))) - (if (not (string? path)) - (skribe-error 'image - (format "Can't find `~a' image file in path: " file) - (skribe-image-path)) - (let ((suf (suffix file))) - (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - #f))) - (if dir - (let ((dest (basename path))) - (copy-file path (make-file-name dir dest)) - dest) - path)) - (let loop ((fmts formats)) - (if (null? fmts) - #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - ".")) - (p (builtin-convert-image path (car fmts) dir))) - (if (string? p) - p - (loop (cdr fmts))))))))))) - -;*---------------------------------------------------------------------*/ -;* html-string ... */ -;*---------------------------------------------------------------------*/ -(define (html-string str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (if (=fx nlen len) - str - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let ((c (string-ref-ur str r))) - (case c - ((#\<) - (blit-string! "<" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\>) - (blit-string! ">" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\&) - (blit-string! "&" 0 res w 5) - (loop (+fx r 1) (+fx w 5))) - ((#\") - (blit-string! """ 0 res w 6) - (loop (+fx r 1) (+fx w 6))) - (else - (string-set! res w c) - (loop (+fx r 1) (+fx w 1))))))))) - (case (string-ref-ur str r) - ((#\< #\>) - (loop (+fx r 1) (+fx nlen 3))) - ((#\&) - (loop (+fx r 1) (+fx nlen 4))) - ((#\") - (loop (+fx r 1) (+fx nlen 5))) - (else - (loop (+fx r 1) nlen))))))) - -;*---------------------------------------------------------------------*/ -;* make-generic-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-generic-string-replace lst) - (lambda (str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (let ((pl (string-length (cadr p)))) - (blit-string! (cadr p) 0 res w pl) - (loop (+fx r 1) (+fx w pl))) - (begin - (string-set! res w c) - (loop (+fx r 1) (+fx w 1)))))))) - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (loop (+fx r 1) - (+fx nlen (-fx (string-length (cadr p)) 1))) - (loop (+fx r 1) - nlen)))))))) - -;*---------------------------------------------------------------------*/ -;* make-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-string-replace lst) - (let ((l (sort lst (lambda (r1 r2) (char ">"))) - html-string) - (else - (make-generic-string-replace lst))))) - -;*---------------------------------------------------------------------*/ -;* ast->string ... */ -;*---------------------------------------------------------------------*/ -(define-generic (ast->string ast) - (cond - ((string? ast) - ast) - ((number? ast) - (number->string ast)) - ((pair? ast) - (let* ((t (map ast->string ast)) - (res (make-string - (apply + -1 (length t) (map string-length t)) - #\space))) - (let loop ((t t) - (w 0)) - (if (null? t) - res - (let ((l (string-length (car t)))) - (blit-string! (car t) 0 res w l) - (loop (cdr t) (+ w l 1))))))) - (else - ""))) - -;*---------------------------------------------------------------------*/ -;* ast->string ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (ast->string ast::%node) - (ast->string (%node-body ast))) - -;*---------------------------------------------------------------------*/ -;* string-canonicalize ... */ -;*---------------------------------------------------------------------*/ -(define (string-canonicalize old) - (let* ((l (string-length old)) - (new (make-string l))) - (let loop ((r 0) - (w 0) - (s #f)) - (cond - ((=fx r l) - (cond - ((=fx w 0) - "") - ((char-whitespace? (string-ref new (-fx w 1))) - (substring new 0 (-fx w 1))) - ((=fx w r) - new) - (else - (substring new 0 w)))) - ((char-whitespace? (string-ref old r)) - (if s - (loop (+fx r 1) w #t) - (begin - (string-set! new w #\-) - (loop (+fx r 1) (+fx w 1) #t)))) - ((or (char=? (string-ref old r) #\#) - (char=? (string-ref old r) #\,) - (>= (char->integer (string-ref old r)) #x7f)) - (string-set! new w #\-) - (loop (+fx r 1) (+fx w 1) #t)) - (else - (string-set! new w (string-ref old r)) - (loop (+fx r 1) (+fx w 1) #f)))))) - -;*---------------------------------------------------------------------*/ -;* unspecified? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unspecified? obj) - (eq? obj #unspecified)) - -;*---------------------------------------------------------------------*/ -;* base */ -;* ------------------------------------------------------------- */ -;* A base engine must pre-exist before anything is loaded. In */ -;* particular, this dummy base engine is used to load the */ -;* actual definition of base. */ -;*---------------------------------------------------------------------*/ -(make-engine 'base :version 'bootstrap) - diff --git a/src/bigloo/lisp.scm b/src/bigloo/lisp.scm deleted file mode 100644 index 65a8227..0000000 --- a/src/bigloo/lisp.scm +++ /dev/null @@ -1,530 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Aug 29 08:14:59 2003 */ -;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Handling of lispish source files. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lisp - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export bigloo - scheme - lisp - skribe)) - -;*---------------------------------------------------------------------*/ -;* keys ... */ -;*---------------------------------------------------------------------*/ -(define *the-key* #f) -(define *bracket-highlight* #t) -(define *bigloo-key* #f) -(define *scheme-key* #f) -(define *lisp-key* #f) -(define *skribe-key* #f) - -;*---------------------------------------------------------------------*/ -;* init-bigloo-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-bigloo-fontifier!) - (if (not *bigloo-key*) - (begin - (set! *bigloo-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'symbol)) - '(set! if let cond case quote begin letrec let* - lambda export extern class generic inline - static import foreign type with-access instantiate - duplicate labels - match-case match-lambda - syntax-rules pragma widen! shrink! - wide-class profile profile/gc - regular-grammar lalr-grammar apply)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'define)) - '(define define-inline define-struct define-macro - define-generic define-method define-syntax - define-expander)) - ;; error - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'error)) - '(bind-exit unwind-protect call/cc error warning)) - ;; module - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'module)) - '(module import export library)) - ;; thread - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'thread)) - '(make-thread thread-start! thread-yield! - thread-await! thread-await*! - thread-sleep! thread-join! - thread-terminate! thread-suspend! - thread-resume! thread-yield! - thread-specific thread-specific-set! - thread-name thread-name-set! - scheduler-react! scheduler-start! - broadcast! scheduler-broadcast! - current-thread thread? - current-scheduler scheduler? make-scheduler - make-input-signal make-output-signal - make-connect-signal make-process-signal - make-accept-signal make-timer-signal - thread-get-values! thread-get-values*!))))) - -;*---------------------------------------------------------------------*/ -;* init-lisp-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-lisp-fontifier!) - (if (not *lisp-key*) - (begin - (set! *lisp-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'symbol)) - '(setq if let cond case else progn letrec let* - lambda labels try unwind-protect apply funcall)) - ;; defun - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'define)) - '(define defun defvar defmacro))))) - -;*---------------------------------------------------------------------*/ -;* init-skribe-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-skribe-fontifier!) - (if (not *skribe-key*) - (begin - (set! *skribe-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'symbol)) - '(set! bold it emph tt color ref index underline - figure center pre flush hrule linebreak - image kbd code var samp sc sf sup sub - itemize description enumerate item - table tr td th item prgm author - prgm hook font lambda)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'define)) - '(define define-markup)) - ;; markup - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'markup)) - '(document chapter section subsection subsubsection - paragraph p handle resolve processor - abstract margin toc table-of-contents - current-document current-chapter current-section - document-sections* section-number - footnote print-index include skribe-load - slide))))) - -;*---------------------------------------------------------------------*/ -;* bigloo ... */ -;*---------------------------------------------------------------------*/ -(define bigloo - (new language - (name "bigloo") - (fontifier bigloo-fontifier) - (extractor bigloo-extractor))) - -;*---------------------------------------------------------------------*/ -;* scheme ... */ -;*---------------------------------------------------------------------*/ -(define scheme - (new language - (name "scheme") - (fontifier scheme-fontifier) - (extractor scheme-extractor))) - -;*---------------------------------------------------------------------*/ -;* lisp ... */ -;*---------------------------------------------------------------------*/ -(define lisp - (new language - (name "lisp") - (fontifier lisp-fontifier) - (extractor lisp-extractor))) - -;*---------------------------------------------------------------------*/ -;* bigloo-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-fontifier s) - (init-bigloo-fontifier!) - (set! *the-key* *bigloo-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* bigloo-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-inline define-generic - define-method define-macro define-expander) - (?fun . ?-) . ?-) - (eq? def fun)) - (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* skribe ... */ -;*---------------------------------------------------------------------*/ -(define skribe - (new language - (name "skribe") - (fontifier skribe-fontifier) - (extractor skribe-extractor))) - -;*---------------------------------------------------------------------*/ -;* skribe-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-fontifier s) - (init-skribe-fontifier!) - (set! *the-key* *skribe-key*) - (set! *bracket-highlight* #t) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* skribe-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro define-markup) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - ((markup-output (quote ?mk) . ?-) - (eq? mk def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* scheme-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-fontifier s) s) - -;*---------------------------------------------------------------------*/ -;* scheme-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* lisp-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-fontifier s) - (init-lisp-fontifier!) - (set! *the-key* *lisp-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* lisp-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or defun defmacro) ?fun ?- . ?-) - (eq? def fun)) - ((defvar ?var . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* definition-search ... */ -;* ------------------------------------------------------------- */ -;* This function seeks a Bigloo definition. If it finds it, it */ -;* returns two values the starting char number of the definition */ -;* and the stop char. */ -;*---------------------------------------------------------------------*/ -(define (definition-search ip tab semipred) - (cond-expand - (bigloo2.6 - (define (reader-current-line-number) - (let* ((port (open-input-string "(9)")) - (exp (read port #t))) - (close-input-port port) - (line-number exp))) - (define (line-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos ?line) - line)))) - (reader-reset!) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (line-number exp)) - (e (reader-current-line-number))) - (source-read-lines (input-port-name ip) b e tab))))))) - (else - (define (char-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos) - pos)))) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (char-number exp)) - (e (input-port-position ip))) - (source-read-chars (input-port-name ip) - b - e - tab))))))))) - - -;*---------------------------------------------------------------------*/ -;* fontify-lisp ... */ -;*---------------------------------------------------------------------*/ -(define (fontify-lisp port::input-port) - (let ((g (regular-grammar () - ((: ";;" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";*" (* all)) - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-string))) - (cons str (ignore)))) - ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-substring 1 (the-length)))) - (cons str (ignore)))) - ((+ #\Space) - ;; separators - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - (#\( - ;; open parenthesis - (let ((str (highlight (the-string)))) - (pupush-highlight) - (cons str (ignore)))) - (#\) - ;; close parenthesis - (let ((str (highlight (the-string) -1))) - (cons str (ignore)))) - ((+ (in "[]")) - ;; brackets - (let ((s (the-string))) - (if *bracket-highlight* - (let ((c (new markup - (markup '&source-bracket) - (body s)))) - (cons c (ignore))) - (cons s (ignore))))) - ((+ #\Tab) - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((: #\( (+ (out "; \t()[]:\"\n"))) - ;; keywords - (let* ((string (the-substring 1 (the-length))) - (symbol (string->symbol string)) - (key (getprop symbol *the-key*))) - (cons - "(" - (case key - ((symbol) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((define) - (let ((c (new markup - (markup '&source-define) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-define) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((error) - (let ((c (new markup - (markup '&source-error) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((module) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((markup) - (let ((c (new markup - (markup '&source-markup) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((thread) - (let ((c (new markup - (markup '&source-thread) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons (highlight string 1) (ignore))))))) - ((+ (out "; \t()[]:\"\n")) - (let ((string (the-string))) - (cons (highlight string 1) (ignore)))) - ((+ #\Newline) - ;; newline - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (ident (symbol->string (gensym))) - (body s)))) - str) - (ignore)))) - ((: "::" (+ (out ";\n \t()[]:\""))) - ;; type annotations - (let ((c (new markup - (markup '&source-type) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) - ;; keywords annotations - (let ((c (new markup - (markup '&source-key) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\: #\; #\")) - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - ((: #\# #\\ (+ (out " \n\t"))) - ;; characters - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(lisp)" "Unexpected character" c))))))) - (reset-highlight!) - (read/rp g port))) - -;*---------------------------------------------------------------------*/ -;* *highlight* ... */ -;*---------------------------------------------------------------------*/ -(define *highlight* '()) - -;*---------------------------------------------------------------------*/ -;* reset-highlight! ... */ -;*---------------------------------------------------------------------*/ -(define (reset-highlight!) - (set! *highlight* '())) - -;*---------------------------------------------------------------------*/ -;* push-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (push-highlight col pv) - (set! *highlight* (cons (cons col pv) *highlight*))) - -;*---------------------------------------------------------------------*/ -;* pupush-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pupush-highlight) - (if (pair? *highlight*) - (let ((c (car *highlight*))) - (set-cdr! c 100000)))) - -;*---------------------------------------------------------------------*/ -;* pop-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pop-highlight pv) - (case pv - ((-1) - (set! *highlight* (cdr *highlight*))) - ((0) - 'nop) - (else - (let ((c (car *highlight*))) - (if (>fx (cdr c) 1) - (set-cdr! c (-fx (cdr c) 1)) - (set! *highlight* (cdr *highlight*))))))) - -;*---------------------------------------------------------------------*/ -;* highlight ... */ -;*---------------------------------------------------------------------*/ -(define (highlight exp . pop) - (if (pair? *highlight*) - (let* ((c (car *highlight*)) - (r (if (>fx (cdr c) 0) - ((car c) exp) - exp))) - (if (pair? pop) (pop-highlight (car pop))) - r) - exp)) - - diff --git a/src/bigloo/main.scm b/src/bigloo/main.scm deleted file mode 100644 index 5b9e5e5..0000000 --- a/src/bigloo/main.scm +++ /dev/null @@ -1,96 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/main.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:51:49 2003 */ -;* Last change : Wed May 18 15:45:27 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe main entry point */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_main - - (include "debug.sch") - - (import skribe_types - skribe_parse-args - skribe_param - skribe_lib - skribe_eval - skribe_read - skribe_engine - skribe_evapi) - - (main main)) - -;*---------------------------------------------------------------------*/ -;* main ... */ -;*---------------------------------------------------------------------*/ -(define (main args) - (with-debug 2 'main - (debug-item "parse env variables...") - (parse-env-variables) - - (debug-item "load rc file...") - (load-rc) - - (debug-item "parse command line...") - (parse-args args) - - (debug-item "load base...") - (skribe-load "base.skr" :engine 'base) - - (debug-item "preload... (" *skribe-engine* ")") - (for-each (lambda (f) - (skribe-load f :engine *skribe-engine*)) - *skribe-preload*) - - ;; Load the specified variants - (debug-item "variant... (" *skribe-variants* ")") - (for-each (lambda (x) - (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) - (reverse! *skribe-variants*)) - - (debug-item "body..." *skribe-engine*) - (if (string? *skribe-dest*) - (cond-expand - (bigloo2.6 - (try (with-output-to-file *skribe-dest* doskribe) - (lambda (e a b c) - (delete-file *skribe-dest*) - (let ((s (with-output-to-string - (lambda () (write c))))) - (notify-error a b s)) - (exit -1)))) - (else - (with-exception-handler - (lambda (e) - (if (&warning? e) - (raise e) - (begin - (delete-file *skribe-dest*) - (if (&error? e) - (error-notify e) - (raise e)) - (exit 1)))) - (lambda () - (with-output-to-file *skribe-dest* doskribe))))) - (doskribe)))) - -;*---------------------------------------------------------------------*/ -;* doskribe ... */ -;*---------------------------------------------------------------------*/ -(define (doskribe) - (let ((e (find-engine *skribe-engine*))) - (if (and (engine? e) (pair? *skribe-precustom*)) - (for-each (lambda (cv) - (engine-custom-set! e (car cv) (cdr cv))) - *skribe-precustom*)) - (if (pair? *skribe-src*) - (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) - *skribe-src*) - (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/src/bigloo/new.sch b/src/bigloo/new.sch deleted file mode 100644 index 16bb7d5..0000000 --- a/src/bigloo/new.sch +++ /dev/null @@ -1,17 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/new.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 17 11:58:30 2003 */ -;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The new facility */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* new ... */ -;*---------------------------------------------------------------------*/ -(define-macro (new id . inits) - `(,(symbol-append 'instantiate::% id) ,@inits)) - diff --git a/src/bigloo/output.scm b/src/bigloo/output.scm deleted file mode 100644 index 4bc6271..0000000 --- a/src/bigloo/output.scm +++ /dev/null @@ -1,167 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/output.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_output - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (output ::obj ::%engine . w))) - -;*---------------------------------------------------------------------*/ -;* output ... */ -;*---------------------------------------------------------------------*/ -(define (output node e . writer) - (with-debug 3 'output - (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) - (debug-item "writer=" writer) - (if (pair? writer) - (cond - ((%writer? (car writer)) - (out/writer node e (car writer))) - ((not (car writer)) - (skribe-error 'output - (format "Illegal `~a' user writer" (%engine-ident e)) - (if (markup? node) (%markup-markup node) node))) - (else - (skribe-error 'output "Illegal user writer" (car writer)))) - (out node e)))) - -;*---------------------------------------------------------------------*/ -;* out/writer ... */ -;*---------------------------------------------------------------------*/ -(define (out/writer n e w) - (with-debug 5 'out/writer - (debug-item "n=" (find-runtime-type n) - " " (if (markup? n) (markup-markup n) "")) - (debug-item "e=" (%engine-ident e)) - (debug-item "w=" (%writer-ident w)) - (if (%writer? w) - (with-access::%writer w (before action after) - (invoke before n e) - (invoke action n e) - (invoke after n e))))) - -;*---------------------------------------------------------------------*/ -;* out ... */ -;*---------------------------------------------------------------------*/ -(define-generic (out node e::%engine) - (cond - ((pair? node) - (out* node e)) - ((string? node) - (let ((f (%engine-filter e))) - (if (procedure? f) - (display (f node)) - (display node)))) - ((number? node) - (display node)) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* out ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (out n::%processor e::%engine) - (with-access::%processor n (combinator engine body procedure) - (let ((newe (processor-get-engine combinator engine e))) - (out (procedure body newe) newe)))) - -;*---------------------------------------------------------------------*/ -;* out ::%command ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%command e::%engine) - (with-access::%command node (fmt body) - (let ((lb (length body)) - (lf (string-length fmt))) - (define (loops i n) - (if (= i lf) - (begin - (if (> n 0) - (if (<= n lb) - (output (list-ref body (- n 1)) e) - (skribe-error '! - "Too few arguments provided" - node))) - lf) - (let ((c (string-ref fmt i))) - (cond - ((char=? c #\$) - (display "$") - (+ 1 i)) - ((not (char-numeric? c)) - (cond - ((= n 0) - i) - ((<= n lb) - (output (list-ref body (- n 1)) e) - i) - (else - (skribe-error '! - "Too few arguments provided" - node)))) - (else - (loops (+ i 1) - (+ (- (char->integer c) - (char->integer #\0)) - (* 10 n)))))))) - (let loop ((i 0)) - (cond - ((= i lf) - #f) - ((not (char=? (string-ref fmt i) #\$)) - (display (string-ref fmt i)) - (loop (+ i 1))) - (else - (loop (loops (+ i 1) 0)))))))) - -;*---------------------------------------------------------------------*/ -;* out ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%handle e::%engine) - #unspecified) - -;*---------------------------------------------------------------------*/ -;* out ::%unresolved ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%unresolved e::%engine) - (error 'output "Orphan unresolved" node)) - -;*---------------------------------------------------------------------*/ -;* out ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%markup e::%engine) - (let ((w (lookup-markup-writer node e))) - (if (writer? w) - (out/writer node e w) - (output (%markup-body node) e)))) - -;*---------------------------------------------------------------------*/ -;* out* ... */ -;*---------------------------------------------------------------------*/ -(define (out* n+ e) - (let loop ((n* n+)) - (cond - ((pair? n*) - (out (car n*) e) - (loop (cdr n*))) - ((not (null? n*)) - (error 'output "Illegal argument" n*))))) - - diff --git a/src/bigloo/param.bgl b/src/bigloo/param.bgl deleted file mode 100644 index 6ff6b42..0000000 --- a/src/bigloo/param.bgl +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 14:03:15 2003 */ -;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe parameters */ -;* ------------------------------------------------------------- */ -;* Implementation: @label param@ */ -;* bigloo: @path ../common/param.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_param - - (import skribe_configure) - - (export *skribe-verbose* - *skribe-warning* - *skribe-path* - *skribe-bib-path* - *skribe-source-path* - *skribe-image-path* - *load-rc* - - *skribe-src* - *skribe-dest* - *skribe-engine* - *skribe-variants* - *skribe-chapter-split* - - *skribe-ref-base* - - *skribe-rc-directory* - *skribe-rc-file* - *skribe-auto-mode-alist* - *skribe-auto-load-alist* - *skribe-preload* - *skribe-precustom* - - *skribebib-auto-mode-alist*)) - -;*---------------------------------------------------------------------*/ -;* *skribe-verbose* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-verbose* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-warning* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-warning* 5) - -;*---------------------------------------------------------------------*/ -;* *skribe-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-path* (skribe-default-path)) - -;*---------------------------------------------------------------------*/ -;* *skribe-bib-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-bib-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-source-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-source-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-image-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-image-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *load-rc* ... */ -;*---------------------------------------------------------------------*/ -(define *load-rc* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-src* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-src* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-dest* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-dest* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-engine* 'html) - -;*---------------------------------------------------------------------*/ -;* *skribe-variants* */ -;*---------------------------------------------------------------------*/ -(define *skribe-variants* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-chapter-split* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-chapter-split* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-ref-base* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-ref-base* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-directory* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file directory. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-directory* - (let ((home (getenv "HOME")) - (host (hostname))) - (let loop ((host (if (not (string? host)) (getenv "HOST") host))) - (if (string? host) - (let ((home/host (string-append home "/.skribe" host))) - (if (and (file-exists? home/host) (directory? home/host)) - home/host - (if (string=? (suffix host) "") - (let ((home/def (make-file-name home ".skribe"))) - (cond - ((and (file-exists? home/def) - (directory? home/def)) - home/def) - (else - home))) - (loop (prefix host))))))))) - diff --git a/src/bigloo/parseargs.scm b/src/bigloo/parseargs.scm deleted file mode 100644 index 4ce58c4..0000000 --- a/src/bigloo/parseargs.scm +++ /dev/null @@ -1,186 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:52:53 2003 */ -;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Argument parsing */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_parse-args - - (include "debug.sch") - - (import skribe_configure - skribe_param - skribe_read - skribe_types - skribe_eval) - - (export (parse-env-variables) - (parse-args ::pair) - (load-rc))) - -;*---------------------------------------------------------------------*/ -;* parse-env-variables ... */ -;*---------------------------------------------------------------------*/ -(define (parse-env-variables) - (let ((e (getenv "SKRIBEPATH"))) - (if (string? e) - (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) - -;*---------------------------------------------------------------------*/ -;* parse-args ... */ -;*---------------------------------------------------------------------*/ -(define (parse-args args) - (define (usage args-parse-usage) - (print "usage: skribe [options] [input]") - (newline) - (args-parse-usage #f) - (newline) - (print "Rc file:") - (newline) - (print " *skribe-rc* (searched in \".\" then $HOME)") - (newline) - (print "Target formats:") - (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) - (newline) - (print "Shell Variables:") - (newline) - (for-each (lambda (var) - (print " - " (car var) " " (cdr var))) - '(("SKRIBEPATH" . "Skribe input path (all files)")))) - (define (version) - (print "skribe v" (skribe-release))) - (define (query) - (version) - (newline) - (for-each (lambda (x) - (let ((s (keyword->string (car x)))) - (printf " ~a: ~a\n" - (substring s 1 (string-length s)) - (cadr x)))) - (skribe-configure))) - (let ((np '()) - (engine #f)) - (args-parse (cdr args) - ((("-h" "--help") (help "This message")) - (usage args-parse-usage) - (exit 0)) - (("--options" (help "Display the skribe options and exit")) - (args-parse-usage #t) - (exit 0)) - (("--version" (help "The version of Skribe")) - (version) - (exit 0)) - ((("-q" "--query") (help "Display informations about the Skribe configuration")) - (query) - (exit 0)) - ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) - (let ((l (string-length key=val))) - (let loop ((i 0)) - (cond - ((= i l) - (skribe-error 'skribe "Illegal option" key=val)) - ((char=? (string-ref key=val i) #\=) - (let ((key (substring key=val 0 i)) - (val (substring key=val (+ i 1) l))) - (set! *skribe-precustom* - (cons (cons (string->symbol key) val) - *skribe-precustom*)))) - (else - (loop (+ i 1))))))) - (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) - (set! *skribe-verbose* (string->integer level)))) - (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-warning* (+fx 1 *skribe-warning*)) - (set! *skribe-warning* (string->integer level)))) - (("-g?level" (help "Increase or set debug level")) - (if (string=? level "") - (set! *skribe-debug* (+fx 1 *skribe-debug*)) - (let ((l (string->integer level))) - (if (= l 0) - (begin - (set! *skribe-debug* 1) - (set! *skribe-debug-symbols* - (cons (string->symbol level) - *skribe-debug-symbols*))) - (set! *skribe-debug* l))))) - (("--no-color" (help "Disable coloring for debug")) - (set! *skribe-debug-color* #f)) - ((("-t" "--target") ?e (help "The output target format")) - (set! engine (string->symbol e))) - (("-I" ?path (help "Add to skribe path")) - (set! np (cons path np))) - (("-B" ?path (help "Add to skribe bibliography path")) - (skribe-bib-path-set! (cons path (skribe-bib-path)))) - (("-S" ?path (help "Add to skribe source path")) - (skribe-source-path-set! (cons path (skribe-source-path)))) - (("-P" ?path (help "Add to skribe image path")) - (skribe-image-path-set! (cons path (skribe-image-path)))) - ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files")) - (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) - (("--eval" ?expr (help "Evaluate expression")) - (with-input-from-string expr - (lambda () - (eval (skribe-read))))) - (("--no-init-file" (help "Dont load rc Skribe file")) - (set! *load-rc* #f)) - ((("-p" "--preload") ?file (help "Preload file")) - (set! *skribe-preload* (cons file *skribe-preload*))) - ((("-u" "--use-variant") ?variant (help "use output format")) - (set! *skribe-variants* (cons variant *skribe-variants*))) - ((("-o" "--output") ?o (help "The output target name")) - (set! *skribe-dest* o) - (let* ((s (suffix o)) - (c (assoc s *skribe-auto-mode-alist*))) - (if (and (pair? c) (symbol? (cdr c))) - (set! *skribe-engine* (cdr c))))) - ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks")) - (set! *skribe-ref-base* base)) - ;; skribe rc directory - ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory")) - (set! *skribe-rc-directory* dir)) - (else - (set! *skribe-src* (cons else *skribe-src*)))) - ;; we have to configure according to the environment variables - (if engine (set! *skribe-engine* engine)) - (set! *skribe-src* (reverse! *skribe-src*)) - (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH") - (reverse! np) - (skribe-path))))) - -;*---------------------------------------------------------------------*/ -;* build-path-from-shell-variable ... */ -;*---------------------------------------------------------------------*/ -(define (build-path-from-shell-variable var) - (let ((val (getenv var))) - (if (string? val) - (string-case val - ((+ (out #\:)) - (let* ((str (the-string)) - (res (ignore))) - (cons str res))) - (#\: - (ignore)) - (else - '())) - '()))) - -;*---------------------------------------------------------------------*/ -;* load-rc ... */ -;*---------------------------------------------------------------------*/ -(define (load-rc) - (if *load-rc* - (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*))) - (if (and (string? file) (file-exists? file)) - (loadq file))))) - diff --git a/src/bigloo/prog.scm b/src/bigloo/prog.scm deleted file mode 100644 index baad0f0..0000000 --- a/src/bigloo/prog.scm +++ /dev/null @@ -1,196 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Aug 27 09:14:28 2003 */ -;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe prog bigloo implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_prog - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (make-prog-body ::obj ::obj ::obj ::obj) - (resolve-line ::bstring))) - -;*---------------------------------------------------------------------*/ -;* *lines* ... */ -;*---------------------------------------------------------------------*/ -(define *lines* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* make-line-mark ... */ -;*---------------------------------------------------------------------*/ -(define (make-line-mark m lnum b) - (let* ((ls (integer->string lnum)) - (n (list (mark ls) b))) - (hashtable-put! *lines* m n) - n)) - -;*---------------------------------------------------------------------*/ -;* resolve-line ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-line id) - (hashtable-get *lines* id)) - -;*---------------------------------------------------------------------*/ -;* extract-string-mark ... */ -;*---------------------------------------------------------------------*/ -(define (extract-string-mark line mark regexp) - (let ((m (pregexp-match regexp line))) - (if (pair? m) - (values (substring (car m) - (string-length mark) - (string-length (car m))) - (pregexp-replace regexp line "")) - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* extract-mark ... */ -;* ------------------------------------------------------------- */ -;* Extract the prog mark from a line. */ -;*---------------------------------------------------------------------*/ -(define (extract-mark line mark regexp) - (cond - ((not regexp) - (values #f line)) - ((string? line) - (extract-string-mark line mark regexp)) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - (values #f line) - (multiple-value-bind (m l) - (extract-mark (car ls) mark regexp) - (if (not m) - (loop (cdr ls) (cons l res)) - (values m (append (reverse! res) (cons l (cdr ls))))))))) - ((%node? line) - (multiple-value-bind (m l) - (extract-mark (%node-body line) mark regexp) - (if (not m) - (values #f line) - (begin - (%node-body-set! line l) - (values m line))))) - (else - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* split-line ... */ -;*---------------------------------------------------------------------*/ -(define (split-line line) - (cond - ((string? line) - (let ((l (string-length line))) - (let loop ((r1 0) - (r2 0) - (res '())) - (cond - ((=fx r2 l) - (if (=fx r1 r2) - (reverse! res) - (reverse! (cons (substring line r1 r2) res)))) - ((char=? (string-ref line r2) #\Newline) - (loop (+fx r2 1) - (+fx r2 1) - (if (=fx r1 r2) - (cons 'eol res) - (cons* 'eol (substring line r1 r2) res)))) - (else - (loop r1 - (+fx r2 1) - res)))))) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - res - (loop (cdr ls) (append res (split-line (car ls))))))) - (else - (list line)))) - -;*---------------------------------------------------------------------*/ -;* flat-lines ... */ -;*---------------------------------------------------------------------*/ -(define (flat-lines lines) - (apply append (map split-line lines))) - -;*---------------------------------------------------------------------*/ -;* collect-lines ... */ -;*---------------------------------------------------------------------*/ -(define (collect-lines lines) - (let loop ((lines (flat-lines lines)) - (res '()) - (tmp '())) - (cond - ((null? lines) - (reverse! (cons (reverse! tmp) res))) - ((eq? (car lines) 'eol) - (cond - ((null? (cdr lines)) - (reverse! (cons (reverse! tmp) res))) - ((and (null? res) (null? tmp)) - (loop (cdr lines) - res - '())) - (else - (loop (cdr lines) - (cons (reverse! tmp) res) - '())))) - (else - (loop (cdr lines) - res - (cons (car lines) tmp)))))) - -;*---------------------------------------------------------------------*/ -;* make-prog-body ... */ -;*---------------------------------------------------------------------*/ -(define (make-prog-body src lnum-init ldigit mark) - (define (int->str i rl) - (let* ((s (integer->string i)) - (l (string-length s))) - (if (= l rl) - s - (string-append (make-string (- rl l) #\space) s)))) - (let* ((regexp (and mark - (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" - (pregexp-quote mark)))) - (src (cond - ((not (pair? src)) (list src)) - ((and (pair? (car src)) (null? (cdr src))) (car src)) - (else src))) - (lines (collect-lines src)) - (lnum (if (integer? lnum-init) lnum-init 1)) - (s (integer->string (+fx (if (integer? ldigit) - (max lnum (expt 10 (-fx ldigit 1))) - lnum) - (length lines)))) - (cs (string-length s))) - (let loop ((lines lines) - (lnum lnum) - (res '())) - (if (null? lines) - (reverse! res) - (multiple-value-bind (m l) - (extract-mark (car lines) mark regexp) - (let ((n (new markup - (markup '&prog-line) - (ident (and lnum-init (int->str lnum cs))) - (body (if m (make-line-mark m lnum l) l))))) - (loop (cdr lines) - (+ lnum 1) - (cons n res)))))))) diff --git a/src/bigloo/read.scm b/src/bigloo/read.scm deleted file mode 100644 index 91cd345..0000000 --- a/src/bigloo/read.scm +++ /dev/null @@ -1,482 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/read.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Dec 27 11:16:00 1994 */ -;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ -;* ------------------------------------------------------------- */ -;* Skribe's reader */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Le module */ -;*---------------------------------------------------------------------*/ -(module skribe_read - (export (skribe-read . port))) - -;*---------------------------------------------------------------------*/ -;* Global counteurs ... */ -;*---------------------------------------------------------------------*/ -(define *par-open* 0) - -;*---------------------------------------------------------------------*/ -;* Parenthesis mismatch (or unclosing) errors. */ -;*---------------------------------------------------------------------*/ -(define *list-error-level* 20) -(define *list-errors* (make-vector *list-error-level* #unspecified)) -(define *vector-errors* (make-vector *list-error-level* #unspecified)) - -;*---------------------------------------------------------------------*/ -;* Control variables. */ -;*---------------------------------------------------------------------*/ -(define *end-of-list* (cons 0 0)) -(define *dotted-mark* (cons 1 1)) - -;*---------------------------------------------------------------------*/ -;* skribe-reader-reset! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-reader-reset!) - (set! *par-open* 0)) - -;*---------------------------------------------------------------------*/ -;* read-error ... */ -;*---------------------------------------------------------------------*/ -(define (read-error msg obj port) - (let* ((obj-loc (if (epair? obj) - (match-case (cer obj) - ((at ?fname ?pos ?-) - pos) - (else - #f)) - #f)) - (loc (if (number? obj-loc) - obj-loc - (cond - ((>fx *par-open* 0) - (let ((open-key (-fx *par-open* 1))) - (if (char (string->integer (the-substring 2 5)))))) - ((: "#\\" (or letter digit special (in "|#; []" quote paren))) - (string-ref (the-string) 2)) - ((: "#\\" (>= 2 letter)) - (let ((char-name (string->symbol - (string-upcase! - (the-substring 2 (the-length)))))) - (case char-name - ((NEWLINE) - #\Newline) - ((TAB) - #\tab) - ((SPACE) - #\space) - ((RETURN) - (integer->char 13)) - (else - (error/location "skribe-read" - "Illegal character" - (the-string) - (input-port-name (the-port)) - (input-port-position (the-port))))))) - - ;; ucs-2 characters - ((: "#u" (= 4 xdigit)) - (integer->ucs2 (string->integer (the-substring 2 6) 16))) - - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (let ((str (the-substring 1 (-fx (the-length) 1)))) - (let ((str (the-substring 0 (-fx (the-length) 1)))) - (escape-C-string str)))) - ;; ucs2 strings - ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (let ((str (the-substring 3 (-fx (the-length) 1)))) - (utf8-string->ucs2-string str))) - - ;; fixnums - ((: (? (in "-+")) (+ digit)) - (the-fixnum)) - ((: "#o" (? (in "-+")) (+ (in ("07")))) - (string->integer (the-substring 2 (the-length)) 8)) - ((: "#d" (? (in "-+")) (+ (in ("09")))) - (string->integer (the-substring 2 (the-length)) 10)) - ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af")))))) - (string->integer (the-substring 2 (the-length)) 16)) - ((: "#e" (? (in "-+")) (+ digit)) - (string->elong (the-substring 2 (the-length)) 10)) - ((: "#l" (? (in "-+")) (+ digit)) - (string->llong (the-substring 2 (the-length)) 10)) - - ;; flonum - ((: (? (in "-+")) - (or float - (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit)))) - (the-flonum)) - - ;; doted pairs - ("." - (if (<=fx *par-open* 0) - (error/location "read" - "Illegal token" - #\. - (input-port-name (the-port)) - (input-port-position (the-port))) - *dotted-mark*)) - - ;; unspecified and eof-object - ((: "#" (in "ue") (+ (in "nspecified-objt"))) - (let ((symbol (string->symbol - (string-upcase! - (the-substring 1 (the-length)))))) - (case symbol - ((UNSPECIFIED) - unspec) - ((EOF-OBJECT) - beof) - (else - (error/location "read" - "Illegal identifier" - symbol - (input-port-name (the-port)) - (input-port-position (the-port))))))) - - ;; booleans - ((: "#" (uncase #\t)) - #t) - ((: "#" (uncase #\f)) - #f) - - ;; keywords - ((or (: ":" kid) (: kid ":")) - ;; since the keyword expression is also matched by the id - ;; rule, keyword rule has to be placed before the id rule. - (the-keyword)) - - ;; identifiers - (id - ;; this rule has to be placed after the rule matching the `.' char - (the-symbol)) - ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|") - (if (=fx (the-length) 2) - (the-symbol) - (let ((str (the-substring 0 (-fx (the-length) 1)))) - (string->symbol (escape-C-string str))))) - - ;; quotations - ("'" - (read-quote 'quote (the-port) ignore)) - ("`" - (read-quote 'quasiquote (the-port) ignore)) - ("," - (read-quote 'unquote (the-port) ignore)) - (",@" - (read-quote 'unquote-splicing (the-port) ignore)) - - ;; lists - (#\( - ;; if possible, we store the opening parenthesis. - (if (and (vector? *list-errors*) - (vector (reverse! (collect-up-to ignore "vector" (the-port))))) - - ;; error or eof - (else - (let ((port (the-port)) - (char (the-failure))) - (if (eof-object? char) - (cond - ((>fx *par-open* 0) - (let ((open-key (-fx *par-open* 1))) - (skribe-reader-reset!) - (if (and (fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (let loop ((c -1) - (s (readl (current-input-port))) - (r '())) - (let ((p (input-port-position (current-input-port)))) - (cond - ((eof-object? s) - (apply string-append (reverse! r))) - ((>=fx p stop) - (let* ((len (-fx (-fx stop start) c)) - (line (untabify (substring s 0 len) tab))) - (apply string-append - (reverse! (cons line r))))) - ((>=fx c 0) - (loop (+fx (string-length s) c) - (readl (current-input-port)) - (cons (untabify s tab) r))) - ((>=fx p start) - (let* ((len (string-length s)) - (nc (-fx p start))) - (if (>fx p stop) - (untabify - (substring s - (-fx len (-fx p start)) - (-fx (-fx p stop) 1)) - tab) - (loop nc - (readl (current-input-port)) - (list - (untabify - (substring s - (-fx len (-fx p start)) - len) - tab)))))) - (else - (loop c (readl (current-input-port)) r)))))))))) - -;*---------------------------------------------------------------------*/ -;* source-read-lines ... */ -;*---------------------------------------------------------------------*/ -(define (source-read-lines file start stop tab) - (let ((p (find-file/path file (skribe-source-path)))) - (if (or (not (string? p)) (not (file-exists? p))) - (skribe-error 'source - (format "Can't find `~a' source file in path" file) - (skribe-source-path)) - (with-input-from-file p - (lambda () - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (let ((startl (if (string? start) (string-length start) -1)) - (stopl (if (string? stop) (string-length stop) -1))) - (let loop ((l 1) - (armedp (not (or (integer? start) - (string? start)))) - (s (read-line)) - (r '())) - (cond - ((or (eof-object? s) - (and (integer? stop) (> l stop)) - (and (string? stop) (substring=? stop s stopl))) - (apply string-append (reverse! r))) - (armedp - (loop (+fx l 1) - #t - (read-line) - (cons* "\n" (untabify s tab) r))) - ((and (integer? start) (>= l start)) - (loop (+fx l 1) - #t - (read-line) - (cons* "\n" (untabify s tab) r))) - ((and (string? start) (substring=? start s startl)) - (loop (+fx l 1) #t (read-line) r)) - (else - (loop (+fx l 1) #f (read-line) r)))))))))) - -;*---------------------------------------------------------------------*/ -;* untabify ... */ -;*---------------------------------------------------------------------*/ -(define (untabify obj tab) - (if (not tab) - obj - (let ((len (string-length obj)) - (tabl tab)) - (let loop ((i 0) - (col 1)) - (cond - ((=fx i len) - (let ((nlen (-fx col 1))) - (if (=fx len nlen) - obj - (let ((new (make-string col #\space))) - (let liip ((i 0) - (j 0) - (col 1)) - (cond - ((=fx i len) - new) - ((char=? (string-ref obj i) #\tab) - (let ((next-tab (*fx (/fx (+fx col tabl) - tabl) - tabl))) - (liip (+fx i 1) - next-tab - next-tab))) - (else - (string-set! new j (string-ref obj i)) - (liip (+fx i 1) (+fx j 1) (+fx col 1))))))))) - ((char=? (string-ref obj i) #\tab) - (loop (+fx i 1) - (*fx (/fx (+fx col tabl) tabl) tabl))) - (else - (loop (+fx i 1) (+fx col 1)))))))) - -;*---------------------------------------------------------------------*/ -;* source-read-definition ... */ -;*---------------------------------------------------------------------*/ -(define (source-read-definition file definition tab lang) - (let ((p (find-file/path file (skribe-source-path)))) - (cond - ((not (%language-extractor lang)) - (skribe-error 'source - "The specified language has not defined extractor" - lang)) - ((or (not p) (not (file-exists? p))) - (skribe-error 'source - (format "Can't find `~a' program file in path" file) - (skribe-source-path))) - (else - (let ((ip (open-input-file p))) - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [source file: " p "]")) - (if (not (input-port? ip)) - (skribe-error 'source "Can't open file for input" p) - (unwind-protect - (let ((s ((%language-extractor lang) ip definition tab))) - (if (not (string? s)) - (skribe-error 'source - "Can't find definition" - definition) - s)) - (close-input-port ip)))))))) - -;*---------------------------------------------------------------------*/ -;* source-fontify ... */ -;*---------------------------------------------------------------------*/ -(define (source-fontify o language) - (define (fontify f o) - (cond - ((string? o) (f o)) - ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) - (else o))) - (let ((f (%language-fontifier language))) - (if (procedure? f) - (fontify f o) - o))) - -;*---------------------------------------------------------------------*/ -;* split-string-newline ... */ -;*---------------------------------------------------------------------*/ -(define (split-string-newline str) - (let ((l (string-length str))) - (let loop ((i 0) - (j 0) - (r '())) - (cond - ((=fx i l) - (if (=fx i j) - (reverse! r) - (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) - (loop (+fx i 1) - (+fx i 1) - (if (=fx i j) - (cons 'eol r) - (cons* 'eol (substring str j i) r)))) - ((and (char=? (string-ref str i) #a013) - (url ::bstring ::obj ::obj ::pair-nil) - (sui-title::bstring ::pair-nil) - (sui-file::obj ::pair-nil) - (sui-key::obj ::pair-nil ::obj) - (sui-filter::pair-nil ::obj ::procedure ::procedure))) - diff --git a/src/bigloo/types.scm b/src/bigloo/types.scm deleted file mode 100644 index b8babd4..0000000 --- a/src/bigloo/types.scm +++ /dev/null @@ -1,685 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/types.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:40:42 2003 */ -;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The definition of the Skribe classes */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_types - - (export (abstract-class %ast - (parent (default #unspecified)) - (loc (default (evmeaning-location)))) - - (class %command::%ast - (fmt::bstring read-only) - (body (default #f))) - - (class %unresolved::%ast - (proc::procedure read-only)) - - (class %handle::%ast - (ast (default #f))) - - (abstract-class %node::%ast - (required-options::pair-nil read-only (default '())) - (options::pair-nil (default '())) - (body (default #f))) - - (class %processor::%node - (combinator (default (lambda (e1 e2) e1))) - (procedure::procedure (default (lambda (n e) n))) - engine) - - (class %markup::%node - (markup-init) - (ident (default #f)) - (class (default #f)) - (markup::symbol read-only)) - - (class %container::%markup - (env::pair-nil (default '()))) - - (class %document::%container) - - (class %engine - (ident::symbol read-only) - (format::bstring (default "raw")) - (info::pair-nil (default '())) - (version::obj read-only (default #unspecified)) - (delegate read-only (default #f)) - (writers::pair-nil (default '())) - (filter::obj (default #f)) - (customs::pair-nil (default '())) - (symbol-table::pair-nil (default '()))) - - (class %writer - (ident::symbol read-only) - (class read-only) - (pred::procedure read-only) - (upred read-only) - (options::obj read-only) - (verified?::bool (default #f)) - (validate (default #f)) - (before read-only) - (action read-only) - (after read-only)) - - (class %language - (name::bstring read-only) - (fontifier read-only (default #f)) - (extractor read-only (default #f))) - - (markup-init ::%markup) - (find-markups ::bstring) - - (inline ast?::bool ::obj) - (inline ast-parent::obj ::%ast) - (inline ast-loc::obj ::%ast) - (inline ast-loc-set!::obj ::%ast ::obj) - (ast-location::bstring ::%ast) - - (new-command . inits) - (inline command?::bool ::obj) - (inline command-fmt::bstring ::%command) - (inline command-body::obj ::%command) - - (new-unresolved . inits) - (inline unresolved?::bool ::obj) - (inline unresolved-proc::procedure ::%unresolved) - - (new-handle . inits) - (inline handle?::bool ::obj) - (inline handle-ast::obj ::%handle) - - (inline node?::bool ::obj) - (inline node-body::obj ::%node) - (inline node-options::pair-nil ::%node) - (inline node-loc::obj ::%node) - - (new-processor . inits) - (inline processor?::bool ::obj) - (inline processor-combinator::obj ::%processor) - (inline processor-engine::obj ::%processor) - - (new-markup . inits) - (inline markup?::bool ::obj) - (inline is-markup?::bool ::obj ::symbol) - (inline markup-markup::obj ::%markup) - (inline markup-ident::obj ::%markup) - (inline markup-body::obj ::%markup) - (inline markup-options::pair-nil ::%markup) - - (new-container . inits) - (inline container?::bool ::obj) - (inline container-ident::obj ::%container) - (inline container-body::obj ::%container) - (inline container-options::pair-nil ::%container) - - (new-document . inits) - (inline document?::bool ::obj) - (inline document-ident::bool ::%document) - (inline document-body::bool ::%document) - (inline document-options::pair-nil ::%document) - (inline document-env::pair-nil ::%document) - - (inline engine?::bool ::obj) - (inline engine-ident::obj ::obj) - (inline engine-format::obj ::obj) - (inline engine-customs::pair-nil ::obj) - (inline engine-filter::obj ::obj) - (inline engine-symbol-table::pair-nil ::%engine) - - (inline writer?::bool ::obj) - (inline writer-before::obj ::%writer) - (inline writer-action::obj ::%writer) - (inline writer-after::obj ::%writer) - (inline writer-options::obj ::%writer) - - (inline language?::bool ::obj) - (inline language-name::obj ::obj) - (inline language-fontifier::obj ::obj) - (inline language-extractor::obj ::obj) - - (new-language . inits) - - (location?::bool ::obj) - (location-file::bstring ::pair) - (location-pos::int ::pair))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate ... */ -;*---------------------------------------------------------------------*/ -(define-macro (skribe-instantiate type values . slots) - `(begin - (skribe-instantiate-check-values ',type ,values ',slots) - (,(symbol-append 'instantiate::% type) - ,@(map (lambda (slot) - (let ((id (if (pair? slot) (car slot) slot)) - (def (if (pair? slot) (cadr slot) #f))) - `(,id (new-get-value ',id ,values ,def)))) - slots)))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate-check-values ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-instantiate-check-values id values slots) - (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) - (when (pair? bs) - (for-each (lambda (b) - (error (symbol-append '|new | id) - "Illegal field" - b)) - bs)))) - -;*---------------------------------------------------------------------*/ -;* object-print ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-print obj::%ast port print-slot::procedure) - (let* ((class (object-class obj)) - (class-name (class-name class))) - (display "#|" port) - (display class-name port) - (display #\| port))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%ast ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%ast . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a>" - (find-runtime-type n))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a>" - (find-runtime-type n) - (markup-markup n))) - -;*---------------------------------------------------------------------*/ -;* object-write ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-write n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a:~a>" - (find-runtime-type n) - (markup-markup n) - (find-runtime-type (markup-body n)))) - -;*---------------------------------------------------------------------*/ -;* *node-table* */ -;* ------------------------------------------------------------- */ -;* A private hashtable that stores all the nodes of an ast. It */ -;* is used for retreiving a node from its identifier. */ -;*---------------------------------------------------------------------*/ -(define *node-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* ast? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast? obj) - (%ast? obj)) - -;*---------------------------------------------------------------------*/ -;* ast-parent ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-parent obj) - (%ast-parent obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc obj) - (%ast-loc obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc-set! ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc-set! obj loc) - (%ast-loc-set! obj loc)) - -;*---------------------------------------------------------------------*/ -;* ast-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast-location obj) - (with-access::%ast obj (loc) - (if (location? loc) - (let* ((fname (location-file loc)) - (char (location-pos loc)) - (pwd (pwd)) - (len (string-length pwd)) - (lenf (string-length fname)) - (file (if (and (substring=? pwd fname len) - (and (>fx lenf len))) - (substring fname len (+fx 1 (string-length fname))) - fname))) - (format "~a, char ~a" file char)) - "no source location"))) - -;*---------------------------------------------------------------------*/ -;* new-command ... */ -;*---------------------------------------------------------------------*/ -(define (new-command . init) - (skribe-instantiate command init - (parent #unspecified) - (loc #f) - fmt - (body #f))) - -;*---------------------------------------------------------------------*/ -;* command? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command? obj) - (%command? obj)) - -;*---------------------------------------------------------------------*/ -;* command-fmt ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-fmt cmd) - (%command-fmt cmd)) - -;*---------------------------------------------------------------------*/ -;* command-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-body cmd) - (%command-body cmd)) - -;*---------------------------------------------------------------------*/ -;* new-unresolved ... */ -;*---------------------------------------------------------------------*/ -(define (new-unresolved . init) - (skribe-instantiate unresolved init - (parent #unspecified) - loc - proc)) - -;*---------------------------------------------------------------------*/ -;* unresolved? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved? obj) - (%unresolved? obj)) - -;*---------------------------------------------------------------------*/ -;* unresolved-proc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved-proc unr) - (%unresolved-proc unr)) - -;*---------------------------------------------------------------------*/ -;* new-handle ... */ -;*---------------------------------------------------------------------*/ -(define (new-handle . init) - (skribe-instantiate handle init - (parent #unspecified) - loc - (ast #f))) - -;*---------------------------------------------------------------------*/ -;* handle? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle? obj) - (%handle? obj)) - -;*---------------------------------------------------------------------*/ -;* handle-ast ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle-ast obj) - (%handle-ast obj)) - -;*---------------------------------------------------------------------*/ -;* node? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node? obj) - (%node? obj)) - -;*---------------------------------------------------------------------*/ -;* node-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-body obj) - (%node-body obj)) - -;*---------------------------------------------------------------------*/ -;* node-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-options obj) - (%node-options obj)) - -;*---------------------------------------------------------------------*/ -;* node-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-loc obj) - (%node-loc obj)) - -;*---------------------------------------------------------------------*/ -;* new-processor ... */ -;*---------------------------------------------------------------------*/ -(define (new-processor . init) - (skribe-instantiate processor init - (parent #unspecified) - loc - (combinator (lambda (e1 e2) e1)) - engine - (body #f))) - -;*---------------------------------------------------------------------*/ -;* processor? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor? obj) - (%processor? obj)) - -;*---------------------------------------------------------------------*/ -;* processor-combinator ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-combinator proc) - (%processor-combinator proc)) - -;*---------------------------------------------------------------------*/ -;* processor-engine ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-engine proc) - (%processor-engine proc)) - -;*---------------------------------------------------------------------*/ -;* new-markup ... */ -;*---------------------------------------------------------------------*/ -(define (new-markup . init) - (skribe-instantiate markup init - (parent #unspecified) - (loc #f) - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()))) - -;*---------------------------------------------------------------------*/ -;* markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup? obj) - (%markup? obj)) - -;*---------------------------------------------------------------------*/ -;* is-markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (is-markup? obj markup) - (and (markup? obj) (eq? (markup-markup obj) markup))) - -;*---------------------------------------------------------------------*/ -;* markup-init ... */ -;* ------------------------------------------------------------- */ -;* The markup constructor simply stores in the markup table the */ -;* news markups. */ -;*---------------------------------------------------------------------*/ -(define (markup-init markup) - (bind-markup! markup)) - -;*---------------------------------------------------------------------*/ -;* bind-markup! ... */ -;*---------------------------------------------------------------------*/ -(define (bind-markup! node) - (hashtable-update! *node-table* - (markup-ident node) - (lambda (cur) (cons node cur)) - (list node))) - -;*---------------------------------------------------------------------*/ -;* find-markups ... */ -;*---------------------------------------------------------------------*/ -(define (find-markups ident) - (hashtable-get *node-table* ident)) - -;*---------------------------------------------------------------------*/ -;* markup-markup ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-markup obj) - (%markup-markup obj)) - -;*---------------------------------------------------------------------*/ -;* markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-ident obj) - (%markup-ident obj)) - -;*---------------------------------------------------------------------*/ -;* markup-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-body obj) - (%markup-body obj)) - -;*---------------------------------------------------------------------*/ -;* markup-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-options obj) - (%markup-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-container ... */ -;*---------------------------------------------------------------------*/ -(define (new-container . init) - (skribe-instantiate container init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* container? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container? obj) - (%container? obj)) - -;*---------------------------------------------------------------------*/ -;* container-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-ident obj) - (%container-ident obj)) - -;*---------------------------------------------------------------------*/ -;* container-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-body obj) - (%container-body obj)) - -;*---------------------------------------------------------------------*/ -;* container-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-options obj) - (%container-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-document ... */ -;*---------------------------------------------------------------------*/ -(define (new-document . init) - (skribe-instantiate document init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* document? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document? obj) - (%document? obj)) - -;*---------------------------------------------------------------------*/ -;* document-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-options doc) - (%document-options doc)) - -;*---------------------------------------------------------------------*/ -;* document-env ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-env doc) - (%document-env doc)) - -;*---------------------------------------------------------------------*/ -;* document-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-ident doc) - (%document-ident doc)) - -;*---------------------------------------------------------------------*/ -;* document-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-body doc) - (%document-body doc)) - -;*---------------------------------------------------------------------*/ -;* engine? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine? obj) - (%engine? obj)) - -;*---------------------------------------------------------------------*/ -;* engine-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-ident obj) - (%engine-ident obj)) - -;*---------------------------------------------------------------------*/ -;* engine-format ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-format obj) - (%engine-format obj)) - -;*---------------------------------------------------------------------*/ -;* engine-customs ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-customs obj) - (%engine-customs obj)) - -;*---------------------------------------------------------------------*/ -;* engine-filter ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-filter obj) - (%engine-filter obj)) - -;*---------------------------------------------------------------------*/ -;* engine-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-symbol-table obj) - (%engine-symbol-table obj)) - -;*---------------------------------------------------------------------*/ -;* writer? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer? obj) - (%writer? obj)) - -;*---------------------------------------------------------------------*/ -;* writer-before ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-before obj) - (%writer-before obj)) - -;*---------------------------------------------------------------------*/ -;* writer-action ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-action obj) - (%writer-action obj)) - -;*---------------------------------------------------------------------*/ -;* writer-after ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-after obj) - (%writer-after obj)) - -;*---------------------------------------------------------------------*/ -;* writer-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-options obj) - (%writer-options obj)) - -;*---------------------------------------------------------------------*/ -;* language? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language? obj) - (%language? obj)) - -;*---------------------------------------------------------------------*/ -;* language-name ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-name lg) - (%language-name lg)) - -;*---------------------------------------------------------------------*/ -;* language-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-fontifier lg) - (%language-fontifier lg)) - -;*---------------------------------------------------------------------*/ -;* language-extractor ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-extractor lg) - (%language-extractor lg)) - -;*---------------------------------------------------------------------*/ -;* new-get-value ... */ -;*---------------------------------------------------------------------*/ -(define (new-get-value key init def) - (let ((c (assq key init))) - (match-case c - ((?- ?v) - v) - (else - def)))) - -;*---------------------------------------------------------------------*/ -;* new-language ... */ -;*---------------------------------------------------------------------*/ -(define (new-language . init) - (skribe-instantiate language init name fontifier extractor)) - -;*---------------------------------------------------------------------*/ -;* location? ... */ -;*---------------------------------------------------------------------*/ -(define (location? o) - (match-case o - ((at ?- ?-) - #t) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* location-file ... */ -;*---------------------------------------------------------------------*/ -(define (location-file o) - (match-case o - ((at ?fname ?-) - fname) - (else - (error 'location-file "Illegal location" o)))) - -;*---------------------------------------------------------------------*/ -;* location-pos ... */ -;*---------------------------------------------------------------------*/ -(define (location-pos o) - (match-case o - ((at ?- ?loc) - loc) - (else - (error 'location-pos "Illegal location" o)))) diff --git a/src/bigloo/verify.scm b/src/bigloo/verify.scm deleted file mode 100644 index 602a951..0000000 --- a/src/bigloo/verify.scm +++ /dev/null @@ -1,143 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jul 25 09:54:55 2003 */ -;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe verification stage */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_verify - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (generic verify ::obj ::%engine))) - -;*---------------------------------------------------------------------*/ -;* check-required-options ... */ -;*---------------------------------------------------------------------*/ -(define (check-required-options n::%markup w::%writer e::%engine) - (with-access::%markup n (required-options) - (with-access::%writer w (ident options verified?) - (or verified? - (eq? options 'all) - (begin - (for-each (lambda (o) - (if (not (memq o options)) - (skribe-error (%engine-ident e) - (format "Option unsupported: ~a, supported options: ~a" o options) - n))) - required-options) - (set! verified? #t)))))) - -;*---------------------------------------------------------------------*/ -;* check-options ... */ -;* ------------------------------------------------------------- */ -;* Only keywords are checked, symbols are voluntary left unchecked. */ -;*---------------------------------------------------------------------*/ -(define (check-options eo*::pair-nil m::%markup e::%engine) - (with-debug 6 'check-options - (debug-item "markup=" (%markup-markup m)) - (debug-item "options=" (%markup-options m)) - (debug-item "eo*=" eo*) - (for-each (lambda (o2) - (for-each (lambda (o) - (if (and (keyword? o) - (not (eq? o :&skribe-eval-location)) - (not (memq o eo*))) - (skribe-warning/ast - 3 - m - 'verify - (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" - (%engine-ident e) - (%markup-markup m) - o - (markup-option m o))))) - o2)) - (%markup-options m)))) - -;*---------------------------------------------------------------------*/ -;* verify :: ... */ -;*---------------------------------------------------------------------*/ -(define-generic (verify node e) - (if (pair? node) - (for-each (lambda (n) (verify n e)) node)) - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify n::%processor e) - (with-access::%processor n (combinator engine body) - (verify body (processor-get-engine combinator engine e)) - n)) - -;*---------------------------------------------------------------------*/ -;* verify ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%node e) - (with-access::%node node (body options) - (verify body e) - (for-each (lambda (o) (verify (cadr o) e)) options) - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%markup e) - (with-debug 5 'verify::%markup - (debug-item "node=" (%markup-markup node)) - (debug-item "options=" (%markup-options node)) - (debug-item "e=" (%engine-ident e)) - (call-next-method) - (let ((w (lookup-markup-writer node e))) - (if (%writer? w) - (begin - (check-required-options node w e) - (if (pair? (%writer-options w)) - (check-options (%writer-options w) node e)) - (let ((validate (%writer-validate w))) - (when (procedure? validate) - (unless (validate node e) - (skribe-warning - 1 - node - (format "Node `~a' forbidden here by ~a engine" - (markup-markup node) - (engine-ident e)) - node))))))) - ;; return the node - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%document ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%document e) - (call-next-method) - ;; verify the engine custom - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (set-car! (cdr c) (verify a e)))) - (%engine-customs e)) - ;; return the node - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%handle e) - node) - diff --git a/src/bigloo/writer.scm b/src/bigloo/writer.scm deleted file mode 100644 index ce515bf..0000000 --- a/src/bigloo/writer.scm +++ /dev/null @@ -1,232 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 06:19:57 2003 */ -;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe writer management */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_writer - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_engine - skribe_output - skribe_lib) - - (export (invoke proc node e) - - (lookup-markup-writer ::%markup ::%engine) - - (markup-writer ::obj #!optional e #!key p class opt va bef aft act) - (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) - (markup-writer-get ::obj #!optional e #!key class pred) - (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) - -;*---------------------------------------------------------------------*/ -;* invoke ... */ -;*---------------------------------------------------------------------*/ -(define (invoke proc node e) - (let ((id (if (markup? node) - (string->symbol - (format "~a#~a" - (%engine-ident e) - (%markup-markup node))) - (%engine-ident e)))) - (with-push-trace id - (with-debug 5 'invoke - (debug-item "e=" (%engine-ident e)) - (debug-item "node=" (find-runtime-type node) - " " (if (markup? node) (%markup-markup node) "")) - (if (string? proc) - (display proc) - (if (procedure? proc) - (proc node e))))))) - -;*---------------------------------------------------------------------*/ -;* lookup-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (lookup-markup-writer node e) - (with-access::%engine e (writers delegate) - (let loop ((w* writers)) - (cond - ((pair? w*) - (with-access::%writer (car w*) (pred) - (if (pred node e) - (car w*) - (loop (cdr w*))))) - ((engine? delegate) - (lookup-markup-writer node delegate)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* make-writer-predicate ... */ -;*---------------------------------------------------------------------*/ -(define (make-writer-predicate markup predicate class) - (let* ((t1 (if (symbol? markup) - (lambda (n e) (is-markup? n markup)) - (lambda (n e) #t))) - (t2 (if class - (lambda (n e) - (and (t1 n e) (equal? (%markup-class n) class))) - t1))) - (if predicate - (cond - ((not (procedure? predicate)) - (skribe-error 'markup-writer - "Illegal predicate (procedure expected)" - predicate)) - ((not (correct-arity? predicate 2)) - (skribe-error 'markup-writer - "Illegal predicate arity (2 arguments expected)" - predicate)) - (else - (lambda (n e) - (and (t2 n e) (predicate n e))))) - t2))) - -;*---------------------------------------------------------------------*/ -;* markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (markup-writer markup - #!optional - engine - #!key - (predicate #f) - (class #f) - (options '()) - (validate #f) - (before #f) - (action #unspecified) - (after #f)) - (let ((e (or engine (default-engine)))) - (cond - ((and (not (symbol? markup)) (not (eq? markup #t))) - (skribe-error 'markup-writer "Illegal markup" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - ((and (not predicate) - (not class) - (null? options) - (not before) - (eq? action #unspecified) - (not after)) - (skribe-error 'markup-writer "Illegal writer" markup)) - (else - (let ((m (make-writer-predicate markup predicate class)) - (ac (if (eq? action #unspecified) - (lambda (n e) - (output (markup-body n) e)) - action))) - (engine-add-writer! e markup m predicate - options before ac after class validate)))))) - -;*---------------------------------------------------------------------*/ -;* copy-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (copy-markup-writer markup old-engine - #!optional new-engine - #!key - (predicate #unspecified) - (class #unspecified) - (options #unspecified) - (validate #unspecified) - (before #unspecified) - (action #unspecified) - (after #unspecified)) - (let ((old (markup-writer-get markup old-engine)) - (new-engine (or new-engine old-engine))) - (markup-writer markup new-engine - :pred (if (unspecified? predicate) - (%writer-pred old) - predicate) - :class (if (unspecified? class) - (%writer-class old) - class) - :options (if (unspecified? options) - (%writer-options old) - options) - :validate (if (unspecified? validate) - (%writer-validate old) - validate) - :before (if (unspecified? before) - (%writer-before old) - before) - :action (if (unspecified? action) - (%writer-action old) - action) - :after (if (unspecified? after) - (%writer-after old) after)))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get ... */ -;* ------------------------------------------------------------- */ -;* Finds the writer that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e)) - (let loop ((w* (%engine-writers e))) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class) - (or (eq? pred #unspecified) - (eq? (%writer-upred (car w*)) pred))) - (car w*) - (loop (cdr w*)))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get* ... */ -;* ------------------------------------------------------------- */ -;* Finds alll writers that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get* markup #!optional engine #!key (class #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e) - (res '())) - (let loop ((w* (%engine-writers e)) - (res res)) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class)) - (loop (cdr w*) (cons (car w*) res)) - (loop (cdr w*) res))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e) res)) - (else - (reverse! res))))))))) diff --git a/src/bigloo/xml.scm b/src/bigloo/xml.scm deleted file mode 100644 index d4c662e..0000000 --- a/src/bigloo/xml.scm +++ /dev/null @@ -1,92 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Mon May 17 10:14:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* XML fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_xml - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export xml)) - -;*---------------------------------------------------------------------*/ -;* xml ... */ -;*---------------------------------------------------------------------*/ -(define xml - (new language - (name "xml") - (fontifier xml-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* xml-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (xml-fontifier s) - (let ((g (regular-grammar () - ((: #\; (in "") - ;; italic comments - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-line-comment) - (body s)))) - str) - (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>) - ;; markup - (let ((str (the-string))) - (let ((c (new markup - (markup '&source-module) - (body (the-string))))) - (cons c (ignore))))) - ((+ (out #\< #\> #\Space #\Tab #\= #\")) - ;; regular text - (let ((string (the-string))) - (cons string (ignore)))) - ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'")) - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((in "\"=") - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(xml)" "Unexpected character" c))))))) - (with-input-from-string s - (lambda () - (read/rp g (current-input-port)))))) - diff --git a/src/common/api.scm b/src/common/api.scm deleted file mode 100644 index eb657c7..0000000 --- a/src/common/api.scm +++ /dev/null @@ -1,1249 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/api.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:11:56 2003 */ -;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scribe API */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../bigloo/api.bgl@ */ -;* Documentation: */ -;* @path ../../doc/user/markup.skb@ */ -;* @path ../../doc/user/document.skb@ */ -;* @path ../../doc/user/sectioning.skb@ */ -;* @path ../../doc/user/toc.skb@ */ -;* @path ../../doc/user/ornament.skb@ */ -;* @path ../../doc/user/line.skb@ */ -;* @path ../../doc/user/font.skb@ */ -;* @path ../../doc/user/justify.skb@ */ -;* @path ../../doc/user/enumeration.skb@ */ -;* @path ../../doc/user/colframe.skb@ */ -;* @path ../../doc/user/figure.skb@ */ -;* @path ../../doc/user/image.skb@ */ -;* @path ../../doc/user/table.skb@ */ -;* @path ../../doc/user/footnote.skb@ */ -;* @path ../../doc/user/char.skb@ */ -;* @path ../../doc/user/links.skb@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* include ... */ -;*---------------------------------------------------------------------*/ -(define-markup (include file) - (if (not (string? file)) - (skribe-error 'include "Illegal file (string expected)" file) - (skribe-include file))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(define-markup (document #!rest - opts - #!key - (ident #f) (class "document") - (title #f) (html-title #f) (author #f) - (ending #f) (env '())) - (new document - (markup 'document) - (ident (or ident - (ast->string title) - (symbol->string (gensym 'document)))) - (class class) - (required-options '(:title :author :ending)) - (options (the-options opts :ident :class :env)) - (body (the-body opts)) - (env (append env - (list (list 'chapter-counter 0) (list 'chapter-env '()) - (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()) - (list 'figure-counter 0) (list 'figure-env '())))))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(define-markup (author #!rest - opts - #!key - (ident #f) (class "author") - name - (title #f) - (affiliation #f) - (email #f) - (url #f) - (address #f) - (phone #f) - (photo #f) - (align 'center)) - (if (not (memq align '(center left right))) - (skribe-error 'author "Illegal align value" align) - (new container - (markup 'author) - (ident (or ident (symbol->string (gensym 'author)))) - (class class) - (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) - (options `((:name ,name) - (:align ,align) - ,@(the-options opts :ident :class))) - (body #f)))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(define-markup (toc #!rest - opts - #!key - (ident #f) (class "toc") - (chapter #t) (section #t) (subsection #f)) - (let ((body (the-body opts))) - (new container - (markup 'toc) - (ident (or ident (symbol->string (gensym 'toc)))) - (class class) - (required-options '()) - (options `((:chapter ,chapter) - (:section ,section) - (:subsection ,subsection) - ,@(the-options opts :ident :class))) - (body (cond - ((null? body) - (new unresolved - (proc (lambda (n e env) - (handle - (resolve-search-parent n env document?)))))) - ((null? (cdr body)) - (if (handle? (car body)) - (car body) - (skribe-error 'toc - "Illegal argument (handle expected)" - (if (markup? (car body)) - (markup-markup (car body)) - "???")))) - (else - (skribe-error 'toc "Illegal argument" body))))))) - -;*---------------------------------------------------------------------*/ -;* chapter ... ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:chapter@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:chapter@ */ -;*---------------------------------------------------------------------*/ -(define-markup (chapter #!rest - opts - #!key - (ident #f) (class "chapter") - title (html-title #f) (file #f) (toc #t) (number #t)) - (new container - (markup 'chapter) - (ident (or ident (symbol->string (gensym 'chapter)))) - (class class) - (required-options '(:title :file :toc :number)) - (options `((:toc ,toc) - (:number ,(and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n - env - 'chapter - number)))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()))))) - -;*---------------------------------------------------------------------*/ -;* section-number ... */ -;*---------------------------------------------------------------------*/ -(define (section-number number markup) - (and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n env markup number)))))) - -;*---------------------------------------------------------------------*/ -;* section ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:section@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:sectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (section #!rest - opts - #!key - (ident #f) (class "section") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'section) - (ident (or ident (symbol->string (gensym 'section)))) - (class class) - (required-options '(:title :toc :file :toc :number)) - (options `((:number ,(section-number number 'section)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (if file - (list (list 'subsection-counter 0) (list 'subsection-env '()) - (list 'footnote-counter 0) (list 'footnote-env '())) - (list (list 'subsection-counter 0) (list 'subsection-env '())))))) - -;*---------------------------------------------------------------------*/ -;* subsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsection #!rest - opts - #!key - (ident #f) (class "subsection") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'subsection) - (ident (or ident (symbol->string (gensym 'subsection)))) - (class class) - (required-options '(:title :toc :file :number)) - (options `((:number ,(section-number number 'subsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsubsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsubsection #!rest - opts - #!key - (ident #f) (class "subsubsection") - title (file #f) (toc #f) (number #t)) - (new container - (markup 'subsubsection) - (ident (or ident (symbol->string (gensym 'subsubsection)))) - (class class) - (required-options '(:title :toc :number :file)) - (options `((:number ,(section-number number 'subsubsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup paragraph) - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(define-markup (footnote #!rest opts - #!key (ident #f) (class "footnote") (label #t)) - ;; The `:label' option used to be called `:number'. - (new container - (markup 'footnote) - (ident (symbol->string (gensym 'footnote))) - (class class) - (required-options '()) - (options `((:label - ,(cond ((string? label) label) - ((number? label) label) - ((not label) label) - (else - (new unresolved - (proc (lambda (n e env) - (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) - (let ((ln (new markup - (ident (or ident (symbol->string (gensym 'linebreak)))) - (class class) - (markup 'linebreak))) - (num (the-body opts))) - (cond - ((null? num) - ln) - ((not (null? (cdr num))) - (skribe-error 'linebreak "Illegal arguments" num)) - ((not (and (integer? (car num)) (positive? (car num)))) - (skribe-error 'linebreak "Illegal argument" (car num))) - (else - (vector->list (make-vector (car num) ln)))))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(define-markup (hrule #!rest - opts - #!key - (ident #f) (class #f) - (width 100.) (height 1)) - (new markup - (markup 'hrule) - (ident (or ident (symbol->string (gensym 'hrule)))) - (class class) - (required-options '()) - (options `((:width ,width) - (:height ,height) - ,@(the-options opts :ident :class))) - (body #f))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(define-markup (color #!rest - opts - #!key - (ident #f) (class "color") - (bg #f) (fg #f) (width #f) (margin #f)) - (new container - (markup 'color) - (ident (or ident (symbol->string (gensym 'color)))) - (class class) - (required-options '(:bg :fg :width)) - (options `((:bg ,(if bg (skribe-use-color! bg) bg)) - (:fg ,(if fg (skribe-use-color! fg) fg)) - ,@(the-options opts :ident :class :bg :fg))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define-markup (frame #!rest - opts - #!key - (ident #f) (class "frame") - (width #f) (margin 2) (border 1)) - (new container - (markup 'frame) - (ident (or ident (symbol->string (gensym 'frame)))) - (class class) - (required-options '(:width :border :margin)) - (options `((:margin ,margin) - (:border ,(cond - ((integer? border) border) - (border 1) - (else #f))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(define-markup (font #!rest - opts - #!key - (ident #f) (class #f) - (size #f) (face #f)) - (new container - (markup 'font) - (ident (or ident (symbol->string (gensym 'font)))) - (class class) - (required-options '(:size)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(define-markup (flush #!rest - opts - #!key - (ident #f) (class #f) - side) - (case side - ((center left right) - (new container - (markup 'flush) - (ident (or ident (symbol->string (gensym 'flush)))) - (class class) - (required-options '(:side)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - (else - (skribe-error 'flush "Illegal side" side)))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container center) - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container pre) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:prog@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:prog@ */ -;*---------------------------------------------------------------------*/ -(define-markup (prog #!rest - opts - #!key - (ident #f) (class "prog") - (line 1) (linedigit #f) (mark ";!")) - (if (not (or (string? mark) (eq? mark #f))) - (skribe-error 'prog "Illegal mark" mark) - (new container - (markup 'prog) - (ident (or ident (symbol->string (gensym 'prog)))) - (class class) - (required-options '(:line :mark)) - (options (the-options opts :ident :class :linedigit)) - (body (make-prog-body (the-body opts) line linedigit mark))))) - -;*---------------------------------------------------------------------*/ -;* source ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:source@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:source@ */ -;*---------------------------------------------------------------------*/ -(define-markup (source #!rest - opts - #!key - language - (file #f) (start #f) (stop #f) - (definition #f) (tab 8)) - (let ((body (the-body opts))) - (cond - ((and (not (null? body)) (or file start stop definition)) - (skribe-error 'source - "file, start/stop, and definition are exclusive with body" - body)) - ((and start stop definition) - (skribe-error 'source - "start/stop are exclusive with a definition" - body)) - ((and (or start stop definition) (not file)) - (skribe-error 'source - "start/stop and definition require a file specification" - file)) - ((and definition (not language)) - (skribe-error 'source - "definition requires a language specification" - definition)) - ((and file (not (string? file))) - (skribe-error 'source "Illegal file" file)) - ((and start (not (or (integer? start) (string? start)))) - (skribe-error 'source "Illegal start" start)) - ((and stop (not (or (integer? stop) (string? stop)))) - (skribe-error 'source "Illegal start" stop)) - ((and (integer? start) (integer? stop) (> start stop)) - (skribe-error 'source - "start line > stop line" - (format "~a/~a" start stop))) - ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) - ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) - (file - (let ((s (if (not definition) - (source-read-lines file start stop tab) - (source-read-definition file definition tab language)))) - (if language - (source-fontify s language) - s))) - (language - (source-fontify body language)) - (else - body)))) - -;*---------------------------------------------------------------------*/ -;* language ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:language@ */ -;*---------------------------------------------------------------------*/ -(define-markup (language #!key name (fontifier #f) (extractor #f)) - (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") - (new language - (name name) - (fontifier fontifier) - (extractor extractor)))) - -;*---------------------------------------------------------------------*/ -;* figure ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/figure.skb:figure@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:figure@ */ -;*---------------------------------------------------------------------*/ -(define-markup (figure #!rest - opts - #!key - (ident #f) (class "figure") - (legend #f) (number #t) (multicolumns #f)) - (new container - (markup 'figure) - (ident (or ident - (let ((s (ast->string legend))) - (if (not (string=? s "")) - s - (symbol->string (gensym 'figure)))))) - (class class) - (required-options '(:legend :number :multicolumns)) - (options `((:number - ,(new unresolved - (proc (lambda (n e env) - (resolve-counter n env 'figure number))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* parse-list-of ... */ -;* ------------------------------------------------------------- */ -;* The function table accepts two different prototypes. It */ -;* may receive its N elements in a list of N elements or in */ -;* a list of one element which is a list of N elements. This */ -;* gets rid of APPLY when calling container markup such as ITEMIZE */ -;* or TABLE. */ -;*---------------------------------------------------------------------*/ -(define (parse-list-of for markup lst) - (cond - ((null? lst) - '()) - ((and (pair? lst) - (or (pair? (car lst)) (null? (car lst))) - (null? (cdr lst))) - (parse-list-of for markup (car lst))) - (else - (let loop ((lst lst)) - (cond - ((null? lst) - '()) - ((pair? (car lst)) - (loop (car lst))) - (else - (let ((r (car lst))) - (if (not (is-markup? r markup)) - (skribe-warning 2 - for - (format "Illegal `~a' element, `~a' expected" - (if (markup? r) - (markup-markup r) - (find-runtime-type r)) - markup))) - (cons r (loop (cdr lst)))))))))) - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) - (new container - (markup 'itemize) - (ident (or ident (symbol->string (gensym 'itemize)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'itemize 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) - (new container - (markup 'enumerate) - (ident (or ident (symbol->string (gensym 'enumerate)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'enumerate 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) - (new container - (markup 'description) - (ident (or ident (symbol->string (gensym 'description)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'description 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(define-markup (item #!rest opts #!key (ident #f) (class #f) key) - (if (and key (not (or (string? key) - (number? key) - (markup? key) - (pair? key)))) - (skribe-type-error 'item "Illegal key:" key "node") - (new container - (markup 'item) - (ident (or ident (symbol->string (gensym 'item)))) - (class class) - (required-options '(:key)) - (options `((:key ,key) ,@(the-options opts :ident :class :key))) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* table */ -;*---------------------------------------------------------------------*/ -(define-markup (table #!rest - opts - #!key - (ident #f) (class #f) - (border #f) (width #f) - (frame 'none) (rules 'none) - (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) - (let ((frame (cond - ((string? frame) - (string->symbol frame)) - ((not frame) - #f) - (else - frame))) - (rules (cond - ((string? rules) - (string->symbol rules)) - ((not rules) - #f) - (else - rules))) - (frame-vals '(none above below hsides vsides lhs rhs box border)) - (rules-vals '(none rows cols all header)) - (cells-vals '(collapse separate))) - (cond - ((and frame (not (memq frame frame-vals))) - (skribe-error 'table - (format "frame should be one of \"~a\"" frame-vals) - frame)) - ((and rules (not (memq rules rules-vals))) - (skribe-error 'table - (format "rules should be one of \"~a\"" rules-vals) - rules)) - ((not (or (memq cellstyle cells-vals) - (string? cellstyle) - (number? cellstyle))) - (skribe-error 'table - (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) - cellstyle)) - (else - (new container - (markup 'table) - (ident (or ident (symbol->string (gensym 'table)))) - (class class) - (required-options '(:width :frame :rules)) - (options `((:frame ,frame) - (:rules ,rules) - (:cellstyle ,cellstyle) - ,@(the-options opts :ident :class))) - (body (parse-list-of 'table 'tr (the-body opts)))))))) - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) - (new container - (markup 'tr) - (ident (or ident (symbol->string (gensym 'tr)))) - (class class) - (required-options '()) - (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) - ,@(the-options opts :ident :class :bg))) - (body (parse-list-of 'tr 'tc (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* tc... */ -;*---------------------------------------------------------------------*/ -(define-markup (tc m - #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (let ((align (if (string? align) - (string->symbol align) - align)) - (valign (if (string? valign) - (string->symbol valign) - valign))) - (cond - ((not (integer? colspan)) - (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) - ((not (symbol? align)) - (skribe-type-error 'tc "Illegal align, " align "align")) - ((not (memq align '(#f center left right))) - (skribe-error - 'tc - "align should be one of 'left', `center', or `right'" - align)) - ((not (memq valign '(#f top middle center bottom))) - (skribe-error - 'tc - "valign should be one of 'top', `middle', `center', or `bottom'" - valign)) - (else - (new container - (markup 'tc) - (ident (or ident (symbol->string (gensym 'tc)))) - (class class) - (required-options '(:width :align :valign :colspan)) - (options `((markup ,m) - (:align ,align) - (:valign ,valign) - (:colspan ,colspan) - ,@(if bg - `((:bg ,(if bg (skribe-use-color! bg) bg))) - '()) - ,@(the-options opts :ident :class :bg :align :valign))) - (body (the-body opts))))))) - -;*---------------------------------------------------------------------*/ -;* th ... */ -;*---------------------------------------------------------------------*/ -(define-markup (th #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'th opts)) - -;*---------------------------------------------------------------------*/ -;* td ... */ -;*---------------------------------------------------------------------*/ -(define-markup (td #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'td opts)) - -;*---------------------------------------------------------------------*/ -;* image ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/image.skb:image@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:image@ */ -;* latex: @ref ../../skr/latex.skr:image@ */ -;*---------------------------------------------------------------------*/ -(define-markup (image #!rest - opts - #!key - (ident #f) (class #f) - file (url #f) (width #f) (height #f) (zoom #f)) - (cond - ((not (or (string? file) (string? url))) - (skribe-error 'image "No file or url provided" file)) - ((and (string? file) (string? url)) - (skribe-error 'image "Both file and url provided" (list file url))) - (else - (new markup - (markup 'image) - (ident (or ident (symbol->string (gensym 'image)))) - (class class) - (required-options '(:file :url :width :height)) - (options (the-options opts :ident :class)) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* blockquote */ -;*---------------------------------------------------------------------*/ -(define-simple-markup blockquote) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup roman) -(define-simple-markup bold) -(define-simple-markup underline) -(define-simple-markup strike) -(define-simple-markup emph) -(define-simple-markup kbd) -(define-simple-markup it) -(define-simple-markup tt) -(define-simple-markup code) -(define-simple-markup var) -(define-simple-markup samp) -(define-simple-markup sf) -(define-simple-markup sc) -(define-simple-markup sub) -(define-simple-markup sup) - -;*---------------------------------------------------------------------*/ -;* char ... */ -;*---------------------------------------------------------------------*/ -(define-markup (char char) - (cond - ((char? char) - (string char)) - ((integer? char) - (string (integer->char char))) - ((and (string? char) (= (string-length char) 1)) - char) - (else - (skribe-error 'char "Illegal char" char)))) - -;*---------------------------------------------------------------------*/ -;* symbol ... */ -;*---------------------------------------------------------------------*/ -(define-markup (symbol symbol) - (let ((v (cond - ((symbol? symbol) - (symbol->string symbol)) - ((string? symbol) - symbol) - (else - (skribe-error 'symbol - "Illegal argument (symbol expected)" - symbol))))) - (new markup - (markup 'symbol) - (body v)))) - -;*---------------------------------------------------------------------*/ -;* ! ... */ -;*---------------------------------------------------------------------*/ -(define-markup (! format #!rest node) - (if (not (string? format)) - (skribe-type-error '! "Illegal format:" format "string") - (new command - (fmt format) - (body node)))) - -;*---------------------------------------------------------------------*/ -;* processor ... */ -;*---------------------------------------------------------------------*/ -(define-markup (processor #!rest opts - #!key (combinator #f) (engine #f) (procedure #f)) - (cond - ((and combinator (not (procedure? combinator))) - (skribe-error 'processor "Combinator not a procedure" combinator)) - ((and engine (not (engine? engine))) - (skribe-error 'processor "Illegal engine" engine)) - ((and procedure - (or (not (procedure? procedure)) - (not (correct-arity? procedure 2)))) - (skribe-error 'processor "Illegal procedure" procedure)) - (else - (new processor - (combinator combinator) - (engine engine) - (procedure (or procedure (lambda (n e) n))) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* Processors ... */ -;*---------------------------------------------------------------------*/ -(define-processor-markup html-processor) -(define-processor-markup tex-processor) - -;*---------------------------------------------------------------------*/ -;* handle ... */ -;*---------------------------------------------------------------------*/ -(define-markup (handle #!rest opts - #!key (ident #f) (class "handle") value section) - (let ((body (the-body opts))) - (cond - (section - (error 'handle "Illegal handle `section' option" section) - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident section 'section n env))) - (new handle - (ast s))))))) - ((and (pair? body) - (null? (cdr body)) - (markup? (car body))) - (new handle - (ast (car body)))) - (else - (skribe-error 'handle "Illegal handle" opts))))) - -;*---------------------------------------------------------------------*/ -;* mailto ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mailto@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mailto@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) - (new markup - (markup 'mailto) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* *mark-table* ... */ -;*---------------------------------------------------------------------*/ -(define *mark-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mark@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mark@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) - (let ((bd (the-body opts))) - (cond - ((and (pair? bd) (not (null? (cdr bd)))) - (skribe-error 'mark "Too many argument provided" bd)) - ((null? bd) - (skribe-error 'mark "Missing argument" '())) - ((not (string? (car bd))) - (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) - (ident - (skribe-error 'mark "Illegal `ident:' option" ident)) - (else - (let* ((bs (ast->string bd)) - (n (new markup - (markup 'mark) - (ident bs) - (class class) - (options (the-options opts :ident :class :text)) - (body text)))) - (hashtable-put! *mark-table* bs n) - n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:ref@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:ref@ */ -;* latex: @ref ../../skr/latex.skr:ref@ */ -;*---------------------------------------------------------------------*/ -(define-markup (ref #!rest - opts - #!key - (class #f) - (ident #f) - (text #f) - (chapter #f) - (section #f) - (subsection #f) - (subsubsection #f) - (bib #f) - (bib-table (default-bib-table)) - (url #f) - (figure #f) - (mark #f) - (handle #f) - (line #f) - (skribe #f) - (page #f)) - (define (unref ast text kind) - (let ((msg (format "Can't find `~a': " kind))) - (if (ast? ast) - (begin - (skribe-warning/ast 1 ast 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body (list text ": " (ast->file-location ast))))) - (begin - (skribe-warning 1 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body text)))))) - (define (skribe-ref skribe) - (let ((path (find-file/path skribe (skribe-path)))) - (if (not path) - (unref #f skribe 'sui-file) - (let* ((sui (load-sui path)) - (os (the-options opts :skribe :class :text)) - (u (sui-ref->url (dirname path) sui ident os))) - (if (not u) - (unref #f os 'sui-ref) - (ref :url u :text text :ident ident :class class)))))) - (define (handle-ref text) - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind handle) ,@(the-options opts :ident :class))) - (body text))) - (define (doref text kind) - (if (not (string? text)) - (skribe-type-error 'ref "Illegal reference" text "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident text kind n env))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) - (mark ,text) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n text (or kind 'ident))))))))) - (define (mark-ref mark) - (if (not (string? mark)) - (skribe-type-error 'mark "Illegal mark, " mark "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (hashtable-get *mark-table* mark))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind mark) - (mark ,mark) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n mark 'mark)))))))) - (define (make-bib-ref v) - (let ((s (resolve-bib bib-table v))) - (if s - (let* ((n (new markup - (markup 'bib-ref) - (ident (symbol->string 'bib-ref)) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (new handle - (ast s))))) - (h (new handle (ast n))) - (o (markup-option s 'used))) - (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) - n) - (unref #f v 'bib)))) - (define (bib-ref text) - (if (pair? text) - (new markup - (markup 'bib-ref+) - (ident (symbol->string 'bib-ref+)) - (class class) - (options (the-options opts :ident :class)) - (body (map make-bib-ref text))) - (make-bib-ref text))) - (define (url-ref) - (new markup - (markup 'url-ref) - (ident (symbol->string 'url-ref)) - (class class) - (required-options '(:url :text)) - (options (the-options opts :ident :class)))) - (define (line-ref line) - (new unresolved - (proc (lambda (n e env) - (let ((l (resolve-line line))) - (if (pair? l) - (new markup - (markup 'line-ref) - (ident (symbol->string 'line-ref)) - (class class) - (options `((:text ,(markup-ident (car l))) - ,@(the-options opts :ident :class))) - (body (new handle - (ast (car l))))) - (unref n line 'line))))))) - (let ((b (the-body opts))) - (if (not (null? b)) - (skribe-warning 1 'ref "Arguments ignored " b)) - (cond - (skribe (skribe-ref skribe)) - (handle (handle-ref handle)) - (ident (doref ident #f)) - (chapter (doref chapter 'chapter)) - (section (doref section 'section)) - (subsection (doref subsection 'subsection)) - (subsubsection (doref subsubsection 'subsubsection)) - (figure (doref figure 'figure)) - (mark (mark-ref mark)) - (bib (bib-ref bib)) - (url (url-ref)) - (line (line-ref line)) - (else (skribe-error 'ref "Illegal reference" opts))))) - -;*---------------------------------------------------------------------*/ -;* resolve ... */ -;*---------------------------------------------------------------------*/ -(define-markup (resolve fun) - (new unresolved - (proc fun))) - -;*---------------------------------------------------------------------*/ -;* bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (bibliography #!rest files - #!key - (command #f) (bib-table (default-bib-table))) - (for-each (lambda (f) - (cond - ((string? f) - (bib-load! bib-table f command)) - ((pair? f) - (bib-add! bib-table f)) - (else - (skribe-error "bibliography" "Illegal entry" f)))) - (the-body files))) - -;*---------------------------------------------------------------------*/ -;* the-bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:the-bibliography@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-bibliography #!rest opts - #!key - pred - (bib-table (default-bib-table)) - (sort bib-sort/authors) - (count 'partial)) - (if (not (memq count '(partial full))) - (skribe-error 'the-bibliography - "Cound must be either `partial' or `full'" - count) - (new unresolved - (proc (lambda (n e env) - (resolve-the-bib bib-table - (new handle (ast n)) - sort - pred - count - (the-options opts))))))) - -;*---------------------------------------------------------------------*/ -;* make-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:make-index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (make-index ident) - (make-index-table ident)) - -;*---------------------------------------------------------------------*/ -;* index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (index #!rest - opts - #!key - (ident #f) (class "index") - (note #f) (index #f) (shape #f) - (url #f)) - (let* ((entry-name (the-body opts)) - (ename (cond - ((string? entry-name) - entry-name) - ((and (pair? entry-name) (every string? entry-name)) - (apply string-append entry-name)) - (else - (skribe-error - 'index - "entry-name must be either a string or a list of strings" - entry-name)))) - (table (cond - ((not index) (default-index)) - ((index? index) index) - (else (skribe-type-error 'index - "Illegal index table, " - index - "index")))) - (m (mark (symbol->string (gensym)))) - (h (new handle (ast m))) - (new (new markup - (markup '&index-entry) - (ident (or ident (symbol->string (gensym 'index)))) - (class class) - (options `((name ,ename) ,@(the-options opts :ident :class))) - (body (if url - (ref :url url :text (or shape ename)) - (ref :handle h :text (or shape ename))))))) - ;; New is bound to a dummy option of the mark in order - ;; to make new options verified. - (markup-option-add! m 'to-verify new) - (hashtable-update! table - ename - (lambda (cur) (cons new cur)) - (list new)) - m)) - -;*---------------------------------------------------------------------*/ -;* the-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:the-index@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-index@ */ -;* html: @ref ../../skr/html.skr:the-index-header@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-index #!rest - opts - #!key - (ident #f) - (class "the-index") - (split #f) - (char-offset 0) - (header-limit 50) - (column 1)) - (let ((bd (the-body opts))) - (cond - ((not (and (integer? char-offset) (>= char-offset 0))) - (skribe-error 'the-index "Illegal char offset" char-offset)) - ((not (integer? column)) - (skribe-error 'the-index "Illegal column number" column)) - ((not (every? index? bd)) - (skribe-error 'the-index - "Illegal indexes" - (filter (lambda (o) (not (index? o))) bd))) - (else - (new unresolved - (proc (lambda (n e env) - (resolve-the-index (ast-loc n) - ident class - bd - split - char-offset - header-limit - column)))))))) diff --git a/src/common/bib.scm b/src/common/bib.scm deleted file mode 100644 index b73c5f0..0000000 --- a/src/common/bib.scm +++ /dev/null @@ -1,192 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/bib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Wed Jan 14 08:02:45 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../bigloo/bib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* bib-load! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-load! table filename command) - (if (not (bib-table? table)) - (skribe-error 'bib-load "Illegal bibliography table" table) - ;; read the file - (let ((p (skribe-open-bib-file filename command))) - (if (not (input-port? p)) - (skribe-error 'bib-load "Can't open data base" filename) - (unwind-protect - (parse-bib table p) - (close-input-port p)))))) - -;*---------------------------------------------------------------------*/ -;* resolve-bib ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-bib table ident) - (if (not (bib-table? table)) - (skribe-error 'resolve-bib "Illegal bibliography table" table) - (let* ((i (cond - ((string? ident) ident) - ((symbol? ident) (symbol->string ident)) - (else (skribe-error 'resolve-bib "Illegal ident" ident)))) - (en (hashtable-get table i))) - (if (is-markup? en '&bib-entry) - en - #f)))) - -;*---------------------------------------------------------------------*/ -;* make-bib-entry ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-entry kind ident fields from) - (let* ((m (new markup - (markup '&bib-entry) - (ident ident) - (options `((kind ,kind) (from ,from))))) - (h (new handle - (ast m)))) - (for-each (lambda (f) - (if (and (pair? f) - (pair? (cdr f)) - (null? (cddr f)) - (symbol? (car f))) - (markup-option-add! m - (car f) - (new markup - (markup (symbol-append - '&bib-entry- - (car f))) - (parent h) - (body (cadr f)))) - (bib-parse-error f))) - fields) - m)) - -;*---------------------------------------------------------------------*/ -;* bib-sort/authors ... */ -;*---------------------------------------------------------------------*/ -(define (bib-sort/authors l) - (define (cmp i1 i2 def) - (cond - ((and (markup? i1) (markup? i2)) - (cmp (markup-body i1) (markup-body i2) def)) - ((markup? i1) - (cmp (markup-body i1) i2 def)) - ((markup? i2) - (cmp i1 (markup-body i2) def)) - ((and (string? i1) (string? i2)) - (if (string=? i1 i2) - (def) - (string (string-length body) 3) - (substring body 0 3) - body)) - (sy (string->symbol (string-downcase body))) - (c (assq sy '((jan . 1) - (feb . 2) - (mar . 3) - (apr . 4) - (may . 5) - (jun . 6) - (jul . 7) - (aug . 8) - (sep . 9) - (oct . 10) - (nov . 11) - (dec . 12))))) - (if (pair? c) (cdr c) 13))))) - (let ((d1 (markup-option p1 'year)) - (d2 (markup-option p2 'year))) - (cond - ((not (markup? d1)) #f) - ((not (markup? d2)) #t) - (else - (let ((y1 (markup-body d1)) - (y2 (markup-body d2))) - (cond - ((string>? y1 y2) #t) - ((string m1 m2)))))))))))))) - -;*---------------------------------------------------------------------*/ -;* resolve-the-bib ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-the-bib table n sort pred count opts) - (define (count! entries) - (let loop ((es entries) - (i 1)) - (if (pair? es) - (begin - (markup-option-add! (car es) - :title - (new markup - (markup '&bib-entry-ident) - (parent (car es)) - (options `((number ,i))) - (body (new handle - (ast (car es)))))) - (loop (cdr es) (+ i 1)))))) - (if (not (bib-table? table)) - (skribe-error 'resolve-the-bib "Illegal bibliography table" table) - (let* ((es (sort (hashtable->list table))) - (fes (filter (if (procedure? pred) - (lambda (m) (pred m n)) - (lambda (m) (pair? (markup-option m 'used)))) - es))) - (count! (if (eq? count 'full) es fes)) - (new markup - (markup '&the-bibliography) - (options opts) - (body fes))))) - diff --git a/src/common/configure.scm b/src/common/configure.scm deleted file mode 100644 index 90e2339..0000000 --- a/src/common/configure.scm +++ /dev/null @@ -1,8 +0,0 @@ -;; Automatically generated file (don't edit) -(define (skribe-release) "1.2d") -(define (skribe-url) "http://www.inria.fr/mimosa/fp/Skribe") -(define (skribe-doc-dir) "/usr/local/doc/skribe-1.2d") -(define (skribe-ext-dir) "/usr/local/share/skribe/extensions") -(define (skribe-default-path) '("." "/usr/local/share/skribe/extensions" "/usr/local/share/skribe/1.2d/skr" )) -(define (skribe-scheme) "bigloo") - diff --git a/src/common/configure.scm.in b/src/common/configure.scm.in deleted file mode 100644 index 830ec4d..0000000 --- a/src/common/configure.scm.in +++ /dev/null @@ -1,6 +0,0 @@ -(define (skribe-release) "@SKRIBE_RELEASE@") -(define (skribe-url) "@SKRIBE_URL@") -(define (skribe-doc-dir) "@SKRIBE_DOC_DIR@") -(define (skribe-ext-dir) "@SKRIBE_EXT_DIR@") -(define (skribe-default-path) @SKRIBE_SKR_PATH@) -(define (skribe-scheme) "@SKRIBE_SCHEME@") diff --git a/src/common/index.scm b/src/common/index.scm deleted file mode 100644 index 65c271f..0000000 --- a/src/common/index.scm +++ /dev/null @@ -1,126 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/index.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../bigloo/index.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* index? ... */ -;*---------------------------------------------------------------------*/ -(define (index? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *index-table* ... */ -;*---------------------------------------------------------------------*/ -(define *index-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-index-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-index-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-index ... */ -;*---------------------------------------------------------------------*/ -(define (default-index) - (if (not *index-table*) - (set! *index-table* (make-index-table "default-index"))) - *index-table*) - -;*---------------------------------------------------------------------*/ -;* resolve-the-index ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) - ;; fetch the descriminating index name letter - (define (index-ref n) - (let ((name (markup-option n 'name))) - (if (>= char-offset (string-length name)) - (skribe-error 'the-index "char-offset out of bound" char-offset) - (string-ref name char-offset)))) - ;; sort a bucket of entries (the entries in a bucket share there name) - (define (sort-entries-bucket ie) - (sort ie - (lambda (i1 i2) - (or (not (markup-option i1 :note)) - (markup-option i2 :note))))) - ;; accumulate all the entries starting with the same letter - (define (letter-references refs) - (let ((letter (index-ref (car (car refs))))) - (let loop ((refs refs) - (acc '())) - (if (or (null? refs) - (not (char-ci=? letter (index-ref (car (car refs)))))) - (values (char-upcase letter) acc refs) - (loop (cdr refs) (cons (car refs) acc)))))) - ;; merge the buckets that comes from different index tables - (define (merge-buckets buckets) - (if (null? buckets) - '() - (let loop ((buckets buckets) - (res '())) - (cond - ((null? (cdr buckets)) - (reverse! (cons (car buckets) res))) - ((string=? (markup-option (car (car buckets)) 'name) - (markup-option (car (cadr buckets)) 'name)) - ;; we merge - (loop (cons (append (car buckets) (cadr buckets)) - (cddr buckets)) - res)) - (else - (loop (cdr buckets) - (cons (car buckets) res))))))) - (let* ((entries (apply append (map hashtable->list indexes))) - (sorted (map sort-entries-bucket - (merge-buckets - (sort entries - (lambda (e1 e2) - (string-cistring (gensym s)) :text s)) - (h (new handle (loc loc) (ast m))) - (r (ref :handle h :text s))) - (ast-loc-set! m loc) - (ast-loc-set! r loc) - (loop next-refs - (cons r lrefs) - (append lr (cons m body))))))))))) - diff --git a/src/common/lib.scm b/src/common/lib.scm deleted file mode 100644 index b0fa2d0..0000000 --- a/src/common/lib.scm +++ /dev/null @@ -1,238 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/lib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 10 11:57:54 2003 */ -;* Last change : Wed Oct 27 12:16:40 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scheme independent lib part. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/lib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* engine-custom-add! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-add! e id val) - (let ((old (engine-custom e id))) - (if (unspecified? old) - (engine-custom-set! e id (list val)) - (engine-custom-set! e id (cons val old))))) - -;*---------------------------------------------------------------------*/ -;* find-markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define (find-markup-ident ident) - (let ((r (find-markups ident))) - (if (or (pair? r) (null? r)) - r - '()))) - -;*---------------------------------------------------------------------*/ -;* container-search-down ... */ -;*---------------------------------------------------------------------*/ -(define (container-search-down pred obj) - (with-debug 4 'container-search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((container? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* search-down ... */ -;*---------------------------------------------------------------------*/ -(define (search-down pred obj) - (with-debug 4 'search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* find-down ... */ -;*---------------------------------------------------------------------*/ -(define (find-down pred obj) - (with-debug 4 'find-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj obj)) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (debug-item "loop=" (find-runtime-type obj) - " " (markup-ident obj)) - (if (pred obj) - (list (cons obj (loop (markup-body obj)))) - '())) - (else - (if (pred obj) - (list obj) - '())))))) - -;*---------------------------------------------------------------------*/ -;* find1-down ... */ -;*---------------------------------------------------------------------*/ -(define (find1-down pred obj) - (with-debug 4 'find1-down - (let loop ((obj obj) - (stack '())) - (debug-item "obj=" (find-runtime-type obj) - " " (if (markup? obj) (markup-markup obj) "???") - " " (if (markup? obj) (markup-ident obj) "")) - (cond - ((memq obj stack) - (skribe-error 'find1-down "Illegal cyclic object" obj)) - ((pair? obj) - (let liip ((obj obj)) - (cond - ((null? obj) - #f) - (else - (or (loop (car obj) (cons obj stack)) - (liip (cdr obj))))))) - ((pred obj) - obj) - ((markup? obj) - (loop (markup-body obj) (cons obj stack))) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* find-up ... */ -;*---------------------------------------------------------------------*/ -(define (find-up pred obj) - (let loop ((obj obj) - (res '())) - (cond - ((not (ast? obj)) - res) - ((pred obj) - (loop (ast-parent obj) (cons obj res))) - (else - (loop (ast-parent obj) (cons obj res)))))) - -;*---------------------------------------------------------------------*/ -;* find1-up ... */ -;*---------------------------------------------------------------------*/ -(define (find1-up pred obj) - (let loop ((obj obj)) - (cond - ((not (ast? obj)) - #f) - ((pred obj) - obj) - (else - (loop (ast-parent obj)))))) - -;*---------------------------------------------------------------------*/ -;* ast-document ... */ -;*---------------------------------------------------------------------*/ -(define (ast-document m) - (find1-up document? m)) - -;*---------------------------------------------------------------------*/ -;* ast-chapter ... */ -;*---------------------------------------------------------------------*/ -(define (ast-chapter m) - (find1-up (lambda (n) (is-markup? n 'chapter)) m)) - -;*---------------------------------------------------------------------*/ -;* ast-section ... */ -;*---------------------------------------------------------------------*/ -(define (ast-section m) - (find1-up (lambda (n) (is-markup? n 'section)) m)) - -;*---------------------------------------------------------------------*/ -;* the-body ... */ -;* ------------------------------------------------------------- */ -;* Filter out the options */ -;*---------------------------------------------------------------------*/ -(define (the-body opt+) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-body "Illegal body" opt*)) - ((keyword? (car opt*)) - (if (null? (cdr opt*)) - (skribe-error 'the-body "Illegal option" (car opt*)) - (loop (cddr opt*) res))) - (else - (loop (cdr opt*) (cons (car opt*) res)))))) - -;*---------------------------------------------------------------------*/ -;* the-options ... */ -;* ------------------------------------------------------------- */ -;* Returns an list made of options. The OUT argument contains */ -;* keywords that are filtered out. */ -;*---------------------------------------------------------------------*/ -(define (the-options opt+ . out) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-options "Illegal options" opt*)) - ((keyword? (car opt*)) - (cond - ((null? (cdr opt*)) - (skribe-error 'the-options "Illegal option" (car opt*))) - ((memq (car opt*) out) - (loop (cdr opt*) res)) - (else - (loop (cdr opt*) - (cons (list (car opt*) (cadr opt*)) res))))) - (else - (loop (cdr opt*) res))))) - -;*---------------------------------------------------------------------*/ -;* list-split ... */ -;*---------------------------------------------------------------------*/ -(define (list-split l num . fill) - (let loop ((l l) - (i 0) - (acc '()) - (res '())) - (cond - ((null? l) - (reverse! (cons (if (or (null? fill) (= i num)) - (reverse! acc) - (append! (reverse! acc) - (make-list (- num i) (car fill)))) - res))) - ((= i num) - (loop l - 0 - '() - (cons (reverse! acc) res))) - (else - (loop (cdr l) - (+ i 1) - (cons (car l) acc) - res))))) - diff --git a/src/common/param.scm b/src/common/param.scm deleted file mode 100644 index ba8d489..0000000 --- a/src/common/param.scm +++ /dev/null @@ -1,69 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/param.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 30 09:06:53 2003 */ -;* Last change : Thu Oct 28 21:51:49 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Common Skribe parameters */ -;* Implementation: @label param@ */ -;* bigloo: @path ../bigloo/param.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-file* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-file* "skriberc") - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-mode-alist* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-load-alist* ... */ -;* ------------------------------------------------------------- */ -;* Autoload engines. */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-load-alist* - '((base . "base.skr") - (html . "html.skr") - (sui . "html.skr") - (latex . "latex.skr") - (context . "context.skr") - (xml . "xml.skr"))) - -;*---------------------------------------------------------------------*/ -;* *skribe-preload* ... */ -;* ------------------------------------------------------------- */ -;* The list of skribe files (e.g. styles) to be loaded at boot-time */ -;*---------------------------------------------------------------------*/ -(define *skribe-preload* - '("skribe.skr")) - -;*---------------------------------------------------------------------*/ -;* *skribe-precustom* ... */ -;* ------------------------------------------------------------- */ -;* The list of pair to be assigned to the default */ -;* engine. */ -;*---------------------------------------------------------------------*/ -(define *skribe-precustom* - '()) - -;*---------------------------------------------------------------------*/ -;* *skribebib-auto-mode-alist* ... */ -;*---------------------------------------------------------------------*/ -(define *skribebib-auto-mode-alist* - '(("bib" . "skribebibtex"))) diff --git a/src/common/sui.scm b/src/common/sui.scm deleted file mode 100644 index eb6134b..0000000 --- a/src/common/sui.scm +++ /dev/null @@ -1,166 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/sui.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Dec 31 11:44:33 2003 */ -;* Last change : Tue Feb 17 11:35:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Url Indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/sui.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *sui-table* ... */ -;*---------------------------------------------------------------------*/ -(define *sui-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* load-sui ... */ -;* ------------------------------------------------------------- */ -;* Returns a SUI sexp if already loaded. Load it otherwise. */ -;* Raise an error if the file cannot be open. */ -;*---------------------------------------------------------------------*/ -(define (load-sui path) - (let ((sexp (hashtable-get *sui-table* path))) - (or sexp - (begin - (when (> *skribe-verbose* 0) - (fprintf (current-error-port) " [loading sui: ~a]\n" path)) - (let ((p (open-input-file path))) - (if (not (input-port? p)) - (skribe-error 'load-sui - "Can't find `Skribe Url Index' file" - path) - (unwind-protect - (let ((sexp (read p))) - (match-case sexp - ((sui (? string?) . ?-) - (hashtable-put! *sui-table* path sexp)) - (else - (skribe-error 'load-sui - "Illegal `Skribe Url Index' file" - path))) - sexp) - (close-input-port p)))))))) - -;*---------------------------------------------------------------------*/ -;* sui-ref->url ... */ -;*---------------------------------------------------------------------*/ -(define (sui-ref->url dir sui ident opts) - (let ((refs (sui-find-ref sui ident opts))) - (and (pair? refs) - (let ((base (sui-file sui)) - (file (car (car refs))) - (mark (cdr (car refs)))) - (format "~a/~a#~a" dir (or file base) mark))))) - -;*---------------------------------------------------------------------*/ -;* sui-title ... */ -;*---------------------------------------------------------------------*/ -(define (sui-title sexp) - (match-case sexp - ((sui (and ?title (? string?)) . ?-) - title) - (else - (skribe-error 'sui-title "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-file sexp) - (sui-key sexp :file)) - -;*---------------------------------------------------------------------*/ -;* sui-key ... */ -;*---------------------------------------------------------------------*/ -(define (sui-key sexp key) - (match-case sexp - ((sui ?- . ?rest) - (let loop ((rest rest)) - (and (pair? rest) - (if (eq? (car rest) key) - (and (pair? (cdr rest)) - (cadr rest)) - (loop (cdr rest)))))) - (else - (skribe-error 'sui-key "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-find-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-find-ref sui ident opts) - (let ((ident (assq :ident opts)) - (mark (assq :mark opts)) - (class (let ((c (assq :class opts))) - (and (pair? c) (cadr c)))) - (chapter (assq :chapter opts)) - (section (assq :section opts)) - (subsection (assq :subsection opts)) - (subsubsection (assq :subsubsection opts))) - (match-case sui - ((sui (? string?) . ?refs) - (cond - (mark (sui-search-ref 'marks refs (cadr mark) class)) - (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) - (section (sui-search-ref 'sections refs (cadr section) class)) - (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) - (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) - (ident (sui-search-all-refs sui ident class)) - (else '()))) - (else - (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) - -;*---------------------------------------------------------------------*/ -;* sui-search-all-refs ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-all-refs sui id refs) - '()) - -;*---------------------------------------------------------------------*/ -;* sui-search-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-ref kind refs val class) - (define (find-ref refs val class) - (map (lambda (r) - (let ((f (memq :file r)) - (c (memq :mark r))) - (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) - (filter (if class - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val) - (let ((c (memq :class m))) - (and (pair? c) - (eq? (cadr c) class))))) - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val)))) - refs))) - (let loop ((refs refs)) - (if (pair? refs) - (if (and (pair? (car refs)) (eq? (caar refs) kind)) - (find-ref (cdar refs) val class) - (loop (cdr refs))) - '()))) - -;*---------------------------------------------------------------------*/ -;* sui-filter ... */ -;*---------------------------------------------------------------------*/ -(define (sui-filter sui pred1 pred2) - (match-case sui - ((sui (? string?) . ?refs) - (let loop ((refs refs) - (res '())) - (if (pair? refs) - (if (and (pred1 (car refs))) - (loop (cdr refs) - (cons (filter pred2 (cdar refs)) res)) - (loop (cdr refs) res)) - (reverse! res)))) - (else - (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/src/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 -# -# -# 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 6-Mar-2004 15:35 (eg) -;;;; Last file update: 7-Mar-2004 00:10 (eg) -;;;; - -space [ \n\9] -letter [_a-zA-Z] -alphanum [_a-zA-Z0-9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -;;Comments -/\*.*\*/ (new markup - (markup '&source-line-comment) - (body yytext)) -//.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Identifiers (only letters since we are interested in keywords only) -[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) - (tmp (memq ident *the-keys*))) - (if tmp - (new markup - (markup '&source-module) - (body yytext)) - yytext)) - -;; Regular text -[^\"a-zA-Z]+ (begin yytext) - - - -<> 'eof -<> (skribe-error 'lisp-fontifier "Parse error" yytext) - - - - - - - \ No newline at end of file diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 10-Aug-2003 20:45 (eg) -;;;; Last file update: 28-Oct-2004 13:16 (eg) -;;;; - - -(define-module SKRIBE-DEBUG-MODULE - (export debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol - no-debug-color) - -(define *skribe-debug* 0) -(define *skribe-debug-symbols* '()) -(define *skribe-debug-color* #t) -(define *skribe-debug-item* #f) -(define *debug-port* (current-error-port)) -(define *debug-depth* 0) -(define *debug-margin* "") -(define *skribe-margin-debug-level* 0) - - -(define (set-skribe-debug! val) - (set! *skribe-debug* val)) - -(define (add-skribe-debug-symbol s) - (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*))) - - -(define (no-debug-color) - (set! *skribe-debug-color* #f)) - -(define (skribe-debug) - *skribe-debug*) - -;; -;; debug-port -;; -; (define (debug-port . o) -; (cond -; ((null? o) -; *debug-port*) -; ((output-port? (car o)) -; (set! *debug-port* o) -; o) -; (else -; (error 'debug-port "Illegal debug port" (car o))))) -; - -;;; -;;; debug-color -;;; -(define (debug-color col . o) - (with-output-to-string - (if (and *skribe-debug-color* - (equal? (getenv "TERM") "xterm") - (interactive-port? *debug-port*)) - (lambda () - (format #t "[1;~Am" (+ 31 col)) - (for-each display o) - (display "")) - (lambda () - (for-each display o))))) - -;;; -;;; debug-bold -;;; -(define (debug-bold . o) - (apply debug-color -30 o)) - -;;; -;;; debug-item -;;; -(define (debug-item . args) - (when (or (>= *skribe-debug* *skribe-margin-debug-level*) - *skribe-debug-item*) - (display *debug-margin* *debug-port*) - (display (debug-color (- *debug-depth* 1) "- ") *debug-port*) - (for-each (lambda (a) (display a *debug-port*)) args) - (newline *debug-port*))) - -;;(define-macro (debug-item . args) -;; `()) - -;;; -;;; %with-debug-margin -;;; -(define (%with-debug-margin margin thunk) - (let ((om *debug-margin*)) - (set! *debug-depth* (+ *debug-depth* 1)) - (set! *debug-margin* (string-append om margin)) - (let ((res (thunk))) - (set! *debug-depth* (- *debug-depth* 1)) - (set! *debug-margin* om) - res))) - -;;; -;;; %with-debug -;; -(define (%with-debug lvl lbl thunk) - (let ((ol *skribe-margin-debug-level*) - (oi *skribe-debug-item*)) - (set! *skribe-margin-debug-level* lvl) - (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) - (and (symbol? lbl) - (memq lbl *skribe-debug-symbols*) - (set! *skribe-debug-item* #t))) - (begin - (display *debug-margin* *debug-port*) - (display (if (= *debug-depth* 0) - (debug-color *debug-depth* "+ " lbl) - (debug-color *debug-depth* "--+ " lbl)) - *debug-port*) - (newline *debug-port*) - (%with-debug-margin (debug-color *debug-depth* " |") - thunk)) - (thunk)))) - (set! *skribe-debug-item* oi) - (set! *skribe-margin-debug-level* ol) - r))) - -(define-macro (with-debug level label . body) - `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body))) - -;;(define-macro (with-debug level label . body) -;; `(begin ,@body)) - -) - -#| -Example: - -(with-debug 0 'foo1.1 - (debug-item 'foo2.1) - (debug-item 'foo2.2) - (with-debug 0 'foo2.3 - (debug-item 'foo3.1) - (with-debug 0 'foo3.2 - (debug-item 'foo4.1) - (debug-item 'foo4.2)) - (debug-item 'foo3.3)) - (debug-item 'foo2.4)) -|# diff --git a/src/stklos/engine.stk b/src/stklos/engine.stk deleted file mode 100644 index a13ed0f..0000000 --- a/src/stklos/engine.stk +++ /dev/null @@ -1,242 +0,0 @@ -;;;; -;;;; engines.stk -- Skribe Engines Stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; 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 :ident ident :version version :format format - :filter filter :delegate delegate - :symbol-table symbol-table - :custom custom :info info))) - ;; store the engine in the global table - (set! *engines* (cons e *engines*)) - ;; return it - e)) - - -;;; -;;; COPY-ENGINE -;;; -(define (copy-engine ident e :key (version 'unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) - (let ((new (shallow-clone e))) - (slot-set! new 'ident ident) - (slot-set! new 'version version) - (slot-set! new 'filter (or filter (slot-ref e 'filter))) - (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) - (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) - (slot-set! new 'customs (or custom (slot-ref e 'customs))) - - (set! *engines* (cons new *engines*)) - new)) - - -;;; -;;; FIND-ENGINE -;;; -(define (%find-loaded-engine id version) - (let Loop ((es *engines*)) - (cond - ((null? es) #f) - ((eq? (slot-ref (car es) 'ident) id) - (cond - ((eq? version 'unspecified) (car es)) - ((eq? version (slot-ref (car es) 'version)) (car es)) - (else (Loop (cdr es))))) - (else (loop (cdr es)))))) - - -(define (find-engine id :key (version 'unspecified)) - (with-debug 5 'find-engine - (debug-item "id=" id " version=" version) - - (or (%find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and c (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (%find-loaded-engine id version)) - #f))))) - -;;; -;;; ENGINE-CUSTOM -;;; -(define (engine-custom e id) - (let* ((customs (slot-ref e 'customs)) - (c (assq id customs))) - (if (pair? c) - (cadr c) - 'unspecified))) - - -;;; -;;; ENGINE-CUSTOM-SET! -;;; -(define (engine-custom-set! e id val) - (let* ((customs (slot-ref e 'customs)) - (c (assq id customs))) - (if (pair? c) - (set-car! (cdr c) val) - (slot-set! e 'customs (cons (list id val) customs))))) - - -;;; -;;; ENGINE-ADD-WRITER! -;;; -(define (engine-add-writer! e ident pred upred opt before action after class valid) - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error ident "Illegal procedure" proc)) - ((not (equal? (%procedure-arity proc) arity)) - (skribe-error ident - (format #f "Illegal ~S procedure" name) - proc)))) - - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) - - ;; - ;; Engine-add-writer! starts here - ;; - (unless (is-a? e ) - (skribe-error ident "Illegal engine" e)) - - ;; check the options - (unless (or (eq? opt 'all) (list? opt)) - (skribe-error ident "Illegal options" opt)) - - ;; check the correctness of the predicate - (check-procedure "predicate" pred 2) - - ;; check the correctness of the validation proc - (when valid - (check-procedure "validate" valid 2)) - - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - - ;; create a new writer and bind it - (let ((n (make - :ident (if (symbol? ident) ident 'all) - :class class :pred pred :upred upred :options opt - :before before :action action :after after - :validate valid))) - (slot-set! e 'writers (cons n (slot-ref e 'writers))) - n)) - -;;;; ====================================================================== -;;;; -;;;; I N I T S -;;;; -;;;; ====================================================================== - -;; A base engine must pre-exist before anything is loaded. In -;; particular, this dummy base engine is used to load the actual -;; definition of base. - -(make-engine 'base :version 'bootstrap) - - -(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 -;;;; -;;;; -;;;; 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 )) - (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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 5-Jan-2004 18:24 (eg) -;;;; - -space [ \n\9] -letter [#?!_:a-zA-Z\-] -digit [0-9] - - -%% -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) - -;;Comment -\;.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Skribe text (i.e. [....]) -\[|\] (if *bracket-highlight* - (new markup - (markup '&source-bracket) - (body yytext)) - yytext) -;; Spaces & parenthesis -[ \n\9\(\)]+ (begin - yytext) - -;; Identifier (real syntax is slightly more complicated but we are -;; interested here in the identifiers that we will fontify) -[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) - (cond - ((or (char=? c #\:) - (char=? (string-ref yytext - (- (string-length yytext) 1)) - #\:)) - ;; Scheme keyword - (new markup - (markup '&source-type) - (body yytext))) - ((char=? c #\<) - ;; STklos class - (let* ((len (string-length yytext)) - (c (string-ref yytext (- len 1)))) - (if (char=? c #\>) - (if *class-highlight* - (new markup - (markup '&source-module) - (body yytext)) - yytext) ; no - yytext))) ; no - (else - (let ((tmp (assoc (string->symbol yytext) - *the-keys*))) - (if tmp - (new markup - (markup (cdr tmp)) - (body yytext)) - yytext))))) - - -<> 'eof -<> (skribe-error 'lisp-fontifier "Parse error" yytext) - - -; LocalWords: fontify diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 ") - (set! engine (string->symbol target))) - (("I" :arg path :help "adds to Skribe path") - (set! paths (cons path paths))) - (("B" :arg path :help "adds to bibliography path") - (skribe-bib-path-set! (cons path (skribe-bib-path)))) - (("S" :arg path :help "adds to source path") - (skribe-source-path-set! (cons path (skribe-source-path)))) - (("P" :arg path :help "adds to image path") - (skribe-image-path-set! (cons path (skribe-image-path)))) - (("split-chapters" :alternate "C" :arg chapter - :help "emit chapter's sections in separate files") - (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) - (("preload" :arg file :help "preload ") - (set! *skribe-preload* (cons file *skribe-preload*))) - (("use-variant" :alternate "u" :arg variant - :help "use output format") - (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 ") - (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 ") - (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 . 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 . 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 ") - (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 ") - (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 -;;;; -;;;; -;;;; 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) ) - (%out/writer node e (car writer))) - ((not (car writer)) - (skribe-error 'output - (format "Illegal ~A user writer" (engine-ident e)) - (if (markup? node) (markup-markup node) node))) - (else - (skribe-error 'output "Illegal user writer" (car writer))))))) - - -;;; -;;; OUT implementations -;;; -(define-method out (node e) - #f) - - -(define-method out ((node ) e) - (let Loop ((n* node)) - (cond - ((pair? n*) - (out (car n*) e) - (loop (cdr n*))) - ((not (null? n*)) - (skribe-error 'out "Illegal argument" n*))))) - - -(define-method out ((node ) e) - (let ((f (slot-ref e 'filter))) - (if (procedure? f) - (display (f node)) - (display node)))) - - -(define-method out ((node ) e) - (out (number->string node) e)) - - -(define-method out ((n ) e) - (let ((combinator (slot-ref n 'combinator)) - (engine (slot-ref n 'engine)) - (body (slot-ref n 'body)) - (procedure (slot-ref n 'procedure))) - (let ((newe (processor-get-engine combinator engine e))) - (out (procedure body newe) newe)))) - - -(define-method out ((n ) e) - (let* ((fmt (slot-ref n 'fmt)) - (body (slot-ref n 'body)) - (lb (length body)) - (lf (string-length fmt))) - (define (loops i n) - (if (= i lf) - (begin - (if (> n 0) - (if (<= n lb) - (output (list-ref body (- n 1)) e) - (skribe-error '! "Too few arguments provided" n))) - lf) - (let ((c (string-ref fmt i))) - (cond - ((char=? c #\$) - (display "$") - (+ 1 i)) - ((not (char-numeric? c)) - (cond - ((= n 0) - i) - ((<= n lb) - (output (list-ref body (- n 1)) e) - i) - (else - (skribe-error '! "Too few arguments provided" n)))) - (else - (loops (+ i 1) - (+ (- (char->integer c) - (char->integer #\0)) - (* 10 n)))))))) - - (let loop ((i 0)) - (cond - ((= i lf) - #f) - ((not (char=? (string-ref fmt i) #\$)) - (display (string-ref fmt i)) - (loop (+ i 1))) - (else - (loop (loops (+ i 1) 0))))))) - - -(define-method out ((n ) e) - 'unspecified) - - -(define-method out ((n ) e) - (skribe-error 'output "Orphan unresolved" n)) - - -(define-method out ((node ) e) - (let ((w (lookup-markup-writer node e))) - (if (writer? w) - (%out/writer node e w) - (output (slot-ref node 'body) e)))) -) diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 ) engine env) - (let Loop ((n* ast)) - (cond - ((pair? n*) - (set-car! n* (do-resolve! (car n*) engine env)) - (Loop (cdr n*))) - ((not (null? n*)) - (error 'do-resolve "Illegal argument" n*)) - (else - ast)))) - - -(define-method do-resolve! ((node ) engine env) - (let ((body (slot-ref node 'body)) - (options (slot-ref node 'options)) - (parent (slot-ref node 'parent))) - (with-debug 5 'do-resolve - (debug-item "body=" body) - (when (eq? parent 'unspecified) - (let ((p (assq 'parent env))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (when (pair? options) - (debug-item "unresolved options=" options) - (for-each (lambda (o) - (set-car! (cdr o) - (do-resolve! (cadr o) engine env))) - options) - (debug-item "resolved options=" options)))) - (slot-set! node 'body (do-resolve! body engine env)) - node))) - - - -(define-method do-resolve! ((node ) engine env0) - (let ((body (slot-ref node 'body)) - (options (slot-ref node 'options)) - (env (slot-ref node 'env)) - (parent (slot-ref node 'parent))) - (with-debug 5 'do-resolve - (debug-item "markup=" (markup-markup node)) - (debug-item "body=" body) - (debug-item "env0=" env0) - (debug-item "env=" env) - (when (eq? parent 'unspecified) - (let ((p (assq 'parent env0))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) - (when (pair? options) - (let ((e (append `((parent ,node)) env0))) - (debug-item "unresolved options=" options) - (for-each (lambda (o) - (set-car! (cdr o) - (do-resolve! (cadr o) engine e))) - options) - (debug-item "resolved options=" options))) - (let ((e `((parent ,node) ,@env ,@env0))) - (slot-set! node 'body (do-resolve! body engine e))))) - node))) - - -(define-method do-resolve! ((node ) engine env0) - (next-method) - ;; resolve the engine custom - (let ((env (append `((parent ,node)) env0))) - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (debug-item "custom=" i " " a) - (set-car! (cdr c) (do-resolve! a engine env)))) - (slot-ref engine 'customs))) - node) - - -(define-method do-resolve! ((node ) engine env) - (with-debug 5 'do-resolve - (debug-item "node=" node) - (let ((p (assq 'parent env))) - (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) - - (let* ((proc (slot-ref node 'proc)) - (res (resolve! (proc node engine env) engine env)) - (loc (ast-loc node))) - (when (ast? res) - (ast-loc-set! res loc)) - (debug-item "res=" res) - (set! *unresolved* #t) - res))) - - -(define-method do-resolve! ((node ) engine env) - node) - - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-PARENT -;;;; -;;;; ====================================================================== -(define (resolve-parent n e) - (with-debug 5 'resolve-parent - (debug-item "n=" n) - (cond - ((not (is-a? n )) - (let ((c (assq 'parent e))) - (if (pair? c) - (cadr c) - n))) - ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) - (else - (slot-ref n 'parent))))) - - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-SEARCH-PARENT -;;;; -;;;; ====================================================================== -(define (resolve-search-parent n e pred) - (with-debug 5 'resolve-search-parent - (debug-item "node=" n) - (debug-item "searching=" pred) - (let ((p (resolve-parent n e))) - (debug-item "parent=" p " " - (if (is-a? p 'markup) (slot-ref p 'markup) "???")) - (cond - ((pred p) p) - ((is-a? p ) p) - ((not p) #f) - (else (resolve-search-parent p e pred)))))) - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-COUNTER -;;;; -;;;; ====================================================================== -;;FIXME: factoriser -(define (resolve-counter n e cnt val . opt) - (let ((c (assq (symbol-append cnt '-counter) e))) - (if (not (pair? c)) - (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "Orphan node" n) - (begin - (set-cdr! (last-pair e) - (list (list (symbol-append cnt '-counter) 0) - (list (symbol-append cnt '-env) '()))) - (resolve-counter n e cnt val))) - (let* ((num (cadr c)) - (nval (if (integer? val) - val - (+ 1 num)))) - (let ((c2 (assq (symbol-append cnt '-env) e))) - (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) - (cond - ((integer? val) - (set-car! (cdr c) val) - (car val)) - ((not val) - val) - (else - (set-car! (cdr c) (+ 1 num)) - (+ 1 num))))))) - -;;;; ====================================================================== -;;;; -;;;; RESOLVE-IDENT -;;;; -;;;; ====================================================================== -(define (resolve-ident ident markup n e) - (with-debug 4 'resolve-ident - (debug-item "ident=" ident) - (debug-item "markup=" markup) - (debug-item "n=" (if (markup? n) (markup-markup n) n)) - (if (not (string? ident)) - (skribe-type-error 'resolve-ident - "Illegal ident" - ident - "string") - (let ((mks (find-markups ident))) - (and mks - (if (not markup) - (car mks) - (let loop ((mks mks)) - (cond - ((null? mks) - #f) - ((is-markup? (car mks) markup) - (car mks)) - (else - (loop (cdr mks))))))))))) - -) diff --git a/src/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 -;;;; -;;;; -;;;; 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 )) -;; (skribe-error 'markup-writer "illegal engine" e)) -;; ((and (not before) -;; (not action) -;; (not after)) -;; (%find-markup-output e markup)) -;; (else -;; (let ((mp (if (procedure? predicate) -;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) -;; (lambda (n e) (is-markup? n markup))))) -;; (engine-output e markup mp options -;; (or before (slot-ref e 'default-before)) -;; (or action (slot-ref e 'default-action)) -;; (or after (slot-ref e 'default-after)))))))) - -(define (markup-option m opt) - (if (markup? m) - (let ((c (assq opt (slot-ref m 'options)))) - (and (pair? c) (pair? (cdr c)) - (cadr c))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - - -(define (markup-option-add! m opt val) - (if (markup? m) - (slot-set! m 'options (cons (list opt val) - (slot-ref m 'options))) - (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) - -;;;; ====================================================================== -;;;; -;;;; C O N T A I N E R S -;;;; -;;;; ====================================================================== -(define (container-env-get m key) - (let ((c (assq key (slot-ref m 'env)))) - (and (pair? c) (cadr c)))) - - -;;;; ====================================================================== -;;;; -;;;; I M A G E S -;;;; -;;;; ====================================================================== -(define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) - (to (string-append dir "/" f))) ;; FIXME: - (cond - ((string=? s fmt) - to) - ((file-exists? to) - to) - (else - (let ((c (if (string=? s "fig") - (string-append "fig2dev -L " fmt " " from " > " to) - (string-append "convert " from " " to)))) - (cond - ((> *skribe-verbose* 1) - (format (current-error-port) " [converting image: ~S (~S)]" from c)) - ((> *skribe-verbose* 0) - (format (current-error-port) " [converting image: ~S]" from))) - (and (zero? (system c)) - to)))))) - -(define (convert-image file formats) - (let ((path (find-path file (skribe-image-path)))) - (if (not path) - (skribe-error 'convert-image - (format "Can't find `~a' image file in path: " file) - (skribe-image-path)) - (let ((suf (suffix file))) - (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - #f))) - (if dir - (let ((dest (basename path))) - (copy-file path (make-path dir dest)) - dest) - path)) - (let loop ((fmts formats)) - (if (null? fmts) - #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - ".")) - (p (builtin-convert-image path (car fmts) dir))) - (if (string? p) - p - (loop (cdr fmts))))))))))) - -;;;; ====================================================================== -;;;; -;;;; S T R I N G - W R I T I N G -;;;; -;;;; ====================================================================== - -;; -;; (define (%make-html-replace) -;; ;; Ad-hoc version for HTML, a little bit faster than the -;; ;; make-general-string-replace define later (particularily if there -;; ;; is nothing to replace since, it does not allocate a new string -;; (let ((specials (string->regexp "&|\"|<|>"))) -;; (lambda (str) -;; (if (regexp-match specials str) -;; (begin -;; (let ((out (open-output-string))) -;; (dotimes (i (string-length str)) -;; (let ((ch (string-ref str i))) -;; (case ch -;; ((#\") (display """ out)) -;; ((#\&) (display "&" out)) -;; ((#\<) (display "<" out)) -;; ((#\>) (display ">" out)) -;; (else (write-char ch out))))) -;; (get-output-string out))) -;; str)))) - - -(define (%make-general-string-replace lst) - ;; The general version - (lambda (str) - (let ((out (open-output-string))) - (dotimes (i (string-length str)) - (let* ((ch (string-ref str i)) - (res (assq ch lst))) - (display (if res (cadr res) ch) out))) - (get-output-string out)))) - - -(define (make-string-replace lst) - (let ((l (sort lst (lambda (r1 r2) (char ">"))) - string->html) - (else - (%make-general-string-replace lst))))) - - - - -;;;; ====================================================================== -;;;; -;;;; O P T I O N S -;;;; -;;;; ====================================================================== - -;;NEW ;; -;;NEW ;; GET-OPTION -;;NEW ;; -;;NEW (define (get-option obj key) -;;NEW ;; This function either searches inside an a-list or a markup. -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (pair? (cdr c)) (cadr c)))) -;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key)) -;;NEW (else #f))) -;;NEW -;;NEW ;; -;;NEW ;; BIND-OPTION! -;;NEW ;; -;;NEW (define (bind-option! obj key value) -;;NEW (slot-set! obj 'option* (cons (list key value) -;;NEW (slot-ref obj 'option*)))) -;;NEW -;;NEW -;;NEW ;; -;;NEW ;; GET-ENV -;;NEW ;; -;;NEW (define (get-env obj key) -;;NEW ;; This function either searches inside an a-list or a container -;;NEW (cond -;;NEW ((pair? obj) (let ((c (assq key obj))) -;;NEW (and (pair? c) (cadr c)))) -;;NEW ((container? obj) (get-env (slot-ref obj 'env) key)) -;;NEW (else #f))) -;;NEW - - - - -;;;; ====================================================================== -;;;; -;;;; A S T -;;;; -;;;; ====================================================================== - -(define-generic ast->string) - - -(define-method ast->string ((ast )) "") -(define-method ast->string ((ast )) ast) -(define-method ast->string ((ast )) (number->string ast)) - -(define-method ast->string ((ast )) - (let ((out (open-output-string))) - (let Loop ((lst ast)) - (cond - ((null? lst) - (get-output-string out)) - (else - (display (ast->string (car lst)) out) - (unless (null? (cdr lst)) - (display #\space out)) - (Loop (cdr lst))))))) - -(define-method ast->string ((ast )) - (ast->string (slot-ref ast 'body))) - - -;;NEW ;; -;;NEW ;; AST-PARENT -;;NEW ;; -;;NEW (define (ast-parent n) -;;NEW (slot-ref n 'parent)) -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-PARENT -;;NEW ;; -;;NEW (define (markup-parent m) -;;NEW (let ((p (slot-ref m 'parent))) -;;NEW (if (eq? p 'unspecified) -;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m) -;;NEW p))) -;;NEW -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-DOCUMENT -;;NEW ;; -;;NEW (define (markup-document m) -;;NEW (let Loop ((p m) -;;NEW (l #f)) -;;NEW (cond -;;NEW ((is-markup? p 'document) p) -;;NEW ((or (eq? p 'unspecified) (not p)) l) -;;NEW (else (Loop (slot-ref p 'parent) p))))) -;;NEW -;;NEW ;; -;;NEW ;; MARKUP-CHAPTER -;;NEW ;; -;;NEW (define (markup-chapter m) -;;NEW (let loop ((p m) -;;NEW (l #f)) -;;NEW (cond -;;NEW ((is-markup? p 'chapter) p) -;;NEW ((or (eq? p 'unspecified) (not p)) l) -;;NEW (else (loop (slot-ref p 'parent) p))))) -;;NEW -;;NEW -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; H A N D L E S -;;NEW ;;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (handle-body h) -;;NEW (slot-ref h 'body)) -;;NEW -;;NEW -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; F I N D -;;NEW ;;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (find pred obj) -;;NEW (with-debug 4 'find -;;NEW (debug-item "obj=" obj) -;;NEW (let loop ((obj (if (is-a? obj ) (container-body obj) obj))) -;;NEW (cond -;;NEW ((pair? obj) -;;NEW (apply append (map (lambda (o) (loop o)) obj))) -;;NEW ((is-a? obj ) -;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident)) -;;NEW (if (pred obj) -;;NEW (list (cons obj (loop (container-body obj)))) -;;NEW '())) -;;NEW (else -;;NEW (if (pred obj) -;;NEW (list obj) -;;NEW '())))))) -;;NEW - -;;NEW ;;;; ====================================================================== -;;NEW ;;;; -;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G -;;NEW ;;; -;;NEW ;;;; ====================================================================== -;;NEW (define (the-body opt) -;;NEW ;; Filter out the options -;;NEW (let loop ((opt* opt) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-body "Illegal body" opt)) -;;NEW ((keyword? (car opt*)) -;;NEW (if (null? (cdr opt*)) -;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) -;;NEW (loop (cddr opt*) res))) -;;NEW (else -;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) -;;NEW -;;NEW -;;NEW -;;NEW (define (the-options opt+ . out) -;;NEW ;; Returns an list made of options.The OUT argument contains -;;NEW ;; keywords that are filtered out. -;;NEW (let loop ((opt* opt+) -;;NEW (res '())) -;;NEW (cond -;;NEW ((null? opt*) -;;NEW (reverse! res)) -;;NEW ((not (pair? opt*)) -;;NEW (skribe-error 'the-options "Illegal options" opt*)) -;;NEW ((keyword? (car opt*)) -;;NEW (cond -;;NEW ((null? (cdr opt*)) -;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) -;;NEW ((memq (car opt*) out) -;;NEW (loop (cdr opt*) res)) -;;NEW (else -;;NEW (loop (cdr opt*) -;;NEW (cons (list (car opt*) (cadr opt*)) res))))) -;;NEW (else -;;NEW (loop (cdr opt*) res))))) -;;NEW - - -) diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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. - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -;;FIXME: set! location in -(define-class () - ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) - (loc :init-form #f))) - -(define (ast? obj) (is-a? obj )) -(define (ast-loc obj) (slot-ref obj 'loc)) -(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((fmt :init-keyword :fmt) - (body :init-keyword :body))) - -(define (command? obj) (is-a? obj )) -(define (command-fmt obj) (slot-ref obj 'fmt)) -(define (command-body obj) (slot-ref obj 'body)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((proc :init-keyword :proc))) - -(define (unresolved? obj) (is-a? obj )) -(define (unresolved-proc obj) (slot-ref obj 'proc)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ast :init-keyword :ast :init-form #f :getter handle-ast))) - -(define (handle? obj) (is-a? obj )) -(define (handle-ast obj) (slot-ref obj 'ast)) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((required-options :init-keyword :required-options :init-form '()) - (options :init-keyword :options :init-form '()) - (body :init-keyword :body :init-form #f - :getter node-body))) - -(define (node? obj) (is-a? obj )) -(define (node-options obj) (slot-ref obj 'options)) -(define node-loc ast-loc) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1)) - (engine :init-keyword :engine :init-form 'unspecified) - (procedure :init-keyword :procedure :init-form (lambda (n e) n)))) - -(define (processor? obj) (is-a? obj )) -(define (processor-combinator obj) (slot-ref obj 'combinator)) -(define (processor-engine obj) (slot-ref obj 'engine)) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :getter markup-ident :init-form #f) - (class :init-keyword :class :getter markup-class :init-form #f) - (markup :init-keyword :markup :getter markup-markup))) - - -(define (bind-markup! node) - (hash-table-update! *node-table* - (markup-ident node) - (lambda (cur) (cons node cur)) - (list node))) - - -(define-method initialize ((self ) initargs) - (next-method) - (bind-markup! self)) - - -(define (markup? obj) (is-a? obj )) -(define (markup-options obj) (slot-ref obj 'options)) -(define markup-body node-body) - - -(define (is-markup? obj markup) - (and (is-a? obj ) - (eq? (slot-ref obj 'markup) markup))) - - - -(define (find-markups ident) - (hash-table-get *node-table* ident #f)) - - -(define-method write-object ((obj ) port) - (format port "#[~A (~A/~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'markup) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((env :init-keyword :env :init-form '()))) - -(define (container? obj) (is-a? obj )) -(define (container-env obj) (slot-ref obj 'env)) -(define container-options markup-options) -(define container-ident markup-ident) -(define container-body node-body) - - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ()) - -(define (document? obj) (is-a? obj )) -(define (document-ident obj) (slot-ref obj 'ident)) -(define (document-body obj) (slot-ref obj 'body)) -(define document-options markup-options) -(define document-env container-env) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :init-form '???) - (format :init-keyword :format :init-form "raw") - (info :init-keyword :info :init-form '()) - (version :init-keyword :version :init-form 'unspecified) - (delegate :init-keyword :delegate :init-form #f) - (writers :init-keyword :writers :init-form '()) - (filter :init-keyword :filter :init-form #f) - (customs :init-keyword :custom :init-form '()) - (symbol-table :init-keyword :symbol-table :init-form '()))) - - - -(define (engine? obj) - (is-a? obj )) - -(define (engine-ident obj) ;; Define it here since the doc searches it - (slot-ref obj 'ident)) - -(define (engine-format obj) ;; Define it here since the doc searches it - (slot-ref obj 'format)) - -(define (engine-customs obj) ;; Define it here since the doc searches it - (slot-ref obj 'customs)) - -(define (engine-filter obj) ;; Define it here since the doc searches it - (slot-ref obj 'filter)) - -(define (engine-symbol-table obj) ;; Define it here since the doc searches it - (slot-ref obj 'symbol-table)) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((ident :init-keyword :ident :init-form '??? :getter writer-ident) - (class :init-keyword :class :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 )) - -(define-method write-object ((obj ) port) - (format port "#[~A (~A) ~A]" - (class-name (class-of obj)) - (slot-ref obj 'ident) - (address-of obj))) - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((name :init-keyword :name :init-form #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))) - -(define (language? obj) - (is-a? obj )) - - -;;;; ====================================================================== -;;;; -;;;; -;;;; -;;;; ====================================================================== -(define-class () - ((file :init-keyword :file :getter location-file) - (pos :init-keyword :pos :getter location-pos) - (line :init-keyword :line :getter location-line))) - -(define (location? obj) - (is-a? obj )) - -(define (ast-location obj) - (let ((loc (slot-ref obj 'loc))) - (if (location? loc) - (let* ((fname (location-file loc)) - (line (location-line loc)) - (pwd (getcwd)) - (len (string-length pwd)) - (lenf (string-length fname)) - (file (if (and (substring=? pwd fname len) - (> lenf len)) - (substring fname len (+ 1 (string-length fname))) - fname))) - (format "~a, line ~a" file line)) - "no source location"))) diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; 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 ) e) - obj) - -;;; PAIR -(define-method verify ((obj ) e) - (for-each (lambda (x) (verify x e)) obj) - obj) - -;;; PROCESSOR -(define-method verify ((obj ) e) - (let ((combinator (slot-ref obj 'combinator)) - (engine (slot-ref obj 'engine)) - (body (slot-ref obj 'body))) - (verify body (processor-get-engine combinator engine e)) - obj)) - -;;; NODE -(define-method verify ((node ) e) - ;; Verify body - (verify (slot-ref node 'body) e) - ;; Verify options - (for-each (lambda (o) (verify (cadr o) e)) - (slot-ref node 'options)) - node) - -;;; MARKUP -(define-method verify ((node ) e) - (with-debug 5 'verify:: - (debug-item "node=" (markup-markup node)) - (debug-item "options=" (slot-ref node 'options)) - (debug-item "e=" (engine-ident e)) - - (next-method) - - (let ((w (lookup-markup-writer node e))) - (when (writer? w) - (check-required-options node w e) - (when (pair? (writer-options w)) - (check-options (slot-ref w 'options) node e)) - (let ((validate (slot-ref w 'validate))) - (when (procedure? validate) - (unless (validate node e) - (skribe-warning - 1 - node - (format "Node `~a' forbidden here by ~a engine" - (markup-markup node) - (engine-ident e)))))))) - node)) - - -;;; DOCUMENT -(define-method verify ((node ) e) - (next-method) - - ;; verify the engine customs - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (set-car! (cdr c) (verify a e)))) - (slot-ref e 'customs)) - - node) - - -) - diff --git a/src/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 -;;;; -;;;; -;;;; 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 -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 21-Dec-2003 22:38 (eg) -;;;; - -space [ \n\9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -'[^']*' (new markup - (markup '&source-string) - (body yytext)) - -;;Comment - (new markup - (markup '&source-comment) - (body yytext)) - -;; Markup -<[^>\n ]+|> (new markup - (markup '&source-module) - (body yytext)) - -;; Regular text -[^<>\"']+ (begin yytext) - - -<> 'eof -<> (skribe-error 'xml-fontifier "Parse error" yytext) - - - - - - - - - \ No newline at end of file diff --git a/src/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 -;;;; -;;;; -;;;; 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))) -) -- cgit v1.2.3 From 052c10245a523aa714489bda59e18a6c1a4f473e Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 31 Oct 2005 23:26:24 +0000 Subject: Installed Autoconf/Automake machinery. Fixed a few things. * src/guile/skribilo/evaluator.scm (skribe-load): Search through `%load-path' and try with a `.scm' extension (rather than the `.skr' one provided by the user). (skribe-include): Added a few debugging statements. * src/guile/skribilo/lib.scm (fix-rest-arg): Handle the dot notation for rest arguments. * src/guile/skribilo/reader/skribe.scm (%make-skribe-reader): Use SQUARE-BRACKET-FREE-SYMBOL-MISC-CHARS. * src/guile/skribilo/skribe/index.scm: Use `define-public' instead of `define'. * src/guile/skribilo/packages/*.scm: Moved to `skribilo/package'. * LICENSE: Removed. * COPYING: New. * AUTHORS: New. * NEWS: New. * ChangeLog: New. * configure.ac: New. * Makefile.am: New. In various directories. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-10 --- AUTHORS | 8 + COPYING | 340 ++++++++ ChangeLog | 1225 +++++++++++++++++++++++++++ LICENSE | 25 - Makefile.am | 1 + NEWS | 1 + configure.ac | 36 + doc/Makefile | 649 +++++++++----- doc/Makefile.am | 1 + doc/user/Makefile.am | 22 + doc/user/start.skb | 13 +- doc/user/user.skb | 2 +- src/Makefile.am | 1 + src/guile/Makefile.am | 4 + src/guile/skribilo/Makefile.am | 9 + src/guile/skribilo/Makefile.in | 517 +++++++++-- src/guile/skribilo/coloring/Makefile.am | 2 + src/guile/skribilo/config.scm.in | 2 +- src/guile/skribilo/engine/Makefile.am | 5 + src/guile/skribilo/engine/html.scm | 2 +- src/guile/skribilo/engine/latex.scm | 2 + src/guile/skribilo/evaluator.scm | 54 +- src/guile/skribilo/lib.scm | 23 +- src/guile/skribilo/package/Makefile.am | 4 + src/guile/skribilo/package/acmproc.scm | 155 ++++ src/guile/skribilo/package/french.scm | 21 + src/guile/skribilo/package/jfp.scm | 319 +++++++ src/guile/skribilo/package/letter.scm | 148 ++++ src/guile/skribilo/package/lncs.scm | 149 ++++ src/guile/skribilo/package/scribe.scm | 231 +++++ src/guile/skribilo/package/sigplan.scm | 157 ++++ src/guile/skribilo/package/skribe.scm | 76 ++ src/guile/skribilo/package/slide.scm | 667 +++++++++++++++ src/guile/skribilo/package/web-article.scm | 232 +++++ src/guile/skribilo/package/web-book.scm | 109 +++ src/guile/skribilo/packages/acmproc.scm | 155 ---- src/guile/skribilo/packages/french.scm | 21 - src/guile/skribilo/packages/jfp.scm | 319 ------- src/guile/skribilo/packages/letter.scm | 148 ---- src/guile/skribilo/packages/lncs.scm | 149 ---- src/guile/skribilo/packages/scribe.scm | 231 ----- src/guile/skribilo/packages/sigplan.scm | 157 ---- src/guile/skribilo/packages/skribe.scm | 76 -- src/guile/skribilo/packages/slide.scm | 667 --------------- src/guile/skribilo/packages/web-article.scm | 232 ----- src/guile/skribilo/packages/web-book.scm | 107 --- src/guile/skribilo/reader/Makefile.am | 2 + src/guile/skribilo/reader/skribe.scm | 20 +- src/guile/skribilo/skribe/Makefile.am | 2 + src/guile/skribilo/skribe/index.scm | 12 +- 50 files changed, 4866 insertions(+), 2644 deletions(-) create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog delete mode 100644 LICENSE create mode 100644 Makefile.am create mode 100644 NEWS create mode 100644 configure.ac create mode 100644 doc/Makefile.am create mode 100644 doc/user/Makefile.am create mode 100644 src/Makefile.am create mode 100644 src/guile/Makefile.am create mode 100644 src/guile/skribilo/Makefile.am create mode 100644 src/guile/skribilo/coloring/Makefile.am create mode 100644 src/guile/skribilo/engine/Makefile.am create mode 100644 src/guile/skribilo/package/Makefile.am create mode 100644 src/guile/skribilo/package/acmproc.scm create mode 100644 src/guile/skribilo/package/french.scm create mode 100644 src/guile/skribilo/package/jfp.scm create mode 100644 src/guile/skribilo/package/letter.scm create mode 100644 src/guile/skribilo/package/lncs.scm create mode 100644 src/guile/skribilo/package/scribe.scm create mode 100644 src/guile/skribilo/package/sigplan.scm create mode 100644 src/guile/skribilo/package/skribe.scm create mode 100644 src/guile/skribilo/package/slide.scm create mode 100644 src/guile/skribilo/package/web-article.scm create mode 100644 src/guile/skribilo/package/web-book.scm delete mode 100644 src/guile/skribilo/packages/acmproc.scm delete mode 100644 src/guile/skribilo/packages/french.scm delete mode 100644 src/guile/skribilo/packages/jfp.scm delete mode 100644 src/guile/skribilo/packages/letter.scm delete mode 100644 src/guile/skribilo/packages/lncs.scm delete mode 100644 src/guile/skribilo/packages/scribe.scm delete mode 100644 src/guile/skribilo/packages/sigplan.scm delete mode 100644 src/guile/skribilo/packages/skribe.scm delete mode 100644 src/guile/skribilo/packages/slide.scm delete mode 100644 src/guile/skribilo/packages/web-article.scm delete mode 100644 src/guile/skribilo/packages/web-book.scm create mode 100644 src/guile/skribilo/reader/Makefile.am create mode 100644 src/guile/skribilo/skribe/Makefile.am (limited to 'src') diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..bc03de5 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,8 @@ +Erick Gallesio and Manuel Serrano implemented Skribe, +http://www.inria.fr/mimosa/fp/Skribe . + +Skribilo is based upon Skribe 1.2d and re-uses a large body of code +written for Skribe by Erick and Manuel. The port to Skribe and +several enhancements were implemented by Ludovic Courtès. + +You can contact me at `ludovic.courtes@laas.fr'. diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..3912109 --- /dev/null +++ b/COPYING @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..cc89110 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,1225 @@ +# do not edit -- automatically generated by arch changelog +# arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 +# + +2005-10-31 23:26:24 GMT Ludovic Courtes patch-10 + + Summary: + Installed Autoconf/Automake machinery. Fixed a few things. + Revision: + skribilo--devel--1.2--patch-10 + + * src/guile/skribilo/evaluator.scm (skribe-load): Search through + `%load-path' and try with a `.scm' extension (rather than the `.skr' + one provided by the user). + (skribe-include): Added a few debugging statements. + + * src/guile/skribilo/lib.scm (fix-rest-arg): Handle the dot notation for + rest arguments. + + * src/guile/skribilo/reader/skribe.scm (%make-skribe-reader): Use + SQUARE-BRACKET-FREE-SYMBOL-MISC-CHARS. + + * src/guile/skribilo/skribe/index.scm: Use `define-public' instead of + `define'. + + * src/guile/skribilo/packages/*.scm: Moved to `skribilo/package'. + + * LICENSE: Removed. + + * COPYING: New. + + * AUTHORS: New. + + * NEWS: New. + + * ChangeLog: New. + + * configure.ac: New. + + * Makefile.am: New. In various directories. + + new files: + .arch-ids/AUTHORS.id .arch-ids/COPYING.id + .arch-ids/Makefile.am.id .arch-ids/NEWS.id + .arch-ids/configure.ac.id AUTHORS COPYING ChangeLog + Makefile.am NEWS configure.ac doc/.arch-ids/Makefile.am.id + doc/Makefile.am doc/user/.arch-ids/Makefile.am.id + doc/user/Makefile.am src/.arch-ids/Makefile.am.id + src/Makefile.am src/guile/.arch-ids/Makefile.am.id + src/guile/Makefile.am + src/guile/skribilo/.arch-ids/Makefile.am.id + src/guile/skribilo/Makefile.am + src/guile/skribilo/coloring/.arch-ids/Makefile.am.id + src/guile/skribilo/coloring/Makefile.am + src/guile/skribilo/engine/.arch-ids/Makefile.am.id + src/guile/skribilo/engine/Makefile.am + src/guile/skribilo/package/.arch-ids/=id + src/guile/skribilo/package/.arch-ids/Makefile.am.id + src/guile/skribilo/package/Makefile.am + src/guile/skribilo/reader/.arch-ids/Makefile.am.id + src/guile/skribilo/reader/Makefile.am + src/guile/skribilo/skribe/.arch-ids/Makefile.am.id + src/guile/skribilo/skribe/Makefile.am + + removed files: + .arch-ids/LICENSE.id LICENSE + src/guile/skribilo/packages/.arch-ids/=id + + modified files: + doc/Makefile doc/user/start.skb doc/user/user.skb + src/guile/skribilo/Makefile.in + src/guile/skribilo/config.scm.in + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/latex.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/lib.scm + src/guile/skribilo/package/french.scm + src/guile/skribilo/package/jfp.scm + src/guile/skribilo/package/letter.scm + src/guile/skribilo/package/lncs.scm + src/guile/skribilo/package/scribe.scm + src/guile/skribilo/package/sigplan.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/package/web-article.scm + src/guile/skribilo/package/web-book.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/skribe/index.scm + + renamed files: + src/guile/skribilo/packages/.arch-ids/acmproc.scm.id + ==> src/guile/skribilo/package/.arch-ids/acmproc.scm.id + src/guile/skribilo/packages/.arch-ids/french.scm.id + ==> src/guile/skribilo/package/.arch-ids/french.scm.id + src/guile/skribilo/packages/.arch-ids/jfp.scm.id + ==> src/guile/skribilo/package/.arch-ids/jfp.scm.id + src/guile/skribilo/packages/.arch-ids/letter.scm.id + ==> src/guile/skribilo/package/.arch-ids/letter.scm.id + src/guile/skribilo/packages/.arch-ids/lncs.scm.id + ==> src/guile/skribilo/package/.arch-ids/lncs.scm.id + src/guile/skribilo/packages/.arch-ids/scribe.scm.id + ==> src/guile/skribilo/package/.arch-ids/scribe.scm.id + src/guile/skribilo/packages/.arch-ids/sigplan.scm.id + ==> src/guile/skribilo/package/.arch-ids/sigplan.scm.id + src/guile/skribilo/packages/.arch-ids/skribe.scm.id + ==> src/guile/skribilo/package/.arch-ids/skribe.scm.id + src/guile/skribilo/packages/.arch-ids/slide.scm.id + ==> src/guile/skribilo/package/.arch-ids/slide.scm.id + src/guile/skribilo/packages/.arch-ids/web-article.scm.id + ==> src/guile/skribilo/package/.arch-ids/web-article.scm.id + src/guile/skribilo/packages/.arch-ids/web-book.scm.id + ==> src/guile/skribilo/package/.arch-ids/web-book.scm.id + src/guile/skribilo/packages/acmproc.scm + ==> src/guile/skribilo/package/acmproc.scm + src/guile/skribilo/packages/french.scm + ==> src/guile/skribilo/package/french.scm + src/guile/skribilo/packages/jfp.scm + ==> src/guile/skribilo/package/jfp.scm + src/guile/skribilo/packages/letter.scm + ==> src/guile/skribilo/package/letter.scm + src/guile/skribilo/packages/lncs.scm + ==> src/guile/skribilo/package/lncs.scm + src/guile/skribilo/packages/scribe.scm + ==> src/guile/skribilo/package/scribe.scm + src/guile/skribilo/packages/sigplan.scm + ==> src/guile/skribilo/package/sigplan.scm + src/guile/skribilo/packages/skribe.scm + ==> src/guile/skribilo/package/skribe.scm + src/guile/skribilo/packages/slide.scm + ==> src/guile/skribilo/package/slide.scm + src/guile/skribilo/packages/web-article.scm + ==> src/guile/skribilo/package/web-article.scm + src/guile/skribilo/packages/web-book.scm + ==> src/guile/skribilo/package/web-book.scm + + new directories: + src/guile/skribilo/package + src/guile/skribilo/package/.arch-ids + + removed directories: + src/guile/skribilo/packages + src/guile/skribilo/packages/.arch-ids + + +2005-10-31 16:16:54 GMT Ludovic Courtes patch-9 + + Summary: + Moved the STkLos and Bigloo code to `legacy'. + Revision: + skribilo--devel--1.2--patch-9 + + Moved the STkLos and Bigloo code from `src' to `legacy'. + + new files: + legacy/.arch-ids/=id legacy/bigloo/.arch-ids/=id + legacy/stklos/.arch-ids/=id + + removed files: + .arch-ids/Makefile.id .arch-ids/configure.id Makefile + configure src/.arch-ids/Makefile.id src/Makefile + src/bigloo/.arch-ids/=id src/common/.arch-ids/=id + src/common/.arch-ids/api.scm.id + src/common/.arch-ids/bib.scm.id + src/common/.arch-ids/configure.scm.id + src/common/.arch-ids/configure.scm.in.id + src/common/.arch-ids/index.scm.id + src/common/.arch-ids/lib.scm.id + src/common/.arch-ids/param.scm.id + src/common/.arch-ids/sui.scm.id src/common/api.scm + src/common/bib.scm src/common/configure.scm + src/common/configure.scm.in src/common/index.scm + src/common/lib.scm src/common/param.scm src/common/sui.scm + src/stklos/.arch-ids/=id + + renamed files: + src/bigloo/.arch-ids/Makefile.id + ==> legacy/bigloo/.arch-ids/Makefile.id + src/bigloo/.arch-ids/api.bgl.id + ==> legacy/bigloo/.arch-ids/api.bgl.id + src/bigloo/.arch-ids/api.sch.id + ==> legacy/bigloo/.arch-ids/api.sch.id + src/bigloo/.arch-ids/asm.scm.id + ==> legacy/bigloo/.arch-ids/asm.scm.id + src/bigloo/.arch-ids/bib.bgl.id + ==> legacy/bigloo/.arch-ids/bib.bgl.id + src/bigloo/.arch-ids/c.scm.id + ==> legacy/bigloo/.arch-ids/c.scm.id + src/bigloo/.arch-ids/color.scm.id + ==> legacy/bigloo/.arch-ids/color.scm.id + src/bigloo/.arch-ids/configure.bgl.id + ==> legacy/bigloo/.arch-ids/configure.bgl.id + src/bigloo/.arch-ids/debug.sch.id + ==> legacy/bigloo/.arch-ids/debug.sch.id + src/bigloo/.arch-ids/debug.scm.id + ==> legacy/bigloo/.arch-ids/debug.scm.id + src/bigloo/.arch-ids/engine.scm.id + ==> legacy/bigloo/.arch-ids/engine.scm.id + src/bigloo/.arch-ids/eval.scm.id + ==> legacy/bigloo/.arch-ids/eval.scm.id + src/bigloo/.arch-ids/evapi.scm.id + ==> legacy/bigloo/.arch-ids/evapi.scm.id + src/bigloo/.arch-ids/index.bgl.id + ==> legacy/bigloo/.arch-ids/index.bgl.id + src/bigloo/.arch-ids/lib.bgl.id + ==> legacy/bigloo/.arch-ids/lib.bgl.id + src/bigloo/.arch-ids/lisp.scm.id + ==> legacy/bigloo/.arch-ids/lisp.scm.id + src/bigloo/.arch-ids/main.scm.id + ==> legacy/bigloo/.arch-ids/main.scm.id + src/bigloo/.arch-ids/new.sch.id + ==> legacy/bigloo/.arch-ids/new.sch.id + src/bigloo/.arch-ids/output.scm.id + ==> legacy/bigloo/.arch-ids/output.scm.id + src/bigloo/.arch-ids/param.bgl.id + ==> legacy/bigloo/.arch-ids/param.bgl.id + src/bigloo/.arch-ids/parseargs.scm.id + ==> legacy/bigloo/.arch-ids/parseargs.scm.id + src/bigloo/.arch-ids/prog.scm.id + ==> legacy/bigloo/.arch-ids/prog.scm.id + src/bigloo/.arch-ids/read.scm.id + ==> legacy/bigloo/.arch-ids/read.scm.id + src/bigloo/.arch-ids/resolve.scm.id + ==> legacy/bigloo/.arch-ids/resolve.scm.id + src/bigloo/.arch-ids/source.scm.id + ==> legacy/bigloo/.arch-ids/source.scm.id + src/bigloo/.arch-ids/sui.bgl.id + ==> legacy/bigloo/.arch-ids/sui.bgl.id + src/bigloo/.arch-ids/types.scm.id + ==> legacy/bigloo/.arch-ids/types.scm.id + src/bigloo/.arch-ids/verify.scm.id + ==> legacy/bigloo/.arch-ids/verify.scm.id + src/bigloo/.arch-ids/writer.scm.id + ==> legacy/bigloo/.arch-ids/writer.scm.id + src/bigloo/.arch-ids/xml.scm.id + ==> legacy/bigloo/.arch-ids/xml.scm.id + src/bigloo/Makefile + ==> legacy/bigloo/Makefile + src/bigloo/api.bgl + ==> legacy/bigloo/api.bgl + src/bigloo/api.sch + ==> legacy/bigloo/api.sch + src/bigloo/asm.scm + ==> legacy/bigloo/asm.scm + src/bigloo/bib.bgl + ==> legacy/bigloo/bib.bgl + src/bigloo/c.scm + ==> legacy/bigloo/c.scm + src/bigloo/color.scm + ==> legacy/bigloo/color.scm + src/bigloo/configure.bgl + ==> legacy/bigloo/configure.bgl + src/bigloo/debug.sch + ==> legacy/bigloo/debug.sch + src/bigloo/debug.scm + ==> legacy/bigloo/debug.scm + src/bigloo/engine.scm + ==> legacy/bigloo/engine.scm + src/bigloo/eval.scm + ==> legacy/bigloo/eval.scm + src/bigloo/evapi.scm + ==> legacy/bigloo/evapi.scm + src/bigloo/index.bgl + ==> legacy/bigloo/index.bgl + src/bigloo/lib.bgl + ==> legacy/bigloo/lib.bgl + src/bigloo/lisp.scm + ==> legacy/bigloo/lisp.scm + src/bigloo/main.scm + ==> legacy/bigloo/main.scm + src/bigloo/new.sch + ==> legacy/bigloo/new.sch + src/bigloo/output.scm + ==> legacy/bigloo/output.scm + src/bigloo/param.bgl + ==> legacy/bigloo/param.bgl + src/bigloo/parseargs.scm + ==> legacy/bigloo/parseargs.scm + src/bigloo/prog.scm + ==> legacy/bigloo/prog.scm + src/bigloo/read.scm + ==> legacy/bigloo/read.scm + src/bigloo/resolve.scm + ==> legacy/bigloo/resolve.scm + src/bigloo/source.scm + ==> legacy/bigloo/source.scm + src/bigloo/sui.bgl + ==> legacy/bigloo/sui.bgl + src/bigloo/types.scm + ==> legacy/bigloo/types.scm + src/bigloo/verify.scm + ==> legacy/bigloo/verify.scm + src/bigloo/writer.scm + ==> legacy/bigloo/writer.scm + src/bigloo/xml.scm + ==> legacy/bigloo/xml.scm + src/stklos/.arch-ids/Makefile.in.id + ==> legacy/stklos/.arch-ids/Makefile.in.id + src/stklos/.arch-ids/biblio.stk.id + ==> legacy/stklos/.arch-ids/biblio.stk.id + src/stklos/.arch-ids/c-lex.l.id + ==> legacy/stklos/.arch-ids/c-lex.l.id + src/stklos/.arch-ids/c.stk.id + ==> legacy/stklos/.arch-ids/c.stk.id + src/stklos/.arch-ids/color.stk.id + ==> legacy/stklos/.arch-ids/color.stk.id + src/stklos/.arch-ids/configure.stk.id + ==> legacy/stklos/.arch-ids/configure.stk.id + src/stklos/.arch-ids/debug.stk.id + ==> legacy/stklos/.arch-ids/debug.stk.id + src/stklos/.arch-ids/engine.stk.id + ==> legacy/stklos/.arch-ids/engine.stk.id + src/stklos/.arch-ids/eval.stk.id + ==> legacy/stklos/.arch-ids/eval.stk.id + src/stklos/.arch-ids/lib.stk.id + ==> legacy/stklos/.arch-ids/lib.stk.id + src/stklos/.arch-ids/lisp-lex.l.id + ==> legacy/stklos/.arch-ids/lisp-lex.l.id + src/stklos/.arch-ids/lisp.stk.id + ==> legacy/stklos/.arch-ids/lisp.stk.id + src/stklos/.arch-ids/main.stk.id + ==> legacy/stklos/.arch-ids/main.stk.id + src/stklos/.arch-ids/output.stk.id + ==> legacy/stklos/.arch-ids/output.stk.id + src/stklos/.arch-ids/prog.stk.id + ==> legacy/stklos/.arch-ids/prog.stk.id + src/stklos/.arch-ids/reader.stk.id + ==> legacy/stklos/.arch-ids/reader.stk.id + src/stklos/.arch-ids/resolve.stk.id + ==> legacy/stklos/.arch-ids/resolve.stk.id + src/stklos/.arch-ids/runtime.stk.id + ==> legacy/stklos/.arch-ids/runtime.stk.id + src/stklos/.arch-ids/source.stk.id + ==> legacy/stklos/.arch-ids/source.stk.id + src/stklos/.arch-ids/types.stk.id + ==> legacy/stklos/.arch-ids/types.stk.id + src/stklos/.arch-ids/vars.stk.id + ==> legacy/stklos/.arch-ids/vars.stk.id + src/stklos/.arch-ids/verify.stk.id + ==> legacy/stklos/.arch-ids/verify.stk.id + src/stklos/.arch-ids/writer.stk.id + ==> legacy/stklos/.arch-ids/writer.stk.id + src/stklos/.arch-ids/xml-lex.l.id + ==> legacy/stklos/.arch-ids/xml-lex.l.id + src/stklos/.arch-ids/xml.stk.id + ==> legacy/stklos/.arch-ids/xml.stk.id + src/stklos/Makefile.in + ==> legacy/stklos/Makefile.in + src/stklos/biblio.stk + ==> legacy/stklos/biblio.stk + src/stklos/c-lex.l + ==> legacy/stklos/c-lex.l + src/stklos/c.stk + ==> legacy/stklos/c.stk + src/stklos/color.stk + ==> legacy/stklos/color.stk + src/stklos/configure.stk + ==> legacy/stklos/configure.stk + src/stklos/debug.stk + ==> legacy/stklos/debug.stk + src/stklos/engine.stk + ==> legacy/stklos/engine.stk + src/stklos/eval.stk + ==> legacy/stklos/eval.stk + src/stklos/lib.stk + ==> legacy/stklos/lib.stk + src/stklos/lisp-lex.l + ==> legacy/stklos/lisp-lex.l + src/stklos/lisp.stk + ==> legacy/stklos/lisp.stk + src/stklos/main.stk + ==> legacy/stklos/main.stk + src/stklos/output.stk + ==> legacy/stklos/output.stk + src/stklos/prog.stk + ==> legacy/stklos/prog.stk + src/stklos/reader.stk + ==> legacy/stklos/reader.stk + src/stklos/resolve.stk + ==> legacy/stklos/resolve.stk + src/stklos/runtime.stk + ==> legacy/stklos/runtime.stk + src/stklos/source.stk + ==> legacy/stklos/source.stk + src/stklos/types.stk + ==> legacy/stklos/types.stk + src/stklos/vars.stk + ==> legacy/stklos/vars.stk + src/stklos/verify.stk + ==> legacy/stklos/verify.stk + src/stklos/writer.stk + ==> legacy/stklos/writer.stk + src/stklos/xml-lex.l + ==> legacy/stklos/xml-lex.l + src/stklos/xml.stk + ==> legacy/stklos/xml.stk + + new directories: + legacy legacy/.arch-ids legacy/bigloo legacy/bigloo/.arch-ids + legacy/stklos legacy/stklos/.arch-ids + + removed directories: + src/bigloo src/bigloo/.arch-ids src/common + src/common/.arch-ids src/stklos src/stklos/.arch-ids + + +2005-10-31 16:03:49 GMT Ludovic Courtes patch-8 + + Summary: + Removed useless files, integrated packages. + Revision: + skribilo--devel--1.2--patch-8 + + * src/guile/skribilo/packages: New directory and files. + + * bin: Removed. + + * skr: Removed (files moved to `src/guile/skribilo/packages'). + + * skribe: Removed. + + * doc/skr/env.skr (*courtes-mail*): New. + + * doc/user/user.skb: Removed postal addresses, added my name. + + * src/guile/skribilo/engine/lout.scm: Uncommented the slide-related + markup writers. + + * src/guile/skribilo/evaluator.scm (%evaluate): Try weird things with + source properties. + + * src/guile/skribilo/reader/skribe.scm: Comply with the new guile-reader + API. + + * src/guile/skribilo/types.scm: Removed the special `initialize' method + for ASTs which was supposed to set their location. + + +2005-10-31 16:03:18 GMT Ludovic Courtes patch-7 + + Summary: + Removed useless files, integrated packages. + Revision: + skribilo--devel--1.2--patch-7 + + * src/guile/skribilo/packages: New directory and files. + + * bin: Removed. + + * skr: Removed (files moved to `src/guile/skribilo/packages'). + + * skribe: Removed. + + * doc/skr/env.skr (*courtes-mail*): New. + + * doc/user/user.skb: Removed postal addresses, added my name. + + * src/guile/skribilo/engine/lout.scm: Uncommented the slide-related + markup writers. + + * src/guile/skribilo/evaluator.scm (%evaluate): Try weird things with + source properties. + + * src/guile/skribilo/reader/skribe.scm: Comply with the new guile-reader + API. + + * src/guile/skribilo/types.scm: Removed the special `initialize' method + for ASTs which was supposed to set their location. + + new files: + src/guile/skribilo/packages/.arch-ids/=id + + removed files: + .arch-ids/README.java.id .arch-ids/skribe.prj.id README.java + bin/.arch-ids/=id bin/.arch-ids/skribe.bigloo.id + bin/.arch-ids/skribebibtex.bigloo.id bin/skribe.bigloo + bin/skribebibtex.bigloo skr/.arch-ids/=id + skr/.arch-ids/Makefile.id skr/Makefile skribe.prj + skribe/.arch-ids/=id skribe/.arch-ids/INSTALL.id + skribe/.arch-ids/LICENSE.id skribe/.arch-ids/Makefile.id + skribe/.arch-ids/README.id skribe/.arch-ids/README.java.id + skribe/.arch-ids/configure.id skribe/.arch-ids/skribe.prj.id + skribe/INSTALL skribe/LICENSE skribe/Makefile skribe/README + skribe/README.java skribe/configure skribe/doc/.arch-ids/=id + skribe/doc/.arch-ids/Makefile.dir.id + skribe/doc/.arch-ids/Makefile.id skribe/doc/Makefile + skribe/doc/Makefile.dir skribe/doc/dir/.arch-ids/=id + skribe/doc/dir/.arch-ids/dir.skb.id skribe/doc/dir/dir.skb + skribe/doc/img/.arch-ids/=id + skribe/doc/img/.arch-ids/bsd.gif.id + skribe/doc/img/.arch-ids/lambda.gif.id + skribe/doc/img/.arch-ids/linux.gif.id skribe/doc/img/bsd.gif + skribe/doc/img/lambda.gif skribe/doc/img/linux.gif + skribe/doc/skr/.arch-ids/=id + skribe/doc/skr/.arch-ids/api.skr.id + skribe/doc/skr/.arch-ids/env.skr.id + skribe/doc/skr/.arch-ids/extension.skr.id + skribe/doc/skr/.arch-ids/manual.skr.id skribe/doc/skr/api.skr + skribe/doc/skr/env.skr skribe/doc/skr/extension.skr + skribe/doc/skr/manual.skr skribe/doc/user/.arch-ids/=id + skribe/doc/user/.arch-ids/bib.skb.id + skribe/doc/user/.arch-ids/char.skb.id + skribe/doc/user/.arch-ids/colframe.skb.id + skribe/doc/user/.arch-ids/document.skb.id + skribe/doc/user/.arch-ids/emacs.skb.id + skribe/doc/user/.arch-ids/engine.skb.id + skribe/doc/user/.arch-ids/enumeration.skb.id + skribe/doc/user/.arch-ids/examples.skb.id + skribe/doc/user/.arch-ids/figure.skb.id + skribe/doc/user/.arch-ids/font.skb.id + skribe/doc/user/.arch-ids/footnote.skb.id + skribe/doc/user/.arch-ids/htmle.skb.id + skribe/doc/user/.arch-ids/image.skb.id + skribe/doc/user/.arch-ids/index.skb.id + skribe/doc/user/.arch-ids/justify.skb.id + skribe/doc/user/.arch-ids/latexe.skb.id + skribe/doc/user/.arch-ids/lib.skb.id + skribe/doc/user/.arch-ids/line.skb.id + skribe/doc/user/.arch-ids/links.skb.id + skribe/doc/user/.arch-ids/markup.skb.id + skribe/doc/user/.arch-ids/ornament.skb.id + skribe/doc/user/.arch-ids/package.skb.id + skribe/doc/user/.arch-ids/prgm.skb.id + skribe/doc/user/.arch-ids/sectioning.skb.id + skribe/doc/user/.arch-ids/skribe-config.skb.id + skribe/doc/user/.arch-ids/skribec.skb.id + skribe/doc/user/.arch-ids/skribeinfo.skb.id + skribe/doc/user/.arch-ids/slide.skb.id + skribe/doc/user/.arch-ids/start.skb.id + skribe/doc/user/.arch-ids/syntax.skb.id + skribe/doc/user/.arch-ids/table.skb.id + skribe/doc/user/.arch-ids/toc.skb.id + skribe/doc/user/.arch-ids/user.skb.id + skribe/doc/user/.arch-ids/xmle.skb.id skribe/doc/user/bib.skb + skribe/doc/user/char.skb skribe/doc/user/colframe.skb + skribe/doc/user/document.skb skribe/doc/user/emacs.skb + skribe/doc/user/engine.skb skribe/doc/user/enumeration.skb + skribe/doc/user/examples.skb skribe/doc/user/figure.skb + skribe/doc/user/font.skb skribe/doc/user/footnote.skb + skribe/doc/user/htmle.skb skribe/doc/user/image.skb + skribe/doc/user/index.skb skribe/doc/user/justify.skb + skribe/doc/user/latexe.skb skribe/doc/user/lib.skb + skribe/doc/user/line.skb skribe/doc/user/links.skb + skribe/doc/user/markup.skb skribe/doc/user/ornament.skb + skribe/doc/user/package.skb skribe/doc/user/prgm.skb + skribe/doc/user/sectioning.skb + skribe/doc/user/skribe-config.skb skribe/doc/user/skribec.skb + skribe/doc/user/skribeinfo.skb skribe/doc/user/slide.skb + skribe/doc/user/src/.arch-ids/=id + skribe/doc/user/src/.arch-ids/api1.skb.id + skribe/doc/user/src/.arch-ids/api10.skb.id + skribe/doc/user/src/.arch-ids/api11.skb.id + skribe/doc/user/src/.arch-ids/api12.skb.id + skribe/doc/user/src/.arch-ids/api13.skb.id + skribe/doc/user/src/.arch-ids/api14.skb.id + skribe/doc/user/src/.arch-ids/api15.skb.id + skribe/doc/user/src/.arch-ids/api16.skb.id + skribe/doc/user/src/.arch-ids/api17.skb.id + skribe/doc/user/src/.arch-ids/api18.skb.id + skribe/doc/user/src/.arch-ids/api19.skb.id + skribe/doc/user/src/.arch-ids/api2.skb.id + skribe/doc/user/src/.arch-ids/api20.skb.id + skribe/doc/user/src/.arch-ids/api3.skb.id + skribe/doc/user/src/.arch-ids/api4.skb.id + skribe/doc/user/src/.arch-ids/api5.skb.id + skribe/doc/user/src/.arch-ids/api6.skb.id + skribe/doc/user/src/.arch-ids/api7.skb.id + skribe/doc/user/src/.arch-ids/api8.skb.id + skribe/doc/user/src/.arch-ids/api9.skb.id + skribe/doc/user/src/.arch-ids/bib1.sbib.id + skribe/doc/user/src/.arch-ids/bib2.skb.id + skribe/doc/user/src/.arch-ids/bib3.skb.id + skribe/doc/user/src/.arch-ids/bib4.skb.id + skribe/doc/user/src/.arch-ids/bib5.skb.id + skribe/doc/user/src/.arch-ids/bib6.skb.id + skribe/doc/user/src/.arch-ids/index1.skb.id + skribe/doc/user/src/.arch-ids/index2.skb.id + skribe/doc/user/src/.arch-ids/index3.skb.id + skribe/doc/user/src/.arch-ids/links1.skb.id + skribe/doc/user/src/.arch-ids/links2.skb.id + skribe/doc/user/src/.arch-ids/prgm1.skb.id + skribe/doc/user/src/.arch-ids/prgm2.skb.id + skribe/doc/user/src/.arch-ids/prgm3.skb.id + skribe/doc/user/src/.arch-ids/slides.skb.id + skribe/doc/user/src/.arch-ids/start1.skb.id + skribe/doc/user/src/.arch-ids/start2.skb.id + skribe/doc/user/src/.arch-ids/start3.skb.id + skribe/doc/user/src/.arch-ids/start4.skb.id + skribe/doc/user/src/.arch-ids/start5.skb.id + skribe/doc/user/src/api1.skb skribe/doc/user/src/api10.skb + skribe/doc/user/src/api11.skb skribe/doc/user/src/api12.skb + skribe/doc/user/src/api13.skb skribe/doc/user/src/api14.skb + skribe/doc/user/src/api15.skb skribe/doc/user/src/api16.skb + skribe/doc/user/src/api17.skb skribe/doc/user/src/api18.skb + skribe/doc/user/src/api19.skb skribe/doc/user/src/api2.skb + skribe/doc/user/src/api20.skb skribe/doc/user/src/api3.skb + skribe/doc/user/src/api4.skb skribe/doc/user/src/api5.skb + skribe/doc/user/src/api6.skb skribe/doc/user/src/api7.skb + skribe/doc/user/src/api8.skb skribe/doc/user/src/api9.skb + skribe/doc/user/src/bib1.sbib skribe/doc/user/src/bib2.skb + skribe/doc/user/src/bib3.skb skribe/doc/user/src/bib4.skb + skribe/doc/user/src/bib5.skb skribe/doc/user/src/bib6.skb + skribe/doc/user/src/index1.skb skribe/doc/user/src/index2.skb + skribe/doc/user/src/index3.skb skribe/doc/user/src/links1.skb + skribe/doc/user/src/links2.skb skribe/doc/user/src/prgm1.skb + skribe/doc/user/src/prgm2.skb skribe/doc/user/src/prgm3.skb + skribe/doc/user/src/slides.skb skribe/doc/user/src/start1.skb + skribe/doc/user/src/start2.skb skribe/doc/user/src/start3.skb + skribe/doc/user/src/start4.skb skribe/doc/user/src/start5.skb + skribe/doc/user/start.skb skribe/doc/user/syntax.skb + skribe/doc/user/table.skb skribe/doc/user/toc.skb + skribe/doc/user/user.skb skribe/doc/user/xmle.skb + skribe/emacs/.arch-ids/=id skribe/emacs/.arch-ids/Makefile.id + skribe/emacs/.arch-ids/skribe.el.in.id skribe/emacs/Makefile + skribe/emacs/skribe.el.in skribe/etc/.arch-ids/=id + skribe/etc/.arch-ids/ChangeLog.id + skribe/etc/.arch-ids/Makefile.id + skribe/etc/.arch-ids/skribe-config.in.id skribe/etc/ChangeLog + skribe/etc/Makefile skribe/etc/bigloo/.arch-ids/=id + skribe/etc/bigloo/.arch-ids/Makefile.id + skribe/etc/bigloo/.arch-ids/Makefile.tpl.id + skribe/etc/bigloo/.arch-ids/configure.id + skribe/etc/bigloo/Makefile skribe/etc/bigloo/Makefile.tpl + skribe/etc/bigloo/autoconf/.arch-ids/=id + skribe/etc/bigloo/autoconf/.arch-ids/Makefile.id + skribe/etc/bigloo/autoconf/.arch-ids/bfildir.id + skribe/etc/bigloo/autoconf/.arch-ids/blibdir.id + skribe/etc/bigloo/autoconf/.arch-ids/bversion.id + skribe/etc/bigloo/autoconf/.arch-ids/getbversion.id + skribe/etc/bigloo/autoconf/.arch-ids/gmaketest.id + skribe/etc/bigloo/autoconf/Makefile + skribe/etc/bigloo/autoconf/bfildir + skribe/etc/bigloo/autoconf/blibdir + skribe/etc/bigloo/autoconf/bversion + skribe/etc/bigloo/autoconf/getbversion + skribe/etc/bigloo/autoconf/gmaketest + skribe/etc/bigloo/configure skribe/etc/skribe-config.in + skribe/etc/stklos/.arch-ids/=id + skribe/etc/stklos/.arch-ids/Makefile.config.in.id + skribe/etc/stklos/.arch-ids/Makefile.in.id + skribe/etc/stklos/.arch-ids/Makefile.skb.in.id + skribe/etc/stklos/.arch-ids/configure.id + skribe/etc/stklos/.arch-ids/configure.in.id + skribe/etc/stklos/Makefile.config.in + skribe/etc/stklos/Makefile.in + skribe/etc/stklos/Makefile.skb.in skribe/etc/stklos/configure + skribe/etc/stklos/configure.in skribe/examples/.arch-ids/=id + skribe/examples/.arch-ids/Makefile.id skribe/examples/Makefile + skribe/examples/slide/.arch-ids/=id + skribe/examples/slide/.arch-ids/Makefile.id + skribe/examples/slide/.arch-ids/PPRskribe.sty.id + skribe/examples/slide/.arch-ids/README.id + skribe/examples/slide/.arch-ids/advi.sty.id + skribe/examples/slide/Makefile + skribe/examples/slide/PPRskribe.sty + skribe/examples/slide/README skribe/examples/slide/advi.sty + skribe/examples/slide/ex/.arch-ids/=id + skribe/examples/slide/ex/.arch-ids/skribe.skb.id + skribe/examples/slide/ex/.arch-ids/syntax.scr.id + skribe/examples/slide/ex/skribe.skb + skribe/examples/slide/ex/syntax.scr + skribe/examples/slide/skb/.arch-ids/=id + skribe/examples/slide/skb/.arch-ids/slides.skb.id + skribe/examples/slide/skb/slides.skb + skribe/examples/slide/skr/.arch-ids/=id + skribe/examples/slide/skr/.arch-ids/local.skr.id + skribe/examples/slide/skr/local.skr skribe/skr/.arch-ids/=id + skribe/skr/.arch-ids/Makefile.id + skribe/skr/.arch-ids/acmproc.skr.id + skribe/skr/.arch-ids/base.skr.id + skribe/skr/.arch-ids/context.skr.id + skribe/skr/.arch-ids/french.skr.id + skribe/skr/.arch-ids/html.skr.id + skribe/skr/.arch-ids/html4.skr.id + skribe/skr/.arch-ids/jfp.skr.id + skribe/skr/.arch-ids/latex-simple.skr.id + skribe/skr/.arch-ids/latex.skr.id + skribe/skr/.arch-ids/letter.skr.id + skribe/skr/.arch-ids/lncs.skr.id + skribe/skr/.arch-ids/scribe.skr.id + skribe/skr/.arch-ids/sigplan.skr.id + skribe/skr/.arch-ids/skribe.skr.id + skribe/skr/.arch-ids/slide.skr.id + skribe/skr/.arch-ids/web-article.skr.id + skribe/skr/.arch-ids/web-book.skr.id + skribe/skr/.arch-ids/xml.skr.id skribe/skr/Makefile + skribe/skr/acmproc.skr skribe/skr/base.skr + skribe/skr/context.skr skribe/skr/french.skr + skribe/skr/html.skr skribe/skr/html4.skr skribe/skr/jfp.skr + skribe/skr/latex-simple.skr skribe/skr/latex.skr + skribe/skr/letter.skr skribe/skr/lncs.skr + skribe/skr/scribe.skr skribe/skr/sigplan.skr + skribe/skr/skribe.skr skribe/skr/slide.skr + skribe/skr/web-article.skr skribe/skr/web-book.skr + skribe/skr/xml.skr skribe/skribe.prj skribe/src/.arch-ids/=id + skribe/src/.arch-ids/Makefile.id skribe/src/Makefile + skribe/src/bigloo/.arch-ids/=id + skribe/src/bigloo/.arch-ids/Makefile.id + skribe/src/bigloo/.arch-ids/api.bgl.id + skribe/src/bigloo/.arch-ids/api.sch.id + skribe/src/bigloo/.arch-ids/asm.scm.id + skribe/src/bigloo/.arch-ids/bib.bgl.id + skribe/src/bigloo/.arch-ids/c.scm.id + skribe/src/bigloo/.arch-ids/color.scm.id + skribe/src/bigloo/.arch-ids/configure.bgl.id + skribe/src/bigloo/.arch-ids/debug.sch.id + skribe/src/bigloo/.arch-ids/debug.scm.id + skribe/src/bigloo/.arch-ids/engine.scm.id + skribe/src/bigloo/.arch-ids/eval.scm.id + skribe/src/bigloo/.arch-ids/evapi.scm.id + skribe/src/bigloo/.arch-ids/index.bgl.id + skribe/src/bigloo/.arch-ids/lib.bgl.id + skribe/src/bigloo/.arch-ids/lisp.scm.id + skribe/src/bigloo/.arch-ids/main.scm.id + skribe/src/bigloo/.arch-ids/new.sch.id + skribe/src/bigloo/.arch-ids/output.scm.id + skribe/src/bigloo/.arch-ids/param.bgl.id + skribe/src/bigloo/.arch-ids/parseargs.scm.id + skribe/src/bigloo/.arch-ids/prog.scm.id + skribe/src/bigloo/.arch-ids/read.scm.id + skribe/src/bigloo/.arch-ids/resolve.scm.id + skribe/src/bigloo/.arch-ids/source.scm.id + skribe/src/bigloo/.arch-ids/sui.bgl.id + skribe/src/bigloo/.arch-ids/types.scm.id + skribe/src/bigloo/.arch-ids/verify.scm.id + skribe/src/bigloo/.arch-ids/writer.scm.id + skribe/src/bigloo/.arch-ids/xml.scm.id + skribe/src/bigloo/Makefile skribe/src/bigloo/api.bgl + skribe/src/bigloo/api.sch skribe/src/bigloo/asm.scm + skribe/src/bigloo/bib.bgl skribe/src/bigloo/c.scm + skribe/src/bigloo/color.scm skribe/src/bigloo/configure.bgl + skribe/src/bigloo/debug.sch skribe/src/bigloo/debug.scm + skribe/src/bigloo/engine.scm skribe/src/bigloo/eval.scm + skribe/src/bigloo/evapi.scm skribe/src/bigloo/index.bgl + skribe/src/bigloo/lib.bgl skribe/src/bigloo/lisp.scm + skribe/src/bigloo/main.scm skribe/src/bigloo/new.sch + skribe/src/bigloo/output.scm skribe/src/bigloo/param.bgl + skribe/src/bigloo/parseargs.scm skribe/src/bigloo/prog.scm + skribe/src/bigloo/read.scm skribe/src/bigloo/resolve.scm + skribe/src/bigloo/source.scm skribe/src/bigloo/sui.bgl + skribe/src/bigloo/types.scm skribe/src/bigloo/verify.scm + skribe/src/bigloo/writer.scm skribe/src/bigloo/xml.scm + skribe/src/common/.arch-ids/=id + skribe/src/common/.arch-ids/api.scm.id + skribe/src/common/.arch-ids/bib.scm.id + skribe/src/common/.arch-ids/configure.scm.in.id + skribe/src/common/.arch-ids/index.scm.id + skribe/src/common/.arch-ids/lib.scm.id + skribe/src/common/.arch-ids/param.scm.id + skribe/src/common/.arch-ids/sui.scm.id + skribe/src/common/api.scm skribe/src/common/bib.scm + skribe/src/common/configure.scm.in skribe/src/common/index.scm + skribe/src/common/lib.scm skribe/src/common/param.scm + skribe/src/common/sui.scm skribe/src/stklos/.arch-ids/=id + skribe/src/stklos/.arch-ids/Makefile.in.id + skribe/src/stklos/.arch-ids/biblio.stk.id + skribe/src/stklos/.arch-ids/c-lex.l.id + skribe/src/stklos/.arch-ids/c.stk.id + skribe/src/stklos/.arch-ids/color.stk.id + skribe/src/stklos/.arch-ids/configure.stk.id + skribe/src/stklos/.arch-ids/debug.stk.id + skribe/src/stklos/.arch-ids/engine.stk.id + skribe/src/stklos/.arch-ids/eval.stk.id + skribe/src/stklos/.arch-ids/lib.stk.id + skribe/src/stklos/.arch-ids/lisp-lex.l.id + skribe/src/stklos/.arch-ids/lisp.stk.id + skribe/src/stklos/.arch-ids/main.stk.id + skribe/src/stklos/.arch-ids/output.stk.id + skribe/src/stklos/.arch-ids/prog.stk.id + skribe/src/stklos/.arch-ids/reader.stk.id + skribe/src/stklos/.arch-ids/resolve.stk.id + skribe/src/stklos/.arch-ids/runtime.stk.id + skribe/src/stklos/.arch-ids/source.stk.id + skribe/src/stklos/.arch-ids/types.stk.id + skribe/src/stklos/.arch-ids/vars.stk.id + skribe/src/stklos/.arch-ids/verify.stk.id + skribe/src/stklos/.arch-ids/writer.stk.id + skribe/src/stklos/.arch-ids/xml-lex.l.id + skribe/src/stklos/.arch-ids/xml.stk.id + skribe/src/stklos/Makefile.in skribe/src/stklos/biblio.stk + skribe/src/stklos/c-lex.l skribe/src/stklos/c.stk + skribe/src/stklos/color.stk skribe/src/stklos/configure.stk + skribe/src/stklos/debug.stk skribe/src/stklos/engine.stk + skribe/src/stklos/eval.stk skribe/src/stklos/lib.stk + skribe/src/stklos/lisp-lex.l skribe/src/stklos/lisp.stk + skribe/src/stklos/main.stk skribe/src/stklos/output.stk + skribe/src/stklos/prog.stk skribe/src/stklos/reader.stk + skribe/src/stklos/resolve.stk skribe/src/stklos/runtime.stk + skribe/src/stklos/source.stk skribe/src/stklos/types.stk + skribe/src/stklos/vars.stk skribe/src/stklos/verify.stk + skribe/src/stklos/writer.stk skribe/src/stklos/xml-lex.l + skribe/src/stklos/xml.stk skribe/tools/.arch-ids/=id + skribe/tools/.arch-ids/Makefile.id skribe/tools/Makefile + skribe/tools/skribebibtex/.arch-ids/=id + skribe/tools/skribebibtex/bigloo/.arch-ids/=id + skribe/tools/skribebibtex/bigloo/.arch-ids/Makefile.id + skribe/tools/skribebibtex/bigloo/.arch-ids/main.scm.id + skribe/tools/skribebibtex/bigloo/.arch-ids/skribebibtex.scm.id + skribe/tools/skribebibtex/bigloo/Makefile + skribe/tools/skribebibtex/bigloo/main.scm + skribe/tools/skribebibtex/bigloo/skribebibtex.scm + skribe/tools/skribebibtex/stklos/.arch-ids/=id + skribe/tools/skribebibtex/stklos/.arch-ids/Makefile.id + skribe/tools/skribebibtex/stklos/.arch-ids/bibtex-lex.l.id + skribe/tools/skribebibtex/stklos/.arch-ids/bibtex-parser.y.id + skribe/tools/skribebibtex/stklos/.arch-ids/main.stk.id + skribe/tools/skribebibtex/stklos/Makefile + skribe/tools/skribebibtex/stklos/bibtex-lex.l + skribe/tools/skribebibtex/stklos/bibtex-parser.y + skribe/tools/skribebibtex/stklos/main.stk + + modified files: + doc/skr/env.skr doc/user/user.skb + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm + src/guile/skribilo/packages/french.scm + src/guile/skribilo/packages/jfp.scm + src/guile/skribilo/packages/letter.scm + src/guile/skribilo/packages/lncs.scm + src/guile/skribilo/packages/scribe.scm + src/guile/skribilo/packages/sigplan.scm + src/guile/skribilo/packages/slide.scm + src/guile/skribilo/packages/web-article.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/skribe/param.scm + src/guile/skribilo/types.scm + + renamed files: + skr/.arch-ids/acmproc.skr.id + ==> src/guile/skribilo/packages/.arch-ids/acmproc.scm.id + skr/.arch-ids/french.skr.id + ==> src/guile/skribilo/packages/.arch-ids/french.scm.id + skr/.arch-ids/jfp.skr.id + ==> src/guile/skribilo/packages/.arch-ids/jfp.scm.id + skr/.arch-ids/letter.skr.id + ==> src/guile/skribilo/packages/.arch-ids/letter.scm.id + skr/.arch-ids/lncs.skr.id + ==> src/guile/skribilo/packages/.arch-ids/lncs.scm.id + skr/.arch-ids/scribe.skr.id + ==> src/guile/skribilo/packages/.arch-ids/scribe.scm.id + skr/.arch-ids/sigplan.skr.id + ==> src/guile/skribilo/packages/.arch-ids/sigplan.scm.id + skr/.arch-ids/skribe.skr.id + ==> src/guile/skribilo/packages/.arch-ids/skribe.scm.id + skr/.arch-ids/slide.skr.id + ==> src/guile/skribilo/packages/.arch-ids/slide.scm.id + skr/.arch-ids/web-article.skr.id + ==> src/guile/skribilo/packages/.arch-ids/web-article.scm.id + skr/.arch-ids/web-book.skr.id + ==> src/guile/skribilo/packages/.arch-ids/web-book.scm.id + skr/acmproc.skr + ==> src/guile/skribilo/packages/acmproc.scm + skr/french.skr + ==> src/guile/skribilo/packages/french.scm + skr/jfp.skr + ==> src/guile/skribilo/packages/jfp.scm + skr/letter.skr + ==> src/guile/skribilo/packages/letter.scm + skr/lncs.skr + ==> src/guile/skribilo/packages/lncs.scm + skr/scribe.skr + ==> src/guile/skribilo/packages/scribe.scm + skr/sigplan.skr + ==> src/guile/skribilo/packages/sigplan.scm + skr/skribe.skr + ==> src/guile/skribilo/packages/skribe.scm + skr/slide.skr + ==> src/guile/skribilo/packages/slide.scm + skr/web-article.skr + ==> src/guile/skribilo/packages/web-article.scm + skr/web-book.skr + ==> src/guile/skribilo/packages/web-book.scm + + new directories: + src/guile/skribilo/packages + src/guile/skribilo/packages/.arch-ids + + removed directories: + bin bin/.arch-ids skr skr/.arch-ids skribe skribe/.arch-ids + skribe/doc skribe/doc/.arch-ids skribe/doc/dir + skribe/doc/dir/.arch-ids skribe/doc/img + skribe/doc/img/.arch-ids skribe/doc/skr + skribe/doc/skr/.arch-ids skribe/doc/user + skribe/doc/user/.arch-ids skribe/doc/user/src + skribe/doc/user/src/.arch-ids skribe/emacs + skribe/emacs/.arch-ids skribe/etc skribe/etc/.arch-ids + skribe/etc/bigloo skribe/etc/bigloo/.arch-ids + skribe/etc/bigloo/autoconf + skribe/etc/bigloo/autoconf/.arch-ids skribe/etc/stklos + skribe/etc/stklos/.arch-ids skribe/examples + skribe/examples/.arch-ids skribe/examples/slide + skribe/examples/slide/.arch-ids skribe/examples/slide/ex + skribe/examples/slide/ex/.arch-ids skribe/examples/slide/skb + skribe/examples/slide/skb/.arch-ids skribe/examples/slide/skr + skribe/examples/slide/skr/.arch-ids skribe/skr + skribe/skr/.arch-ids skribe/src skribe/src/.arch-ids + skribe/src/bigloo skribe/src/bigloo/.arch-ids + skribe/src/common skribe/src/common/.arch-ids + skribe/src/stklos skribe/src/stklos/.arch-ids skribe/tools + skribe/tools/.arch-ids skribe/tools/skribebibtex + skribe/tools/skribebibtex/.arch-ids + skribe/tools/skribebibtex/bigloo + skribe/tools/skribebibtex/bigloo/.arch-ids + skribe/tools/skribebibtex/stklos + skribe/tools/skribebibtex/stklos/.arch-ids + + +2005-07-02 17:06:50 GMT Ludovic Courtes patch-6 + + Summary: + Cosmetic changes. + Revision: + skribilo--devel--1.2--patch-6 + + * src/guile/skribilo/resolve.scm: Minor cosmetic changes. + + modified files: + src/guile/skribilo/resolve.scm + + +2005-07-02 12:40:07 GMT Ludovic Courtes patch-5 + + Summary: + Minor fixes for file/line error reporting. + Revision: + skribilo--devel--1.2--patch-5 + + * src/guile/skribilo/lib.scm (skribe-line-error): Removed. + (skribe-ast-error): Fixed. Use `location-line' instead of + `location-pos'. + (skribe-error): Fixed. + (%skribe-warn): Use the file and line number of CURRENT-INPUT-PORT by + default. + + * src/guile/skribilo/types.scm: Export `location-file', `location-line' + and `location-pos'. + (initialize): New method for `' objects, initialize slot `loc' + with information from CURRENT-INPUT-PORT. + (ast-location): Fixed. + + modified files: + src/guile/skribilo/lib.scm src/guile/skribilo/types.scm + + +2005-07-02 03:51:27 GMT Ludovic Courtes patch-4 + + Summary: + First real document produced! + Revision: + skribilo--devel--1.2--patch-4 + + Lots of things, including: + + * src/guile/skribilo/engine/lout.scm: New file. + + First real document produced! + + new files: + src/guile/skribilo/engine/.arch-ids/lout.scm.id + src/guile/skribilo/engine/lout.scm + + modified files: + src/guile/README src/guile/skribilo.scm + src/guile/skribilo/debug.scm src/guile/skribilo/engine.scm + src/guile/skribilo/engine/base.scm + src/guile/skribilo/engine/context.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/html4.scm + src/guile/skribilo/engine/latex.scm src/guile/skribilo/lib.scm + src/guile/skribilo/module.scm src/guile/skribilo/runtime.scm + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/skribe/bib.scm + src/guile/skribilo/skribe/utils.scm + src/guile/skribilo/types.scm src/guile/skribilo/vars.scm + src/guile/skribilo/verify.scm src/guile/skribilo/writer.scm + + +2005-07-02 02:04:46 GMT Ludovic Courtes patch-3 + + Summary: + Started relying on the per-module reader; first doc produced ever! + Revision: + skribilo--devel--1.2--patch-3 + + First document compiled by Skribilo to HTML! + + * src/guile/skribilo/module.scm (define-skribe-module): Use the + `#:reader' option of `define-module' (not yet integrated in Guile 1.7). + + Plus lots of other things... + + modified files: + src/guile/README src/guile/skribilo.scm + src/guile/skribilo/biblio.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/lib.scm + src/guile/skribilo/module.scm src/guile/skribilo/output.scm + src/guile/skribilo/resolve.scm src/guile/skribilo/runtime.scm + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/skribe/bib.scm + src/guile/skribilo/skribe/utils.scm + src/guile/skribilo/source.scm src/guile/skribilo/types.scm + src/guile/skribilo/vars.scm src/guile/skribilo/verify.scm + src/guile/skribilo/writer.scm + + +2005-07-01 23:55:56 GMT Ludovic Courtes patch-2 + + Summary: + Lots of changes, again. + Revision: + skribilo--devel--1.2--patch-2 + + Lots of changes, notably the following: + + * skr/*.skr: Moved engines to `src/guile/skribilo/engine'. + + * src/guile/skribilo/engine.scm (lookup-engine): Rewritten. Don't use + the auto-load alist. + + * src/guile/skribilo/evaluator.scm: New name of the `eval' module. + `eval' couldn't be used as the module base-name because of Guile's + recursive module name space. + + new files: + src/guile/README src/guile/skribilo/engine/.arch-ids/=id + + modified files: + src/guile/skribilo.scm src/guile/skribilo/biblio.scm + src/guile/skribilo/config.scm.in src/guile/skribilo/debug.scm + src/guile/skribilo/engine.scm + src/guile/skribilo/engine/base.scm + src/guile/skribilo/engine/context.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/html4.scm + src/guile/skribilo/engine/latex-simple.scm + src/guile/skribilo/engine/xml.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/lib.scm + src/guile/skribilo/module.scm src/guile/skribilo/output.scm + src/guile/skribilo/reader.scm src/guile/skribilo/resolve.scm + src/guile/skribilo/runtime.scm src/guile/skribilo/source.scm + src/guile/skribilo/writer.scm {arch}/=tagging-method + + renamed files: + skr/.arch-ids/base.skr.id + ==> src/guile/skribilo/engine/.arch-ids/base.scm.id + skr/.arch-ids/context.skr.id + ==> src/guile/skribilo/engine/.arch-ids/context.scm.id + skr/.arch-ids/html.skr.id + ==> src/guile/skribilo/engine/.arch-ids/html.scm.id + skr/.arch-ids/html4.skr.id + ==> src/guile/skribilo/engine/.arch-ids/html4.scm.id + skr/.arch-ids/latex-simple.skr.id + ==> src/guile/skribilo/engine/.arch-ids/latex-simple.scm.id + skr/.arch-ids/latex.skr.id + ==> src/guile/skribilo/engine/.arch-ids/latex.scm.id + skr/.arch-ids/xml.skr.id + ==> src/guile/skribilo/engine/.arch-ids/xml.scm.id + skr/base.skr + ==> src/guile/skribilo/engine/base.scm + skr/context.skr + ==> src/guile/skribilo/engine/context.scm + skr/html.skr + ==> src/guile/skribilo/engine/html.scm + skr/html4.skr + ==> src/guile/skribilo/engine/html4.scm + skr/latex-simple.skr + ==> src/guile/skribilo/engine/latex-simple.scm + skr/latex.skr + ==> src/guile/skribilo/engine/latex.scm + skr/xml.skr + ==> src/guile/skribilo/engine/xml.scm + src/guile/skribilo/.arch-ids/eval.scm.id + ==> src/guile/skribilo/.arch-ids/evaluator.scm.id + src/guile/skribilo/eval.scm + ==> src/guile/skribilo/evaluator.scm + + new directories: + src/guile/skribilo/engine src/guile/skribilo/engine/.arch-ids + + +2005-07-01 13:33:34 GMT Ludovic Courtes patch-1 + + Summary: + Lots of changes. + Revision: + skribilo--devel--1.2--patch-1 + + Too many changes to describe here, among which, moving the `(skribe)' module + namespace to `(skribilo)'. This is work in progress. + + + new files: + src/guile/skribilo/.arch-ids/config.scm.in.id + src/guile/skribilo/.arch-ids/module.scm.id + src/guile/skribilo/.arch-ids/reader.scm.id + src/guile/skribilo/coloring/.arch-ids/=id + src/guile/skribilo/config.scm.in src/guile/skribilo/module.scm + src/guile/skribilo/reader.scm + src/guile/skribilo/reader/.arch-ids/=id + src/guile/skribilo/skribe/.arch-ids/=id + src/guile/skribilo/skribe/.arch-ids/api.scm.id + src/guile/skribilo/skribe/.arch-ids/bib.scm.id + src/guile/skribilo/skribe/.arch-ids/index.scm.id + src/guile/skribilo/skribe/.arch-ids/param.scm.id + src/guile/skribilo/skribe/.arch-ids/sui.scm.id + src/guile/skribilo/skribe/.arch-ids/utils.scm.id + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/skribe/bib.scm + src/guile/skribilo/skribe/index.scm + src/guile/skribilo/skribe/param.scm + src/guile/skribilo/skribe/sui.scm + src/guile/skribilo/skribe/utils.scm + + removed files: + src/guile/skribe/.arch-ids/configure.scm.id + src/guile/skribe/configure.scm + + modified files: + src/guile/skribilo.scm src/guile/skribilo/biblio.scm + src/guile/skribilo/color.scm src/guile/skribilo/coloring/c.scm + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/coloring/xml.scm + src/guile/skribilo/debug.scm src/guile/skribilo/engine.scm + src/guile/skribilo/eval.scm src/guile/skribilo/lib.scm + src/guile/skribilo/output.scm src/guile/skribilo/prog.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/resolve.scm src/guile/skribilo/runtime.scm + src/guile/skribilo/source.scm src/guile/skribilo/types.scm + src/guile/skribilo/vars.scm src/guile/skribilo/verify.scm + src/guile/skribilo/writer.scm + + renamed files: + src/guile/skribe/.arch-ids/=id + ==> src/guile/skribilo/.arch-ids/=id + src/guile/skribe/.arch-ids/Makefile.in.id + ==> src/guile/skribilo/.arch-ids/Makefile.in.id + src/guile/skribe/.arch-ids/biblio.scm.id + ==> src/guile/skribilo/.arch-ids/biblio.scm.id + src/guile/skribe/.arch-ids/c-lex.l.id + ==> src/guile/skribilo/coloring/.arch-ids/c-lex.l.id + src/guile/skribe/.arch-ids/c.scm.id + ==> src/guile/skribilo/coloring/.arch-ids/c.scm.id + src/guile/skribe/.arch-ids/color.scm.id + ==> src/guile/skribilo/.arch-ids/color.scm.id + src/guile/skribe/.arch-ids/debug.scm.id + ==> src/guile/skribilo/.arch-ids/debug.scm.id + src/guile/skribe/.arch-ids/engine.scm.id + ==> src/guile/skribilo/.arch-ids/engine.scm.id + src/guile/skribe/.arch-ids/eval.scm.id + ==> src/guile/skribilo/.arch-ids/eval.scm.id + src/guile/skribe/.arch-ids/lib.scm.id + ==> src/guile/skribilo/.arch-ids/lib.scm.id + src/guile/skribe/.arch-ids/lisp-lex.l.id + ==> src/guile/skribilo/coloring/.arch-ids/lisp-lex.l.id + src/guile/skribe/.arch-ids/lisp.scm.id + ==> src/guile/skribilo/coloring/.arch-ids/lisp.scm.id + src/guile/skribe/.arch-ids/output.scm.id + ==> src/guile/skribilo/.arch-ids/output.scm.id + src/guile/skribe/.arch-ids/prog.scm.id + ==> src/guile/skribilo/.arch-ids/prog.scm.id + src/guile/skribe/.arch-ids/reader.scm.id + ==> src/guile/skribilo/reader/.arch-ids/skribe.scm.id + src/guile/skribe/.arch-ids/resolve.scm.id + ==> src/guile/skribilo/.arch-ids/resolve.scm.id + src/guile/skribe/.arch-ids/runtime.scm.id + ==> src/guile/skribilo/.arch-ids/runtime.scm.id + src/guile/skribe/.arch-ids/source.scm.id + ==> src/guile/skribilo/.arch-ids/source.scm.id + src/guile/skribe/.arch-ids/types.scm.id + ==> src/guile/skribilo/.arch-ids/types.scm.id + src/guile/skribe/.arch-ids/vars.scm.id + ==> src/guile/skribilo/.arch-ids/vars.scm.id + src/guile/skribe/.arch-ids/verify.scm.id + ==> src/guile/skribilo/.arch-ids/verify.scm.id + src/guile/skribe/.arch-ids/writer.scm.id + ==> src/guile/skribilo/.arch-ids/writer.scm.id + src/guile/skribe/.arch-ids/xml-lex.l.id + ==> src/guile/skribilo/coloring/.arch-ids/xml-lex.l.id + src/guile/skribe/.arch-ids/xml.scm.id + ==> src/guile/skribilo/coloring/.arch-ids/xml.scm.id + src/guile/skribe/c-lex.l + ==> src/guile/skribilo/coloring/c-lex.l + src/guile/skribe/c.scm + ==> src/guile/skribilo/coloring/c.scm + src/guile/skribe/lisp-lex.l + ==> src/guile/skribilo/coloring/lisp-lex.l + src/guile/skribe/lisp.scm + ==> src/guile/skribilo/coloring/lisp.scm + src/guile/skribe/reader.scm + ==> src/guile/skribilo/reader/skribe.scm + src/guile/skribe/xml-lex.l + ==> src/guile/skribilo/coloring/xml-lex.l + src/guile/skribe/xml.scm + ==> src/guile/skribilo/coloring/xml.scm + + new directories: + src/guile/skribilo/.arch-ids src/guile/skribilo/coloring + src/guile/skribilo/coloring/.arch-ids + src/guile/skribilo/reader src/guile/skribilo/reader/.arch-ids + src/guile/skribilo/skribe src/guile/skribilo/skribe/.arch-ids + + removed directories: + src/guile/skribe/.arch-ids + + renamed directories: + src/guile/skribe + ==> src/guile/skribilo + + +2005-06-24 07:29:38 GMT Ludovic Courtes base-0 + + Summary: + tag of lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-5 + Revision: + skribilo--devel--1.2--base-0 + + (automatically generated log message) + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-1 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-2 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-3 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-4 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-5 + + diff --git a/LICENSE b/LICENSE deleted file mode 100644 index dbf912f..0000000 --- a/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ ---------------------------------------------------------------------- - Skribe - - Copyright (c) 2003, 2004 -- Erick Gallesio, Manuel Serrano - - Bug descriptions, use reports, comments or suggestions are - welcome. Send them to - skribe@sophia.inria.fr - http://www.inria.fr/mimosa/fp/Skribe - - 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. ---------------------------------------------------------------------- diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..3920780 --- /dev/null +++ b/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = src doc diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..a8e220f --- /dev/null +++ b/NEWS @@ -0,0 +1 @@ +No news today. diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..a4bc494 --- /dev/null +++ b/configure.ac @@ -0,0 +1,36 @@ +# -*- Autoconf -*- +# Process this file with autoconf to produce a configure script. + +AC_PREREQ(2.59) +AC_INIT(skribilo, 1.2, ludovic.courtes@laas.fr) +AM_INIT_AUTOMAKE(skribilo, 1.2) + +AC_CONFIG_SRCDIR([src/guile/skribilo/reader.scm]) + +# Look for Guile. +GUILE_PROGS +GUILE_SITE_DIR + +# Need guile-reader 0.2. +GUILE_MODULE_REQUIRED([system reader]) + +# Look for Lout. +AC_PATH_PROG([LOUT], [lout], [not-found]) +AM_CONDITIONAL([HAVE_LOUT], [test "x$LOUT" != "xnot-found"]) + +AC_SUBST([SKRIBILO_DOC_DIR], ["$datadir/doc/skribilo"]) +AC_SUBST([SKRIBILO_EXT_DIR], ["$datadir/skribilo/1.2/"]) +AC_SUBST([SKRIBILO_SKR_PATH], ["$GUILE_SITE/"]) + +AC_OUTPUT([Makefile + src/Makefile + src/guile/Makefile + src/guile/skribilo/Makefile + src/guile/skribilo/config.scm + src/guile/skribilo/engine/Makefile + src/guile/skribilo/reader/Makefile + src/guile/skribilo/package/Makefile + src/guile/skribilo/skribe/Makefile + src/guile/skribilo/coloring/Makefile + doc/Makefile + doc/user/Makefile]) diff --git a/doc/Makefile b/doc/Makefile index 934389e..7a177fc 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -1,233 +1,420 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/doc/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Mon Sep 1 10:29:28 2003 */ -#* Last change : Wed Mar 10 11:16:48 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Skribe documentation. */ -#*=====================================================================*/ -include ../etc/Makefile.config -include ../etc/$(SYSTEM)/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compiler and tools */ -#*---------------------------------------------------------------------*/ -BINDIR = ../bin -LIBDIR = ../lib -LATEX = latex -DVIPS = dvips - -SKRIBEVERBOSE = -v1 -SKRIBEWARNING = -w1 -SFLAGS = $(SKRIBEVERBOSE) $(SKRIBEWARNING) \ - -I ../skr \ - -I skr \ - -P img \ - -S .. \ - --custom emit-sui=yes \ - --eval '(define *skribe-bin* "$(SKRIBE)")' \ - --eval '(define *skribebibtex-bin* "$(SKRIBEBIBTEX)")' - -#*---------------------------------------------------------------------*/ -#* Doc skr */ -#*---------------------------------------------------------------------*/ -_SKR = manual.skr env.skr api.skr extension.skr -SKR = $(_SKR:%=skr/%) - -#*---------------------------------------------------------------------*/ -#* Images */ -#*---------------------------------------------------------------------*/ -_IMG = bsd.gif lambda.gif linux.gif -IMG = $(_IMG:%=img/%) - -#*---------------------------------------------------------------------*/ -#* User document */ -#*---------------------------------------------------------------------*/ -_USERMAIN = user.skb -_USEROTHERS = start.skb syntax.skb \ - markup.skb document.skb \ - sectioning.skb toc.skb ornament.skb line.skb font.skb \ - justify.skb enumeration.skb \ - examples.skb colframe.skb figure.skb image.skb table.skb \ - footnote.skb char.skb \ - links.skb index.skb bib.skb prgm.skb \ - engine.skb htmle.skb latexe.skb xmle.skb \ - emacs.skb skribec.skb skribe-config.skb \ - lib.skb slide.skb package.skb -_USERSRC = start1.skb start2.skb start3.skb start4.skb start5.skb \ - api1.skb api2.skb api3.skb api4.skb api5.skb \ - api6.skb api7.skb api8.skb api9.skb api10.skb \ - api11.skb api12.skb api13.skb api14.skb api15.skb \ - api16.skb api17.skb api18.skb api19.skb api20.skb \ - links1.skb links2.skb \ - index1.skb index2.skb index3.skb \ - bib1.sbib bib2.skb bib3.skb bib4.skb bib5.skb bib6.skb \ - prgm1.skb prgm2.skb prgm3.skb slides.skb - -USERMAIN = $(_USERMAIN:%=user/%) -USEROTHERS = $(_USEROTHERS:%=user/%) -USERSRC = $(_USERSRC:%=user/src/%) -USERSKB = $(USERMAIN) $(USEROTHERS) $(USERSRC) - -#*---------------------------------------------------------------------*/ -#* User document */ -#*---------------------------------------------------------------------*/ -_DIRMAIN = dir.skb -_DIROTHERS = -_DIRSRC = - -DIRMAIN = $(_DIRMAIN:%=dir/%) -DIROTHERS = $(_DIROTHERS:%=dir/%) -DIRSRC = $(_DIRSRC:%=dir/src/%) -DIRSKB = $(DIRMAIN) $(DIROTHERS) $(DIRSRC) - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .skb .man .html .sui - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -.PHONY: user dir - -all: user dir -re: re.html re.dir - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo doc/Makefile doc/Makefile.dir - @ echo $(USERSKB:%=doc/%) - @ echo $(DIRSKB:%=doc/%) - @ echo $(SKR:%=doc/%) - @ echo $(IMG:%=doc/%) - -#*---------------------------------------------------------------------*/ -#* user */ -#*---------------------------------------------------------------------*/ -.PHONY: user re.html user.html - -user: user.html user.sui -user.html: html/user.html html/img/lambda.gif html/img/bsd.gif html/img/linux.gif -user.sui: html/user.sui - -user.ps: tex/user.dvi - (cd tex; $(DVIPS) user.dvi -o user.ps) - -user.dvi: tex/user.dvi -tex/user.dvi: tex/user.tex - (cd tex; $(LATEX) user.tex) +# Makefile.in generated by automake 1.9.6 from Makefile.am. +# doc/Makefile. Generated from Makefile.in by configure. + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + + +srcdir = . +top_srcdir = .. + +pkgdatadir = $(datadir)/skribilo +pkglibdir = $(libdir)/skribilo +pkgincludedir = $(includedir)/skribilo +top_builddir = .. +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +INSTALL = /usr/bin/install -c +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +subdir = doc +DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_CLEAN_FILES = +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \ + html-recursive info-recursive install-data-recursive \ + install-exec-recursive install-info-recursive \ + install-recursive installcheck-recursive installdirs-recursive \ + pdf-recursive ps-recursive uninstall-info-recursive \ + uninstall-recursive +ETAGS = etags +CTAGS = ctags +DIST_SUBDIRS = $(SUBDIRS) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = ${SHELL} /home/ludo/src/skribilo/missing --run aclocal-1.9 +AMTAR = ${SHELL} /home/ludo/src/skribilo/missing --run tar +AUTOCONF = ${SHELL} /home/ludo/src/skribilo/missing --run autoconf +AUTOHEADER = ${SHELL} /home/ludo/src/skribilo/missing --run autoheader +AUTOMAKE = ${SHELL} /home/ludo/src/skribilo/missing --run automake-1.9 +AWK = gawk +CYGPATH_W = echo +DEFS = -DPACKAGE_NAME=\"skribilo\" -DPACKAGE_TARNAME=\"skribilo\" -DPACKAGE_VERSION=\"1.2\" -DPACKAGE_STRING=\"skribilo\ 1.2\" -DPACKAGE_BUGREPORT=\"ludovic.courtes@laas.fr\" -DPACKAGE=\"skribilo\" -DVERSION=\"1.2\" +ECHO_C = +ECHO_N = -n +ECHO_T = +GUILE = /usr/bin/guile +GUILE_CONFIG = /usr/bin/guile-config +GUILE_SITE = /usr/share/guile/site +GUILE_TOOLS = /usr/bin/guile-tools +HAVE_LOUT_FALSE = # +HAVE_LOUT_TRUE = +INSTALL_DATA = ${INSTALL} -m 644 +INSTALL_PROGRAM = ${INSTALL} +INSTALL_SCRIPT = ${INSTALL} +INSTALL_STRIP_PROGRAM = ${SHELL} $(install_sh) -c -s +LIBOBJS = +LIBS = +LOUT = /usr/bin/lout +LTLIBOBJS = +MAKEINFO = ${SHELL} /home/ludo/src/skribilo/missing --run makeinfo +PACKAGE = skribilo +PACKAGE_BUGREPORT = ludovic.courtes@laas.fr +PACKAGE_NAME = skribilo +PACKAGE_STRING = skribilo 1.2 +PACKAGE_TARNAME = skribilo +PACKAGE_VERSION = 1.2 +PATH_SEPARATOR = : +SET_MAKE = +SHELL = /bin/sh +SKRIBILO_DOC_DIR = ${prefix}/share/doc/skribilo +SKRIBILO_EXT_DIR = ${prefix}/share/skribilo/1.2/ +SKRIBILO_SKR_PATH = /usr/share/guile/site/ +STRIP = +VERSION = 1.2 +ac_ct_STRIP = +am__leading_dot = . +am__tar = ${AMTAR} chof - "$$tardir" +am__untar = ${AMTAR} xf - +bindir = ${exec_prefix}/bin +build_alias = +datadir = ${prefix}/share +exec_prefix = ${prefix} +host_alias = +includedir = ${prefix}/include +infodir = ${prefix}/info +install_sh = /home/ludo/src/skribilo/install-sh +libdir = ${exec_prefix}/lib +libexecdir = ${exec_prefix}/libexec +localstatedir = ${prefix}/var +mandir = ${prefix}/man +mkdir_p = mkdir -p -- +oldincludedir = /usr/include +prefix = /usr/local +program_transform_name = s,x,x, +sbindir = ${exec_prefix}/sbin +sharedstatedir = ${prefix}/com +sysconfdir = ${prefix}/etc +target_alias = +SUBDIRS = user +all: all-recursive -html/user.html html/user.sui: html $(USERSKB) $(SKR) - $(MAKE) re.html - -tex/user.tex: tex $(USERSKB) $(SKR) tex/img/lambda.eps tex/img/bsd.eps tex/img/linux.eps - $(MAKE) re.tex - -# gif -html/img/lambda.gif: html/img img/lambda.gif - cp img/lambda.gif html/img/lambda.gif - -html/img/linux.gif: html/img img/linux.gif - cp img/linux.gif html/img/linux.gif - -html/img/bsd.gif: html/img img/bsd.gif - cp img/bsd.gif html/img/bsd.gif - -# eps image -tex/img/lambda.eps: tex/img img/lambda.gif - convert img/lambda.gif tex/img/lambda.eps - -tex/img/linux.eps: tex/img img/linux.gif - convert img/linux.gif tex/img/linux.eps - -tex/img/bsd.eps: tex/img img/bsd.gif - convert img/bsd.gif tex/img/bsd.eps - -re.html: - $(SKRIBE) $(SFLAGS) $(USERMAIN) \ - --base html -I user -S user \ - -o html/user.html - -re.tex: - $(SKRIBE) $(SFLAGS) $(USERMAIN) \ - --base tex -I user -S user \ - -o tex/user.tex - -#*---------------------------------------------------------------------*/ -#* dir */ -#*---------------------------------------------------------------------*/ -.PHONY: dir re.dir dir.html - -dir: dir.html -dir.html: html/dir.html - -html/dir.html: html $(DIRSKB) $(SKR) - $(MAKE) re.dir - -re.dir: - $(MAKE) -f Makefile.dir SKRIBE="$(SKRIBE)" BASE=html - -#*---------------------------------------------------------------------*/ -#* Misc */ -#*---------------------------------------------------------------------*/ -html: - mkdir -p html - -html/img: - mkdir -p html/img - -tex: - mkdir -p tex - -tex/img: - mkdir -p tex/img - -gethtml: - @ echo "html/user.html" - -#*---------------------------------------------------------------------*/ -#* install/uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: $(DESTDIR)$(INSTALL_DOCDIR) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr - cp -r html/* $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/* \ - && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR)/img - cp -r skr/* $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc \ - && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr/* - cp Makefile.dir $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/Makefile.dir - cp dir/dir.skb $(DESTDIR)$(INSTALL_DOCDIR) \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/dir.skb - -uninstall: - $(RM) -rf $(DESTDIR)$(INSTALL_DOCDIR) - -$(DESTDIR)$(INSTALL_DOCDIR): - mkdir -p $(DESTDIR)$(INSTALL_DOCDIR) && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR) - - -$(DESTDIR)$(INSTALL_SKRDIR)/doc/skr: - mkdir -p $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ - && chmod -R a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean +.SUFFIXES: +$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu doc/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --gnu doc/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; + +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh + +$(top_srcdir)/configure: $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +uninstall-info-am: + +# This directory's subdirectories are mostly independent; you can cd +# into them and run `make' without going through this Makefile. +# To change the values of `make' variables: instead of editing Makefiles, +# (1) if the variable is set in `config.status', edit `config.status' +# (which will cause the Makefiles to be regenerated when you run `make'); +# (2) otherwise, pass the desired values on the `make' command line. +$(RECURSIVE_TARGETS): + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" + +mostlyclean-recursive clean-recursive distclean-recursive \ +maintainer-clean-recursive: + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + rev=''; for subdir in $$list; do \ + if test "$$subdir" = "."; then :; else \ + rev="$$subdir $$rev"; \ + fi; \ + done; \ + rev="$$rev ."; \ + target=`echo $@ | sed s/-recursive//`; \ + for subdir in $$rev; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done && test -z "$$fail" +tags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \ + done +ctags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \ + done + +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + mkid -fID $$unique +tags: TAGS + +TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + tags="$$tags $$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$tags $$unique; \ + fi +ctags: CTAGS +CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + test -z "$(CTAGS_ARGS)$$tags$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$tags $$unique + +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && cd $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) $$here + +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags + +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ + list='$(DISTFILES)'; for file in $$list; do \ + case $$file in \ + $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ + $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \ + esac; \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test "$$dir" != "$$file" && test "$$dir" != "."; then \ + dir="/$$dir"; \ + $(mkdir_p) "$(distdir)$$dir"; \ + else \ + dir=''; \ + fi; \ + if test -d $$d/$$file; then \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done + list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test -d "$(distdir)/$$subdir" \ + || $(mkdir_p) "$(distdir)/$$subdir" \ + || exit 1; \ + distdir=`$(am__cd) $(distdir) && pwd`; \ + top_distdir=`$(am__cd) $(top_distdir) && pwd`; \ + (cd $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$top_distdir" \ + distdir="$$distdir/$$subdir" \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +all-am: Makefile +installdirs: installdirs-recursive +installdirs-am: +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive + +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am + +installcheck: installcheck-recursive +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: + +clean-generic: + +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) + +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive + +clean-am: clean-generic mostlyclean-am + +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags + +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +info: info-recursive + +info-am: + +install-data-am: + +install-exec-am: + +install-info: install-info-recursive + +install-man: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive + +ps-am: + +uninstall-am: uninstall-info-am + +uninstall-info: uninstall-info-recursive + +.PHONY: $(RECURSIVE_TARGETS) CTAGS GTAGS all all-am check check-am \ + clean clean-generic clean-recursive ctags ctags-recursive \ + distclean distclean-generic distclean-recursive distclean-tags \ + distdir dvi dvi-am html html-am info info-am install \ + install-am install-data install-data-am install-exec \ + install-exec-am install-info install-info-am install-man \ + install-strip installcheck installcheck-am installdirs \ + installdirs-am maintainer-clean maintainer-clean-generic \ + maintainer-clean-recursive mostlyclean mostlyclean-generic \ + mostlyclean-recursive pdf pdf-am ps ps-am tags tags-recursive \ + uninstall uninstall-am uninstall-info-am -clean: - $(RM) -rf html - $(RM) -rf tex - $(RM) -f img/bsd.eps img/linux.eps +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/doc/Makefile.am b/doc/Makefile.am new file mode 100644 index 0000000..1b8257b --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = user diff --git a/doc/user/Makefile.am b/doc/user/Makefile.am new file mode 100644 index 0000000..33d16ce --- /dev/null +++ b/doc/user/Makefile.am @@ -0,0 +1,22 @@ +BUILT_SOURCES = user.html + +skribilo = $(top_srcdir)/src/guile/skribilo.scm +load_path = $(top_srcdir)/src/guile:$(top_srcdir)/src/guile/skribilo/package + +%.html: %.skb + GUILE_LOAD_PATH=$(load_path) \ + $(skribilo) --target html -I ../ -o $@ $< + +if HAVE_LOUT + +BUILT_SOURCES += user.ps + +%.lout: %.skb + GUILE_LOAD_PATH=$(load_path) \ + $(skribilo) --target lout -I ../ -o $@ $< + +%.ps: %.lout + $(LOUT) -c $(<:%.lout=%) -o $@ $< + +endif + diff --git a/doc/user/start.skb b/doc/user/start.skb index f3c1e28..d437b3a 100644 --- a/doc/user/start.skb +++ b/doc/user/start.skb @@ -14,13 +14,12 @@ ;*---------------------------------------------------------------------*/ (chapter :title "Getting Started" -(p [ -In this chapter, the syntax of a Skribe text is presented ,(emph "informally"). -In particular, the Skribe syntax is compared to the HTML syntax. Then, -it is presented how one can use Skribe to make dynamic text -(i.e texts which are generated by the system rather than entered-in by hand. -Finally, It is also -presented how Skribe source files can be processed.]) +(p [ In this chapter, the syntax of a Skribe text is presented ,(emph +"informally"). In particular, the Skribe syntax is compared to the HTML +syntax. Then, it is presented how one can use Skribe to make dynamic +text (i.e texts which are generated by the system rather than entered-in +by hand). Finally, It is also presented how Skribe source files can be +processed.]) ;*--- Hello world -----------------------------------------------------*/ (section :title "Hello World!" [ diff --git a/doc/user/user.skb b/doc/user/user.skb index 334dd5c..d5ed06b 100644 --- a/doc/user/user.skb +++ b/doc/user/user.skb @@ -36,7 +36,7 @@ ;*---------------------------------------------------------------------*/ ;* The document */ ;*---------------------------------------------------------------------*/ -(document :title "Skribe User Manual" +(document :title "Skribilo User Manual" :env '((example-counter 0) (example-env ())) :author (list (author :name "Erick Gallesio" :affiliation "Université de Nice - Sophia Antipolis" diff --git a/src/Makefile.am b/src/Makefile.am new file mode 100644 index 0000000..1d3db1f --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = guile diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..afe4667 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,4 @@ +SUBDIRS = skribilo + +bin_SCRIPTS = skribilo.scm +EXTRA_DIST = README diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am new file mode 100644 index 0000000..c86f2f3 --- /dev/null +++ b/src/guile/skribilo/Makefile.am @@ -0,0 +1,9 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm + +SUBDIRS = reader engine package skribe coloring diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in index 80a26de..add7d0e 100644 --- a/src/guile/skribilo/Makefile.in +++ b/src/guile/skribilo/Makefile.in @@ -1,110 +1,463 @@ -# -# Makefile.in -- Skribe Src Makefile -# -# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -# -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# +# Makefile.in generated by automake 1.9.6 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + # This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 10-Aug-2003 20:26 (eg) -# Last file update: 6-Mar-2004 16:00 (eg) -# -include ../../etc/stklos/Makefile.skb +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. -prefix=@PREFIX@ +@SET_MAKE@ -SKR = $(wildcard ../../skr/*.skr) +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +top_builddir = ../../.. +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +INSTALL = @INSTALL@ +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +subdir = src/guile/skribilo +DIST_COMMON = $(dist_guilemodule_DATA) $(srcdir)/Makefile.am \ + $(srcdir)/Makefile.in $(srcdir)/config.scm.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_CLEAN_FILES = config.scm +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \ + html-recursive info-recursive install-data-recursive \ + install-exec-recursive install-info-recursive \ + install-recursive installcheck-recursive installdirs-recursive \ + pdf-recursive ps-recursive uninstall-info-recursive \ + uninstall-recursive +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; +am__installdirs = "$(DESTDIR)$(guilemoduledir)" +dist_guilemoduleDATA_INSTALL = $(INSTALL_DATA) +DATA = $(dist_guilemodule_DATA) +ETAGS = etags +CTAGS = ctags +DIST_SUBDIRS = $(SUBDIRS) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +GUILE = @GUILE@ +GUILE_CONFIG = @GUILE_CONFIG@ +GUILE_SITE = @GUILE_SITE@ +GUILE_TOOLS = @GUILE_TOOLS@ +HAVE_LOUT_FALSE = @HAVE_LOUT_FALSE@ +HAVE_LOUT_TRUE = @HAVE_LOUT_TRUE@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LOUT = @LOUT@ +LTLIBOBJS = @LTLIBOBJS@ +MAKEINFO = @MAKEINFO@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +SKRIBILO_DOC_DIR = @SKRIBILO_DOC_DIR@ +SKRIBILO_EXT_DIR = @SKRIBILO_EXT_DIR@ +SKRIBILO_SKR_PATH = @SKRIBILO_SKR_PATH@ +STRIP = @STRIP@ +VERSION = @VERSION@ +ac_ct_STRIP = @ac_ct_STRIP@ +am__leading_dot = @am__leading_dot@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build_alias = @build_alias@ +datadir = @datadir@ +exec_prefix = @exec_prefix@ +host_alias = @host_alias@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm -DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ - ../common/index.scm ../common/bib.scm ../common/lib.scm +SUBDIRS = reader engine package skribe coloring +all: all-recursive -SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ - eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ - resolve.stk runtime.stk source.stk types.stk vars.stk \ - verify.stk writer.stk xml.stk +.SUFFIXES: +$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/guile/skribilo/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --gnu src/guile/skribilo/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; -LEXFILES = c-lex.l lisp-lex.l xml-lex.l +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk +$(top_srcdir)/configure: $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +config.scm: $(top_builddir)/config.status $(srcdir)/config.scm.in + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ +uninstall-info-am: +install-dist_guilemoduleDATA: $(dist_guilemodule_DATA) + @$(NORMAL_INSTALL) + test -z "$(guilemoduledir)" || $(mkdir_p) "$(DESTDIR)$(guilemoduledir)" + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(dist_guilemoduleDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + $(dist_guilemoduleDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -BINDIR=../../bin +uninstall-dist_guilemoduleDATA: + @$(NORMAL_UNINSTALL) + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + rm -f "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -EXE= $(BINDIR)/skribe.stklos +# This directory's subdirectories are mostly independent; you can cd +# into them and run `make' without going through this Makefile. +# To change the values of `make' variables: instead of editing Makefiles, +# (1) if the variable is set in `config.status', edit `config.status' +# (which will cause the Makefiles to be regenerated when you run `make'); +# (2) otherwise, pass the desired values on the `make' command line. +$(RECURSIVE_TARGETS): + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" -PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) +mostlyclean-recursive clean-recursive distclean-recursive \ +maintainer-clean-recursive: + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + rev=''; for subdir in $$list; do \ + if test "$$subdir" = "."; then :; else \ + rev="$$subdir $$rev"; \ + fi; \ + done; \ + rev="$$rev ."; \ + target=`echo $@ | sed s/-recursive//`; \ + for subdir in $$rev; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done && test -z "$$fail" +tags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \ + done +ctags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \ + done -SFLAGS= +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + mkid -fID $$unique +tags: TAGS -all: $(EXE) +TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + tags="$$tags $$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$tags $$unique; \ + fi +ctags: CTAGS +CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + test -z "$(CTAGS_ARGS)$$tags$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$tags $$unique -Makefile: Makefile.in - (cd ../../etc/stklos; autoconf; configure) +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && cd $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) $$here -$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) - stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ - chmod $(BMASK) $(EXE) +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -# -# Lex files -# -lisp-lex.stk: lisp-lex.l - stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ + list='$(DISTFILES)'; for file in $$list; do \ + case $$file in \ + $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ + $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \ + esac; \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test "$$dir" != "$$file" && test "$$dir" != "."; then \ + dir="/$$dir"; \ + $(mkdir_p) "$(distdir)$$dir"; \ + else \ + dir=''; \ + fi; \ + if test -d $$d/$$file; then \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done + list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test -d "$(distdir)/$$subdir" \ + || $(mkdir_p) "$(distdir)/$$subdir" \ + || exit 1; \ + distdir=`$(am__cd) $(distdir) && pwd`; \ + top_distdir=`$(am__cd) $(top_distdir) && pwd`; \ + (cd $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$top_distdir" \ + distdir="$$distdir/$$subdir" \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +all-am: Makefile $(DATA) +installdirs: installdirs-recursive +installdirs-am: + for dir in "$(DESTDIR)$(guilemoduledir)"; do \ + test -z "$$dir" || $(mkdir_p) "$$dir"; \ + done +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive -xml-lex.stk: xml-lex.l - stklos-genlex xml-lex.l xml-lex.stk xml-lex +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am -c-lex.stk: c-lex.l - stklos-genlex c-lex.l c-lex.stk c-lex +installcheck: installcheck-recursive +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: +clean-generic: -install: $(INSTALL_BINDIR) - cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ - && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos - rm -f $(INSTALL_BINDIR)/skribe - ln -s skribe.stklos $(INSTALL_BINDIR)/skribe +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -uninstall: - rm $(INSTALL_BINDIR)/skribe - rm $(INSTALL_BINDIR)/skribe.stklos +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive -$(BINDIR): - mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) +clean-am: clean-generic mostlyclean-am -$(INSTALL_BINDIR): - mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags -## -## Services -## -tags: TAGS +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +info: info-recursive + +info-am: + +install-data-am: install-dist_guilemoduleDATA + +install-exec-am: + +install-info: install-info-recursive + +install-man: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive -TAGS: $(SRCS) - etags -l scheme $(SRCS) +ps-am: -pop: - @echo $(PRCS_FILES:%=src/stklos/%) +uninstall-am: uninstall-dist_guilemoduleDATA uninstall-info-am -links: - ln -s $(DEPS) . - ln -s $(SKR) . +uninstall-info: uninstall-info-recursive -clean: - /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr +.PHONY: $(RECURSIVE_TARGETS) CTAGS GTAGS all all-am check check-am \ + clean clean-generic clean-recursive ctags ctags-recursive \ + distclean distclean-generic distclean-recursive distclean-tags \ + distdir dvi dvi-am html html-am info info-am install \ + install-am install-data install-data-am \ + install-dist_guilemoduleDATA install-exec install-exec-am \ + install-info install-info-am install-man install-strip \ + installcheck installcheck-am installdirs installdirs-am \ + maintainer-clean maintainer-clean-generic \ + maintainer-clean-recursive mostlyclean mostlyclean-generic \ + mostlyclean-recursive pdf pdf-am ps ps-am tags tags-recursive \ + uninstall uninstall-am uninstall-dist_guilemoduleDATA \ + uninstall-info-am -distclean: clean - /bin/rm -f Makefile - /bin/rm -f ../common/configure.scm +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am new file mode 100644 index 0000000..d518553 --- /dev/null +++ b/src/guile/skribilo/coloring/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = c.scm lisp.scm xml.scm diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in index a5e3b7c..51e7a93 100644 --- a/src/guile/skribilo/config.scm.in +++ b/src/guile/skribilo/config.scm.in @@ -3,7 +3,7 @@ (define-module (skribilo config)) -(define-public (skribilo-release) "1.3") +(define-public (skribilo-release) "1.2") (define-public (skribilo-url) "http://www.laas.fr/~lcourtes/") (define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") (define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am new file mode 100644 index 0000000..7b6ec2c --- /dev/null +++ b/src/guile/skribilo/engine/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/engine +dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \ + latex-simple.scm latex.scm \ + lout.scm \ + xml.scm diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index 3ad7da6..6e0dc85 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -82,7 +82,7 @@ ;*---------------------------------------------------------------------*/ ;* html-engine ... */ ;*---------------------------------------------------------------------*/ -(define html-engine +(define-public html-engine ;; setup the html engine (default-engine-set! (make-engine 'html diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm index 8bd0ae3..2a59b4f 100644 --- a/src/guile/skribilo/engine/latex.scm +++ b/src/guile/skribilo/engine/latex.scm @@ -16,6 +16,8 @@ ;* @ref ../../doc/user/latexe.skb:ref@ */ ;*=====================================================================*/ +(define-skribe-module (skribilo engine latex)) + ;*---------------------------------------------------------------------*/ ;* latex-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 616144d..974d72a 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -39,8 +39,11 @@ (skribilo types) (skribilo lib) (skribilo vars) + (ice-9 optargs) - (oop goops)) + (oop goops) + (srfi srfi-13) + (srfi srfi-1)) @@ -49,6 +52,9 @@ (define *skribe-loaded* '()) ;; List of already loaded files (define *skribe-load-options* '()) +;;; +;;; %EVALUATE +;;; (define (%evaluate expr) (let ((result (eval expr (current-module)))) (if (or (ast? result) (markup? result)) @@ -84,6 +90,8 @@ (reader %default-reader)) (with-debug 2 'skribe-eval-port (debug-item "engine=" engine) + (debug-item "reader=" reader) + (let ((e (if (symbol? engine) (find-engine engine) engine))) (debug-item "e=" e) (if (not (is-a? e )) @@ -114,22 +122,31 @@ ((engine? engine) engine) ((not (symbol? engine)) (skribe-error 'skribe-load - "Illegal engine" engine)) + "illegal engine" engine)) (else engine))) - (path (cond - ((not path) (skribe-path)) - ((string? path) (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else path))) - (filep (search-path path file))) + (path (append (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "illegal path" path)) + (else path)) + %load-path)) + (filep (or (search-path path file) + (search-path (append path %load-path) file) + (search-path (append path %load-path) + (let ((dot (string-rindex file #\.))) + (if dot + (string-append + (string-take file dot) + ".scm") + file)))))) (set! *skribe-load-options* opt) (unless (and (string? filep) (file-exists? filep)) (skribe-error 'skribe-load (string-append "cannot find `" file "' in path") - (skribe-path))) + path)) ;; Load this file if not already done (unless (member filep *skribe-loaded*) @@ -149,22 +166,25 @@ ;;; (define* (skribe-include file #:optional (path (skribe-path))) (unless (every string? path) - (skribe-error 'skribe-include "Illegal path" path)) + (skribe-error 'skribe-include "illegal path" path)) (let ((path (search-path path file))) (unless (and (string? path) (file-exists? path)) (skribe-error 'skribe-load - (format "Cannot find ~S in path" file) + (format #t "cannot find ~S in path" file) path)) (when (> *skribe-verbose* 0) (format (current-error-port) " [including file: ~S]\n" path)) (with-input-from-file path (lambda () - (let Loop ((exp (read (current-input-port))) + (let Loop ((exp (%default-reader (current-input-port))) (res '())) + (format (current-error-port) "exp=~a~%" exp) (if (eof-object? exp) - (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (Loop (read (current-input-port)) + (begin + (format (current-error-port) "include: eof reached~%") + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res))) + (Loop (%default-reader (current-input-port)) (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index 8667f7e..d916db4 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -99,12 +99,23 @@ (let loop ((args args) (result '()) (rest-arg #f)) - (if (null? args) - (if rest-arg (append (reverse result) rest-arg) (reverse result)) - (let ((is-rest-arg? (eq? (car args) #:rest))) - (loop (if is-rest-arg? (cddr args) (cdr args)) - (if is-rest-arg? result (cons (car args) result)) - (if is-rest-arg? (list (car args) (cadr args)) rest-arg)))))) + (cond ((null? args) + (if rest-arg + (append (reverse result) rest-arg) + (reverse result))) + + ((list? args) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? + (list (car args) (cadr args)) + rest-arg)))) + + ((pair? args) + (loop '() + (cons (car args) result) + (list #:rest (cdr args))))))) (let ((name (car bindings)) (opts (cdr bindings))) diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am new file mode 100644 index 0000000..6e047d3 --- /dev/null +++ b/src/guile/skribilo/package/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package +dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ + lncs.scm scribe.scm sigplan.scm skribe.scm \ + slide.scm web-article.scm web-book.scm diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/src/guile/skribilo/package/acmproc.scm @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/acmproc.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[letterpaper]{acmproc}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\numberofauthors{~a}\n\\author{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "\\alignauthor\n") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\CopyrightYear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\crdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key (class "abstract") postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :class class :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/french.scm b/src/guile/skribilo/package/french.scm new file mode 100644 index 0000000..bd095db --- /dev/null +++ b/src/guile/skribilo/package/french.scm @@ -0,0 +1,21 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* French Skribe style */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package french)) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/src/guile/skribilo/package/jfp.scm b/src/guile/skribilo/package/jfp.scm new file mode 100644 index 0000000..108b938 --- /dev/null +++ b/src/guile/skribilo/package/jfp.scm @@ -0,0 +1,319 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/jfp.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for JFP articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package jfp)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/src/guile/skribilo/package/letter.scm b/src/guile/skribilo/package/letter.scm new file mode 100644 index 0000000..1c39301 --- /dev/null +++ b/src/guile/skribilo/package/letter.scm @@ -0,0 +1,148 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for letters */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package letter)) + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (display "\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "
") + (output n e) + (when hd + (display "") + (output hd e) + (set! hd #f)) + (display "
\n
\n\n")) + + diff --git a/src/guile/skribilo/package/lncs.scm b/src/guile/skribilo/package/lncs.scm new file mode 100644 index 0000000..2f027d0 --- /dev/null +++ b/src/guile/skribilo/package/lncs.scm @@ -0,0 +1,149 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/lncs.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for LNCS articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package lncs)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm new file mode 100644 index 0000000..8e99c76 --- /dev/null +++ b/src/guile/skribilo/package/scribe.scm @@ -0,0 +1,231 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/scribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 29 10:07:21 2003 */ +;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Scribe Compatibility kit */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package scribe)) + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/package/sigplan.scm b/src/guile/skribilo/package/sigplan.scm new file mode 100644 index 0000000..b5269dc --- /dev/null +++ b/src/guile/skribilo/package/sigplan.scm @@ -0,0 +1,157 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/sigplan.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Wed May 18 16:00:38 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package sigplan)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/skribe.scm b/src/guile/skribilo/package/skribe.scm new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/src/guile/skribilo/package/skribe.scm @@ -0,0 +1,76 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/skribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 11 11:23:12 2002 */ +;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The standard Skribe style (always loaded). */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm new file mode 100644 index 0000000..37ee054 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,667 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package slide)) + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "
\n" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "
") + (output title e) + (display ""))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "
")) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* html */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (skribe-message "HTML slides setup...\n") + ;; &html-page-title + (markup-writer '&html-document-title he + :predicate (lambda (n e) %slide-initialized) + :action html-slide-title) + ;; slide + (markup-writer 'slide he + :options '(:title :number :transition :toc :bg) + :before (lambda (n e) + (printf "
" (markup-ident n)) + (display "
\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "
") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "
")))) + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm new file mode 100644 index 0000000..6a480be --- /dev/null +++ b/src/guile/skribilo/package/web-article.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-article.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jan 10 09:09:43 2004 */ +;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* A Skribe style for producing web articles */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-article)) + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "
\n" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "
" tbg) + (display "")) + (if (string? tfg) + (printf "" tfg)) + (if title + (begin + (display "
") + (if (string? tfont) + (begin + (printf "" tfont) + (output title e) + (display "")) + (begin + (printf "

") + (output title e) + (display "

"))) + (display "
\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "
")) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-document-title ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-document-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (id (markup-ident n))) + ;; the title + (printf "
\n" + (string-canonicalize id)) + (output title e) + (display "
\n") + ;; the authors + (printf "
\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "
\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-author ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-author n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (when name + (printf "" + (string-canonicalize (markup-ident n))) + (output name e) + (display "\n")) + (when title + (printf "" + (string-canonicalize (markup-ident n))) + (output title e) + (display "\n")) + (when affiliation + (printf "" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "\n")) + (when (pair? address) + (printf "" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "\n")) + (when phone + (printf "" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "\n")) + (when email + (printf "" + (string-canonicalize (markup-ident n))) + (output email e) + (display "\n")) + (when url + (printf "" + (string-canonicalize (markup-ident n))) + (output url e) + (display "\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML settings */ +;*---------------------------------------------------------------------*/ +(define (web-article-modern-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :action html-document-title-web) + ;; section + (markup-writer 'section he + :options 'all + :before "
" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background))) + (markup-writer 'section e1 + :options 'all + :action (lambda (n e2) (output n e sec))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg n)) + e1)))) + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before "
" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background)) + (fg (engine-custom he 'subsection-title-foreground))) + (markup-writer '&html-footnotes e1 + :options 'all + :action (lambda (n e2) + (invoke (writer-action ft) n e))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg :fg fg n)) + e1)))))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-setup ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :before (lambda (n e) + (printf "
\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "
\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "
" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "
\n"))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &web-article-load-options) + (p (memq :style opt)) + (css (memq :css opt)) + (he (find-engine 'html))) + (cond + ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) + (web-article-css-setup he)) + ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) + (engine-custom-set! he 'css (cadr css)) + (web-article-css-setup he)) + (else + (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm new file mode 100644 index 0000000..a954c7a --- /dev/null +++ b/src/guile/skribilo/package/web-book.scm @@ -0,0 +1,109 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-book.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:54:32 2003 */ +;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe web book style. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-book)) + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold "main page")))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (markup-option n :title))))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (if chap "Chapters" "Sections"))))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/src/guile/skribilo/packages/acmproc.scm b/src/guile/skribilo/packages/acmproc.scm deleted file mode 100644 index 4accc7c..0000000 --- a/src/guile/skribilo/packages/acmproc.scm +++ /dev/null @@ -1,155 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/acmproc.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[letterpaper]{acmproc}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\numberofauthors{~a}\n\\author{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "\\alignauthor\n") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\CopyrightYear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\crdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key (class "abstract") postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :class class :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/french.scm b/src/guile/skribilo/packages/french.scm deleted file mode 100644 index 3e454f5..0000000 --- a/src/guile/skribilo/packages/french.scm +++ /dev/null @@ -1,21 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* French Skribe style */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages french)) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'usepackage - (string-append (engine-custom le 'usepackage) - "\\usepackage[french]{babel} -\\usepackage{a4}"))) diff --git a/src/guile/skribilo/packages/jfp.scm b/src/guile/skribilo/packages/jfp.scm deleted file mode 100644 index e34a4fe..0000000 --- a/src/guile/skribilo/packages/jfp.scm +++ /dev/null @@ -1,319 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/jfp.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for JFP articles. */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages jfp)) - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{jfp}") - (engine-custom-set! le 'hyperref #f) - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-subauthor) - (let* ((d (ast-document n)) - (sa (and (is-markup? d 'document) - (markup-option d :head-author)))) - (if sa - (begin - (display "[") - (output sa e) - (display "]"))))) - (define (&latex-author-1 n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author") - (&latex-subauthor) - (display "{\n") - (output (car n) e) - (for-each (lambda (a) - (display "\\and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (&latex-author-1 body)) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (&latex-author-n body)) - (else - (skribe-error 'author - "Illegal `jfp' author" - body)))))) - ;; title - (markup-writer '&latex-title le - :before (lambda (n e) - (let* ((d (ast-document n)) - (st (and (is-markup? d 'document) - (markup-option d :head-title)))) - (if st - (begin - (display "\\title[") - (output st e) - (display "]{")) - (display "\\title{")))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (aff (markup-option n :affiliation)) - (addr (markup-option n :address)) - (email (markup-option n :email))) - (if name - (begin - (output name e) - (display "\\\\\n"))) - (if aff - (begin - (output aff e) - (display "\\\\\n"))) - (if addr - (begin - (if (pair? addr) - (for-each (lambda (a) - (output a e) - (display "\\\\\n")) - addr) - (begin - (output addr e) - (display "\\\\\n"))))) - (if email - (begin - (display "\\email{") - (output email e) - (display "}\\\\\n"))))))) - ;; bib-ref - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :before "(" - :action (lambda (n e) - (let ((be (handle-ast (markup-body n)))) - (if (is-markup? be '&bib-entry) - (let ((a (markup-option be 'author)) - (y (markup-option be 'year))) - (cond - ((and (is-markup? a '&bib-entry-author) - (is-markup? y '&bib-entry-year)) - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e) - (display ", ") - (output y e))))) - ((is-markup? y '&bib-entry-year) - (skribe-error 'bib-ref - "Missing `name' entry" - (markup-ident be))) - (else - (let ((ba (markup-body a))) - (if (not (string? ba)) - (output ba e) - (let* ((s1 (pregexp-replace* " and " - ba - " \\& ")) - (s2 (pregexp-replace* ", [^ ]+" - s1 - ""))) - (output s2 e))))))) - (skribe-error 'bib-ref - "Illegal bib-ref" - (markup-ident be))))) - :after ")") - ;; bib-ref/text - (markup-writer 'bib-ref le - :options '(:bib :text :key) - :predicate (lambda (n e) - (markup-option n :key)) - :action (lambda (n e) - (output (markup-option n :key) e))) - ;; &the-bibliography - (markup-writer '&the-bibliography le - :before (lambda (n e) - (display "{% -\\sloppy -\\sfcode`\\.=1000\\relax -\\newdimen\\bibindent -\\bibindent=0em -\\begin{list}{}{% - \\settowidth\\labelwidth{[]}% - \\leftmargin\\labelwidth - \\advance\\leftmargin\\labelsep - \\advance\\leftmargin\\bibindent - \\itemindent -\\bibindent - \\listparindent \\itemindent - }%\n")) - :after (lambda (n e) - (display "\n\\end{list}}\n"))) - ;; bib-entry - (markup-writer '&bib-entry le - :options '(:title) - :action (lambda (n e) - (output n e (markup-writer-get '&bib-entry-body e))) - :after "\n") - ;; %bib-entry-title - (markup-writer '&bib-entry-title le - :action (lambda (n e) - (output (markup-body n) e))) - ;; %bib-entry-body - (markup-writer '&bib-entry-body le - :action (lambda (n e) - (define (output-fields descr) - (display "\\item[") - (let loop ((descr descr) - (pending #f) - (armed #f) - (first #t)) - (cond - ((null? descr) - 'done) - ((pair? (car descr)) - (if (eq? (caar descr) 'or) - (let ((o1 (cadr (car descr)))) - (if (markup-option n o1) - (loop (cons o1 (cdr descr)) - pending - #t - #f) - (let ((o2 (caddr (car descr)))) - (loop (cons o2 (cdr descr)) - pending - armed - #f)))) - (let ((o (markup-option n (cadr (car descr))))) - (if o - (begin - (if (and pending armed) - (output pending e)) - (output (caar descr) e) - (output o e) - (if (pair? (cddr (car descr))) - (output (caddr (car descr)) e)) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f))))) - ((symbol? (car descr)) - (let ((o (markup-option n (car descr)))) - (if o - (begin - (if (and armed pending) - (output pending e)) - (output o e) - (if first - (display "]")) - (loop (cdr descr) #f #t #f)) - (loop (cdr descr) pending armed #f)))) - ((null? (cdr descr)) - (output (car descr) e)) - ((string? (car descr)) - (loop (cdr descr) - (if pending pending (car descr)) - armed - #f)) - (else - (skribe-error 'output-bib-fields - "Illegal description" - (car descr)))))) - (output-fields - (case (markup-option n 'kind) - ((techreport) - `(author (" (" year ")") " " (or title url) ". " - number ", " institution ", " - address ", " month ", " - ("pp. " pages) ".")) - ((article) - `(author (" (" year ")") " " (or title url) ". " - journal ", " volume ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((inproceedings) - `(author (" (" year ")") " " (or title url) ". " - book(or title url) ", " series ", " ("(" number ")") ", " - address ", " month ", " - ("pp. " pages) ".")) - ((book) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")) - ((phdthesis) - '(author (" (" year ")") " " (or title url) ". " type ", " - school ", " address - ", " month ".")) - ((misc) - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ".")) - (else - '(author (" (" year ")") " " (or title url) ". " - publisher ", " address - ", " month ", " ("pp. " pages) ".")))))) - ;; abstract - (markup-writer 'jfp-abstract le - :options '(postscript) - :before "\\begin{abstract}\n" - :after "\\end{abstract}\n")) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-jfp-abstract he - :action (lambda (n e) - (let* ((bg (engine-custom e 'abstract-background)) - (exp (p (if bg - (center (color :bg bg :width 90. - (it (markup-body n)))) - (it (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (new markup - (markup 'jfp-abstract) - (body (p (the-body opt)))) - (let ((a (new markup - (markup '&html-jfp-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (section :title "References" :class "references" - :number (not (engine-format? "latex")) - (font :size -1 (the-bibliography))))) - diff --git a/src/guile/skribilo/packages/letter.scm b/src/guile/skribilo/packages/letter.scm deleted file mode 100644 index 565a1eb..0000000 --- a/src/guile/skribilo/packages/letter.scm +++ /dev/null @@ -1,148 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/letter.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for letters */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages letter)) - -;*---------------------------------------------------------------------*/ -;* document */ -;*---------------------------------------------------------------------*/ -(define %letter-document document) - -(define-markup (document #!rest opt - #!key (ident #f) (class "letter") - where date author - &skribe-eval-location) - (let* ((ubody (the-body opt)) - (body (list (new markup - (markup '&letter-where) - (loc &skribe-eval-location) - (options `((:where ,where) - (:date ,date) - (:author ,author)))) - ubody))) - (apply %letter-document - :author #f :title #f - (append (apply append - (the-options opt :where :date :author :title)) - body)))) - -;*---------------------------------------------------------------------*/ -;* LaTeX configuration */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") - (engine-custom-set! le 'maketitle #f) - ;; &letter-where - (markup-writer '&letter-where le - :before "\\begin{raggedright}\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (output n e) - (when hd - (display "\\hfill ") - (output hd e) - (set! hd #f)) - (display "\\\\\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) - -;*---------------------------------------------------------------------*/ -;* HTML configuration */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - ;; &letter-where - (markup-writer '&letter-where he - :before "\n" - :action (lambda (n e) - (let* ((w (markup-option n :where)) - (d (markup-option n :date)) - (a (markup-option n :author)) - (hd (if (and w d) - (list w ", " d) - (or w d))) - (ne (copy-engine 'author e))) - ;; author - (markup-writer 'author ne - :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone))) - (define (row n) - (display "\n")) - ;; name - (if name (row name)) - ;; title - (if title (row title)) - ;; affiliation - (if affiliation (row affiliation)) - ;; address - (if (pair? address) - (for-each row address)) - ;; telephone - (if phone (row phone)) - ;; email - (if email (row email)) - ;; url - (if url (row url))))) - ;; emit the author - (if a - (output a ne) - (output hd e)))) - :after "
") - (output n e) - (when hd - (display "") - (output hd e) - (set! hd #f)) - (display "
\n
\n\n")) - - diff --git a/src/guile/skribilo/packages/lncs.scm b/src/guile/skribilo/packages/lncs.scm deleted file mode 100644 index 4aadacc..0000000 --- a/src/guile/skribilo/packages/lncs.scm +++ /dev/null @@ -1,149 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/lncs.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for LNCS articles. */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages lncs)) - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le 'documentclass "\\documentclass{llncs}") - ;; &latex-author - (markup-writer '&latex-author le - :action (lambda (n e) - (define (&latex-inst-body n) - (let ((affiliation (markup-option n :affiliation)) - (address (markup-option n :address))) - (when affiliation (output affiliation e) (display ", ")) - (when address - (for-each (lambda (a) (output a e) (display " ")) - address) - (newline)))) - (define (&latex-inst-n i) - (display "\\institute{\n") - (&latex-inst-body (car i)) - (for-each (lambda (n) - (display "\\and\n") - (&latex-inst-body n)) - (cdr i)) - (display "}\n")) - (define (&latex-author-1 n) - (display "\\author{\n") - (output n e) - (display "}\n")) - (define (&latex-author-n n) - (display "\\author{\n") - (output (car n) e) - (for-each (lambda (a) - (display " and ") - (output a e)) - (cdr n)) - (display "}\n")) - (let ((body (markup-body n))) - (cond - ((is-markup? body 'author) - (markup-option-add! n 'inst 1) - (&latex-author-1 body) - (&latex-inst-n (list body))) - ((and (list? body) - (every? (lambda (b) (is-markup? b 'author)) - body)) - (define (institute=? n1 n2) - (let ((aff1 (markup-option n1 :affiliation)) - (add1 (markup-option n1 :address)) - (aff2 (markup-option n2 :affiliation)) - (add2 (markup-option n2 :address))) - (and (equal? aff1 aff2) (equal? add1 add2)))) - (define (search-institute n i j) - (cond - ((null? i) - #f) - ((institute=? n (car i)) - j) - (else - (search-institute n (cdr i) (- j 1))))) - (if (null? (cdr body)) - (begin - (markup-option-add! (car body) 'inst 1) - (&latex-author-1 (car body)) - (&latex-inst-n body)) - ;; collect the institutes - (let loop ((ns body) - (is '()) - (j 1)) - (if (null? ns) - (begin - (&latex-author-n body) - (&latex-inst-n (reverse! is))) - (let* ((n (car ns)) - (si (search-institute n is (- j 1)))) - (if (integer? si) - (begin - (markup-option-add! n 'inst si) - (loop (cdr ns) is j)) - (begin - (markup-option-add! n 'inst j) - (loop (cdr ns) - (cons n is) - (+ 1 j))))))))) - (else - (skribe-error 'author - "Illegal `lncs' author" - body)))))) - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (lambda (n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (inst (markup-option n 'inst))) - (if name (output name e)) - (if title (output title e)) - (if inst (printf "\\inst{~a}\n" inst))))))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-lncs-abstract he - :action (lambda (n e) - (let* ((bg (or (engine-custom e 'abstract-background) - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e))))) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-lncs-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/scribe.scm b/src/guile/skribilo/packages/scribe.scm deleted file mode 100644 index c97f8e9..0000000 --- a/src/guile/skribilo/packages/scribe.scm +++ /dev/null @@ -1,231 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/scribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 29 10:07:21 2003 */ -;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Scribe Compatibility kit */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages scribe)) - -;*---------------------------------------------------------------------*/ -;* style ... */ -;*---------------------------------------------------------------------*/ -(define (style . styles) - (define (load-style style) - (let ((name (cond - ((string? style) - style) - ((symbol? style) - (string-append (symbol->string style) ".scr"))))) - (skribe-load name :engine *skribe-engine*))) - (for-each load-style styles)) - -;*---------------------------------------------------------------------*/ -;* chapter ... */ -;*---------------------------------------------------------------------*/ -(define skribe-chapter chapter) - -(define-markup (chapter #!rest opt #!key title subtitle split number toc file) - (apply skribe-chapter - :title (or title subtitle) - :number number - :toc toc - :file file - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* table-of-contents ... */ -;*---------------------------------------------------------------------*/ -(define-markup (table-of-contents #!rest opts #!key chapter section subsection) - (apply toc opts)) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define skribe-frame frame) - -(define-markup (frame #!rest opt #!key width margin) - (apply skribe-frame - :width (if (real? width) (* 100 width) width) - :margin margin - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* copyright ... */ -;*---------------------------------------------------------------------*/ -(define (copyright) - (symbol 'copyright)) - -;*---------------------------------------------------------------------*/ -;* sect ... */ -;*---------------------------------------------------------------------*/ -(define (sect) - (symbol 'section)) - -;*---------------------------------------------------------------------*/ -;* euro ... */ -;*---------------------------------------------------------------------*/ -(define (euro) - (symbol 'euro)) - -;*---------------------------------------------------------------------*/ -;* tab ... */ -;*---------------------------------------------------------------------*/ -(define (tab) - (char #\tab)) - -;*---------------------------------------------------------------------*/ -;* space ... */ -;*---------------------------------------------------------------------*/ -(define (space) - (char #\space)) - -;*---------------------------------------------------------------------*/ -;* print-bibliography ... */ -;*---------------------------------------------------------------------*/ -(define-markup (print-bibliography #!rest opts - #!key all (sort bib-sort/authors)) - (the-bibliography all sort)) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define skribe-linebreak linebreak) - -(define-markup (linebreak . lnum) - (cond - ((null? lnum) - (skribe-linebreak)) - ((string? (car lnum)) - (skribe-linebreak (string->number (car lnum)))) - (else - (skribe-linebreak (car lnum))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define skribe-ref ref) - -(define-markup (ref #!rest opts - #!key scribe url id page figure mark - chapter section subsection subsubsection subsubsection - bib bib+ number) - (let ((bd (the-body opts)) - (args (apply append (the-options opts :id)))) - (if id (set! args (cons* :mark id args))) - (if (pair? bd) (set! args (cons* :text bd args))) - (apply skribe-ref args))) - -;*---------------------------------------------------------------------*/ -;* indexes ... */ -;*---------------------------------------------------------------------*/ -(define *scribe-indexes* - (list (cons "theindex" (make-index "theindex")))) - -(define skribe-index index) -(define skribe-make-index make-index) - -(define-markup (make-index index) - (let ((i (skribe-make-index index))) - (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) - i)) - -(define-markup (index #!rest opts #!key note index shape) - (let ((i (if (not index) - "theindex" - (let ((i (assoc index *scribe-indexes*))) - (if (pair? i) - (cdr i) - (make-index index)))))) - (apply skribe-index :note note :index i :shape shape (the-body opts)))) - -(define-markup (print-index #!rest opts - #!key split (char-offset 0) (header-limit 100)) - (apply the-index - :split split - :char-offset char-offset - :header-limit header-limit - (map (lambda (i) - (let ((c (assoc i *scribe-indexes*))) - (if (pair? c) - (cdr c) - (skribe-error 'the-index "Unknown index" i)))) - (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* format? */ -;*---------------------------------------------------------------------*/ -(define (scribe-format? fmt) #f) - -;*---------------------------------------------------------------------*/ -;* scribe-url ... */ -;*---------------------------------------------------------------------*/ -(define (scribe-url) (skribe-url)) - -;*---------------------------------------------------------------------*/ -;* Various configurations */ -;*---------------------------------------------------------------------*/ -(define *scribe-background* #f) -(define *scribe-foreground* #f) -(define *scribe-tbackground* #f) -(define *scribe-tforeground* #f) -(define *scribe-title-font* #f) -(define *scribe-author-font* #f) -(define *scribe-chapter-numbering* #f) -(define *scribe-footer* #f) -(define *scribe-prgm-color* #f) - -;*---------------------------------------------------------------------*/ -;* prgm ... */ -;*---------------------------------------------------------------------*/ -(define-markup (prgm #!rest opts - #!key lnum lnumwidth language bg frame (width 1.) - colors (monospace #t)) - (let* ((w (cond - ((real? width) (* width 100.)) - ((number? width) width) - (else 100.))) - (body (if language - (source :language language (the-body opts)) - (the-body opts))) - (body (if monospace - (prog :line lnum body) - body)) - (body (if bg - (color :width 100. :bg bg body) - body))) - (skribe-frame :width w - :border (if frame 1 #f) - body))) - -;*---------------------------------------------------------------------*/ -;* latex configuration */ -;*---------------------------------------------------------------------*/ -(define *scribe-tex-predocument* #f) - -;*---------------------------------------------------------------------*/ -;* latex-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (latex-prelude e) - (if (engine-format? "latex" e) - (begin - (if *scribe-tex-predocument* - (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) - -;*---------------------------------------------------------------------*/ -;* html-prelude ... */ -;*---------------------------------------------------------------------*/ -(define (html-prelude e) - (if (engine-format? "html" e) - (begin - #f))) - -;*---------------------------------------------------------------------*/ -;* prelude */ -;*---------------------------------------------------------------------*/ -(let ((p (user-prelude))) - (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/packages/sigplan.scm b/src/guile/skribilo/packages/sigplan.scm deleted file mode 100644 index c4ea1e2..0000000 --- a/src/guile/skribilo/packages/sigplan.scm +++ /dev/null @@ -1,157 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/sigplan.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Sep 28 14:40:38 2003 */ -;* Last change : Wed May 18 16:00:38 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe style for ACMPROC articles. */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages sigplan)) - -;*---------------------------------------------------------------------*/ -;* LaTeX global customizations */ -;*---------------------------------------------------------------------*/ -(let ((le (find-engine 'latex))) - (engine-custom-set! le - 'documentclass - "\\documentclass[twocolumns]{sigplanconf}") - ;; &latex-author - (markup-writer '&latex-author le - :before (lambda (n e) - (let ((body (markup-body n))) - (printf "\\authorinfo{\n" - (if (pair? body) (length body) 1)))) - :action (lambda (n e) - (let ((body (markup-body n))) - (for-each (lambda (a) - (display "}\n\\authorinfo{") - (output a e)) - (if (pair? body) body (list body))))) - :after "}\n") - ;; author - (let ((old-author (markup-writer-get 'author le))) - (markup-writer 'author le - :options (writer-options old-author) - :action (writer-action old-author))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category le - :options '(:index :section :subsection) - :before (lambda (n e) - (display "\\category{") - (display (markup-option n :index)) - (display "}") - (display "{") - (display (markup-option n :section)) - (display "}") - (display "{") - (display (markup-option n :subsection)) - (display "}\n[")) - :after "]\n") - (markup-writer '&acm-terms le - :before "\\terms{" - :after "}") - (markup-writer '&acm-keywords le - :before "\\keywords{" - :after "}") - (markup-writer '&acm-copyright le - :action (lambda (n e) - (display "\\conferenceinfo{") - (output (markup-option n :conference) e) - (display ",} {") - (output (markup-option n :location) e) - (display "}\n") - (display "\\copyrightyear{") - (output (markup-option n :year) e) - (display "}\n") - (display "\\copyrightdata{") - (output (markup-option n :crdata) e) - (display "}\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML global customizations */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (markup-writer '&html-acmproc-abstract he - :action (lambda (n e) - (let* ((ebg (engine-custom e 'abstract-background)) - (bg (or (and (string? ebg) - (> (string-length ebg) 0)) - ebg - "#cccccc")) - (exp (p (center (color :bg bg :width 90. - (markup-body n)))))) - (skribe-eval exp e)))) - ;; ACM category, terms, and keywords - (markup-writer '&acm-category :action #f) - (markup-writer '&acm-terms :action #f) - (markup-writer '&acm-keywords :action #f) - (markup-writer '&acm-copyright :action #f)) - -;*---------------------------------------------------------------------*/ -;* abstract ... */ -;*---------------------------------------------------------------------*/ -(define-markup (abstract #!rest opt #!key postscript) - (if (engine-format? "latex") - (section :number #f :title "ABSTRACT" (p (the-body opt))) - (let ((a (new markup - (markup '&html-acmproc-abstract) - (body (the-body opt))))) - (list (if postscript - (section :number #f :toc #f :title "Postscript download" - postscript)) - (section :number #f :toc #f :title "Abstract" a) - (section :number #f :toc #f :title "Table of contents" - (toc :subsection #t)))))) - -;*---------------------------------------------------------------------*/ -;* acm-category ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-category #!rest opt #!key index section subsection) - (new markup - (markup '&acm-category) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-terms ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-terms #!rest opt) - (new markup - (markup '&acm-terms) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-keywords ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-keywords #!rest opt) - (new markup - (markup '&acm-keywords) - (options (the-options opt)) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* acm-copyright ... */ -;*---------------------------------------------------------------------*/ -(define-markup (acm-copyright #!rest opt #!key conference location year crdata) - (let* ((le (find-engine 'latex)) - (cop (format "\\conferenceinfo{~a,} {~a} -\\CopyrightYear{~a} -\\crdata{~a}\n" conference location year crdata)) - (old (engine-custom le 'predocument))) - (if (string? old) - (engine-custom-set! le 'predocument (string-append cop old)) - (engine-custom-set! le 'predocument cop)))) - -;*---------------------------------------------------------------------*/ -;* references ... */ -;*---------------------------------------------------------------------*/ -(define (references) - (list "\n\n" - (if (engine-format? "latex") - (font :size -1 (flush :side 'left (the-bibliography))) - (section :title "References" - (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/packages/skribe.scm b/src/guile/skribilo/packages/skribe.scm deleted file mode 100644 index 86425ac..0000000 --- a/src/guile/skribilo/packages/skribe.scm +++ /dev/null @@ -1,76 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/skribe.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jan 11 11:23:12 2002 */ -;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The standard Skribe style (always loaded). */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* p ... */ -;*---------------------------------------------------------------------*/ -(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) - (paragraph :ident ident :class class :loc &skribe-eval-location - (the-body opt))) - -;*---------------------------------------------------------------------*/ -;* fg ... */ -;*---------------------------------------------------------------------*/ -(define (fg c . body) - (color :fg c body)) - -;*---------------------------------------------------------------------*/ -;* bg ... */ -;*---------------------------------------------------------------------*/ -(define (bg c . body) - (color :bg c body)) - -;*---------------------------------------------------------------------*/ -;* counter ... */ -;* ------------------------------------------------------------- */ -;* This produces a kind of "local enumeration" that is: */ -;* (counting "toto," "tutu," "titi.") */ -;* produces: */ -;* i) toto, ii) tutu, iii) titi. */ -;*---------------------------------------------------------------------*/ -(define-markup (counter #!rest opts #!key (numbering 'roman)) - (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) - (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) - (define (the-roman-number num) - (if (< num (vector-length vroman)) - (list (list "(" (it (vector-ref vroman num)) ") ")) - (skribe-error 'counter - "too many items for roman numbering" - (length items)))) - (define (the-arabic-number num) - (list (list "(" (it (integer->string num)) ") "))) - (define (the-alpha-number num) - (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) - (let ((the-number (case numbering - ((roman) the-roman-number) - ((arabic) the-arabic-number) - ((alpha) the-alpha-number) - (else (skribe-error 'counter - "Illegal numbering" - numbering))))) - (let loop ((num 1) - (items items) - (res '())) - (if (null? items) - (reverse! res) - (loop (+ num 1) - (cdr items) - (cons (list (the-number num) (car items)) res)))))) - -;*---------------------------------------------------------------------*/ -;* q */ -;*---------------------------------------------------------------------*/ -(define-markup (q #!rest opt) - (new markup - (markup 'q) - (options (the-options opt)) - (body (the-body opt)))) - diff --git a/src/guile/skribilo/packages/slide.scm b/src/guile/skribilo/packages/slide.scm deleted file mode 100644 index 54ac21c..0000000 --- a/src/guile/skribilo/packages/slide.scm +++ /dev/null @@ -1,667 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/slide.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Oct 3 12:22:13 2003 */ -;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe style for slides */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages slide)) - -;*---------------------------------------------------------------------*/ -;* slide-options */ -;*---------------------------------------------------------------------*/ -(define &slide-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-predocument - "\\special{landscape} - \\slideframe{none} - \\centerslidesfalse - \\raggedslides[0pt] - \\renewcommand{\\slideleftmargin}{0.2in} - \\renewcommand{\\slidetopmargin}{0.3in} - \\newdimen\\slidewidth \\slidewidth 9in") - -;*---------------------------------------------------------------------*/ -;* &slide-seminar-maketitle ... */ -;*---------------------------------------------------------------------*/ -(define &slide-seminar-maketitle - "\\def\\labelitemi{$\\bullet$} - \\def\\labelitemii{$\\circ$} - \\def\\labelitemiii{$\\diamond$} - \\def\\labelitemiv{$\\cdot$} - \\pagestyle{empty} - \\slideframe{none} - \\centerslidestrue - \\begin{slide} - \\date{} - \\maketitle - \\end{slide} - \\slideframe{none} - \\centerslidesfalse") - -;*---------------------------------------------------------------------*/ -;* &slide-prosper-predocument ... */ -;*---------------------------------------------------------------------*/ -(define &slide-prosper-predocument - "\\slideCaption{}\n") - -;*---------------------------------------------------------------------*/ -;* %slide-the-slides ... */ -;*---------------------------------------------------------------------*/ -(define %slide-the-slides '()) -(define %slide-the-counter 0) -(define %slide-initialized #f) -(define %slide-latex-mode 'seminar) - -;*---------------------------------------------------------------------*/ -;* %slide-initialize! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-initialize!) - (unless %slide-initialized - (set! %slide-initialized #t) - (case %slide-latex-mode - ((seminar) - (%slide-seminar-setup!)) - ((advi) - (%slide-advi-setup!)) - ((prosper) - (%slide-prosper-setup!)) - (else - (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) - -;*---------------------------------------------------------------------*/ -;* slide ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide #!rest opt - #!key - (ident #f) (class #f) - (toc #t) - title (number #t) - (vspace #f) (vfill #f) - (transition #f) - (bg #f) (image #f)) - (%slide-initialize!) - (let ((s (new container - (markup 'slide) - (ident (if (not ident) - (symbol->string (gensym 'slide)) - ident)) - (class class) - (required-options '(:title :number :toc)) - (options `((:number - ,(cond - ((number? number) - (set! %slide-the-counter number) - number) - (number - (set! %slide-the-counter - (+ 1 %slide-the-counter)) - %slide-the-counter) - (else - #f))) - (:toc ,toc) - ,@(the-options opt :ident :class :vspace :toc))) - (body (if vspace - (list (slide-vspace vspace) (the-body opt)) - (the-body opt)))))) - (set! %slide-the-slides (cons s %slide-the-slides)) - s)) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;*---------------------------------------------------------------------*/ -(define %slide-old-ref ref) - -(define-markup (ref #!rest opt #!key (slide #f)) - (if (not slide) - (apply %slide-old-ref opt) - (new unresolved - (proc (lambda (n e env) - (cond - ((eq? slide 'next) - (let ((c (assq n %slide-the-slides))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((eq? slide 'prev) - (let ((c (assq n (reverse %slide-the-slides)))) - (if (pair? c) - (handle (cadr c)) - #f))) - ((number? slide) - (let loop ((s %slide-the-slides)) - (cond - ((null? s) - #f) - ((= slide (markup-option (car s) :number)) - (handle (car s))) - (else - (loop (cdr s)))))) - (else - #f))))))) - -;*---------------------------------------------------------------------*/ -;* slide-pause ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-pause) - (new markup - (markup 'slide-pause))) - -;*---------------------------------------------------------------------*/ -;* slide-vspace ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) - (new markup - (markup 'slide-vspace) - (options `((:unit ,unit) ,@(the-options opt :unit))) - (body (the-body opt)))) - -;*---------------------------------------------------------------------*/ -;* slide-embed ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-embed #!rest opt - #!key - command - (geometry-opt "-geometry") - (geometry #f) (rgeometry #f) - (transient #f) (transient-opt #f) - (alt #f) - &skribe-eval-location) - (if (not (string? command)) - (skribe-error 'slide-embed - "No command provided" - command) - (new markup - (markup 'slide-embed) - (loc &skribe-eval-location) - (required-options '(:alt)) - (options `((:geometry-opt ,geometry-opt) - (:alt ,alt) - ,@(the-options opt :geometry-opt :alt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-record ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) - (if (not tag) - (skribe-error 'slide-record "Tag missing" tag) - (new markup - (markup 'slide-record) - (ident ident) - (class class) - (options `((:play ,play) ,@(the-options opt))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play #!rest opt #!key ident class tag color) - (if (not tag) - (skribe-error 'slide-play "Tag missing" tag) - (new markup - (markup 'slide-play) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - ,@(the-options opt :color))) - (body (the-body opt))))) - -;*---------------------------------------------------------------------*/ -;* slide-play* ... */ -;*---------------------------------------------------------------------*/ -(define-markup (slide-play* #!rest opt - #!key ident class color (scolor "#000000")) - (let ((body (the-body opt))) - (for-each (lambda (lbl) - (match-case lbl - ((?id ?col) - (skribe-use-color! col)))) - body) - (new markup - (markup 'slide-play*) - (ident ident) - (class class) - (options `((:color ,(if color (skribe-use-color! color) #f)) - (:scolor ,(if color (skribe-use-color! scolor) #f)) - ,@(the-options opt :color :scolor))) - (body body)))) - -;*---------------------------------------------------------------------*/ -;* base */ -;*---------------------------------------------------------------------*/ -(let ((be (find-engine 'base))) - (skribe-message "Base slides setup...\n") - ;; slide-pause - (markup-writer 'slide-pause be - :action #f) - ;; slide-vspace - (markup-writer 'slide-vspace be - :options '() - :action #f) - ;; slide-embed - (markup-writer 'slide-embed be - :options '(:alt :geometry-opt) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-record - (markup-writer 'slide-record be - :options '(:tag :play) - :action (lambda (n e) - (output (markup-body n) e))) - ;; slide-play - (markup-writer 'slide-play be - :options '(:tag :color) - :action (lambda (n e) - (output (markup-option n :alt) e))) - ;; slide-play* - (markup-writer 'slide-play* be - :options '(:tag :color :scolor) - :action (lambda (n e) - (output (markup-option n :alt) e)))) - -;*---------------------------------------------------------------------*/ -;* slide-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (slide-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 95.))) - -;*---------------------------------------------------------------------*/ -;* html-slide-title ... */ -;*---------------------------------------------------------------------*/ -(define (html-slide-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (slide-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "
") - (output title e) - (display ""))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* slide-number ... */ -;*---------------------------------------------------------------------*/ -(define (slide-number) - (length (filter (lambda (n) - (and (is-markup? n 'slide) - (markup-option n :number))) - %slide-the-slides))) - -;*---------------------------------------------------------------------*/ -;* html */ -;*---------------------------------------------------------------------*/ -(let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") - ;; &html-page-title - (markup-writer '&html-document-title he - :predicate (lambda (n e) %slide-initialized) - :action html-slide-title) - ;; slide - (markup-writer 'slide he - :options '(:title :number :transition :toc :bg) - :before (lambda (n e) - (printf "
" (markup-ident n)) - (display "
\n")) - :action (lambda (n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (skribe-eval - (center - (color :width (slide-body-width e) - :bg (or (markup-option n :bg) "#ffffff") - (table :width 100. - (tr (th :align 'left - (list - (if nb - (format "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) - :after "
") - ;; slide-vspace - (markup-writer 'slide-vspace he - :action (lambda (n e) (display "
")))) - -;*---------------------------------------------------------------------*/ -;* latex */ -;*---------------------------------------------------------------------*/ -(define &latex-slide #f) -(define &latex-pause #f) -(define &latex-embed #f) -(define &latex-record #f) -(define &latex-play #f) -(define &latex-play* #f) - -(let ((le (find-engine 'latex))) - ;; slide-vspace - (markup-writer 'slide-vspace le - :options '(:unit) - :action (lambda (n e) - (display "\n\\vspace{") - (output (markup-body n) e) - (printf " ~a}\n\n" (markup-option n :unit)))) - ;; slide-slide - (markup-writer 'slide le - :options '(:title :number :transition :vfill :toc :vspace :image) - :action (lambda (n e) - (if (procedure? &latex-slide) - (&latex-slide n e)))) - ;; slide-pause - (markup-writer 'slide-pause le - :options '() - :action (lambda (n e) - (if (procedure? &latex-pause) - (&latex-pause n e)))) - ;; slide-embed - (markup-writer 'slide-embed le - :options '(:alt :command :geometry-opt :geometry - :rgeometry :transient :transient-opt) - :action (lambda (n e) - (if (procedure? &latex-embed) - (&latex-embed n e)))) - ;; slide-record - (markup-writer 'slide-record le - :options '(:tag :play) - :action (lambda (n e) - (if (procedure? &latex-record) - (&latex-record n e)))) - ;; slide-play - (markup-writer 'slide-play le - :options '(:tag :color) - :action (lambda (n e) - (if (procedure? &latex-play) - (&latex-play n e)))) - ;; slide-play* - (markup-writer 'slide-play* le - :options '(:tag :color :scolor) - :action (lambda (n e) - (if (procedure? &latex-play*) - (&latex-play* n e))))) - -;*---------------------------------------------------------------------*/ -;* %slide-seminar-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-seminar-setup!) - (skribe-message "Seminar slides setup...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - ;; latex configuration - (define (seminar-slide n e) - (let ((nb (markup-option n :number)) - (t (markup-option n :title))) - (display "\\begin{slide}\n") - (if nb (printf "~a/~a -- " nb (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n")) - (engine-custom-set! le 'documentclass - "\\documentclass[landscape]{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'hyperref-usepackage - "\\usepackage[setpagesize=false]{hyperref}\n") - ;; slide-slide - (set! &latex-slide seminar-slide))) - -;*---------------------------------------------------------------------*/ -;* %slide-advi-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-advi-setup!) - (skribe-message "Generating `Advi Seminar' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base))) - (define (advi-geometry geo) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) - (if (pair? r) - (let* ((w (cadr r)) - (w' (string->integer w)) - (w'' (number->string (/ w' *skribe-slide-advi-scale*))) - (h (caddr r)) - (h' (string->integer h)) - (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) - (values "" (string-append w "x" h "+!x+!y"))) - (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) - (if (pair? r) - (let ((w (number->string (/ (string->integer (cadr r)) - *skribe-slide-advi-scale*))) - (h (number->string (/ (string->integer (caddr r)) - *skribe-slide-advi-scale*))) - (x (cadddr r)) - (y (car (cddddr r)))) - (values (string-append "width=" w "cm,height=" h "cm") - "!g")) - (values "" geo)))))) - (define (advi-transition trans) - (cond - ((string? trans) - (printf "\\advitransition{~s}" trans)) - ((and (symbol? trans) - (memq trans '(wipe block slide))) - (printf "\\advitransition{~s}" trans)) - (else - #f))) - ;; latex configuration - (define (advi-slide n e) - (let ((i (markup-option n :image)) - (n (markup-option n :number)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition))) - (if (and i (engine-custom e 'advi)) - (printf "\\advibg[global]{image=~a}\n" - (if (and (pair? i) - (null? (cdr i)) - (string? (car i))) - (car i) - i))) - (display "\\begin{slide}\n") - (advi-transition (or lt gt)) - (if n (printf "~a/~a -- " n (slide-number))) - (output t e) - (display "\\hrule\n")) - (output (markup-body n) e) - (if (markup-option n :vill) (display "\\vfill\n")) - (display "\\end{slide}\n\n\n")) - ;; advi record - (define (advi-record n e) - (display "\\advirecord") - (when (markup-option n :play) (display "[play]")) - (printf "{~a}{" (markup-option n :tag)) - (output (markup-body n) e) - (display "}")) - ;; advi play - (define (advi-play n e) - (display "\\adviplay") - (let ((c (markup-option n :color))) - (when c - (display "[") - (display (skribe-get-latex-color c)) - (display "]"))) - (printf "{~a}" (markup-option n :tag))) - ;; advi play* - (define (advi-play* n e) - (let ((c (skribe-get-latex-color (markup-option n :color))) - (d (skribe-get-latex-color (markup-option n :scolor)))) - (let loop ((lbls (markup-body n)) - (last #f)) - (when last - (display "\\adviplay[") - (display d) - (printf "]{~a}" last)) - (when (pair? lbls) - (let ((lbl (car lbls))) - (match-case lbl - ((?id ?col) - (display "\\adviplay[") - (display (skribe-get-latex-color col)) - (printf "]{" ~a "}" id) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) id)) - (else - (display "\\adviplay[") - (display c) - (printf "]{~a}" lbl) - (skribe-eval (slide-pause) e) - (loop (cdr lbls) lbl)))))))) - (engine-custom-set! le 'documentclass - "\\documentclass{seminar}\n") - (let ((o (engine-custom le 'predocument))) - (engine-custom-set! le 'predocument - (if (string? o) - (string-append &slide-seminar-predocument o) - &slide-seminar-predocument))) - (engine-custom-set! le 'maketitle - &slide-seminar-maketitle) - (engine-custom-set! le 'usepackage - (string-append "\\usepackage{advi}\n" - (engine-custom le 'usepackage))) - ;; slide - (set! &latex-slide advi-slide) - (set! &latex-pause - (lambda (n e) (display "\\adviwait\n"))) - (set! &latex-embed - (lambda (n e) - (let ((geometry-opt (markup-option n :geometry-opt)) - (geometry (markup-option n :geometry)) - (rgeometry (markup-option n :rgeometry)) - (transient (markup-option n :transient)) - (transient-opt (markup-option n :transient-opt)) - (cmd (markup-option n :command))) - (let* ((a (string-append "ephemeral=" - (symbol->string (gensym)))) - (c (cond - (geometry - (string-append cmd " " - geometry-opt " " - geometry)) - (rgeometry - (multiple-value-bind (aopt dopt) - (advi-geometry rgeometry) - (set! a (string-append a "," aopt)) - (string-append cmd " " - geometry-opt " " - dopt))) - (else - cmd))) - (c (if (and transient transient-opt) - (string-append c " " transient-opt " !p") - c))) - (printf "\\adviembed[~a]{~a}\n" a c))))) - (set! &latex-record advi-record) - (set! &latex-play advi-play) - (set! &latex-play* advi-play*))) - -;*---------------------------------------------------------------------*/ -;* %slide-prosper-setup! ... */ -;*---------------------------------------------------------------------*/ -(define (%slide-prosper-setup!) - (skribe-message "Generating `Prosper' slides...\n") - (let ((le (find-engine 'latex)) - (be (find-engine 'base)) - (overlay-count 0)) - ;; transitions - (define (prosper-transition trans) - (cond - ((string? trans) - (printf "[~s]" trans)) - ((eq? trans 'slide) - (printf "[Blinds]")) - ((and (symbol? trans) - (memq trans '(split blinds box wipe dissolve glitter))) - (printf "[~s]" - (string-upcase (symbol->string trans)))) - (else - #f))) - ;; latex configuration - (define (prosper-slide n e) - (let* ((i (markup-option n :image)) - (t (markup-option n :title)) - (lt (markup-option n :transition)) - (gt (engine-custom e 'transition)) - (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) - (lpa (length pa))) - (set! overlay-count 1) - (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) - (display "\\begin{slide}") - (prosper-transition (or lt gt)) - (display "{") - (output t e) - (display "}\n") - (output (markup-body n) e) - (display "\\end{slide}\n") - (if (>= lpa 1) (display "}\n")) - (newline) - (newline))) - (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") - (let* ((cap (engine-custom le 'slide-caption)) - (o (engine-custom le 'predocument)) - (n (if (string? cap) - (format "~a\\slideCaption{~a}\n" - &slide-prosper-predocument - cap) - &slide-prosper-predocument))) - (engine-custom-set! le 'predocument - (if (string? o) (string-append n o) n))) - (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") - ;; writers - (set! &latex-slide prosper-slide) - (set! &latex-pause - (lambda (n e) - (set! overlay-count (+ 1 overlay-count)) - (printf "\\FromSlide{~s}%\n" overlay-count))))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &slide-load-options) - (p (memq :prosper opt))) - (if (and (pair? p) (pair? (cdr p)) (cadr p)) - ;; prosper - (set! %slide-latex-mode 'prosper) - (let ((a (memq :advi opt))) - (if (and (pair? a) (pair? (cdr a)) (cadr a)) - ;; advi - (set! %slide-latex-mode 'advi))))) diff --git a/src/guile/skribilo/packages/web-article.scm b/src/guile/skribilo/packages/web-article.scm deleted file mode 100644 index f853231..0000000 --- a/src/guile/skribilo/packages/web-article.scm +++ /dev/null @@ -1,232 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-article.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jan 10 09:09:43 2004 */ -;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ -;* Copyright : 2004 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* A Skribe style for producing web articles */ -;*=====================================================================*/ - -(define-skribe-module (skribilo packages web-article)) - -;*---------------------------------------------------------------------*/ -;* &web-article-load-options ... */ -;*---------------------------------------------------------------------*/ -(define &web-article-load-options (skribe-load-options)) - -;*---------------------------------------------------------------------*/ -;* web-article-body-width ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-body-width e) - (let ((w (engine-custom e 'body-width))) - (if (or (number? w) (string? w)) w 98.))) - -;*---------------------------------------------------------------------*/ -;* html-document-title-web ... */ -;*---------------------------------------------------------------------*/ -(define (html-document-title-web n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (tbg (engine-custom e 'title-background)) - (tfg (engine-custom e 'title-foreground)) - (tfont (engine-custom e 'title-font))) - (printf "
\n" - (html-width (web-article-body-width e))) - (if (string? tbg) - (printf "
" tbg) - (display "")) - (if (string? tfg) - (printf "" tfg)) - (if title - (begin - (display "
") - (if (string? tfont) - (begin - (printf "" tfont) - (output title e) - (display "")) - (begin - (printf "

") - (output title e) - (display "

"))) - (display "
\n"))) - (if (not authors) - (display "\n") - (html-title-authors authors e)) - (if (string? tfg) - (display "
")) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-document-title ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-document-title n e) - (let* ((title (markup-body n)) - (authors (markup-option n 'author)) - (id (markup-ident n))) - ;; the title - (printf "
\n" - (string-canonicalize id)) - (output title e) - (display "
\n") - ;; the authors - (printf "
\n" - (string-canonicalize id)) - (for-each (lambda (a) (output a e)) - (cond - ((is-markup? authors 'author) - (list authors)) - ((list? authors) - authors) - (else - '()))) - (display "
\n"))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-author ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-author n e) - (let ((name (markup-option n :name)) - (title (markup-option n :title)) - (affiliation (markup-option n :affiliation)) - (email (markup-option n :email)) - (url (markup-option n :url)) - (address (markup-option n :address)) - (phone (markup-option n :phone)) - (nfn (engine-custom e 'author-font)) - (align (markup-option n :align))) - (when name - (printf "" - (string-canonicalize (markup-ident n))) - (output name e) - (display "\n")) - (when title - (printf "" - (string-canonicalize (markup-ident n))) - (output title e) - (display "\n")) - (when affiliation - (printf "" - (string-canonicalize (markup-ident n))) - (output affiliation e) - (display "\n")) - (when (pair? address) - (printf "" - (string-canonicalize (markup-ident n))) - (for-each (lambda (a) - (output a e) - (newline)) - address) - (display "\n")) - (when phone - (printf "" - (string-canonicalize (markup-ident n))) - (output phone e) - (display "\n")) - (when email - (printf "" - (string-canonicalize (markup-ident n))) - (output email e) - (display "\n")) - (when url - (printf "" - (string-canonicalize (markup-ident n))) - (output url e) - (display "\n")))) - -;*---------------------------------------------------------------------*/ -;* HTML settings */ -;*---------------------------------------------------------------------*/ -(define (web-article-modern-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :action html-document-title-web) - ;; section - (markup-writer 'section he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background))) - (markup-writer 'section e1 - :options 'all - :action (lambda (n e2) (output n e sec))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg n)) - e1)))) - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before "
" - :action (lambda (n e) - (let ((e1 (make-engine 'html-web :delegate e)) - (bg (engine-custom he 'section-background)) - (fg (engine-custom he 'subsection-title-foreground))) - (markup-writer '&html-footnotes e1 - :options 'all - :action (lambda (n e2) - (invoke (writer-action ft) n e))) - (skribe-eval - (center (color :width (web-article-body-width e) - :margin 5 :bg bg :fg fg n)) - e1)))))) - -;*---------------------------------------------------------------------*/ -;* web-article-css-setup ... */ -;*---------------------------------------------------------------------*/ -(define (web-article-css-setup he) - (let ((sec (markup-writer-get 'section he)) - (ft (markup-writer-get '&html-footnotes he))) - ;; &html-document-title - (markup-writer '&html-document-title he - :before (lambda (n e) - (printf "
\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-document-title - :after "
\n") - ;; author - (markup-writer 'author he - :options '(:name :title :affiliation :email :url :address :phone :photo :align) - :before (lambda (n e) - (printf "\n" - (string-canonicalize (markup-ident n)))) - :action web-article-css-author - :after "" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) (output n e sec)) - :after "\n") - ;; &html-footnotes - (markup-writer '&html-footnotes he - :options 'all - :before (lambda (n e) - (printf "
" - (string-canonicalize (markup-ident n)))) - :action (lambda (n e) - (output n e ft)) - :after "
\n"))) - -;*---------------------------------------------------------------------*/ -;* Setup ... */ -;*---------------------------------------------------------------------*/ -(let* ((opt &web-article-load-options) - (p (memq :style opt)) - (css (memq :css opt)) - (he (find-engine 'html))) - (cond - ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) - (web-article-css-setup he)) - ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) - (engine-custom-set! he 'css (cadr css)) - (web-article-css-setup he)) - (else - (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/packages/web-book.scm b/src/guile/skribilo/packages/web-book.scm deleted file mode 100644 index f907c8b..0000000 --- a/src/guile/skribilo/packages/web-book.scm +++ /dev/null @@ -1,107 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/skr/web-book.skr */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 10:54:32 2003 */ -;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe web book style. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* html customization */ -;*---------------------------------------------------------------------*/ -(define he (find-engine 'html)) -(engine-custom-set! he 'main-browsing-extra #f) -(engine-custom-set! he 'chapter-file #t) - -;*---------------------------------------------------------------------*/ -;* main-browsing ... */ -;*---------------------------------------------------------------------*/ -(define main-browsing - (lambda (n e) - ;; search the document - (let ((p (ast-document n))) - (cond - ((document? p) - ;; got it - (let* ((mt (markup-option p :margin-title)) - (r (ref :handle (handle p) - :text (or mt (markup-option p :title)))) - (fx (engine-custom e 'web-book-main-browsing-extra))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold "main page")))) - (tr :bg (engine-custom e 'background) - (td (apply table :width 100. :border 0 - (tr (td :align 'left - :valign 'top - (bold "top:")) - (td :align 'right - :valign 'top r)) - (if (procedure? fx) - (list (tr (td :width 100. - :colspan 2 - (fx n e)))) - '())))))))) - ((not p) - ;; no document!!! - #f))))) - -;*---------------------------------------------------------------------*/ -;* chapter-browsing ... */ -;*---------------------------------------------------------------------*/ -(define chapter-browsing - (lambda (n e) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (markup-option n :title))))) - (tr :bg (engine-custom e 'background) - (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) - -;*---------------------------------------------------------------------*/ -;* document-browsing ... */ -;*---------------------------------------------------------------------*/ -(define document-browsing - (lambda (n e) - (let ((chap (find1-down (lambda (n) - (is-markup? n 'chapter)) - n))) - (center - (table :width 97. :border 1 :frame 'box - :cellpadding 0 :cellspacing 0 - (tr :bg (engine-custom e 'title-background) - (th (color :fg (engine-custom e 'background) - (bold (if chap "Chapters" "Sections"))))) - (tr :bg (engine-custom e 'background) - (td (if chap - (toc (handle n) :chapter #t :section #f) - (toc (handle n) :section #t :subsection #t))))))))) - -;*---------------------------------------------------------------------*/ -;* left margin ... */ -;*---------------------------------------------------------------------*/ -(engine-custom-set! he 'left-margin-size 20.) - -(engine-custom-set! he 'left-margin - (lambda (n e) - (let ((d (ast-document n)) - (c (ast-chapter n))) - (list (linebreak 1) - (main-browsing n e) - (if (is-markup? c 'chapter) - (list (linebreak 2) - (chapter-browsing c e)) - #f) - (if (document? d) - (list (linebreak 2) - (document-browsing d e)) - #f))))) - diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..a1c58fb --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index 78f1814..714f19e 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -54,6 +54,7 @@ the Skribe syntax." (sharp-reader (r:make-reader (cons dsssl-keyword-reader (map r:standard-token-reader '(character srfi-4 + vector number+radix boolean))) #f ;; use default fault handler @@ -61,16 +62,25 @@ the Skribe syntax." (colon-keywords ;; keywords à la `:key' fashion (r:make-token-reader #\: (r:token-reader-procedure - (r:standard-token-reader 'keyword))))) + (r:standard-token-reader 'keyword)))) + (square-bracket-free-symbol-misc-chars + (let* ((tr (r:standard-token-reader 'guile-symbol-misc-chars)) + (tr-spec (r:token-reader-specification tr)) + (tr-proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (or (eq? chr #\[) + (eq? chr #\])))) + tr-spec) + tr-proc)))) (r:make-reader (cons* (r:make-token-reader #\# sharp-reader) colon-keywords + square-bracket-free-symbol-misc-chars (map r:standard-token-reader `(whitespace - sexp string number - symbol-lower-case - symbol-upper-case - symbol-misc-chars + sexp string guile-number + guile-symbol-lower-case + guile-symbol-upper-case quote-quasiquote-unquote semicolon-comment skribe-exp))) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am new file mode 100644 index 0000000..2850c4d --- /dev/null +++ b/src/guile/skribilo/skribe/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = api.scm bib.scm index.scm param.scm sui.scm utils.scm diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm index 840a179..415cadf 100644 --- a/src/guile/skribilo/skribe/index.scm +++ b/src/guile/skribilo/skribe/index.scm @@ -36,24 +36,24 @@ ;*---------------------------------------------------------------------*/ ;* index? ... */ ;*---------------------------------------------------------------------*/ -(define (index? obj) +(define-public (index? obj) (hashtable? obj)) ;*---------------------------------------------------------------------*/ ;* *index-table* ... */ ;*---------------------------------------------------------------------*/ -(define *index-table* #f) +(define-public *index-table* #f) ;*---------------------------------------------------------------------*/ ;* make-index-table ... */ ;*---------------------------------------------------------------------*/ -(define (make-index-table ident) +(define-public (make-index-table ident) (make-hashtable)) ;*---------------------------------------------------------------------*/ ;* default-index ... */ ;*---------------------------------------------------------------------*/ -(define (default-index) +(define-public (default-index) (if (not *index-table*) (set! *index-table* (make-index-table "default-index"))) *index-table*) @@ -61,7 +61,7 @@ ;*---------------------------------------------------------------------*/ ;* resolve-the-index ... */ ;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) +(define-public (resolve-the-index loc i c indexes split char-offset header-limit col) ;; fetch the descriminating index name letter (define (index-ref n) (let ((name (markup-option n 'name))) @@ -70,7 +70,7 @@ (string-ref name char-offset)))) ;; sort a bucket of entries (the entries in a bucket share there name) (define (sort-entries-bucket ie) - (sort ie + (sort ie (lambda (i1 i2) (or (not (markup-option i1 :note)) (markup-option i2 :note))))) -- cgit v1.2.3 From f553cb65b157b6df9563cefa593902d59301461b Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Tue, 1 Nov 2005 16:19:34 +0000 Subject: Changes related to source-highlighting and to the manual. * src/guile/skribilo/engine/lout.scm (lout-make-doc-cover-sheet): Fixed the definition of MULTI-COLUMN? (fixes a bug when producing multi-column documents). (lout-definitions): `@SkribeLeaders' renamed to `@SkribiloLeaders'. * doc/skr/api.skr (api-search-definition): Fixed calls to `format'. * doc/skr/manual.skr (keyword): Use `write' instead of `keyword->string'. * doc/user/start.skb: Cosmetic changes. * src/guile/skribilo/coloring/lisp.scm: First stab at its adaptation. * src/guile/skribilo/coloring/xml.scm: Rewritten "by hand". * src/guile/skribilo/evaluator.scm (skribe-include): Removed debugging statements. * src/guile/skribilo/lib.scm (new): Added a trick such that users of this macro don't have to use `(oop goops)' and `(skribilo types)'. (date): New procedure. * src/guile/skribilo/module.scm (*skribe-core-modules*): Renamed to `%skribe-core-modules'. (%skribe-core-modules): Removed `(oop goops)'. Added `(skribilo source)', `(skribilo coloring lisp)' and `(skribilo coloring xml)'. * src/guile/skribilo/skribe/api.scm (footnote): Fixed. * src/guile/skribilo/source.scm: Cosmetic changes. * src/guile/skribilo/types.scm: Export `language-extractor' and `language-fontifier'. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-11 --- ChangeLog | 52 +++++++++++++++ doc/skr/api.skr | 7 ++- doc/skr/manual.skr | 4 +- doc/user/start.skb | 4 +- src/guile/skribilo/coloring/lisp.scm | 113 +++++++++++++++++---------------- src/guile/skribilo/coloring/xml.scm | 119 ++++++++++++++++++++++------------- src/guile/skribilo/engine/lout.scm | 11 ++-- src/guile/skribilo/evaluator.scm | 8 +-- src/guile/skribilo/lib.scm | 36 +++++++---- src/guile/skribilo/module.scm | 15 +++-- src/guile/skribilo/skribe/api.scm | 10 +-- src/guile/skribilo/source.scm | 23 +++---- src/guile/skribilo/types.scm | 6 +- 13 files changed, 250 insertions(+), 158 deletions(-) (limited to 'src') diff --git a/ChangeLog b/ChangeLog index cc89110..6d3e667 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,58 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2005-11-01 16:19:34 GMT Ludovic Courtes patch-11 + + Summary: + Changes related to source-highlighting and to the manual. + Revision: + skribilo--devel--1.2--patch-11 + + * src/guile/skribilo/engine/lout.scm (lout-make-doc-cover-sheet): Fixed + the definition of MULTI-COLUMN? (fixes a bug when producing + multi-column documents). + (lout-definitions): `@SkribeLeaders' renamed to `@SkribiloLeaders'. + + * doc/skr/api.skr (api-search-definition): Fixed calls to `format'. + + * doc/skr/manual.skr (keyword): Use `write' instead of `keyword->string'. + + * doc/user/start.skb: Cosmetic changes. + + * src/guile/skribilo/coloring/lisp.scm: First stab at its adaptation. + + * src/guile/skribilo/coloring/xml.scm: Rewritten "by hand". + + * src/guile/skribilo/evaluator.scm (skribe-include): Removed debugging + statements. + + * src/guile/skribilo/lib.scm (new): Added a trick such that users of this + macro don't have to use `(oop goops)' and `(skribilo types)'. + (date): New procedure. + + * src/guile/skribilo/module.scm (*skribe-core-modules*): Renamed to + `%skribe-core-modules'. + (%skribe-core-modules): Removed `(oop goops)'. Added `(skribilo + source)', `(skribilo coloring lisp)' and `(skribilo coloring xml)'. + + * src/guile/skribilo/skribe/api.scm (footnote): Fixed. + + * src/guile/skribilo/source.scm: Cosmetic changes. + + * src/guile/skribilo/types.scm: Export `language-extractor' and + `language-fontifier'. + + modified files: + ChangeLog doc/skr/api.skr doc/skr/manual.skr + doc/user/start.skb src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/coloring/xml.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/lib.scm + src/guile/skribilo/module.scm + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/source.scm src/guile/skribilo/types.scm + + 2005-10-31 23:26:24 GMT Ludovic Courtes patch-10 Summary: diff --git a/doc/skr/api.skr b/doc/skr/api.skr index a27c3a4..504dd5a 100644 --- a/doc/skr/api.skr +++ b/doc/skr/api.skr @@ -62,14 +62,15 @@ (let ((f (find-file/path file *skribe-source-path*))) (if (not (string? f)) (skribe-error 'api-search-definition - (format "Can't find source file `~a' in path" file) + (format #t "can't find source file `~a' in path" file) *skribe-source-path*) (with-input-from-file f (lambda () (let loop ((exp (read))) (if (eof-object? exp) - (skribe-error 'api-search-definition - (format "Can't find `~a' definition" id) + (skribe-error 'api-search-definition + (format #t + "can't find `~a' definition" id) file) (or (pred id exp) (loop (read)))))))))) diff --git a/doc/skr/manual.skr b/doc/skr/manual.skr index 1982237..30b2fcd 100644 --- a/doc/skr/manual.skr +++ b/doc/skr/manual.skr @@ -123,7 +123,9 @@ (markup '&source-key) (body (cond ((keyword? arg) - (keyword->string arg)) + (with-output-to-string + (lambda () + (write arg)))) ((symbol? arg) (string-append ":" (symbol->string arg))) (else diff --git a/doc/user/start.skb b/doc/user/start.skb index d437b3a..d478a7e 100644 --- a/doc/user/start.skb +++ b/doc/user/start.skb @@ -147,7 +147,8 @@ often need to generate some repetitive text. Skribe programming skills can be used to ease the construction of such documents as illustrated below. ,(disp (itemize - (map (lambda (x) (item [The square of ,(bold x) is ,(bold (* x x))])) + (map (lambda (x) + (item [The square of ,(bold x) is ,(bold (* x x))])) '(1 2 3 4 5 6 7 8 9)))) This text has been generated with the following piece of code ,(prgm :language skribe [ @@ -191,6 +192,5 @@ In order to compile to various formats one must type in:]) ,(disp :verb #t [ $ skribe file.skb -o file.html ,(char 35) ,(it "This produces an HTML file.") $ skribe file.skb -o file.tex ,(char 35) ,(it "This produces a TeX file.") -$ skribe file.skb -o file.man ,(char 35) ,(it "This produces a man page.") $ skribe file.skb -o file.info ,(char 35) ,(it "This produces an info page.") $ skribe file.skb -o file.mgp ,(char 35) ,(it "This produces a MagicPoint document")])])) diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm index 53cf670..ad02431 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,46 +1,46 @@ ;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; +;;;; lisp.scm -- Lisp Family Fontification +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; +;;;; Copyright © 2005 Ludovic Courtès +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 16-Oct-2003 22:17 (eg) ;;;; Last file update: 28-Oct-2004 21:14 (eg) ;;;; -(require "lex-rt") ;; to avoid module problems +(define-module (skribilo coloring lisp) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo runtime) + :export (skribe scheme stklos bigloo lisp)) -(define-module (skribilo lisp) - :export (skribe scheme stklos bigloo lisp) - :import (skribe source)) -(include "lisp-lex.stk") ;; SILex generated - -(define *bracket-highlight* #f) -(define *class-highlight* #f) -(define *the-keys* #f) +(define *bracket-highlight* (make-fluid)) +(define *class-highlight* (make-fluid)) +(define *the-keys* (make-fluid)) -(define *lisp-keys* #f) -(define *scheme-keys* #f) -(define *skribe-keys* #f) -(define *stklos-keys* #f) -(define *lisp-keys* #f) +(define *lisp-keys* (make-fluid)) +(define *scheme-keys* (make-fluid)) +(define *skribe-keys* (make-fluid)) +(define *stklos-keys* (make-fluid)) +(define *lisp-keys* (make-fluid)) ;;; @@ -57,17 +57,17 @@ (define (lisp-family-fontifier s) - (let ((lex (lisp-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) + (let ((lisp-input (open-input-string s))) + (let loop ((token (read lisp-input)) (res '())) - (if (eq? token 'eof) + (if (eof-object? token) (reverse! res) - (Loop (lexer-next-token lex) + (loop (read lisp-input) (cons token res)))))) ;;;; ====================================================================== ;;;; -;;;; LISP +;;;; LISP ;;;; ;;;; ====================================================================== (define (lisp-extractor iport def tab) @@ -77,17 +77,17 @@ (lambda (exp) (match-case exp (((or defun defmacro) ?fun ?- . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) ((defvar ?var . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-lisp-keys) (unless *lisp-keys* (set! *lisp-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(setq if let let* letrec cond case else progn lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -95,9 +95,9 @@ *lisp-keys*) (define (lisp-fontifier s) - (fluid-let ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) @@ -109,7 +109,7 @@ ;;;; ====================================================================== ;;;; -;;;; SCHEME +;;;; SCHEME ;;;; ;;;; ====================================================================== (define (scheme-extractor iport def tab) @@ -130,7 +130,7 @@ (unless *scheme-keys* (set! *scheme-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(set! if let let* letrec quote cond case else begin do lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -139,11 +139,11 @@ (define (scheme-fontifier s) - (fluid-let ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) - + (define scheme (new language @@ -153,7 +153,7 @@ ;;;; ====================================================================== ;;;; -;;;; STKLOS +;;;; STKLOS ;;;; ;;;; ====================================================================== (define (stklos-extractor iport def tab) @@ -164,11 +164,11 @@ (match-case exp (((or define define-generic define-method define-macro) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-module) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-stklos-keys) @@ -192,9 +192,9 @@ (define (stklos-fontifier s) - (fluid-let ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -206,7 +206,7 @@ ;;;; ====================================================================== ;;;; -;;;; SKRIBE +;;;; SKRIBE ;;;; ;;;; ====================================================================== (define (skribe-extractor iport def tab) @@ -250,12 +250,12 @@ (map (lambda (x) (cons x '&source-define)) '(define-markup))))) *skribe-keys*) - + (define (skribe-fontifier s) - (fluid-let ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -267,7 +267,7 @@ ;;;; ====================================================================== ;;;; -;;;; BIGLOO +;;;; BIGLOO ;;;; ;;;; ====================================================================== (define (bigloo-extractor iport def tab) @@ -279,15 +279,14 @@ (((or define define-inline define-generic define-method define-macro define-expander) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define bigloo (new language (name "bigloo") (fontifier scheme-fontifier) (extractor bigloo-extractor))) - diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm index d71e98c..e3db36f 100644 --- a/src/guile/skribilo/coloring/xml.scm +++ b/src/guile/skribilo/coloring/xml.scm @@ -1,53 +1,82 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:33 (eg) -;;;; Last file update: 28-Dec-2003 17:33 (eg) -;;;; - - -;(require "lex-rt") ;; to avoid module problems - - -(define-module (skribilo xml) - :export (xml)) - -(use-modules (skribilo source)) - -(include "xml-lex.stk") ;; SILex generated - -(define (xml-fontifier s) - (let ((lex (xml-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (Loop (lexer-next-token lex) - (cons token res)))))) +;;; xml.scm -- XML syntax highlighting. +;;; +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +(define-module (skribilo coloring xml) + :export (xml) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (ice-9 rdelim) + :use-module (ice-9 regex)) + + +(define %comment-rx (make-regexp "" regexp/extended)) + +(define (xml-fontifier str) + (let loop ((start 0) + (result '())) + (if (>= start (string-length str)) + (reverse! result) + (case (string-ref str start) + ((#\") + (let ((end (string-index str start #\"))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML string" + (string-drop str start)) + (loop end + (cons (new markup + (markup '&source-string) + (body (substring str start end))) + result))))) + ((#\<) + (let ((end (string-index str #\> start))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML tag" + (string-drop str start)) + (let ((comment? (regexp-exec %comment-rx + (substring str start end)))) + (loop end + (cons (if comment? + (new markup + (markup '&source-comment) + (body (substring str start end))) + (new markup + (markup '&source-module) + (body (substring str start end)))) + result)))))) + + (else + (loop (+ 1 start) + (if (or (null? result) + (not (string? (car result)))) + (cons (string (string-ref str start)) result) + (cons (string-append (car result) + (string (string-ref str start))) + (cdr result))))))))) + + (define xml (new language (name "xml") (fontifier xml-fontifier) (extractor #f))) +;;; xml.scm ends here diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b466ac1..36df9f9 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -384,10 +384,10 @@ " @PageMark @Tag\n" "}\n\n" - "# @SkribeLeaders is used in `toc'\n" + "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" - "def @SkribeLeaders { " - ,leader " |" ,leader-space " @SkribeLeaders }\n\n")))) + "def @SkribiloLeaders { " + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -397,7 +397,8 @@ (author (markup-option doc :author)) (date-line (engine-custom engine 'date-line)) (cover-sheet? (engine-custom engine 'cover-sheet?)) - (multi-column? (> 1 (engine-custom engine 'column-number)))) + (multi-column? (> (engine-custom engine 'column-number) 1))) + (if multi-column? ;; In single-column document, `@FullWidth' yields a blank page. (display "\n@FullWidth {")) @@ -1205,7 +1206,7 @@ (entry-proc node engine) (display " &1rt @OneCol { ") - (printf " @SkribeLeaders & @PageOf { ~a }" + (printf " @SkribiloLeaders & @PageOf { ~a }" (lout-tagify (markup-ident node))) (display " &0io } }") diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 974d72a..def3280 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -175,16 +175,14 @@ path)) (when (> *skribe-verbose* 0) (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path (lambda () (let Loop ((exp (%default-reader (current-input-port))) (res '())) - (format (current-error-port) "exp=~a~%" exp) (if (eof-object? exp) - (begin - (format (current-error-port) "include: eof reached~%") - (if (and (pair? res) (null? (cdr res))) + (if (and (pair? res) (null? (cdr res))) (car res) - (reverse! res))) + (reverse! res)) (Loop (%default-reader (current-input-port)) (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index d916db4..2961fc6 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -1,5 +1,5 @@ ;;; -;;; lib.stk -- Utilities +;;; lib.scm -- Utilities ;;; ;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI ;;; @@ -18,11 +18,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -;;; -;;; Author: Erick Gallesio [eg@essi.fr] -;;; Creation date: 11-Aug-2003 20:29 (eg) -;;; Last file update: 27-Oct-2004 12:41 (eg) -;;; (read-set! keywords 'prefix) @@ -59,7 +54,9 @@ hashtable->list skribe-read - find-runtime-type) + find-runtime-type + + date) :export-syntax (new define-markup define-simple-markup define-simple-container define-processor-markup @@ -73,6 +70,8 @@ :use-module (skribilo vars) :use-module (srfi srfi-1) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) ;; date + :use-module (oop goops) :use-module (ice-9 optargs)) @@ -81,11 +80,20 @@ ;;; ;;; NEW ;;; + +(define %types-module (resolve-module '(skribilo types))) + (define-macro (new class . parameters) - `(make ,(string->symbol (format #f "<~a>" class)) - ,@(apply append (map (lambda (x) - `(,(symbol->keyword (car x)) ,(cadr x))) - parameters)))) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo types)' in order to make use of `new'. + (let* ((class-name (symbol-append '< class '>)) + (actual-class (module-ref %types-module class-name))) + `(let ((make ,make) + (,class-name ,actual-class)) + (make ,class-name + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))))) ;;; ;;; DEFINE-MARKUP @@ -387,3 +395,9 @@ (define-macro (when condition . exprs) `(if ,condition (begin ,@exprs))) + +(define (date) + (s19:date->string (s19:current-date) "~c")) + + +;;; lib.scm ends here diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 1a8f622..bb0c5ad 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -42,7 +42,6 @@ '((srfi srfi-1) ;; lists (srfi srfi-13) ;; strings ;(srfi srfi-19) ;; date and time - (oop goops) ;; `make' (ice-9 optargs) ;; `define*' (ice-9 and-let-star) ;; `and-let*' (ice-9 receive) ;; `receive' @@ -60,9 +59,13 @@ (skribilo output) (skribilo evaluator) (skribilo color) - (skribilo debug))) + (skribilo debug) + (skribilo source) ;; `source-read-lines', `source-fontify', etc. + (skribilo coloring lisp) ;; `skribe', `scheme', `lisp' + (skribilo coloring xml) ;; `xml' + )) -(define *skribe-core-modules* +(define %skribe-core-modules '("utils" "api" "bib" "index" "param" "sui")) (define-macro (define-skribe-module name . options) @@ -81,7 +84,7 @@ ,(string->symbol mod)))) (and (not (equal? m name)) m))) - *skribe-core-modules*))))) + %skribe-core-modules))))) ;; Make it available to the top-level module. @@ -106,7 +109,7 @@ execution of Skribilo/Skribe code." (map (lambda (mod) `(skribilo skribe ,(string->symbol mod))) - *skribe-core-modules*))) + %skribe-core-modules))) (set-module-name! the-module '(skribilo-user)) the-module)) @@ -152,7 +155,7 @@ hierarchy and in @code{(run-time-module)}." (module-use! (run-time-module) (resolve-module `(skribilo skribe ,(string->symbol mod))))) - *skribe-core-modules*)) + %skribe-core-modules)) ;;; module.scm ends here diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm index d66b3b4..34528ac 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/skribe/api.scm @@ -274,8 +274,8 @@ (new unresolved (proc (lambda (n e env) (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) + 'footnote #t)))))) + ,@(the-options opts :ident :class)))) (body (the-body opts)))) ;*---------------------------------------------------------------------*/ @@ -466,9 +466,9 @@ "start line > stop line" (format #f "~a/~a" start stop))) ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) + (skribe-error 'source "illegal language" language)) ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) + (skribe-error 'source "illegal tab" tab)) (file (let ((s (if (not definition) (source-read-lines file start stop tab) @@ -489,7 +489,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (language #!key name (fontifier #f) (extractor #f)) (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") + (skribe-type-error 'language "illegal name" name "string") (new language (name name) (fontifier fontifier) diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index c682687..e03deae 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,7 +1,8 @@ ;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; source.scm -- Highlighting source files. ;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; Copyright © 2005 Ludovic Courtès ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -19,24 +20,16 @@ ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. ;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 3-Sep-2003 12:22 (eg) -;;;; Last file update: 27-Oct-2004 20:09 (eg) -;;;; (define-module (skribilo source) :export (source-read-lines source-read-definition source-fontify) - :use-module (skribilo vars)) - - -;; Temporary solution -(define (language-extractor lang) - (slot-ref lang 'extractor)) + :use-module (skribilo types) + :use-module (skribilo vars) + :use-module (skribilo lib) + :use-module (ice-9 rdelim)) -(define (language-fontifier lang) - (slot-ref lang 'fontifier)) ;*---------------------------------------------------------------------*/ @@ -172,7 +165,7 @@ (if (= i j) (reverse! r) (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) + ((char=? (string-ref str i) #\newline) (loop (+ i 1) (+ i 1) (if (= i j) @@ -180,7 +173,7 @@ (cons* 'eol (substring str j i) r)))) ((and (char=? (string-ref str i) #\cr) (< (+ i 1) l) - (char=? (string-ref str (+ i 1)) #\Newline)) + (char=? (string-ref str (+ i 1)) #\newline)) (loop (+ i 2) (+ i 2) (if (= i j) diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index c6188b6..ac1edc4 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -43,7 +43,7 @@ container-ident container-body document? document-ident document-body document-options document-end - language? + language? language-extractor language-fontifier location? ast-location location-file location-line location-pos @@ -283,8 +283,8 @@ ;;; ====================================================================== (define-class () (name :init-keyword :name :init-value #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-value #f :getter langage-extractor)) + (fontifier :init-keyword :fontifier :init-value #f :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f :getter language-extractor)) (define (language? obj) (is-a? obj )) -- cgit v1.2.3