From 19dffc6bdf3c048312352f2f702dc18c9afb88e6 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 11 Oct 2006 07:30:01 +0000 Subject: slide: Propagate the `outline?' parameter in `slide-(sub)?topic'. * src/guile/skribilo/package/slide.scm (slide-topic): Propagate the `outline?' parameter as an option. (slide-subtopic): Likewise. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-60 --- src/guile/skribilo/package/slide.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index 380fdc5..7f731e3 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -232,7 +232,8 @@ (markup 'slide-topic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-topic)))) - (options (the-options opt)) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) (body (the-body opt)))) ;*---------------------------------------------------------------------*/ @@ -245,7 +246,8 @@ (markup 'slide-subtopic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-subtopic)))) - (options (the-options opt)) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) (body (the-body opt)))) -- cgit v1.2.3 From f648eb505cd7a63af01f2fdfed4a269014e2f9da Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 11 Oct 2006 07:39:58 +0000 Subject: Lout engine: Honor `date-line' for slides. * src/guile/skribilo/engine/lout.scm (document): Honor `date-line' for `slides' (was only honored for `report'). git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-61 --- src/guile/skribilo/engine/lout.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 893ab2e..f087d55 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -1051,23 +1051,25 @@ (output institution e) (printf " }\n")))))))) + (if (memq doc-type '(report slides)) + (let ((date-line (engine-custom e 'date-line))) + (display " @DateLine { ") + (if (or (string? date-line) (ast? date-line)) + (output date-line e) + (display (if date-line "Yes" "No"))) + (display " }\n"))) + ;; Lout reports make it possible to choose whether to prepend ;; a cover sheet (books and docs don't). Same for a date ;; line. (if (eq? doc-type 'report) (let ((cover-sheet? (engine-custom e 'cover-sheet?)) - (date-line (engine-custom e 'date-line)) (abstract (engine-custom e 'abstract)) (abstract-title (engine-custom e 'abstract-title))) (display (string-append " @CoverSheet { " (if cover-sheet? "Yes" "No") " }\n")) - (display " @DateLine { ") - (if (string? date-line) - (output date-line e) - (display (if date-line "Yes" "No"))) - (display " }\n") (if abstract (begin -- cgit v1.2.3 From d4360259d60722eaa175a483f792fce7b8c66d97 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 11 Oct 2006 07:43:47 +0000 Subject: slide: Propagate the `outline?' parameter in `slide-(sub)?topic'. * src/guile/skribilo/package/slide.scm (slide-topic): Propagate the `outline?' parameter as an option. (slide-subtopic): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1 --- .arch-inventory | 4 + AUTHORS | 9 + COPYING | 340 ++ ChangeLog | 3508 +++++++++++++++++++++ ChangeLog.Skribe | 698 ++++ LICENSE | 25 - Makefile | 131 - Makefile.am | 1 + NEWS | 12 + README.java | 36 - arch-config | 5 + bin/skribe.bigloo | Bin 412304 -> 0 bytes bin/skribebibtex.bigloo | Bin 36696 -> 0 bytes configure | 124 - configure.ac | 57 + doc/COPYING | 1 + doc/Makefile | 233 -- doc/Makefile.am | 1 + doc/dir/Makefile.am | 3 + doc/dir/dir.skb | 31 +- doc/img/Makefile.am | 3 + doc/img/bsd.gif | Bin 4226 -> 0 bytes doc/img/bsd.png | Bin 0 -> 4162 bytes doc/img/lambda.gif | Bin 169 -> 0 bytes doc/img/lambda.png | Bin 0 -> 222 bytes doc/img/linux.gif | Bin 1972 -> 0 bytes doc/img/linux.png | Bin 0 -> 1928 bytes doc/modules/Makefile.am | 3 + doc/modules/skribilo/Makefile.am | 3 + doc/modules/skribilo/documentation/Makefile.am | 3 + doc/modules/skribilo/documentation/api.scm | 623 ++++ doc/modules/skribilo/documentation/env.scm | 47 + doc/modules/skribilo/documentation/extension.scm | 111 + doc/modules/skribilo/documentation/manual.scm | 328 ++ doc/skr/api.skr | 575 ---- doc/skr/env.skr | 32 - doc/skr/extension.skr | 95 - doc/skr/manual.skr | 281 -- doc/user/.arch-inventory | 4 + doc/user/Makefile.am | 42 + doc/user/bib.skb | 63 +- doc/user/char.skb | 38 +- doc/user/colframe.skb | 29 +- doc/user/document.skb | 35 +- doc/user/emacs.skb | 31 +- doc/user/engine.skb | 45 +- doc/user/enumeration.skb | 29 +- doc/user/eq.skb | 79 + doc/user/examples.skb | 29 +- doc/user/figure.skb | 39 +- doc/user/font.skb | 29 +- doc/user/footnote.skb | 35 +- doc/user/htmle.skb | 36 +- doc/user/image.skb | 33 +- doc/user/index.skb | 31 +- doc/user/justify.skb | 29 +- doc/user/latexe.skb | 33 +- doc/user/lib.skb | 77 +- doc/user/line.skb | 29 +- doc/user/links.skb | 43 +- doc/user/markup.skb | 31 +- doc/user/ornament.skb | 29 +- doc/user/package.skb | 41 +- doc/user/pie.skb | 71 + doc/user/prgm.skb | 29 +- doc/user/sectioning.skb | 31 +- doc/user/skribe-config.skb | 51 +- doc/user/skribec.skb | 37 +- doc/user/skribeinfo.skb | 29 +- doc/user/slide.skb | 132 +- doc/user/src/Makefile.am | 11 + doc/user/src/api14.skb | 2 +- doc/user/src/api16.skb | 10 +- doc/user/src/api2.skb | 2 +- doc/user/src/api20-html.skb | 2 + doc/user/src/api20-lout.skb | 2 + doc/user/src/api20.skb | 2 - doc/user/src/bib1.sbib | 2 + doc/user/src/eq1.skb | 6 + doc/user/src/eq2.skb | 3 + doc/user/src/links1.skb | 2 +- doc/user/src/pie1.skb | 13 + doc/user/src/pie2.skb | 14 + doc/user/src/slides.skb | 34 +- doc/user/src/start3.skb | 4 +- doc/user/src/start4.skb | 8 +- doc/user/src/start5.skb | 2 +- doc/user/start.skb | 46 +- doc/user/syntax.skb | 29 +- doc/user/table.skb | 30 +- doc/user/toc.skb | 30 +- doc/user/user.skb | 106 +- doc/user/xmle.skb | 41 +- emacs/Makefile | 55 - etc/ChangeLog | 698 ---- etc/Makefile | 50 - etc/Makefile.config | 9 - etc/bigloo/Makefile | 114 - etc/bigloo/Makefile.skb | 158 - etc/bigloo/Makefile.tpl | 200 -- etc/bigloo/autoconf/Makefile | 53 - etc/bigloo/autoconf/bfildir | 36 - etc/bigloo/autoconf/blibdir | 36 - etc/bigloo/autoconf/bversion | 42 - etc/bigloo/autoconf/getbversion | 36 - etc/bigloo/autoconf/gmaketest | 38 - etc/bigloo/configure | 552 ---- etc/config | 4 - etc/skribe-config | 64 - etc/skribe-config.in | 64 - etc/stklos/Makefile.config.in | 5 - etc/stklos/Makefile.in | 44 - etc/stklos/Makefile.skb.in | 5 - etc/stklos/configure | 830 ----- etc/stklos/configure.in | 57 - examples/Makefile | 48 - examples/slide/Makefile | 153 - skr/Makefile | 43 - skr/acmproc.skr | 155 - skr/base.skr | 464 --- skr/context.skr | 1380 -------- skr/french.skr | 19 - skr/html.skr | 2251 ------------- skr/html4.skr | 165 - skr/jfp.skr | 317 -- skr/latex-simple.skr | 101 - skr/latex.skr | 1780 ----------- 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 - skr/xml.skr | 111 - 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/.arch-inventory | 4 + src/Makefile | 41 - src/Makefile.am | 4 + 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 | 281 -- 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 | 1243 -------- 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/guile/Makefile.am | 5 + src/guile/README | 63 + src/guile/skribilo.scm | 480 +++ src/guile/skribilo/.arch-inventory | 5 + src/guile/skribilo/Makefile.am | 10 + src/guile/skribilo/ast.scm | 602 ++++ src/guile/skribilo/biblio.scm | 382 +++ src/guile/skribilo/biblio/Makefile.am | 4 + src/guile/skribilo/biblio/abbrev.scm | 170 + src/guile/skribilo/biblio/author.scm | 136 + src/guile/skribilo/biblio/bibtex.scm | 83 + src/guile/skribilo/color.scm | 621 ++++ src/guile/skribilo/coloring/Makefile.am | 16 + src/guile/skribilo/coloring/c-lex.l | 67 + src/guile/skribilo/coloring/c-lex.l.scm | 1225 +++++++ src/guile/skribilo/coloring/c.scm | 93 + src/guile/skribilo/coloring/lisp-lex.l | 86 + src/guile/skribilo/coloring/lisp-lex.l.scm | 1249 ++++++++ src/guile/skribilo/coloring/lisp.scm | 302 ++ src/guile/skribilo/coloring/xml-lex.l | 64 + src/guile/skribilo/coloring/xml-lex.l.scm | 1221 +++++++ src/guile/skribilo/coloring/xml.scm | 82 + src/guile/skribilo/condition.scm | 171 + src/guile/skribilo/config.scm.in | 20 + src/guile/skribilo/debug.scm | 168 + src/guile/skribilo/engine.scm | 390 +++ src/guile/skribilo/engine/Makefile.am | 5 + src/guile/skribilo/engine/base.scm | 479 +++ src/guile/skribilo/engine/context.scm | 1382 ++++++++ src/guile/skribilo/engine/html.scm | 2313 ++++++++++++++ src/guile/skribilo/engine/html4.scm | 168 + src/guile/skribilo/engine/latex-simple.scm | 103 + src/guile/skribilo/engine/latex.scm | 1784 +++++++++++ src/guile/skribilo/engine/lout.scm | 2891 +++++++++++++++++ src/guile/skribilo/engine/xml.scm | 115 + src/guile/skribilo/evaluator.scm | 203 ++ src/guile/skribilo/index.scm | 170 + src/guile/skribilo/lib.scm | 239 ++ src/guile/skribilo/location.scm | 69 + src/guile/skribilo/module.scm | 153 + src/guile/skribilo/output.scm | 228 ++ src/guile/skribilo/package/Makefile.am | 7 + src/guile/skribilo/package/acmproc.scm | 164 + src/guile/skribilo/package/base.scm | 1410 +++++++++ src/guile/skribilo/package/eq.scm | 439 +++ src/guile/skribilo/package/eq/Makefile.am | 4 + src/guile/skribilo/package/eq/lout.scm | 217 ++ src/guile/skribilo/package/french.scm | 30 + src/guile/skribilo/package/jfp.scm | 328 ++ src/guile/skribilo/package/letter.scm | 157 + src/guile/skribilo/package/lncs.scm | 158 + src/guile/skribilo/package/pie.scm | 314 ++ src/guile/skribilo/package/pie/Makefile.am | 4 + src/guile/skribilo/package/pie/lout.scm | 132 + src/guile/skribilo/package/scribe.scm | 240 ++ src/guile/skribilo/package/sigplan.scm | 166 + src/guile/skribilo/package/skribe.scm | 85 + src/guile/skribilo/package/slide.scm | 274 ++ src/guile/skribilo/package/slide/Makefile.am | 4 + src/guile/skribilo/package/slide/base.scm | 185 ++ src/guile/skribilo/package/slide/html.scm | 144 + src/guile/skribilo/package/slide/latex.scm | 394 +++ src/guile/skribilo/package/slide/lout.scm | 151 + src/guile/skribilo/package/web-article.scm | 241 ++ src/guile/skribilo/package/web-book.scm | 121 + src/guile/skribilo/parameters.scm | 88 + src/guile/skribilo/prog.scm | 220 ++ src/guile/skribilo/reader.scm | 106 + src/guile/skribilo/reader/Makefile.am | 2 + src/guile/skribilo/reader/outline.scm | 426 +++ src/guile/skribilo/reader/skribe.scm | 113 + src/guile/skribilo/resolve.scm | 296 ++ src/guile/skribilo/source.scm | 208 ++ src/guile/skribilo/sui.scm | 199 ++ src/guile/skribilo/utils/Makefile.am | 5 + src/guile/skribilo/utils/compat.scm | 309 ++ src/guile/skribilo/utils/files.scm | 55 + src/guile/skribilo/utils/images.scm | 99 + src/guile/skribilo/utils/keywords.scm | 99 + src/guile/skribilo/utils/strings.scm | 145 + src/guile/skribilo/utils/syntax.scm | 81 + src/guile/skribilo/verify.scm | 160 + src/guile/skribilo/writer.scm | 261 ++ src/skribe-config.in | 64 + src/skribilo.in | 40 + 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 - tools/Makefile | 60 - tools/skribebibtex/bigloo/Makefile | 70 - tools/skribebibtex/bigloo/main.scm | 44 - tools/skribebibtex/bigloo/skribebibtex.scm | 385 --- tools/skribebibtex/stklos/Makefile | 62 - tools/skribebibtex/stklos/bibtex-lex.l | 2 +- tools/skribebibtex/stklos/bibtex-parser.y | 2 +- tools/skribebibtex/stklos/main.stk | 2 +- 505 files changed, 33365 insertions(+), 61640 deletions(-) create mode 100644 .arch-inventory create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 ChangeLog.Skribe delete mode 100644 LICENSE delete mode 100644 Makefile create mode 100644 Makefile.am create mode 100644 NEWS delete mode 100644 README.java create mode 100644 arch-config delete mode 100755 bin/skribe.bigloo delete mode 100755 bin/skribebibtex.bigloo delete mode 100755 configure create mode 100644 configure.ac create mode 120000 doc/COPYING delete mode 100644 doc/Makefile create mode 100644 doc/Makefile.am create mode 100644 doc/dir/Makefile.am create mode 100644 doc/img/Makefile.am delete mode 100644 doc/img/bsd.gif create mode 100644 doc/img/bsd.png delete mode 100644 doc/img/lambda.gif create mode 100644 doc/img/lambda.png delete mode 100644 doc/img/linux.gif create mode 100644 doc/img/linux.png create mode 100644 doc/modules/Makefile.am create mode 100644 doc/modules/skribilo/Makefile.am create mode 100644 doc/modules/skribilo/documentation/Makefile.am create mode 100644 doc/modules/skribilo/documentation/api.scm create mode 100644 doc/modules/skribilo/documentation/env.scm create mode 100644 doc/modules/skribilo/documentation/extension.scm create mode 100644 doc/modules/skribilo/documentation/manual.scm delete mode 100644 doc/skr/api.skr delete mode 100644 doc/skr/env.skr delete mode 100644 doc/skr/extension.skr delete mode 100644 doc/skr/manual.skr create mode 100644 doc/user/.arch-inventory create mode 100644 doc/user/Makefile.am create mode 100644 doc/user/eq.skb create mode 100644 doc/user/pie.skb create mode 100644 doc/user/src/Makefile.am create mode 100644 doc/user/src/api20-html.skb create mode 100644 doc/user/src/api20-lout.skb delete mode 100644 doc/user/src/api20.skb create mode 100644 doc/user/src/eq1.skb create mode 100644 doc/user/src/eq2.skb create mode 100644 doc/user/src/pie1.skb create mode 100644 doc/user/src/pie2.skb delete mode 100644 emacs/Makefile delete mode 100644 etc/ChangeLog delete mode 100644 etc/Makefile delete mode 100644 etc/Makefile.config delete mode 100644 etc/bigloo/Makefile delete mode 100644 etc/bigloo/Makefile.skb delete mode 100644 etc/bigloo/Makefile.tpl delete mode 100644 etc/bigloo/autoconf/Makefile delete mode 100755 etc/bigloo/autoconf/bfildir delete mode 100755 etc/bigloo/autoconf/blibdir delete mode 100755 etc/bigloo/autoconf/bversion delete mode 100755 etc/bigloo/autoconf/getbversion delete mode 100755 etc/bigloo/autoconf/gmaketest delete mode 100755 etc/bigloo/configure delete mode 100644 etc/config delete mode 100644 etc/skribe-config delete mode 100644 etc/skribe-config.in delete mode 100644 etc/stklos/Makefile.config.in delete mode 100644 etc/stklos/Makefile.in delete mode 100644 etc/stklos/Makefile.skb.in delete mode 100755 etc/stklos/configure delete mode 100644 etc/stklos/configure.in delete mode 100644 examples/Makefile delete mode 100644 examples/slide/Makefile delete mode 100644 skr/Makefile delete mode 100644 skr/acmproc.skr delete mode 100644 skr/base.skr delete mode 100644 skr/context.skr delete mode 100644 skr/french.skr delete mode 100644 skr/html.skr delete mode 100644 skr/html4.skr delete mode 100644 skr/jfp.skr delete mode 100644 skr/latex-simple.skr delete mode 100644 skr/latex.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 skr/xml.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/.arch-inventory delete mode 100644 src/Makefile create mode 100644 src/Makefile.am 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 create mode 100644 src/guile/Makefile.am create mode 100644 src/guile/README create mode 100644 src/guile/skribilo.scm create mode 100644 src/guile/skribilo/.arch-inventory create mode 100644 src/guile/skribilo/Makefile.am create mode 100644 src/guile/skribilo/ast.scm create mode 100644 src/guile/skribilo/biblio.scm create mode 100644 src/guile/skribilo/biblio/Makefile.am create mode 100644 src/guile/skribilo/biblio/abbrev.scm create mode 100644 src/guile/skribilo/biblio/author.scm create mode 100644 src/guile/skribilo/biblio/bibtex.scm create mode 100644 src/guile/skribilo/color.scm create mode 100644 src/guile/skribilo/coloring/Makefile.am create mode 100644 src/guile/skribilo/coloring/c-lex.l create mode 100644 src/guile/skribilo/coloring/c-lex.l.scm create mode 100644 src/guile/skribilo/coloring/c.scm create mode 100644 src/guile/skribilo/coloring/lisp-lex.l create mode 100644 src/guile/skribilo/coloring/lisp-lex.l.scm create mode 100644 src/guile/skribilo/coloring/lisp.scm create mode 100644 src/guile/skribilo/coloring/xml-lex.l create mode 100644 src/guile/skribilo/coloring/xml-lex.l.scm create mode 100644 src/guile/skribilo/coloring/xml.scm create mode 100644 src/guile/skribilo/condition.scm create mode 100644 src/guile/skribilo/config.scm.in create mode 100644 src/guile/skribilo/debug.scm create mode 100644 src/guile/skribilo/engine.scm create mode 100644 src/guile/skribilo/engine/Makefile.am create mode 100644 src/guile/skribilo/engine/base.scm create mode 100644 src/guile/skribilo/engine/context.scm create mode 100644 src/guile/skribilo/engine/html.scm create mode 100644 src/guile/skribilo/engine/html4.scm create mode 100644 src/guile/skribilo/engine/latex-simple.scm create mode 100644 src/guile/skribilo/engine/latex.scm create mode 100644 src/guile/skribilo/engine/lout.scm create mode 100644 src/guile/skribilo/engine/xml.scm create mode 100644 src/guile/skribilo/evaluator.scm create mode 100644 src/guile/skribilo/index.scm create mode 100644 src/guile/skribilo/lib.scm create mode 100644 src/guile/skribilo/location.scm create mode 100644 src/guile/skribilo/module.scm create mode 100644 src/guile/skribilo/output.scm 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/base.scm create mode 100644 src/guile/skribilo/package/eq.scm create mode 100644 src/guile/skribilo/package/eq/Makefile.am create mode 100644 src/guile/skribilo/package/eq/lout.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/pie.scm create mode 100644 src/guile/skribilo/package/pie/Makefile.am create mode 100644 src/guile/skribilo/package/pie/lout.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/slide/Makefile.am create mode 100644 src/guile/skribilo/package/slide/base.scm create mode 100644 src/guile/skribilo/package/slide/html.scm create mode 100644 src/guile/skribilo/package/slide/latex.scm create mode 100644 src/guile/skribilo/package/slide/lout.scm create mode 100644 src/guile/skribilo/package/web-article.scm create mode 100644 src/guile/skribilo/package/web-book.scm create mode 100644 src/guile/skribilo/parameters.scm create mode 100644 src/guile/skribilo/prog.scm create mode 100644 src/guile/skribilo/reader.scm create mode 100644 src/guile/skribilo/reader/Makefile.am create mode 100644 src/guile/skribilo/reader/outline.scm create mode 100644 src/guile/skribilo/reader/skribe.scm create mode 100644 src/guile/skribilo/resolve.scm create mode 100644 src/guile/skribilo/source.scm create mode 100644 src/guile/skribilo/sui.scm create mode 100644 src/guile/skribilo/utils/Makefile.am create mode 100644 src/guile/skribilo/utils/compat.scm create mode 100644 src/guile/skribilo/utils/files.scm create mode 100644 src/guile/skribilo/utils/images.scm create mode 100644 src/guile/skribilo/utils/keywords.scm create mode 100644 src/guile/skribilo/utils/strings.scm create mode 100644 src/guile/skribilo/utils/syntax.scm create mode 100644 src/guile/skribilo/verify.scm create mode 100644 src/guile/skribilo/writer.scm create mode 100644 src/skribe-config.in create mode 100755 src/skribilo.in 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 delete mode 100644 tools/Makefile delete mode 100644 tools/skribebibtex/bigloo/Makefile delete mode 100644 tools/skribebibtex/bigloo/main.scm delete mode 100644 tools/skribebibtex/bigloo/skribebibtex.scm delete mode 100644 tools/skribebibtex/stklos/Makefile diff --git a/.arch-inventory b/.arch-inventory new file mode 100644 index 0000000..5dfe4f9 --- /dev/null +++ b/.arch-inventory @@ -0,0 +1,4 @@ +# Files generated by Autoconf, Automake and Libtool. +precious ^(aclocal\.m4|autom4te\.cache|compile|config\.(cache|guess|log|status|sub)|configure|install-sh|missing|mkinstalldirs)$ + +# arch-tag: d42970d8-c42f-423e-a3d5-785e10cce49b diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..640bc1d --- /dev/null +++ b/AUTHORS @@ -0,0 +1,9 @@ +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, and in particular mostly code +by Erick from the STkLos implementation. The port to GNU Guile 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..c805653 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3508 @@ +# do not edit -- automatically generated by arch changelog +# arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 +# + +2006-09-04 09:15:58 GMT Ludovic Courtes patch-74 + + Summary: + `base' package: Removed more sources of duplicate identifiers. + Revision: + skribilo--devel--1.2--patch-74 + + * src/guile/skribilo/package/base.scm (~): Use `gensym' to produce unique + identifiers. + (ref)[unref]: Likewise. + [handle-ref]: Likewise. + [do-title-ref]: Likewise. + [mark-ref]: Likewise. + [make-bib-ref]: Likewise. + [line-ref]: Likewise. + + modified files: + ChangeLog src/guile/skribilo/package/base.scm + + +2006-09-03 15:08:10 GMT Ludovic Courtes patch-73 + + Summary: + Added error conditions in `ast.scm'. + Revision: + skribilo--devel--1.2--patch-73 + + * src/guile/skribilo/ast.scm: Use `srfi-3[45]' and `condition' but not + `lib'. + (&ast-error): New. + (&ast-orphan-error): New. + (&ast-cycle-error): New. + (&markup-unknown-option-error): New. + (&markup-already-bound-error): New. + (handle-ast-error): New. + (markup-option): Use `raise' instead of `skribe-(type-)?error'. + (markup-option-set!): Likewise. + (markup-option-add!): Likewise. + (markup-parent): Likewise. + (document-bind-node!): Likewise. + (find1-down): Likewise. + + * src/guile/skribilo/resolve.scm (&resolution-error): Removed. + (&resolution-orphan-error): Removed. Moved as `&ast-orphan-error' in + `ast.scm'. Updated users. + + modified files: + ChangeLog src/guile/skribilo/ast.scm + src/guile/skribilo/resolve.scm + + +2006-09-03 11:25:37 GMT Ludovic Courtes patch-72 + + Summary: + Implemented per-document node identifiers. + Revision: + skribilo--devel--1.2--patch-72 + + * src/guile/skribilo/ast.scm: Autoload `srfi-1' on `fold'. + (*node-table*): Removed. + (bind-markup!): Removed. + (initialize): Removed. + (find-markups): Removed. + (write): Commented out debugging `format'. + ()[node-table]: New slot. + [nodes-bound?]: New slot. + (document-lookup-node): New. + (document-bind-node!): New. + (document-bind-nodes!): New. + (ast-fold): New. + (find-markup-ident): Removed. + + * src/guile/skribilo/output.scm (*document-being-output*): New. + (out): New. + + * src/guile/skribilo/resolve.scm (*document-being-resolved*): New. + (resolve!): Invoke `document-bind-nodes!' before resolving the + document. + (do-resolve!): Parameterize `*document-being-resolved*'. + (resolve-ident): Use `document-lookup-node' instead of `find-markups'. + + * src/guile/skribilo/utils/compat.scm (bind-markup!): New. + (find-markups): New. + (find-markup-ident): New. + + modified files: + ChangeLog src/guile/skribilo/ast.scm + src/guile/skribilo/output.scm src/guile/skribilo/resolve.scm + src/guile/skribilo/utils/compat.scm + + +2006-09-03 10:49:42 GMT Ludovic Courtes patch-71 + + Summary: + Doc: Various fixes (non-unique idents, dangling refs). + Revision: + skribilo--devel--1.2--patch-71 + + * doc/modules/skribilo/documentation/api.scm (doc-markup): Added an + `ident' argument, use it. + + * doc/user/package.skb (Articles): Differentiate the identifiers for the + various `abstract' markups. + + * doc/user/Makefile.am (skribilo): Look for it in `$(top_builddir)' + rather than `$(top_srcdir)'. + + * doc/user/markup.skb (Standard Markups): Added an identifier. + + * doc/user/src/links1.skb: When referring to `Standard Markups' by + identifier, use its current identifier (`std-markups'). + + modified files: + ChangeLog doc/modules/skribilo/documentation/api.scm + doc/user/Makefile.am doc/user/markup.skb doc/user/package.skb + doc/user/src/links1.skb + + +2006-09-03 10:36:42 GMT Ludovic Courtes patch-70 + + Summary: + Removed sources of non-unique node identifiers. + Revision: + skribilo--devel--1.2--patch-70 + + * src/guile/skribilo/prog.scm (make-prog-body): Use `gensym' to create an + identifier instead of `(int->str lnum cs)'. + (make-line-mark): Take that identifier. + + * src/guile/skribilo/package/base.scm (mark): Use `gensym' to create an + identifier rather than BS. + (ref)[bib-ref]: Likewise. + [url-ref]: Likewise. + + modified files: + ChangeLog src/guile/skribilo/package/base.scm + src/guile/skribilo/prog.scm + + +2006-09-01 20:50:54 GMT Ludovic Courtes patch-69 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-69 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 48-54) + + - Tiny Arch inventory fix. + - Doc: Converted GIF images to PNG. + - Added a GPL header to the documentation files (license confirmed by + Manuel Serrano). + - Removed `tools/skribebibtex/bigloo'. + - Removed the `etc' directory, kept `ChangeLog' and `skribe-config.in'. + - Updated the project URL. :-) + - Turned `doc/skr' into `doc/modules', `skribe-load' into `use-modules'. + + new files: + doc/.arch-ids/COPYING.id doc/COPYING + doc/img/.arch-ids/bsd.png.id doc/img/.arch-ids/lambda.png.id + doc/img/.arch-ids/linux.png.id doc/img/bsd.png + doc/img/lambda.png doc/img/linux.png doc/modules/Makefile.am + doc/modules/skribilo/.arch-ids/=id + doc/modules/skribilo/Makefile.am + doc/modules/skribilo/documentation/.arch-ids/=id + + removed files: + doc/img/.arch-ids/bsd.gif.id doc/img/.arch-ids/lambda.gif.id + doc/img/.arch-ids/linux.gif.id doc/img/bsd.gif + doc/img/lambda.gif doc/img/linux.gif etc/.arch-ids/=id + etc/.arch-ids/Makefile.config.id etc/.arch-ids/config.id + etc/.arch-ids/skribe-config.id etc/Makefile.config + etc/bigloo/.arch-ids/=id etc/bigloo/.arch-ids/Makefile.skb.id + etc/bigloo/.arch-ids/Makefile.tpl.id + etc/bigloo/.arch-ids/configure.id etc/bigloo/Makefile.skb + etc/bigloo/Makefile.tpl etc/bigloo/autoconf/.arch-ids/=id + etc/bigloo/autoconf/.arch-ids/bfildir.id + etc/bigloo/autoconf/.arch-ids/blibdir.id + etc/bigloo/autoconf/.arch-ids/bversion.id + etc/bigloo/autoconf/.arch-ids/getbversion.id + etc/bigloo/autoconf/.arch-ids/gmaketest.id + etc/bigloo/autoconf/bfildir etc/bigloo/autoconf/blibdir + etc/bigloo/autoconf/bversion etc/bigloo/autoconf/getbversion + etc/bigloo/autoconf/gmaketest etc/bigloo/configure etc/config + etc/skribe-config etc/stklos/.arch-ids/=id + etc/stklos/.arch-ids/Makefile.config.in.id + etc/stklos/.arch-ids/Makefile.skb.in.id + etc/stklos/.arch-ids/configure.id + etc/stklos/.arch-ids/configure.in.id + etc/stklos/Makefile.config.in etc/stklos/Makefile.skb.in + etc/stklos/configure etc/stklos/configure.in + tools/skribebibtex/bigloo/.arch-ids/=id + tools/skribebibtex/bigloo/.arch-ids/main.scm.id + tools/skribebibtex/bigloo/.arch-ids/skribebibtex.scm.id + tools/skribebibtex/bigloo/main.scm + tools/skribebibtex/bigloo/skribebibtex.scm + + modified files: + ChangeLog configure.ac doc/Makefile.am doc/dir/dir.skb + doc/img/Makefile.am + doc/modules/skribilo/documentation/Makefile.am + doc/modules/skribilo/documentation/api.scm + doc/modules/skribilo/documentation/env.scm + doc/modules/skribilo/documentation/extension.scm + doc/modules/skribilo/documentation/manual.scm + doc/user/.arch-inventory doc/user/Makefile.am doc/user/bib.skb + doc/user/char.skb doc/user/colframe.skb doc/user/document.skb + doc/user/emacs.skb doc/user/engine.skb + doc/user/enumeration.skb doc/user/eq.skb doc/user/examples.skb + doc/user/figure.skb doc/user/font.skb doc/user/footnote.skb + doc/user/htmle.skb doc/user/image.skb doc/user/index.skb + doc/user/justify.skb doc/user/latexe.skb doc/user/lib.skb + doc/user/line.skb doc/user/links.skb doc/user/markup.skb + doc/user/ornament.skb doc/user/package.skb doc/user/pie.skb + doc/user/prgm.skb doc/user/sectioning.skb + doc/user/skribe-config.skb doc/user/skribec.skb + doc/user/skribeinfo.skb doc/user/slide.skb + doc/user/src/api14.skb doc/user/src/api16.skb + doc/user/start.skb doc/user/syntax.skb doc/user/table.skb + doc/user/toc.skb doc/user/user.skb doc/user/xmle.skb + src/guile/skribilo/config.scm.in + + renamed files: + doc/skr/.arch-ids/=id + ==> doc/modules/.arch-ids/=id + doc/skr/.arch-ids/api.skr.id + ==> doc/modules/skribilo/documentation/.arch-ids/api.scm.id + doc/skr/.arch-ids/env.skr.id + ==> doc/modules/skribilo/documentation/.arch-ids/env.scm.id + doc/skr/.arch-ids/extension.skr.id + ==> doc/modules/skribilo/documentation/.arch-ids/extension.scm.id + doc/skr/.arch-ids/manual.skr.id + ==> doc/modules/skribilo/documentation/.arch-ids/manual.scm.id + doc/skr/Makefile.am + ==> doc/modules/skribilo/documentation/Makefile.am + doc/skr/api.skr + ==> doc/modules/skribilo/documentation/api.scm + doc/skr/env.skr + ==> doc/modules/skribilo/documentation/env.scm + doc/skr/extension.skr + ==> doc/modules/skribilo/documentation/extension.scm + doc/skr/manual.skr + ==> doc/modules/skribilo/documentation/manual.scm + etc/.arch-ids/ChangeLog.id + ==> .arch-ids/ChangeLog.Skribe.id + etc/.arch-ids/skribe-config.in.id + ==> src/.arch-ids/skribe-config.in.id + etc/ChangeLog + ==> ChangeLog.Skribe + etc/skribe-config.in + ==> src/skribe-config.in + + new directories: + doc/modules/.arch-ids doc/modules/skribilo + doc/modules/skribilo/.arch-ids + doc/modules/skribilo/documentation + doc/modules/skribilo/documentation/.arch-ids + + removed directories: + doc/skr/.arch-ids etc etc/.arch-ids etc/bigloo + etc/bigloo/.arch-ids etc/bigloo/autoconf + etc/bigloo/autoconf/.arch-ids etc/stklos etc/stklos/.arch-ids + tools/skribebibtex/bigloo tools/skribebibtex/bigloo/.arch-ids + + renamed directories: + doc/skr + ==> doc/modules + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-48 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-49 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-50 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-51 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-52 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-53 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-54 + + +2006-08-26 15:58:53 GMT Ludovic Courtes patch-68 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-68 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 41-47) + + - Base package: use `type-name' instead of `find-runtime-type'. + - Fixed autoloading issue in `(skribilo biblio)'. + - slide: Implemented `slide-topic' and `slide-subtopic'. + - doc: Fixed index-related documentation. + - slide: Added a `:class' argument to (sub)topics. + - doc: Documented `slide-topic' and `slide-subtopic'. + - Added a GPL headers to those files that did not already have it. + + new files: + src/guile/skribilo/package/slide/base.scm + + modified files: + ChangeLog doc/user/index.skb doc/user/slide.skb + doc/user/src/slides.skb src/guile/skribilo/biblio.scm + src/guile/skribilo/engine/base.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/latex.scm + src/guile/skribilo/engine/xml.scm + src/guile/skribilo/package/acmproc.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/skribe.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/package/slide/Makefile.am + src/guile/skribilo/package/slide/html.scm + src/guile/skribilo/package/slide/lout.scm + src/guile/skribilo/package/web-article.scm + src/guile/skribilo/package/web-book.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-41 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-42 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-43 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-44 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-45 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-46 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-47 + + +2006-07-31 18:40:57 GMT Ludovic Courtes patch-67 + + Summary: + Base package: use `type-name' instead of `find-runtime-type'. + Revision: + skribilo--devel--1.2--patch-67 + + * src/guile/skribilo/package/base.scm (parse-list-of): Use `type-name' + instead of `find-runtime-type'. + + modified files: + ChangeLog src/guile/skribilo/package/base.scm + + +2006-07-31 16:52:59 GMT Ludovic Courtes patch-66 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-66 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 35-40) + + - Introduced `type-name' as a replacement for `find-runtime-type'. + - Made the HTML class naming more consistent. + - Fixed autoloading in `(skribilo package base)'. + - HTML: Repeat document keywords in each file. + - Removed `(skribilo skribe param)' (was useless). + - Moved the `sui' module; removed the `skribe' subdirectory. + + removed files: + src/guile/skribilo/skribe/.arch-ids/=id + src/guile/skribilo/skribe/.arch-ids/Makefile.am.id + src/guile/skribilo/skribe/.arch-ids/param.scm.id + src/guile/skribilo/skribe/Makefile.am + src/guile/skribilo/skribe/param.scm + + modified files: + ChangeLog configure.ac src/guile/skribilo.scm + src/guile/skribilo/Makefile.am + src/guile/skribilo/engine/html.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/module.scm + src/guile/skribilo/package/base.scm src/guile/skribilo/sui.scm + + renamed files: + src/guile/skribilo/skribe/.arch-ids/sui.scm.id + ==> src/guile/skribilo/.arch-ids/sui.scm.id + src/guile/skribilo/skribe/sui.scm + ==> src/guile/skribilo/sui.scm + + removed directories: + src/guile/skribilo/skribe src/guile/skribilo/skribe/.arch-ids + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-35 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-36 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-37 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-38 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-39 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-40 + + +2006-07-30 11:35:52 GMT Ludovic Courtes patch-65 + + Summary: + Introduced `type-name' as a replacement for `find-runtime-type'. + Revision: + skribilo--devel--1.2--patch-65 + + * src/guile/skribilo/lib.scm (type-name): New (formerly + `find-runtime-type'). + + * src/guile/skribilo/utils/compat.scm (find-runtime-type): New. + + modified files: + ChangeLog src/guile/skribilo/lib.scm + src/guile/skribilo/utils/compat.scm + + +2006-07-28 18:29:50 GMT Ludovic Courtes patch-64 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-64 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 22-34) + + - Fixed `engine-add-writer!' so that the insertion order is kept. + - Improved error reporting of the Skribilo module reader. + - Added a pie-chart package that can use either Ploticus or Lout. + - Updated Automake/Autoconf files for the `pie' package. + - Detect Ploticus at configuration-time and decide how to build the doc. + - Reverted patch-22 (was wrong). + - Added before the introduction of the User Manual. + - Updated the FSF address. + - Lout engine: Fixed handling of `:keywords' for `document'. + - pie: Fixed the Lout engine. + - Moved `skribe/api.scm' to `(skribilo package base)'. + - Moved `(skribilo skribe index)' to `(skribilo index)'. + - Fixed `ref' for references by title (`:chapter', `:section', etc.). + + new files: + src/guile/skribilo/package/pie/Makefile.am + + modified files: + ChangeLog configure.ac doc/skr/api.skr doc/user/Makefile.am + doc/user/bib.skb doc/user/eq.skb doc/user/links.skb + doc/user/pie.skb doc/user/sectioning.skb + doc/user/src/Makefile.am doc/user/user.skb + src/guile/skribilo.scm src/guile/skribilo/ast.scm + src/guile/skribilo/biblio.scm + src/guile/skribilo/biblio/abbrev.scm + src/guile/skribilo/biblio/author.scm + src/guile/skribilo/biblio/bibtex.scm + src/guile/skribilo/color.scm + src/guile/skribilo/coloring/c-lex.l + src/guile/skribilo/coloring/c-lex.l.scm + src/guile/skribilo/coloring/c.scm + src/guile/skribilo/coloring/lisp-lex.l + src/guile/skribilo/coloring/lisp-lex.l.scm + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/coloring/xml-lex.l + src/guile/skribilo/coloring/xml-lex.l.scm + src/guile/skribilo/condition.scm src/guile/skribilo/debug.scm + src/guile/skribilo/engine.scm + src/guile/skribilo/engine/context.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/html4.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/index.scm + src/guile/skribilo/lib.scm src/guile/skribilo/location.scm + src/guile/skribilo/module.scm src/guile/skribilo/output.scm + src/guile/skribilo/package/Makefile.am + src/guile/skribilo/package/base.scm + src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + src/guile/skribilo/package/pie.scm + src/guile/skribilo/package/pie/lout.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/package/slide/html.scm + src/guile/skribilo/package/slide/latex.scm + src/guile/skribilo/package/slide/lout.scm + src/guile/skribilo/parameters.scm src/guile/skribilo/prog.scm + src/guile/skribilo/reader.scm + src/guile/skribilo/reader/outline.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/resolve.scm + src/guile/skribilo/skribe/Makefile.am + src/guile/skribilo/skribe/param.scm + src/guile/skribilo/skribe/sui.scm + src/guile/skribilo/source.scm + src/guile/skribilo/utils/compat.scm + src/guile/skribilo/utils/files.scm + src/guile/skribilo/utils/images.scm + src/guile/skribilo/utils/keywords.scm + src/guile/skribilo/utils/strings.scm + src/guile/skribilo/utils/syntax.scm + src/guile/skribilo/verify.scm src/guile/skribilo/writer.scm + src/skribilo.in tools/skribebibtex/stklos/bibtex-lex.l + tools/skribebibtex/stklos/bibtex-parser.y + tools/skribebibtex/stklos/main.stk + + renamed files: + src/guile/skribilo/skribe/.arch-ids/api.scm.id + ==> src/guile/skribilo/package/.arch-ids/base.scm.id + src/guile/skribilo/skribe/.arch-ids/index.scm.id + ==> src/guile/skribilo/.arch-ids/index.scm.id + src/guile/skribilo/skribe/api.scm + ==> src/guile/skribilo/package/base.scm + src/guile/skribilo/skribe/index.scm + ==> src/guile/skribilo/index.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-22 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-23 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-24 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-25 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-26 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-27 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-28 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-29 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-30 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-31 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-32 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-33 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-34 + + +2006-07-23 20:47:15 GMT Ludovic Courtes patch-63 + + Summary: + Added a pie-chart package that can use either Ploticus or Lout. + Revision: + skribilo--devel--1.2--patch-63 + + * doc/user/user.skb: Use the `pie' package and include `pie.skb'. + + new files: + doc/user/pie.skb doc/user/src/.arch-ids/pie1.skb.id + doc/user/src/.arch-ids/pie2.skb.id doc/user/src/pie1.skb + doc/user/src/pie2.skb src/guile/skribilo/package/pie.scm + src/guile/skribilo/package/pie/.arch-ids/=id + src/guile/skribilo/package/pie/lout.scm + + modified files: + ChangeLog doc/user/user.skb + + new directories: + src/guile/skribilo/package/pie + src/guile/skribilo/package/pie/.arch-ids + + +2006-07-23 20:36:51 GMT Ludovic Courtes patch-62 + + Summary: + Improved error reporting of the Skribilo module reader. + Revision: + skribilo--devel--1.2--patch-62 + + * src/guile/skribilo/utils/syntax.scm (%skribilo-module-reader): Improved + error reporting by showing the location of the unexpected character. + + modified files: + ChangeLog src/guile/skribilo/utils/syntax.scm + + +2006-07-23 14:38:34 GMT Ludovic Courtes patch-61 + + Summary: + Fixed `engine-add-writer!' so that the insertion order is kept. + Revision: + skribilo--devel--1.2--patch-61 + + * src/guile/skribilo/engine.scm (engine-add-writer!): Use `append' + instead of `cons' when adding a writer, so that the insertion order is + honored when lookups are performed. This fixes a generation bug (e.g., + for the first page of the User Manual) and slightly improves + performance. + + * src/guile/skribilo/writer.scm (lookup-markup-writer): Documented the + impact of registration order. + + modified files: + ChangeLog src/guile/skribilo/engine.scm + src/guile/skribilo/writer.scm + + +2006-07-23 14:11:06 GMT Ludovic Courtes patch-60 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-60 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 8-21) + + - Use `setvbuf' on the Skribilo output port. + - Made `parse-list-of' tail-recursive. + - Fixed the handling of `:' by the Skribe reader. + - compat: Optimized `hashtable->list'. + - Merged the two bibliography modules. + - Implemented `markup-body-set!'. + - Fixed abbreviations and author names handling. + - Turned `with-debug' into a more self-sufficient macro. + - Removed unused code in `(skribilo lib)'. + - Removed the `(skribilo skribe utils)' module. + - Renamed `(skribilo runtime)' to `(skribilo utils strings)'. + - biblio abbrev: Added a few more abbreviations. + - Added support for the `:keywords' option of `document' (Lout + HTML). + - Made the HTML engine and `web-book' more style-neutral. + + new files: + src/guile/skribilo/utils/keywords.scm + + removed files: + src/guile/skribilo/skribe/.arch-ids/bib.scm.id + src/guile/skribilo/skribe/.arch-ids/utils.scm.id + src/guile/skribilo/skribe/bib.scm + src/guile/skribilo/skribe/utils.scm + + modified files: + ChangeLog NEWS doc/user/document.skb doc/user/user.skb + src/guile/skribilo/Makefile.am src/guile/skribilo/ast.scm + src/guile/skribilo/biblio.scm + src/guile/skribilo/biblio/abbrev.scm + src/guile/skribilo/biblio/author.scm + src/guile/skribilo/biblio/bibtex.scm + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/debug.scm src/guile/skribilo/engine.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/lout.scm src/guile/skribilo/lib.scm + src/guile/skribilo/module.scm + src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + src/guile/skribilo/package/web-book.scm + src/guile/skribilo/skribe/Makefile.am + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/utils/Makefile.am + src/guile/skribilo/utils/compat.scm + src/guile/skribilo/utils/strings.scm + src/guile/skribilo/verify.scm + + renamed files: + src/guile/skribilo/.arch-ids/runtime.scm.id + ==> src/guile/skribilo/utils/.arch-ids/strings.scm.id + src/guile/skribilo/runtime.scm + ==> src/guile/skribilo/utils/strings.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-8 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-9 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-10 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-11 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-12 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-13 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-14 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-15 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-16 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-17 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-18 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-19 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-20 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-21 + + +2006-07-14 14:42:40 GMT Ludovic Courtes patch-59 + + Summary: + Fixed the handling of `:' by the Skribe reader. + Revision: + skribilo--devel--1.2--patch-59 + + * src/guile/skribilo/reader/skribe.scm (make-colon-free-token-reader): + New. + (%make-skribe-reader): Make sure `:' is handled only by the keyword + reader. + + modified files: + ChangeLog src/guile/skribilo/reader/skribe.scm + + +2006-07-12 16:28:29 GMT Ludovic Courtes patch-58 + + Summary: + Made `parse-list-of' tail-recursive. + Revision: + skribilo--devel--1.2--patch-58 + + * src/guile/skribilo/skribe/api.scm (parse-list-of): Made tail-recursive, + thereby fixing potential stack overflows (e.g., when building the user + manual) and perhaps slightly improving performance. + + modified files: + ChangeLog src/guile/skribilo/skribe/api.scm + + +2006-07-12 16:14:24 GMT Ludovic Courtes patch-57 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-57 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 2-7) + + - outline: Fixed the regexps of the inline markup for `tt' and `q'. + - Tiny configure fix: make `src/skribilo' executable. + - By default, use (internally) a reader that does not record positions. + - Use SRFI-35 error conditions in `resolve.scm' rather than the `error' + procedures. + - Noticeable performance improvements (notably in `debug'). + - Fixed autoloading of `verify', plus tiny cosmetic change. + + modified files: + ChangeLog configure.ac src/guile/skribilo/biblio.scm + src/guile/skribilo/debug.scm src/guile/skribilo/engine.scm + src/guile/skribilo/reader/outline.scm + src/guile/skribilo/resolve.scm + src/guile/skribilo/utils/syntax.scm + src/guile/skribilo/verify.scm src/skribilo.in + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-2 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-3 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-4 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-5 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-6 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-7 + + +2006-06-08 20:26:55 GMT Ludovic Courtes patch-56 + + Summary: + Merge from lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-56 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (base, patch 1) + + - tag of lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--version-0 + - eq: Handle operator precedence when parenthesizing. + + modified files: + ChangeLog src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--base-0 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-1 + + +2006-06-08 20:24:12 GMT Ludovic Courtes patch-55 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-55 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 84-87) + + - Added `bib-map'. + - Cleaned up the `write' method for `markup' and `unresolved' objects. + - Generalized the error condition handling framework. + - Fixed exception handling in `output.scm'. + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2- (version 0) + + - Sealing and moving to `lcourtes@laas.fr--2005-libre/skribilo--devo--1.2'. + + modified files: + ChangeLog src/guile/skribilo/ast.scm + src/guile/skribilo/biblio.scm src/guile/skribilo/condition.scm + src/guile/skribilo/output.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-84 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-85 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-86 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-87 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--version-0 + + +2006-05-10 17:14:10 GMT Ludovic Courtes patch-54 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-54 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 80-83) + + - Added `markup-option-set!'. + - eq: Fixed the rendering of `*' in the Lout implementation. + - Added `bib-for-each'. Fixed binding issues in the evaluator and compat. + - Added biblio helpers (abbrev, author, BibTeX) taken from my `biblib.skr'. + + new files: + src/guile/skribilo/biblio/.arch-ids/=id + src/guile/skribilo/biblio/Makefile.am + src/guile/skribilo/biblio/abbrev.scm + src/guile/skribilo/biblio/author.scm + src/guile/skribilo/biblio/bibtex.scm + + modified files: + ChangeLog configure.ac src/guile/skribilo/Makefile.am + src/guile/skribilo/ast.scm src/guile/skribilo/biblio.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm + src/guile/skribilo/package/eq/lout.scm + src/guile/skribilo/utils/compat.scm + + new directories: + src/guile/skribilo/biblio src/guile/skribilo/biblio/.arch-ids + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-80 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-81 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-82 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-83 + + +2006-04-23 17:28:38 GMT Ludovic Courtes patch-53 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-53 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 79) + + - eq: Added the `inline?' keyword; fixed the Lout engine. + + modified files: + ChangeLog src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-79 + + +2006-04-23 17:28:14 GMT Ludovic Courtes patch-52 + + Summary: + Use `setvbuf' on the Skribilo output port. + Revision: + skribilo--devel--1.2--patch-52 + + * src/guile/skribilo.scm (skribilo): Call `setvbuf'. + + + modified files: + ChangeLog src/guile/skribilo.scm + + +2006-04-08 10:26:51 GMT Ludovic Courtes patch-51 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-51 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 73-78) + + - Merge from lcourtes@laas.fr--2005-mobile + - Moved `convert-image' et al. to `utils/images.scm'. + - Image- and compat-related fixes. + - Lout engine: small fixes. + - Various documentation fixes + completed the doc automake stuff. + - Small aesthetic changes in the Lout engine. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + src/guile/skribilo/package/eq/lout.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-73 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-74 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-75 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-76 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-77 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-78 + + +2006-03-19 20:08:40 GMT Ludovic Courtes patch-50 + + Summary: + Various documentation fixes + completed the doc automake stuff. + Revision: + skribilo--devel--1.2--patch-50 + + * doc/user/Makefile.am (%.html): Added `-P ../img'. + (%.lout): Likewise. + (SUBDIRS): New. + + * doc/user/char.skb (Some characters): Use the Lout-specific example for + `!' when relevant. + + * doc/user/figure.skb (The figure markup): Avoid using `example-produce'. + + * doc/user/slide.skb (dummy-slide-set-output): New. + (dummy-slide-output): New. + (dummy-slide-vspace-output): New. + (dummy-slide-embed-output): New. + (Example of Skribilo Slides): Use a processor, as in `document.skb', in + order to use the dummy output functions. + + new files: + doc/dir/Makefile.am doc/img/Makefile.am doc/skr/Makefile.am + doc/user/src/.arch-ids/api20-lout.skb.id + doc/user/src/Makefile.am doc/user/src/api20-lout.skb + + removed files: + doc/html/.arch-ids/=id + + modified files: + ChangeLog configure.ac doc/Makefile.am doc/user/Makefile.am + doc/user/char.skb doc/user/figure.skb doc/user/slide.skb + doc/user/user.skb + + renamed files: + doc/user/src/.arch-ids/api20.skb.id + ==> doc/user/src/.arch-ids/api20-html.skb.id + doc/user/src/api20.skb + ==> doc/user/src/api20-html.skb + + removed directories: + doc/html doc/html/.arch-ids + + +2006-03-19 19:55:24 GMT Ludovic Courtes patch-49 + + Summary: + Lout engine: small fixes. + Revision: + skribilo--devel--1.2--patch-49 + + * src/guile/skribilo/engine/lout.scm (figure): For `@BypassNumber', make + sure NUMBER is not `#f'. + + * src/guile/skribilo/package/slide/lout.scm: Don't switch automatically + DOCUMENT-TYPE to `slides'. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + src/guile/skribilo/package/slide/lout.scm + + +2006-03-19 15:13:13 GMT Ludovic Courtes patch-48 + + Summary: + Image- and compat-related fixes. + Revision: + skribilo--devel--1.2--patch-48 + + * src/guile/skribilo/utils/images.scm: Autoload `parameters' on + `*verbose*' too. + + * src/guile/skribilo/lib.scm (skribe-read): Moved to... + + * src/guile/skribilo/utils/compat.scm: ... here. + + modified files: + ChangeLog src/guile/skribilo/lib.scm + src/guile/skribilo/utils/compat.scm + src/guile/skribilo/utils/images.scm + + +2006-03-18 18:12:00 GMT Ludovic Courtes patch-47 + + Summary: + Moved `convert-image' et al. to `utils/images.scm'. + Revision: + skribilo--devel--1.2--patch-47 + + * src/guile/skribilo/runtime.scm: Moved image-related code to... + + * src/guile/skribilo/utils/images.scm: ... here (new file). + + * src/guile/skribilo/utils/Makefile.am (dist_guilemodule_DATA): Updated. + + * src/guile/skribilo/module.scm (%skribilo-user-autoloads): Added + `(skribilo utils images)'. + + new files: + src/guile/skribilo/utils/images.scm + + modified files: + ChangeLog src/guile/skribilo/module.scm + src/guile/skribilo/runtime.scm + src/guile/skribilo/utils/Makefile.am + + +2006-03-18 18:09:34 GMT Ludovic Courtes patch-46 + + Summary: + Lout engine: better handling of the `slides' document type. + Revision: + skribilo--devel--1.2--patch-46 + + * src/guile/skribilo/engine/lout.scm (lout-slides-markup-alist): New. + (lout-structure-markup): Handle `slides'. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + + +2006-03-18 17:25:58 GMT Ludovic Courtes patch-45 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-45 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 70-72) + + - Merge from lcourtes@laas.fr--2005-mobile + - Slight optimization: allow for non-proc predicates for markup writers. + - Partial rewrite of the debugging facilities (slightly slower). + + modified files: + ChangeLog + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-70 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-71 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-72 + + +2006-03-07 22:58:58 GMT Ludovic Courtes patch-44 + + Summary: + Partial rewrite of the debugging facilities (slightly slower). + Revision: + skribilo--devel--1.2--patch-44 + + * src/guile/skribilo.scm (skribilo): Use the new debugging API. + + * src/guile/skribilo/debug.scm: Use SRFI-39 parameter objects. + Moved legacy procedures to `compat.scm'. + + * src/guile/skribilo/utils/compat.scm (set-skribe-debug!): New. + (no-debug-color): New. + (skribe-debug): New. + (add-skribe-debug-symbol): New. + + modified files: + ChangeLog src/guile/skribilo.scm src/guile/skribilo/debug.scm + src/guile/skribilo/utils/compat.scm + + +2006-03-07 22:56:07 GMT Ludovic Courtes patch-43 + + Summary: + Slight optimization: allow for non-proc predicated for markup writers. + Revision: + skribilo--devel--1.2--patch-43 + + * src/guile/skribilo/engine.scm (engine-add-writer!): Allow PRED to be + `#f'. + + * src/guile/skribilo/writer.scm (make-writer-predicate): Likewise. + (lookup-markup-writer)[matching-writer]: Likewise. + + modified files: + ChangeLog src/guile/skribilo/engine.scm + src/guile/skribilo/writer.scm + + +2006-03-07 21:29:32 GMT Ludovic Courtes patch-42 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-42 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 67-69) + + - Doc: undoed `patch-65'. + - Removed the global engine table. + - Inventory fix. + + modified files: + ChangeLog doc/user/.arch-inventory doc/user/markup.skb + src/guile/skribilo/engine.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-67 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-68 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-69 + + +2006-03-07 21:28:47 GMT Ludovic Courtes patch-41 + + Summary: + Fixed `copy-engine' with respect to the writers optimization. + Revision: + skribilo--devel--1.2--patch-41 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 66) + + - Fixed `copy-engine' with respect to the writers optimization. + + modified files: + ChangeLog src/guile/skribilo/engine.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-66 + + +2006-03-07 21:28:02 GMT Ludovic Courtes patch-40 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-40 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 64-65) + + - Fixed tiny module loading/autoloading mistakes. + - Doc: commented out code that uses processors to work around bug. + + modified files: + ChangeLog doc/user/markup.skb src/guile/skribilo/module.scm + src/guile/skribilo/output.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-64 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-65 + + +2006-03-07 21:27:01 GMT Ludovic Courtes patch-39 + + Summary: + Significantly optimized lookup of markup writers. + Revision: + skribilo--devel--1.2--patch-39 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 63) + + - Significantly optimized lookup of markup writers. + + modified files: + ChangeLog src/guile/skribilo/engine.scm + src/guile/skribilo/writer.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-63 + + +2006-03-07 21:25:37 GMT Ludovic Courtes patch-38 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-38 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 60-62) + + - Slightly optimized the resolution process (added `ast-resolved?'). + - Various fixes in the documentation code. + - Lout engine: use `push-default-engine' and `pop-default-engine'. + + modified files: + ChangeLog doc/skr/manual.skr doc/user/document.skb + doc/user/src/api2.skb doc/user/src/bib1.sbib doc/user/user.skb + src/guile/skribilo/engine/lout.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-60 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-61 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-62 + + +2006-02-28 21:40:26 GMT Ludovic Courtes patch-37 + + Summary: + Slightly optimized the resolution process (added `ast-resolved?'). + Revision: + skribilo--devel--1.2--patch-37 + + * src/guile/skribilo/ast.scm (): Added a `resolved?' slot, with + accessor `ast-resolved?'. + + * src/guile/skribilo/resolve.scm (do-resolve!)[]: Check whether + `ast-resolved?' is true and set it once it's resolved. + + modified files: + ChangeLog src/guile/skribilo/ast.scm + src/guile/skribilo/resolve.scm + + +2006-02-28 20:08:45 GMT Ludovic Courtes patch-36 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-36 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 55-59) + + - Made `make-string-replace' faster. + - `eq': Implemented the text-based markup writers. + - `eq': Added the `:renderer' option to `eq'. Support `lout'. + - Changed the way `slide' implementations are loaded. Doc is buildable now. + - Doc: Added a chapter (stub) about the `eq' package. + + new files: + doc/user/eq.skb doc/user/src/.arch-ids/eq1.skb.id + doc/user/src/.arch-ids/eq2.skb.id doc/user/src/eq1.skb + doc/user/src/eq2.skb + + modified files: + ChangeLog doc/user/user.skb src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/package/slide/html.scm + src/guile/skribilo/package/slide/latex.scm + src/guile/skribilo/package/slide/lout.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-55 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-56 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-57 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-58 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-59 + + +2006-02-25 13:02:20 GMT Ludovic Courtes patch-35 + + Summary: + Made `make-string-replace' faster. + Revision: + skribilo--devel--1.2--patch-35 + + * src/guile/skribilo/runtime.scm (%make-general-string-replace): Use a + hash table rather than a list. + + modified files: + ChangeLog src/guile/skribilo/runtime.scm + + +2006-02-21 20:55:41 GMT Ludovic Courtes patch-34 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-34 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 41-54) + + - Merge from lcourtes@laas.fr--2005-mobile + - More Skribe compatibility fixes (more exported bindings). + - Implemented `lout-illustration' for non-Lout engines. + - Created the `(skribilo utils files)' module. + - Skribe reader: consider square brackets as delimiters. + - `skribilo': do not catch all exceptions, let a stack trace be output + intead. + - Added the equation formatting package (unfinished, undocumented). + - `eq' package: added the `script' markup. + - Implemented `when-engine-is-loaded'. + - Fixes for `when-engine-is-loaded'. + - `slide' and `eq': moved engine-specific code in separate modules. + - Lout engine: fixed use of `@Sym' so that it works fine within `@Eq'. + - `eq': Added `eq:in', `eq:notin' and their Lout writers. + - `eq': added the `apply' markup. + + new files: + src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/.arch-ids/=id + src/guile/skribilo/package/eq/Makefile.am + src/guile/skribilo/package/eq/lout.scm + src/guile/skribilo/package/slide/.arch-ids/=id + src/guile/skribilo/package/slide/Makefile.am + src/guile/skribilo/package/slide/html.scm + src/guile/skribilo/package/slide/latex.scm + src/guile/skribilo/package/slide/lout.scm + src/guile/skribilo/utils/files.scm + + modified files: + ChangeLog NEWS configure.ac src/guile/skribilo/color.scm + src/guile/skribilo/engine.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/module.scm + src/guile/skribilo/package/Makefile.am + src/guile/skribilo/package/slide.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/runtime.scm + src/guile/skribilo/utils/Makefile.am + src/guile/skribilo/utils/compat.scm src/skribilo.in + + new directories: + src/guile/skribilo/package/eq + src/guile/skribilo/package/eq/.arch-ids + src/guile/skribilo/package/slide + src/guile/skribilo/package/slide/.arch-ids + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-41 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-42 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-43 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-44 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-45 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-46 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-47 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-48 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-49 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-50 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-51 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-52 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-53 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-54 + + +2006-02-10 17:19:34 GMT Ludovic Courtes patch-33 + + Summary: + Fixed syntax highlighting thanks to SILex. + Revision: + skribilo--devel--1.2--patch-33 + + * arch-config: New file. + + * src/guile/skribilo/coloring/c-lex.l.scm: New. + + * src/guile/skribilo/coloring/lisp-lex.l.scm: New. + + * src/guile/skribilo/coloring/xml-lex.l.scm: New. + + * doc/user/user.skb: Include `prgm.skb' (works now). + + * src/guile/skribilo/ast.scm: Export `node-body'. + + * src/guile/skribilo/coloring/Makefile.am (dist_guilemodule_DATA): Added + the SILex-generated files. + (%.l.scm): New rule. + + * src/guile/skribilo/coloring/lisp-lex.l: Use the SRFI-39 parameters. + + * src/guile/skribilo/coloring/lisp.scm: Use SRFI-39 parameters instead of + fluids. Load `lisp-lex.l.scm'. + + * src/guile/skribilo/prog.scm: Autoload `ast' upon `node-body' too. + (make-line-mark): Use `hash-set!'. + (resolve-line): Use `hash-ref'. + + * src/guile/skribilo/source.scm (source-read-lines): Use + `string-prefix-length' instead of `substring=?'. + + new files: + arch-config + src/guile/skribilo/coloring/.arch-ids/c-lex.l.scm.id + src/guile/skribilo/coloring/.arch-ids/lisp-lex.l.scm.id + src/guile/skribilo/coloring/.arch-ids/xml-lex.l.scm.id + src/guile/skribilo/coloring/c-lex.l.scm + src/guile/skribilo/coloring/lisp-lex.l.scm + src/guile/skribilo/coloring/xml-lex.l.scm + + modified files: + ChangeLog doc/user/user.skb src/guile/skribilo/ast.scm + src/guile/skribilo/coloring/Makefile.am + src/guile/skribilo/coloring/lisp-lex.l + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/prog.scm src/guile/skribilo/source.scm + + +2006-02-10 14:44:59 GMT Ludovic Courtes patch-32 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-32 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 37-40) + + - Merge from lcourtes@laas.fr--2005-mobile + - First time the user manual is compiled to HTML. + - Added support for subsections and subsubsections in the outline reader. + - Outline reader: added support to parse lists. + + modified files: + ChangeLog src/guile/skribilo/reader/outline.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-37 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-38 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-39 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-40 + + +2006-01-31 23:23:15 GMT Ludovic Courtes patch-31 + + Summary: + First time the user manual is compiled to HTML. + Revision: + skribilo--devel--1.2--patch-31 + + * doc/skr/api.skr (make-engine?): Fixed. + (make-engine-custom): Likewise. + + * doc/skr/manual.skr (the-index): Don't pass `:&skribe-eval-location'. + + * doc/user/emacs.skb: Fixed typo. + + * doc/user/htmle.skb: Documented the `file-name-proc' custom. + + * doc/user/package.skb: Fixed the `prgm' example there. + + * doc/user/skribe-config.skb: Commented out the `OPTIONS' section. + + * doc/user/skribec.skb: Likewise. + + * doc/user/slide.skb: Don't refer to HTML-ENGINE, use `find-engine' + instead. + + * doc/user/src/slides.skb: Don't pass `:slide' to `toc'. + + * doc/user/toc.skb: Commented the `:subsubsection' argument. + + * doc/user/user.skb (Index): Set `:indent' to "Index". + + * src/guile/skribilo.scm (skribilo-options): Added `--image-path'. + (skribilo): Handle it. + + * src/guile/skribilo/ast.scm (ast->file-location): Exported. + + * src/guile/skribilo/engine/base.scm (the-index): Don't pass + `:&skribe-eval-location'. + + * src/guile/skribilo/engine/html.scm: Export `html-width' and + `html-title-authors'. + + * src/guile/skribilo/engine/lout.scm (lout-width): Don't use `flonum?'. + + * src/guile/skribilo/evaluator.scm (load-document): Added + `:allow-other-keys' so that the optional parameters may contain + keywords, too. + + * src/guile/skribilo/package/slide.scm: Use `(skribilo engine html)'. + + * src/guile/skribilo/skribe/api.scm (toc): Added `subsubsection'. + + modified files: + ChangeLog doc/skr/api.skr doc/skr/manual.skr + doc/user/emacs.skb doc/user/htmle.skb doc/user/package.skb + doc/user/skribe-config.skb doc/user/skribec.skb + doc/user/slide.skb doc/user/src/slides.skb doc/user/toc.skb + doc/user/user.skb src/guile/skribilo.scm + src/guile/skribilo/ast.scm src/guile/skribilo/engine/base.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/skribe/api.scm + + +2006-01-25 22:57:34 GMT Ludovic Courtes patch-30 + + Summary: + More progress towards a working user manual. + Revision: + skribilo--devel--1.2--patch-30 + + * doc/skr/api.skr (define-markup?): Support `define*' and + `define*-public'. + + * doc/user/bib.skb: Commented out problematic `skribebibtex'-related + things. + + * doc/user/lib.skb (skribe-load): Replaced by `load-document'. + (skribe-load-options): Replaced by `*load-options*'. + (skribe-path): Replaced by `*document-path*'. + + * src/guile/skribilo/coloring/lisp.scm (definition-search): Removed + debugging statement. + + * src/guile/skribilo/engine.scm (find-engine): For documentation + purposes, explicitly list all keyword parameters. + + * src/guile/skribilo/source.scm (source-read-lines): Start line numbers + from 0. + + * src/guile/skribilo/utils/compat.scm (skribe-path-set!): New. + (skribe-image-path-set!): New. + (skribe-source-path-set!): New. + (skribe-bib-path-set!): New. + + modified files: + ChangeLog doc/skr/api.skr doc/user/bib.skb doc/user/lib.skb + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/engine.scm src/guile/skribilo/source.scm + src/guile/skribilo/utils/compat.scm + + +2006-01-24 20:02:40 GMT Ludovic Courtes patch-29 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-29 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 31-36) + + - Merge from lcourtes@laas.fr--2005-mobile + - Preliminary support for multiple reader front-ends. + - First implementation of a reader for Emacs' outline syntax. + - First working outline reader. + - Changed the default Lout `document-type' to `doc'. + - Fixed the HTML engine's `favicon' output. + + new files: + src/guile/skribilo/reader/outline.scm + + modified files: + ChangeLog src/guile/README src/guile/skribilo.scm + src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/reader.scm + src/guile/skribilo/reader/Makefile.am + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-31 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-32 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-33 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-34 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-35 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-36 + + +2006-01-18 23:22:29 GMT Ludovic Courtes patch-28 + + Summary: + More fixes in the hope to get the manual compiled. + Revision: + skribilo--devel--1.2--patch-28 + + * doc/skr/api.skr (define-markup?): Accept `define-public'. + (define-markup-options): Accept any kind of `define' symbol. + (define-markup-rest): Likewise. + + * doc/user/bib.skb (bibliography): Use `src/bib1.sbib'. + (bib-table?): Provide a definition. + (default-bib-table): Likewise. + (make-bib-table): Likewise. + (bibliography): Fixed a `ref'. + (example): Fixed file name. This example does not work yet. + + * doc/user/footnote.skb (footnote): Documented `label', removed + `number'. + + * doc/user/table.skb (th): Documented `rowspan'. + + * src/guile/skribilo.scm (skribilo-options): Added `-S'/`--source-path'. + Honor it. + + * src/guile/skribilo/coloring/lisp.scm: Use `(ice-9 match)'. Rewrote all + the `match-case' code into corresponding `match' statements. + (definition-search): Fixed, using `source-property' and `port-line'. + Does not work yet due to a bug in guile-reader's source position + recording (shows 1 line earlier). Added a READ parameter. + + * src/guile/skribilo/skribe/api.scm: Mark SYMBOL as replaced instead of + blindly overriding the core binding. + + modified files: + ChangeLog doc/skr/api.skr doc/user/bib.skb + doc/user/footnote.skb doc/user/table.skb + src/guile/skribilo.scm src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/skribe/api.scm + + +2006-01-18 22:16:43 GMT Ludovic Courtes patch-27 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-27 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 25-30) + + - Removed the Bigloo/STkLos in the `legacy' directory. + - Cleaned up the Arch inventory and removed old useless makefiles. + - Introduced SRFI-3[45] conditions; cleaned up `evaluator.scm'. + - More SRFI-3[45] enhancements; first stab at the user documentation. + - Towards a self-hosted user manual. + - Various fixes: HTML engine, resolution, compatibility. + + modified files: + ChangeLog src/guile/skribilo/engine/html.scm + src/guile/skribilo/parameters.scm src/guile/skribilo/prog.scm + src/guile/skribilo/resolve.scm + src/guile/skribilo/utils/compat.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-25 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-26 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-27 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-28 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-29 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-30 + + +2006-01-17 22:50:23 GMT Ludovic Courtes patch-26 + + Summary: + Towards a self-hosted user manual. + Revision: + skribilo--devel--1.2--patch-26 + + * doc/skr/api.skr: Use `(skribilo reader)' and `(skribilo utils syntax)'. + (api-search-definition): Added a SKRIBE-SOURCE? argument. + Determine the appropriate reader based on its value. + (keyword->symbol): Removed. + (define-markup?): Fixed. + (make-engine?): Fixed (but unverified). + (make-engine-custom): Likewise. + (sym/kw?): New. + (define-markup-formals): Fixed. + (define-markup-options): Likewise. + (define-markup-rest): Likewise. + (doc-markup): Added a SKRIBE-SOURCE? argument. + (doc-engine): Likewise. + + * doc/user/*.skb: Updated the `:source' arguments to `doc-markup' and + `doc-engine'. + + * src/guile/skribilo/utils/compat.scm (hashtable-update!): Fixed + according to the Bigloo manual. + + modified files: + ChangeLog doc/skr/api.skr doc/user/bib.skb doc/user/engine.skb + doc/user/htmle.skb doc/user/image.skb doc/user/index.skb + doc/user/latexe.skb doc/user/lib.skb doc/user/package.skb + doc/user/sectioning.skb doc/user/slide.skb doc/user/xmle.skb + src/guile/skribilo/utils/compat.scm + + +2006-01-16 22:31:32 GMT Ludovic Courtes patch-25 + + Summary: + More SRFI-3[45] enhancements; first stab at the user documentation. + Revision: + skribilo--devel--1.2--patch-25 + + * src/guile/skribilo/biblio.scm (skribe-open-bib-file): Raise a + `&file-search-error' when needed. + + * src/guile/skribilo/runtime.scm (convert-image): Likewise. + + * src/guile/skribilo/source.scm (source-read-lines): Likewise. + (source-read-definition): Likewise. + + * src/guile/skribilo/utils/compat.scm (skribe-load): Only look up + `%skribe-known-files' when `load-document' failed. + (find-file/path): Use `search-path'. + (find-runtime-type): Implemented. + + * doc/skr/api.skr: Use `(ice-9 match)'. Use `match' instead of + `match-case'. + (api-search-definition): Search in `%load-path' and `(skribe-path)'. + (define-markup?): First stab at getting the `match' syntax right. + + * doc/user/src/start[3-5].skb: Small fixes. + + modified files: + ChangeLog doc/skr/api.skr doc/user/src/start3.skb + doc/user/src/start4.skb doc/user/src/start5.skb + src/guile/skribilo/biblio.scm src/guile/skribilo/runtime.scm + src/guile/skribilo/source.scm + src/guile/skribilo/utils/compat.scm + + +2006-01-15 21:22:18 GMT Ludovic Courtes patch-24 + + Summary: + Introduced SRFI-3[45] conditions; cleaned up `evaluator.scm'. + Revision: + skribilo--devel--1.2--patch-24 + + * src/guile/skribilo/condition.scm: New. + + * src/guile/skribilo/Makefile.am (dist_guilemodule_DATA): Added + `condition.scm'. + + * src/guile/skribilo/evaluator.scm (skribe-eval): Renamed to + `evaluate-document'. + (skribe-eval-port): Renamed to `evaluate-document-from-port'. + (skribe-load-options): Renamed to `*load-options*', a fluid. + (skribe-load): Renamed to `load-document'. Use SRFI-34 `raise' when a + file is not found. + (skribe-include): Renamed to `include-document'. Use `raise'. + + * src/guile/skribilo/utils/compat.scm (%skribe-known-files): New. + (skribe-load): New. + (skribe-include): New. + (skribe-load-options): New. + (skribe-eval): New. + (skribe-eval-port): New. + + * src/skribilo.in: Invoke `call-with-skribilo-error-catch'. Added a + copyright notice. + + * src/guile/skribilo.scm (doskribe): Use `evaluate-document-from-port', + not `skribe-eval-port'. + + * configure.ac: Look for `(srfi srfi-35)'. + + * AUTHORS: Mention that most of the code comes from the STkLos + implementation. + + new files: + src/guile/skribilo/condition.scm + + modified files: + AUTHORS ChangeLog configure.ac src/guile/skribilo.scm + src/guile/skribilo/Makefile.am + src/guile/skribilo/evaluator.scm + src/guile/skribilo/utils/compat.scm src/skribilo.in + + +2006-01-15 10:12:33 GMT Ludovic Courtes patch-23 + + Summary: + Cleaned up the Arch inventory and removed old useless makefiles. + Revision: + skribilo--devel--1.2--patch-23 + + Cleaned up the Arch inventory and removed old useless makefiles. + + new files: + .arch-inventory doc/user/.arch-inventory src/.arch-inventory + src/guile/skribilo/.arch-inventory + + removed files: + emacs/.arch-ids/Makefile.id emacs/Makefile + etc/.arch-ids/Makefile.id etc/Makefile + etc/bigloo/.arch-ids/Makefile.id etc/bigloo/Makefile + etc/bigloo/autoconf/.arch-ids/Makefile.id + etc/bigloo/autoconf/Makefile + etc/stklos/.arch-ids/Makefile.in.id etc/stklos/Makefile.in + examples/.arch-ids/Makefile.id examples/Makefile + examples/slide/.arch-ids/Makefile.id examples/slide/Makefile + tools/.arch-ids/Makefile.id tools/Makefile + tools/skribebibtex/bigloo/.arch-ids/Makefile.id + tools/skribebibtex/bigloo/Makefile + tools/skribebibtex/stklos/.arch-ids/Makefile.id + tools/skribebibtex/stklos/Makefile + + modified files: + ChangeLog {arch}/=tagging-method + + +2006-01-15 09:57:49 GMT Ludovic Courtes patch-22 + + Summary: + Removed the Bigloo/STkLos in the `legacy' directory. + Revision: + skribilo--devel--1.2--patch-22 + + Removed the `legacy' directory. + + removed files: + legacy/.arch-ids/=id legacy/bigloo/.arch-ids/=id + legacy/bigloo/.arch-ids/Makefile.id + legacy/bigloo/.arch-ids/api.bgl.id + legacy/bigloo/.arch-ids/api.sch.id + legacy/bigloo/.arch-ids/asm.scm.id + legacy/bigloo/.arch-ids/bib.bgl.id + legacy/bigloo/.arch-ids/c.scm.id + legacy/bigloo/.arch-ids/color.scm.id + legacy/bigloo/.arch-ids/configure.bgl.id + legacy/bigloo/.arch-ids/debug.sch.id + legacy/bigloo/.arch-ids/debug.scm.id + legacy/bigloo/.arch-ids/engine.scm.id + legacy/bigloo/.arch-ids/eval.scm.id + legacy/bigloo/.arch-ids/evapi.scm.id + legacy/bigloo/.arch-ids/index.bgl.id + legacy/bigloo/.arch-ids/lib.bgl.id + legacy/bigloo/.arch-ids/lisp.scm.id + legacy/bigloo/.arch-ids/main.scm.id + legacy/bigloo/.arch-ids/new.sch.id + legacy/bigloo/.arch-ids/output.scm.id + legacy/bigloo/.arch-ids/param.bgl.id + legacy/bigloo/.arch-ids/parseargs.scm.id + legacy/bigloo/.arch-ids/prog.scm.id + legacy/bigloo/.arch-ids/read.scm.id + legacy/bigloo/.arch-ids/resolve.scm.id + legacy/bigloo/.arch-ids/source.scm.id + legacy/bigloo/.arch-ids/sui.bgl.id + legacy/bigloo/.arch-ids/types.scm.id + legacy/bigloo/.arch-ids/verify.scm.id + legacy/bigloo/.arch-ids/writer.scm.id + legacy/bigloo/.arch-ids/xml.scm.id legacy/bigloo/Makefile + legacy/bigloo/api.bgl legacy/bigloo/api.sch + legacy/bigloo/asm.scm legacy/bigloo/bib.bgl + legacy/bigloo/c.scm legacy/bigloo/color.scm + legacy/bigloo/configure.bgl legacy/bigloo/debug.sch + legacy/bigloo/debug.scm legacy/bigloo/engine.scm + legacy/bigloo/eval.scm legacy/bigloo/evapi.scm + legacy/bigloo/index.bgl legacy/bigloo/lib.bgl + legacy/bigloo/lisp.scm legacy/bigloo/main.scm + legacy/bigloo/new.sch legacy/bigloo/output.scm + legacy/bigloo/param.bgl legacy/bigloo/parseargs.scm + legacy/bigloo/prog.scm legacy/bigloo/read.scm + legacy/bigloo/resolve.scm legacy/bigloo/source.scm + legacy/bigloo/sui.bgl legacy/bigloo/types.scm + legacy/bigloo/verify.scm legacy/bigloo/writer.scm + legacy/bigloo/xml.scm legacy/stklos/.arch-ids/=id + legacy/stklos/.arch-ids/Makefile.in.id + legacy/stklos/.arch-ids/biblio.stk.id + legacy/stklos/.arch-ids/c-lex.l.id + legacy/stklos/.arch-ids/c.stk.id + legacy/stklos/.arch-ids/color.stk.id + legacy/stklos/.arch-ids/configure.stk.id + legacy/stklos/.arch-ids/debug.stk.id + legacy/stklos/.arch-ids/engine.stk.id + legacy/stklos/.arch-ids/eval.stk.id + legacy/stklos/.arch-ids/lib.stk.id + legacy/stklos/.arch-ids/lisp-lex.l.id + legacy/stklos/.arch-ids/lisp.stk.id + legacy/stklos/.arch-ids/main.stk.id + legacy/stklos/.arch-ids/output.stk.id + legacy/stklos/.arch-ids/prog.stk.id + legacy/stklos/.arch-ids/reader.stk.id + legacy/stklos/.arch-ids/resolve.stk.id + legacy/stklos/.arch-ids/runtime.stk.id + legacy/stklos/.arch-ids/source.stk.id + legacy/stklos/.arch-ids/types.stk.id + legacy/stklos/.arch-ids/vars.stk.id + legacy/stklos/.arch-ids/verify.stk.id + legacy/stklos/.arch-ids/writer.stk.id + legacy/stklos/.arch-ids/xml-lex.l.id + legacy/stklos/.arch-ids/xml.stk.id legacy/stklos/Makefile.in + legacy/stklos/biblio.stk legacy/stklos/c-lex.l + legacy/stklos/c.stk legacy/stklos/color.stk + legacy/stklos/configure.stk legacy/stklos/debug.stk + legacy/stklos/engine.stk legacy/stklos/eval.stk + legacy/stklos/lib.stk legacy/stklos/lisp-lex.l + legacy/stklos/lisp.stk legacy/stklos/main.stk + legacy/stklos/output.stk legacy/stklos/prog.stk + legacy/stklos/reader.stk legacy/stklos/resolve.stk + legacy/stklos/runtime.stk legacy/stklos/source.stk + legacy/stklos/types.stk legacy/stklos/vars.stk + legacy/stklos/verify.stk legacy/stklos/writer.stk + legacy/stklos/xml-lex.l legacy/stklos/xml.stk + + modified files: + ChangeLog + + removed directories: + legacy legacy/.arch-ids legacy/bigloo legacy/bigloo/.arch-ids + legacy/stklos legacy/stklos/.arch-ids + + +2006-01-14 12:33:12 GMT Ludovic Courtes patch-21 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-21 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 17-24) + + - Merge from lcourtes@laas.fr--2005-mobile + - Cleaned up the use of a Skribe-compatible `gensym'. + - Cleaning the compatibility module and other annoyances. + - Syntax highlighting and `image'-related fixes. + - Made compatible with the new `current-reader' as a fluid. + + modified files: + ChangeLog src/guile/skribilo.scm src/guile/skribilo/ast.scm + src/guile/skribilo/biblio.scm src/guile/skribilo/debug.scm + src/guile/skribilo/engine.scm src/guile/skribilo/evaluator.scm + src/guile/skribilo/lib.scm src/guile/skribilo/location.scm + src/guile/skribilo/module.scm src/guile/skribilo/output.scm + src/guile/skribilo/resolve.scm src/guile/skribilo/source.scm + src/guile/skribilo/utils/syntax.scm + src/guile/skribilo/verify.scm src/guile/skribilo/writer.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-17 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-18 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-19 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-20 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-21 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-22 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-23 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-24 + + +2006-01-10 23:40:38 GMT Ludovic Courtes patch-20 + + Summary: + Syntax highlighting and `image'-related fixes. + Revision: + skribilo--devel--1.2--patch-20 + + * src/guile/skribilo/coloring/lisp.scm: Use `(skribilo reader)'. + (lisp-family-fontifier): Take a READ argument. + (skribe-fontifier): Pass `(make-reader 'skribe)' as the reader. + + * src/guile/skribilo/module.scm (%skribilo-user-autoloads): Added + `(skribilo prog)'. + + * src/guile/skribilo/parameters.scm (*ref-base*): New. + + * src/guile/skribilo/prog.scm: Guilified. + + * src/guile/skribilo/reader/skribe.scm: Nothing changed. + + * src/guile/skribilo/runtime.scm (suffix): New. + (string-ref-base): Don't use `file-separator'. Use `string-contains' + instead of Bigloo/STkLos' `substring=?'. + (convert-image): Use `*image-path*' instead of `skribe-image-path'. + Don't use `make-path'. + + modified files: + ChangeLog src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/module.scm + src/guile/skribilo/parameters.scm src/guile/skribilo/prog.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/runtime.scm + + +2006-01-08 17:13:42 GMT Ludovic Courtes patch-19 + + Summary: + Cleaning the compatibility module and other annoyances. + Revision: + skribilo--devel--1.2--patch-19 + + * src/skribilo.in: Catch exceptions and call `(exit 1)' when caught. + + * doc/user/Makefile.am (skribilo): Fixed. + + * src/guile/skribilo.scm: Updated copyright year. + + * src/guile/skribilo/compat.scm: Moved to `utils'. + + * src/guile/skribilo/Makefile.am (dist_guilemodule_DATA): Removed + `compat.scm'. + + * src/guile/skribilo/Makefile.am (dist_guilemodule_DATA): Added + `compat.scm'. + + * src/guile/skribilo/coloring/lisp.scm: Use `(skribilo utils syntax)'. + + * src/guile/skribilo/module.scm (%skribilo-user-imports): Import + `(skribilo utils compat)' instead of `(skribilo compat)'. + Added more triggering procedures for `(skribilo source)'. + + * src/guile/skribilo/skribe/api.scm: Moved the definition of a + Skribe-compatible `gensym' to `compat.scm'. + + * src/guile/skribilo/source.scm: Use `*source-path*' instead of + `skribe-source-path'. + + modified files: + ChangeLog doc/user/Makefile.am src/guile/skribilo.scm + src/guile/skribilo/Makefile.am + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/module.scm + src/guile/skribilo/skribe/api.scm + src/guile/skribilo/source.scm + src/guile/skribilo/utils/Makefile.am + src/guile/skribilo/utils/compat.scm src/skribilo.in + + renamed files: + src/guile/skribilo/.arch-ids/compat.scm.id + ==> src/guile/skribilo/utils/.arch-ids/compat.scm.id + src/guile/skribilo/compat.scm + ==> src/guile/skribilo/utils/compat.scm + + +2006-01-03 23:16:53 GMT Ludovic Courtes patch-18 + + Summary: + Cleaned up the use of a Skribe-compatible `gensym'. + Revision: + skribilo--devel--1.2--patch-18 + + * src/guile/skribilo.scm (gensym): Removed. + + * src/guile/skribilo/lib.scm (define-simple-markup): Comply with Guile's + version of `gensym'. + (define-simple-container): Likewise. + + * src/guile/skribilo/skribe/api.scm (gensym): Improved. Exported via + `#:replace'. + + modified files: + ChangeLog src/guile/skribilo.scm src/guile/skribilo/lib.scm + src/guile/skribilo/skribe/api.scm + + +2005-12-06 23:22:51 GMT Ludovic Courtes patch-17 + + Summary: + Fixed the handling of `footnote''s `:label' by the Lout/HTML engines. + Revision: + skribilo--devel--1.2--patch-17 + + * src/guile/skribilo/engine/lout.scm (footnote): Take the `:label' option + into account. + + * src/guile/skribilo/engine/html.scm (footnote): Likewise. + + modified files: + ChangeLog src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/lout.scm + + +2005-12-04 21:20:44 GMT Ludovic Courtes patch-16 + + Summary: + Added the `~' markup. Added SRFI-62 and SRFI-30 support to the Skribe reader. + Revision: + skribilo--devel--1.2--patch-16 + + * NEWS: Added actual news. + + * src/guile/skribilo/skribe/api.scm (~): New markup. + + * src/guile/skribilo/engine/html.scm: Added a writer for `~'. + + * src/guile/skribilo/engine/latex.scm: Likewise. + + * src/guile/skribilo/engine/lout.scm: Likewise. + + * src/guile/skribilo/evaluator.scm (skribe-include): Added a `:reader' + argument. + + * src/guile/skribilo/reader/skribe.scm (*skribe-reader*): Renamed to + `%skribe-reader'. + (%make-skribe-reader): Moved the sharp reader code to... + (&sharp-reader): ... here. Added support for SRFI-62 and SRFI-30 + (Bigloo supports both). + + modified files: + ChangeLog NEWS src/guile/skribilo/engine/html.scm + src/guile/skribilo/engine/latex.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm + src/guile/skribilo/reader/skribe.scm + src/guile/skribilo/skribe/api.scm + + +2005-12-03 16:44:38 GMT Ludovic Courtes patch-15 + + Summary: + Fixed the resolution mechanism and converted it to SRFI-39. + Revision: + skribilo--devel--1.2--patch-15 + + * src/guile/skribilo/output.scm: Cosmetic changes. + + * src/guile/skribilo/resolve.scm: Use SRFI-39. + (*unresolved*): Became an SRFI-39 parameter object. + (resolve!): Use `parameterize' over `*unresolved*'. + (do-resolve!): For `', resolve the body of NODE even if + PARENT is not unspecified. A similar fix had gone into the Bigloo + implementation of Skribe (the patch was never actually integrated as it + seems). This makes it possible to use `numref'. + For `', to not invoke `do-resolve!' on the result of PROC's + invocation. Similarly, this had gone into Skribe. + + modified files: + ChangeLog src/guile/skribilo/output.scm + src/guile/skribilo/resolve.scm + + +2005-12-03 11:35:47 GMT Ludovic Courtes patch-14 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-14 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 12-16) + + - Fixed and updated the installation process. + - Created a canonical module for Skribilo syntactic sugar. + - More `%skribilo-module-reader' fixes. + - Fixed `ref' and bibliography-related things. + - Fixed Lout-related thingies. + + new files: + src/.arch-ids/skribilo.in.id + src/guile/skribilo/utils/.arch-ids/=id + src/guile/skribilo/utils/Makefile.am + src/guile/skribilo/utils/syntax.scm src/skribilo.in + + removed files: + src/guile/skribilo/.arch-ids/Makefile.in.id + src/guile/skribilo/Makefile.in + + modified files: + ChangeLog configure.ac src/Makefile.am src/guile/Makefile.am + src/guile/skribilo.scm src/guile/skribilo/Makefile.am + src/guile/skribilo/ast.scm src/guile/skribilo/biblio.scm + src/guile/skribilo/coloring/Makefile.am + src/guile/skribilo/debug.scm src/guile/skribilo/engine.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/evaluator.scm src/guile/skribilo/lib.scm + src/guile/skribilo/location.scm src/guile/skribilo/module.scm + src/guile/skribilo/output.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/parameters.scm + src/guile/skribilo/resolve.scm + src/guile/skribilo/skribe/Makefile.am + src/guile/skribilo/skribe/bib.scm + src/guile/skribilo/source.scm src/guile/skribilo/verify.scm + src/guile/skribilo/writer.scm + + new directories: + src/guile/skribilo/utils src/guile/skribilo/utils/.arch-ids + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-12 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-13 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-14 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-15 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-16 + + +2005-11-26 18:03:04 GMT Ludovic Courtes patch-13 + + Summary: + Merge from lcourtes@laas.fr--2004-libre + Revision: + skribilo--devel--1.2--patch-13 + + Patches applied: + + * lcourtes@laas.fr--2004-libre/skribilo--devel--1.2 (patch 6-11) + + - Lots of changes... + - Started relying on the per-module reader; first doc produced ever! + - The first vaguely working version. + - Minor fixes for file/line error reporting. + - Cleaned up the source tree and the installation process. + - Overhaul: emphasized logical separation of the modules. + + new files: + src/guile/skribilo/ast.scm src/guile/skribilo/location.scm + src/guile/skribilo/parameters.scm + + removed files: + doc/.arch-ids/Makefile.id doc/Makefile + src/guile/skribilo/.arch-ids/types.scm.id + src/guile/skribilo/types.scm + + modified files: + ChangeLog src/guile/skribilo.scm src/guile/skribilo/biblio.scm + src/guile/skribilo/compat.scm src/guile/skribilo/engine.scm + src/guile/skribilo/engine/html.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/output.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/verify.scm + src/guile/skribilo/writer.scm + + renamed files: + src/guile/skribilo/.arch-ids/vars.scm.id + ==> src/guile/skribilo/.arch-ids/compat.scm.id + src/guile/skribilo/vars.scm + ==> src/guile/skribilo/compat.scm + + new patches: + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-6 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-7 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-8 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-9 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-10 + lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-11 + + +2005-11-26 18:01:09 GMT Ludovic Courtes patch-12 + + Summary: + Fixed the documentation's Makefile.am. + Revision: + skribilo--devel--1.2--patch-12 + + * doc/user/Makefile.am: Fixed GUILE_LOAD_PATH. + + + modified files: + ChangeLog doc/user/Makefile.am + + +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: + 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/ChangeLog.Skribe b/ChangeLog.Skribe new file mode 100644 index 0000000..6987245 --- /dev/null +++ b/ChangeLog.Skribe @@ -0,0 +1,698 @@ +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/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 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/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..5ac9227 --- /dev/null +++ b/NEWS @@ -0,0 +1,12 @@ +New in Skribilo 1.2 (compared to Skribe 1.2d) + + * New engine: Lout (see http://lout.sf.net/). + + * New package `eq' for equation formatting. + + * New markups: `~', `numref', `!lout', `lout-illustration'. + + * Extended markups: + + - `footnote' now takes a `:label' option. + - `document' now takes a `:keywords' option. 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/arch-config b/arch-config new file mode 100644 index 0000000..e7aa342 --- /dev/null +++ b/arch-config @@ -0,0 +1,5 @@ +# GNU Arch configuration to build the thing. + +./src/guile/silex lcourtes@laas.fr--2005-libre/silex--dube--1.0 + +# arch-tag: bdeb0fe5-6cac-4ad3-b6a6-7fd2197a76c6 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/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/configure.ac b/configure.ac new file mode 100644 index 0000000..5774273 --- /dev/null +++ b/configure.ac @@ -0,0 +1,57 @@ +# -*- 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]) + +# Need SRFI-35, available in `guile-library'. +GUILE_MODULE_REQUIRED([srfi srfi-35]) + +# Look for Lout. +AC_PATH_PROG([LOUT], [lout], [not-found]) +AM_CONDITIONAL([HAVE_LOUT], [test "x$LOUT" != "xnot-found"]) + +# Look for Ploticus. +AC_PATH_PROGS([PLOTICUS], [ploticus pl], [not-found]) +AM_CONDITIONAL([HAVE_PLOTICUS], [test "x$PLOTICUS" != "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_CONFIG_COMMANDS([skribilo-executable], [chmod a+x src/skribilo]) + +AC_OUTPUT([Makefile + src/skribilo + src/Makefile + src/guile/Makefile + src/guile/skribilo/Makefile + src/guile/skribilo/config.scm + src/guile/skribilo/utils/Makefile + src/guile/skribilo/engine/Makefile + src/guile/skribilo/reader/Makefile + src/guile/skribilo/package/Makefile + src/guile/skribilo/package/slide/Makefile + src/guile/skribilo/package/eq/Makefile + src/guile/skribilo/package/pie/Makefile + src/guile/skribilo/coloring/Makefile + src/guile/skribilo/biblio/Makefile + doc/Makefile + doc/user/Makefile + doc/user/src/Makefile + doc/img/Makefile + doc/dir/Makefile + doc/modules/Makefile + doc/modules/skribilo/Makefile + doc/modules/skribilo/documentation/Makefile]) diff --git a/doc/COPYING b/doc/COPYING new file mode 120000 index 0000000..012065c --- /dev/null +++ b/doc/COPYING @@ -0,0 +1 @@ +../COPYING \ No newline at end of file diff --git a/doc/Makefile b/doc/Makefile deleted file mode 100644 index 934389e..0000000 --- a/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/doc/Makefile.am b/doc/Makefile.am new file mode 100644 index 0000000..871a842 --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = user modules img dir diff --git a/doc/dir/Makefile.am b/doc/dir/Makefile.am new file mode 100644 index 0000000..97f6673 --- /dev/null +++ b/doc/dir/Makefile.am @@ -0,0 +1,3 @@ +EXTRA_DIST = dir.skb + +## arch-tag: 68df7b7b-a45d-4cdc-b0b3-ef738a83965c diff --git a/doc/dir/dir.skb b/doc/dir/dir.skb index 8c6d377..1e1a7b6 100644 --- a/doc/dir/dir.skb +++ b/doc/dir/dir.skb @@ -1,14 +1,23 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ - +;;; dir.skb -- The Skribe directory +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + ;*---------------------------------------------------------------------*/ ;* The Skribe documentation style */ ;*---------------------------------------------------------------------*/ diff --git a/doc/img/Makefile.am b/doc/img/Makefile.am new file mode 100644 index 0000000..0be3236 --- /dev/null +++ b/doc/img/Makefile.am @@ -0,0 +1,3 @@ +EXTRA_DIST = bsd.png lambda.png linux.png + +## arch-tag: 0008e69a-4745-46d8-9da4-2173db33965d diff --git a/doc/img/bsd.gif b/doc/img/bsd.gif deleted file mode 100644 index e406ba6..0000000 Binary files a/doc/img/bsd.gif and /dev/null differ diff --git a/doc/img/bsd.png b/doc/img/bsd.png new file mode 100644 index 0000000..eb2e4e2 Binary files /dev/null and b/doc/img/bsd.png differ diff --git a/doc/img/lambda.gif b/doc/img/lambda.gif deleted file mode 100644 index 9c46b7d..0000000 Binary files a/doc/img/lambda.gif and /dev/null differ diff --git a/doc/img/lambda.png b/doc/img/lambda.png new file mode 100644 index 0000000..5673291 Binary files /dev/null and b/doc/img/lambda.png differ diff --git a/doc/img/linux.gif b/doc/img/linux.gif deleted file mode 100644 index fa764bd..0000000 Binary files a/doc/img/linux.gif and /dev/null differ diff --git a/doc/img/linux.png b/doc/img/linux.png new file mode 100644 index 0000000..fd121fb Binary files /dev/null and b/doc/img/linux.png differ diff --git a/doc/modules/Makefile.am b/doc/modules/Makefile.am new file mode 100644 index 0000000..1daf926 --- /dev/null +++ b/doc/modules/Makefile.am @@ -0,0 +1,3 @@ +SUBDIRS = skribilo + +## arch-tag: 9c90dd7b-0ee7-44b9-ab41-5283d1bf1fb9 diff --git a/doc/modules/skribilo/Makefile.am b/doc/modules/skribilo/Makefile.am new file mode 100644 index 0000000..71e8c64 --- /dev/null +++ b/doc/modules/skribilo/Makefile.am @@ -0,0 +1,3 @@ +SUBDIRS = documentation + +## arch-tag: af599d8d-2e67-49b3-afdf-aa2dba5a7c4a diff --git a/doc/modules/skribilo/documentation/Makefile.am b/doc/modules/skribilo/documentation/Makefile.am new file mode 100644 index 0000000..1562b0a --- /dev/null +++ b/doc/modules/skribilo/documentation/Makefile.am @@ -0,0 +1,3 @@ +EXTRA_DIST = api.scm env.scm extension.scm manual.scm + +## arch-tag: 171ec210-e895-42ce-b068-da10ed5c2551 diff --git a/doc/modules/skribilo/documentation/api.scm b/doc/modules/skribilo/documentation/api.scm new file mode 100644 index 0000000..84108c9 --- /dev/null +++ b/doc/modules/skribilo/documentation/api.scm @@ -0,0 +1,623 @@ +;;; api.scm -- The style for documenting Scheme APIs. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo documentation api) + :use-module (skribilo reader) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo ast) + :use-module (skribilo output) + :use-module (skribilo lib) ;; `define-markup' + :use-module (skribilo utils keywords) + :use-module (skribilo utils compat) + :use-module (skribilo utils syntax) ;; `%skribilo-module-reader' + + :use-module (skribilo package base) + :use-module (skribilo documentation manual) ;; `*markup-index*' + :use-module (skribilo documentation env) ;; `*api-engines*' + + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :use-module (ice-9 optargs)) + +(fluid-set! current-reader (make-reader 'skribe)) + + +;*---------------------------------------------------------------------*/ +;* 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 :optional (skribe-source? #t)) + ;; If SKRIBE-SOURCE? is true, then assume Skribe syntax. Otherwise, use + ;; the ``Skribilo module syntax''. + (let* ((path (append %load-path (skribe-path))) + (f (find-file/path file path)) + (read (if skribe-source? (make-reader 'skribe) + %skribilo-module-reader))) + (if (not (string? f)) + (skribe-error 'api-search-definition + (format #f "can't find source file `~a' in path" + file) + path) + (with-input-from-file f + (lambda () + (let loop ((exp (read))) + (if (eof-object? exp) + (skribe-error 'api-search-definition + (format #f + "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)))) + + +;*---------------------------------------------------------------------*/ +;* define-markup? ... */ +;*---------------------------------------------------------------------*/ +(define (define-markup? id o) + (match o + (((or 'define-markup 'define 'define* 'define-public 'define*-public) + ((? (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) + ;(format #t "make-engine? ~a ~a~%" id o) + (match o + (((or 'make-engine 'copy-engine) ('quote sym) . rest) + (if (eq? sym id) + o + #f)) + ((exp ___) + (let loop ((exp exp)) + (cond ((null? exp) + #f) + ((pair? exp) + (or (make-engine? id (car exp)) + (make-engine? id (cdr exp)))) + (else + (make-engine? id exp))))) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* make-engine-custom ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine-custom def) + (let ((customs (memq :custom def))) + (match (if customs (cdr customs) #f) + ((((or 'quote 'quasiquote) custom) _ ___) + custom) + (((custom) _ ___) + (primitive-eval custom)) + (else + '())))) + +(define (sym/kw? x) + (or (symbol? x) (keyword? x))) + +;*---------------------------------------------------------------------*/ +;* define-markup-formals ... */ +;* ------------------------------------------------------------- */ +;* Returns the formal parameters of a define-markup (not the */ +;* options). */ +;*---------------------------------------------------------------------*/ +(define (define-markup-formals def) + (match def + ((_ (id 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 def + ((_ (args ___) _ ___) + (if (not (list? args)) + '() + (let ((keys (memq #!key args))) + (if (pair? keys) + (cdr keys) ;; FIXME: do we need to filter ((key val)...)? + '())))) + (('define-simple-markup _) + '((ident #f) (class #f))) + (('define-simple-container _) + '((ident #f) (class #f))) + (else + (skribe-error 'define-markup-options + "Illegal `define-markup' form" + def)))) + +;*---------------------------------------------------------------------*/ +;* define-markup-rest ... */ +;* ------------------------------------------------------------- */ +;* Returns the rest parameter of a define-markup. */ +;*---------------------------------------------------------------------*/ +(define (define-markup-rest def) + (match 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-rest + "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 #f "~a: missing descriptions" id) + d1) + (skribe-error 'doc-markup + (format #f "~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 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 #f "~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 + (ident #f) + (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 "skribilo/package/base.scm") + (def #f) + (see-also '()) + (others '()) + (force-engines '()) + (engines *api-engines*) + (sui #f) + (skribe-source? #t) + &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? + skribe-source?))) + (od (map (lambda (o) + (api-search-definition o source define-markup? + skribe-source?)) + 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" + (or ident (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 + (skribe-source? #t) + (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? + skribe-source?))) + (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 #f "~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/doc/modules/skribilo/documentation/env.scm b/doc/modules/skribilo/documentation/env.scm new file mode 100644 index 0000000..569f194 --- /dev/null +++ b/doc/modules/skribilo/documentation/env.scm @@ -0,0 +1,47 @@ +;;; env.scm -- The environment variables for the documentation. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo documentation env) + :use-module (skribilo config) + :use-module (skribilo engine)) + +(define-public *serrano-url* "http://www.inria.fr/mimosa/Manuel.Serrano") +(define-public *serrano-mail* "Manuel.Serrano@sophia.inria.fr") +(define-public *courtes-mail* "ludovic.courtes@laas.fr") +(define-public *html-url* "http://www.w3.org/TR/html4") +(define-public *html-form* "interact/forms.html") +(define-public *emacs-url* "http://www.gnu.org/software/emacs") +(define-public *xemacs-url* "http://www.xemacs.org") +(define-public *texinfo-url* "http://www.texinfo.org") +(define-public *r5rs-url* "http://www.inria.fr/mimosa/fp/Bigloo/doc/r5rs.html") +(define-public *bigloo-url* "http://www.inria.fr/mimosa/fp/Bigloo") +(define-public *skribe-user-doc-url* (string-append (skribe-doc-dir) "/user.html")) +(define-public *skribe-dir-doc-url* (string-append (skribe-doc-dir) "/dir.html")) + +(define-public *prgm-width* 97.) +(define-public *prgm-skribe-color* "#ffffcc") +(define-public *prgm-default-color* "#ffffcc") +(define-public *prgm-xml-color* "#ffcccc") +(define-public *prgm-example-color* "#ccccff") +(define-public *disp-color* "#ccffcc") +(define-public *header-color* "#cccccc") + +(define-public *api-engines* (map find-engine '(html latex xml))) diff --git a/doc/modules/skribilo/documentation/extension.scm b/doc/modules/skribilo/documentation/extension.scm new file mode 100644 index 0000000..e012cb2 --- /dev/null +++ b/doc/modules/skribilo/documentation/extension.scm @@ -0,0 +1,111 @@ +;;; extension.scm -- The Skribe package for documenting extensions +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo documentation extension) + :use-module (skribilo reader) + :use-module (skribilo utils compat)) + +(fluid-set! current-reader (make-reader 'skribe)) + + +;*---------------------------------------------------------------------*/ +;* 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/doc/modules/skribilo/documentation/manual.scm b/doc/modules/skribilo/documentation/manual.scm new file mode 100644 index 0000000..f2a6cdd --- /dev/null +++ b/doc/modules/skribilo/documentation/manual.scm @@ -0,0 +1,328 @@ +;;; manual.scm -- Skribe manuals and documentation pages style +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo documentation manual) + :use-module (skribilo reader) + :use-module (skribilo engine) + :use-module (skribilo writer) + :use-module (skribilo ast) + :use-module (skribilo lib) ;; `define-markup' + :use-module (skribilo resolve) + :use-module (skribilo output) + :use-module (skribilo utils keywords) + :use-module (skribilo utils compat) + :use-module (skribilo utils syntax) ;; `when' + + :use-module (skribilo documentation env) + :use-module (skribilo package base) + :use-module (skribilo prog) + :use-module (skribilo coloring lisp) + :use-module (skribilo coloring xml) + + :use-module (ice-9 optargs)) + +(fluid-set! current-reader (make-reader 'skribe)) + + +;*---------------------------------------------------------------------*/ +;* The various indexes */ +;*---------------------------------------------------------------------*/ +(define-public *markup-index* (make-index "markup")) +(define-public *custom-index* (make-index "custom")) +(define-public *function-index* (make-index "function")) +(define-public *package-index* (make-index "package")) + +;*---------------------------------------------------------------------*/ +;* 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 #f "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) + (with-output-to-string + (lambda () + (write 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)) + ;; FIXME: Since we don't support + ;; `:&skribe-eval-location', we could set up a + ;; `parameterize' thing around `skribe-eval' to provide + ;; it with the right location information. + (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 #f "| ~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/doc/skr/api.skr b/doc/skr/api.skr deleted file mode 100644 index a27c3a4..0000000 --- a/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/doc/skr/env.skr b/doc/skr/env.skr deleted file mode 100644 index 09d5146..0000000 --- a/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/doc/skr/extension.skr b/doc/skr/extension.skr deleted file mode 100644 index ce10ce7..0000000 --- a/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/doc/skr/manual.skr b/doc/skr/manual.skr deleted file mode 100644 index 1982237..0000000 --- a/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/doc/user/.arch-inventory b/doc/user/.arch-inventory new file mode 100644 index 0000000..c91230c --- /dev/null +++ b/doc/user/.arch-inventory @@ -0,0 +1,4 @@ +# Skribilo-generated files. +precious ^(user(-[0-9]+)?\.(html|ps|pdf|li|lout|lout\.ld)|doc-config\.scm|(bsd|linux|lambda|pie-.*|eq-.*)\.(png|eps))$ + +# arch-tag: 827d1e94-1b36-474e-bcdb-a4235b4af848 diff --git a/doc/user/Makefile.am b/doc/user/Makefile.am new file mode 100644 index 0000000..3b67dea --- /dev/null +++ b/doc/user/Makefile.am @@ -0,0 +1,42 @@ +SUBDIRS = src + +EXTRA_DIST = bib.skb char.skb colframe.skb document.skb emacs.skb \ + engine.skb enumeration.skb eq.skb examples.skb figure.skb \ + font.skb footnote.skb htmle.skb image.skb index.skb \ + justify.skb latexe.skb lib.skb line.skb links.skb \ + markup.skb ornament.skb package.skb pie.skb prgm.skb sectioning.skb \ + skribe-config.skb skribec.skb skribeinfo.skb slide.skb start.skb \ + syntax.skb table.skb toc.skb user.skb xmle.skb + +BUILT_SOURCES = doc-config.scm +html_DATA = user.html + +skribilo = $(top_builddir)/src/skribilo +load_path = $(top_srcdir)/src/guile:$(top_srcdir)/src/guile/skribilo/package:$(top_builddir)/src/guile:$(top_srcdir)/doc/modules + + +%.html: %.skb + GUILE_LOAD_PATH=$(load_path):$$GUILE_LOAD_PATH \ + $(skribilo) --target html -I ../ -P ../img -o $@ $< + +if HAVE_LOUT + +ps_DATA = user.ps + +%.lout: %.skb + GUILE_LOAD_PATH=$(load_path):$$GUILE_LOAD_PATH \ + $(skribilo) --target lout -I ../ -P ../img -o $@ $< + +%.ps: %.lout + $(LOUT) -c $(<:%.lout=%) -o $@ $< + +endif + +if HAVE_PLOTICUS +doc-config.scm: + -echo "(define %have-ploticus? #t)" > $@ + -echo "(define %ploticus-path \"$(PLOTICUS)\")" >> $@ +else +doc-config.scm: + -echo "(define %have-ploticus? #f) (define %ploticus-path #f)" > $@ +endif diff --git a/doc/user/bib.skb b/doc/user/bib.skb index a006a9b..5b26417 100644 --- a/doc/user/bib.skb +++ b/doc/user/bib.skb @@ -1,15 +1,24 @@ -;*=====================================================================*/ -;* 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") +;;; bib.skb -- The Skribe index +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(bibliography "src/bib1.sbib") ;*---------------------------------------------------------------------*/ ;* Index */ @@ -51,7 +60,8 @@ if its argument is a bibliography table as returned by :see-also '(make-bib-table default-bib-table bibliography the-bibliography) :force-engines *api-engines* :common-args '() - :source "../src/bigloo/bib.bgl") + :source #f ;;"skribilo/biblio.scm" + :def '(define-markup (bib-table? obj) ...)) (p [The function ,(code "default-bib-table") returns a global, pre-existing bibliography-table:]) @@ -60,7 +70,8 @@ bibliography-table:]) :see-also '(bib-table? make-bib-table bibliography the-bibliography) :force-engines *api-engines* :common-args '() - :source "../src/bigloo/bib.bgl") + :source #f + :def '(define-markup (default-bib-table) ...)) (p [The function ,(code "make-bib-table") constructs a new bibliography-table:]) @@ -69,7 +80,8 @@ bibliography-table:]) :see-also '(bib-table? default-bib-table bibliography the-bibliography) :force-engines *api-engines* :common-args '() - :source "../src/bigloo/bib.bgl")) + :source #f + :def '(define-markup (make-bib-table ident) ...))) ;*---------------------------------------------------------------------*/ ;* bibliography ... @label bibliography@ */ @@ -81,7 +93,7 @@ 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 +,(ref :ident "ref" :text "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.]) @@ -204,7 +216,7 @@ 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" + :source "skribilo/biblio.scm" :others '(bib-sort/idents bib-sort/dates) :common-args '()) @@ -214,7 +226,8 @@ 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))))) + (prgm :file "skribilo/biblio.scm" + :definition 'bib-sort/idents))))) ;*---------------------------------------------------------------------*/ ;* skribebibtex */ @@ -226,9 +239,9 @@ entries identifier. The last one sorts according to entries date.]) 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")) +;; Synopsis (FIXME) +;;(subsection :title "SYNOPSIS" :number #f +;; (compiler-command *skribebibtex-bin* "options" "input")) ;; Description (subsection :title "DESCRIPTION" :number #f [ @@ -246,7 +259,9 @@ These suffixes are: ,(description (item :key (it ".bib") [a ,(bold "Bibtex") source file.]))]) -;; Options -(subsection :title "OPTIONS" :number #f -(compiler-options *skribebibtex-bin*)))) +;; Options (FIXME) +;;(subsection :title "OPTIONS" :number #f +;;(compiler-options *skribebibtex-bin*)) + + )) diff --git a/doc/user/char.skb b/doc/user/char.skb index 85409f0..16c4625 100644 --- a/doc/user/char.skb +++ b/doc/user/char.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; char.skb -- Characters, strings and symbols +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Footnote ... */ @@ -49,9 +58,12 @@ without any transformation from the engine.]) (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")))) +(let ((file (if (engine-format? "lout") + "src/api20-lout.skb" + "src/api20-html.skb"))) + (example-produce + (example :legend "Some characters" (prgm :file file)) + (disp (include file))))) ;*--- Symbols ---------------------------------------------------------*/ (subsection :title "Symbols" diff --git a/doc/user/colframe.skb b/doc/user/colframe.skb index 79b32f9..307b95c 100644 --- a/doc/user/colframe.skb +++ b/doc/user/colframe.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/colframe.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Mon Apr 5 11:51:08 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe color and frame */ -;*=====================================================================*/ +;;; colframe.skb -- Skribe color and frame +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Frame and color */ diff --git a/doc/user/document.skb b/doc/user/document.skb index 09f8cb3..b5c3461 100644 --- a/doc/user/document.skb +++ b/doc/user/document.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/document.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 2 11:39:07 2003 */ -;* Last change : Wed Feb 4 14:51:12 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Document and author */ -;*=====================================================================*/ +;;; document.skb -- Document and author +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* dummy-document-output ... */ @@ -19,7 +28,7 @@ (b (markup-body n)) (ta (table (tr (map (lambda (n) (td :valign 'top :align 'center n)) - a))))) + (if (list? a) a (list a))))))) (skribe-eval (center (bold t)) e) (skribe-eval (center ta) e) (output b e)))) @@ -39,6 +48,10 @@ (:html-title "The title of window of the HTML browser.") (:author "The authors of the document.") (:ending "An ending text.") + (:keywords "A list of keywords which may be plain strings +or markups. The keywords will not appear in the final document but only +as meta-information (e.g., using the HTML `meta' tag) if the engine used +supports it.") (:env "A counter environment.") (#!rest node... "The document nodes.")) :see-also '(author chapter toc)) diff --git a/doc/user/emacs.skb b/doc/user/emacs.skb index 742fa87..1255dec 100644 --- a/doc/user/emacs.skb +++ b/doc/user/emacs.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/emacs.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Nov 30 13:36:44 2001 */ -;* Last change : Sun Feb 29 16:12:32 2004 (eg) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Editing Skribe programs */ -;*=====================================================================*/ +;;; emacs.skb -- Editing Skribe programs +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Editing Skribe programs */ @@ -52,7 +61,7 @@ The ,(code "skribe") mode is a minor mode. It is intended to be used with a Lisp or Scheme mode. Hence, to use the ,(code "skribe") mode you will have to use the following Emacs commands:]) -,(disp :vert #t (source :language lisp [ +,(disp :verb #t (source :language lisp [ ESC-x: scheme-mode ESC-x: skribe-mode ]))])) diff --git a/doc/user/engine.skb b/doc/user/engine.skb index 06be3c4..30b8fd2 100644 --- a/doc/user/engine.skb +++ b/doc/user/engine.skb @@ -1,16 +1,28 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/engine.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 11:19:21 2003 */ -;* Last change : Mon Nov 8 15:07:35 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The description of the Skribe engines */ -;*=====================================================================*/ -;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@ +;;; engine.skb -- The description of the Skribe engines +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + (cond-expand + (guile + (define *engine-src* "skribilo/engine.scm") + (define *types-src* #f)) (bigloo (define *engine-src* "../src/bigloo/engine.scm") (define *types-src* "../src/bigloo/types.scm")) @@ -55,6 +67,7 @@ given below:]) (:custom [The engine custom list.]) (:info [Miscellaneous.])) :common-args '() + :skribe-source? #f :source *engine-src* :idx *function-index*) @@ -68,6 +81,7 @@ given below:]) (:symbol-table [The engine symbol table.]) (:custom [The engine custom list.])) :common-args '() + :skribe-source? #f :source *engine-src* :idx *function-index*)) @@ -80,6 +94,7 @@ on failure.]) '((id [The name (a symbol) of the engine to be searched.]) (:version [An optional version number for the searched engine.])) :common-args '() + :skribe-source? #f :source *engine-src* :idx *function-index*)) @@ -91,7 +106,8 @@ argument is an engine. Otherwise, it returns ,(code "#f"). In other words, (doc-markup 'engine? '((obj [The checked object.])) :common-args '() - :source *types-src* + :skribe-source? #f + :source *engine-src* :idx *function-index*) (p [The following functions return information about engines.]) @@ -100,7 +116,8 @@ argument is an engine. Otherwise, it returns ,(code "#f"). In other words, '((obj [The engine.])) :common-args '() :others '(engine-format engine-customs engine-filter engine-symbol-table) - :source *types-src* + :skribe-source? #f + :source *engine-src* :idx *function-index*)) (subsection :title "Engine customs" @@ -117,6 +134,7 @@ a custom.]) ,(ref :mark "find-engine" :text (code "find-engine"))).]) (id [The name of the custom.])) :common-args '() + :skribe-source? #f :source *engine-src* :idx *function-index*) @@ -126,6 +144,7 @@ a custom.]) (id [The name of the custom.]) (val [The new value of the custom.])) :common-args '() + :skribe-source? #f :source *engine-src* :idx *function-index*))) diff --git a/doc/user/enumeration.skb b/doc/user/enumeration.skb index 01155e2..5f19c3a 100644 --- a/doc/user/enumeration.skb +++ b/doc/user/enumeration.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/enumeration.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Fri Sep 12 15:31:37 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe enumerations */ -;*=====================================================================*/ +;;; enumeration.skb -- Skribe enumerations +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Justification */ diff --git a/doc/user/eq.skb b/doc/user/eq.skb new file mode 100644 index 0000000..a611f88 --- /dev/null +++ b/doc/user/eq.skb @@ -0,0 +1,79 @@ +;;; eq.skb -- Equation formatting. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;;; FIXME: This is a stub and must be completed! + +(chapter :title [Equation Formatting] + + (p [Skribilo comes with an equation formatting package. This package +may be loaded by adding the following form at the top of your document:] + + (disp (prog (source :language scheme + [(use-modules (skribilo package eq))]))) + + [It allows the inclusion of (complex) equations in your documents, +such as, for example, the following:] + + (disp (eq :renderer (if (engine-format? "html") 'lout #f) + :ident "eq-disponibilite" + `(= (apply A D) + (sum :from (= i b) :to (* S b) + (* (script :sup (* S b) :sub i C) + (* (expt mu i) + (expt (- 1 mu) + (- (* S b) i)))))))) + + [This chapter will describe the syntactic facilities available to +describe equations, as well as the rendering options.]) + + (section :title [Syntax] + + (p [To start with, let's have a look at a concrete example. ] + + (example-produce + (example :legend "Example of a simple equation using the verbose syntax" + (prgm :file "src/eq1.skb")) + (disp (include "src/eq1.skb"))) + + [In this example, the ,(tt [eq:]) sub-markups are used pretty +much like any other kind of markup. However, the resulting syntax +is very verbose and hard to read.]) + + (p [Fortunately, the ,(tt [eq]) package allows for the use of a +much simple syntax. ] + + (example-produce + (example :legend "Example of a simple equation" + (prgm :file "src/eq2.skb")) + (disp (include "src/eq2.skb"))) + + [Readers familiar with the Lisp family of programming languages +may have already recognized its ,(emph [prefix notation]). Note that, +unlike in the previous example, the equation itself if ,(emph [quoted]), +that is, preceded by the ,(tt [']) sign. Additionally, when referring +to a symbol (such as the Greek letter ,(symbol "phi")), you no longer +need to use the ,(tt [symbol]) markup (,(ref :text [see subsection] +:subsection "Symbols")).])) + + (section :title [Rendering]) + + ) + +;;; arch-tag: e9c83c13-205f-4f68-9100-b445c21b959c diff --git a/doc/user/examples.skb b/doc/user/examples.skb index a37ece4..7aa8f59 100644 --- a/doc/user/examples.skb +++ b/doc/user/examples.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/examples.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 13:35:34 2003 */ -;* Last change : Tue Feb 3 14:52:33 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The list of examples */ -;*=====================================================================*/ +;;; examples.skb -- The list of examples +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Examples */ diff --git a/doc/user/figure.skb b/doc/user/figure.skb index 08fbdd5..5998986 100644 --- a/doc/user/figure.skb +++ b/doc/user/figure.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/figure.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Fri Sep 12 15:31:48 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe figures */ -;*=====================================================================*/ +;;; figure.skb -- Skribe figures +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Figure ... @label figure@ */ @@ -32,9 +41,10 @@ :see-also '(ref document)) -(example-produce + ;; Note: We can't use `example-produce' because the Lout engine, for + ;; instance, forbids the occurrence of `figure' within a table. (example :legend "The figure markup" (prgm :file "src/api14.skb")) - (disp (include "src/api14.skb"))) + (include "src/api14.skb") ;*--- List of figures -------------------------------------------------*/ (subsection :title "List of figures" @@ -51,8 +61,3 @@ shows how to display the list of figures of a document.]) (example :legend "The figure markup" (prgm :file "src/api15.skb")) (disp (include "src/api15.skb"))))) - - - - - diff --git a/doc/user/font.skb b/doc/user/font.skb index df0bfed..cd9ec88 100644 --- a/doc/user/font.skb +++ b/doc/user/font.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/font.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu Sep 4 11:53:32 2003 */ -;* Last change : Fri Sep 12 15:31:25 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe font */ -;*=====================================================================*/ +;;; font.skb -- Skribe font +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Font */ diff --git a/doc/user/footnote.skb b/doc/user/footnote.skb index 96101f3..2326a30 100644 --- a/doc/user/footnote.skb +++ b/doc/user/footnote.skb @@ -1,13 +1,23 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/footnote.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Sep 6 15:43:24 2003 */ -;* Last change : Fri Sep 12 15:32:13 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe footnotes. */ -;*=====================================================================*/ +;;; footnote.skb -- Footnotes. +;;; +;;; Copyright 2003 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Footnote ... */ @@ -18,7 +28,10 @@ the reference to the footnote.]) (doc-markup 'footnote - `((:number [The number of the footnote.]) + `((:label [This may be either a boolean (i.e., ,(code "#f") +or ,(code "#t")) indicating whether a footnote label should +automatically be produced, a string specifying a label to use (e.g., +,(code ["*"])), or a number.]) (#!rest text... [The text of the footnote.])) :see-also '(document chapter section)) diff --git a/doc/user/htmle.skb b/doc/user/htmle.skb index b5d0b0e..b28d7a0 100644 --- a/doc/user/htmle.skb +++ b/doc/user/htmle.skb @@ -1,14 +1,23 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/doc/user/htmle.skb */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 3 11:20:49 2003 */ -;* Last change : Wed Oct 27 12:05:53 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The documentation of the html engine */ -;*=====================================================================*/ -;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ +;;; htmle.skb -- The documentation of the html engine +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + ;*---------------------------------------------------------------------*/ ;* Document */ @@ -65,6 +74,9 @@ the document.]) (title-background "The title background color.") (title-foreground "The title foreground color.") (file-title-separator "A text to be inserted in between the document title and the chapter or section title when the chapter or section is rendered in a separate file.") + (file-name-proc "A two-argument procedure that should return +a string. This procedure is to be passed a node and an engine and +should return a file name for the HTML page corresponding to this node.") ;; index configuration (index-header-font-size "The index header font size.") ;; chapter configuration @@ -106,6 +118,6 @@ the document.]) (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"))) + :source "skribilo/engine/html.scm"))) diff --git a/doc/user/image.skb b/doc/user/image.skb index d08ad18..f74da22 100644 --- a/doc/user/image.skb +++ b/doc/user/image.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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.skb -- Skribe images +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Image ... @label image@ */ @@ -73,7 +82,9 @@ returns the name of the new converted image. On failure, it returns 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" + :skribe-source? #f + :source #f ;;"skribilo/runtime.scm" + :def '(define-markup (convert-image file formats) ...) :see-also '(skribe-image-path) :idx *function-index*))) diff --git a/doc/user/index.skb b/doc/user/index.skb index dd5e8fa..1a0d893 100644 --- a/doc/user/index.skb +++ b/doc/user/index.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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.skb -- Skribe indexes +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Index */ @@ -50,7 +59,7 @@ that pre-exists to all execution.]) (doc-markup 'default-index '() :common-args '() - :source "src/common/index.scm")) + :source "skribilo/index.scm")) ;*---------------------------------------------------------------------*/ ;* Index ... @label index@ */ diff --git a/doc/user/justify.skb b/doc/user/justify.skb index 94db7d5..9246e59 100644 --- a/doc/user/justify.skb +++ b/doc/user/justify.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; justify.skb -- Skribe justification +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Justification */ diff --git a/doc/user/latexe.skb b/doc/user/latexe.skb index f53737b..feca728 100644 --- a/doc/user/latexe.skb +++ b/doc/user/latexe.skb @@ -1,14 +1,23 @@ -;*=====================================================================*/ -;* 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)@ +;;; latexe.skb -- The documentation of the html engine +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + ;*---------------------------------------------------------------------*/ ;* Document */ @@ -45,7 +54,7 @@ (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")) + :source "skribilo/engine/latex.scm")) (subsection :title "LaTeX documentclass" diff --git a/doc/user/lib.skb b/doc/user/lib.skb index 499ca61..0cdfe80 100644 --- a/doc/user/lib.skb +++ b/doc/user/lib.skb @@ -1,11 +1,22 @@ -;;;; -;;;; 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) - +;;; lib.skb -- Standard library. +;;; +;;; Copyright 2003 Erick Gallesio +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. (chapter :title "Standard Library" @@ -34,24 +45,30 @@ 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 + (doc-markup 'load-document `((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" + ;;:skribe-source? #f + ;;:source "skribilo/evaluator.scm" + :source #f + :def '(define (load-document file #!rest opt #!key engine path) ...) :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 + (doc-markup '*load-options* '() - :source "../src/bigloo/eval.scm" + :skribe-source? #f- + ;;:source "skribilo/evaluator.scm" + :source #f + :def '(define (*load-options* #!optional opt) ...) :common-args '() - :see-also '(skribe-load) + :see-also '(load-document) :idx *function-index*) (p [Skribe provides functions for dealing with paths. These functions @@ -59,21 +76,31 @@ 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 + (doc-markup '*document-path* '() - :source "../src/bigloo/eval.scm" + ;;:skribe-source? #f + ;;:source "skribilo/parameters.scm" + :source #f + :def '(define (*document-path* #!optional opt) ...) :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!) + :others '() ;;'(*image-path* *bib-path* *source-path*) + :see-also '(include-document load-document image source +bibliography) :idx *function-index*) - (p [The function ,(code "skribe-path-set!") sets a new path.]) + (p [,(tt [*document-path*]) is a procedure as returned by SRFI-39 +,(tt [make-parameter]). As such, ,(tt [(*document-path*)]) returns the +current document path, while ,(tt [(*document-path* '("." +"/some/path"))]) changes the value of the current path. An equivalent +way to achieve this is by using ,(tt [skribe-path-set!]):]) + (doc-markup 'skribe-path-set! '((path [A list of strings which is the new Skribe search path.])) - :source "../src/bigloo/eval.scm" + :skribe-source? #f + :source "skribilo/utils/compat.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) + :others '() + :see-also '(*document-path*) :idx *function-index*)) ;;; Misc @@ -99,10 +126,10 @@ Skribe configuration. It can be used to ,(emph "get") or ,(emph "check") the configuration.]) (doc-markup 'skribe-configure - '((opt... [Optional arguments.])) + '((#!rest opt... [Optional arguments.])) :common-args '() :source #f - :def '(define (skribe-configure . opt...) ...) + :def '(define (skribe-configure #!rest opt...) ...) :idx *function-index*) (p [The function ,(code "skribe-configure") can be used in three distinct @@ -146,10 +173,10 @@ arguments if the same as that of ,(code "skribe-configure") when invoked with several arguments.]) (doc-markup 'skribe-enforce-configure - '((opt... [Optional arguments.])) + '((#!rest opt... [Optional arguments.])) :common-args '() :source #f - :def '(define (skribe-enforce-configure . opt...) ...) + :def '(define (skribe-enforce-configure #!rest opt...) ...) :idx *function-index*)) diff --git a/doc/user/line.skb b/doc/user/line.skb index 85f84dd..3f9dab3 100644 --- a/doc/user/line.skb +++ b/doc/user/line.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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.skb -- Line breaks +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Line breaks */ diff --git a/doc/user/links.skb b/doc/user/links.skb index b454f28..ae7301c 100644 --- a/doc/user/links.skb +++ b/doc/user/links.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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.skb -- Skribe links +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Links and references */ @@ -76,13 +85,13 @@ section, to bibliographic entries, to source code line number, etc.]) (: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").]) + (:ident [The identifier of a node (which was specified + as an ,(param :ident) value).]) + (:figure [The identifier of a ,(markup-ref "figure").]) + (:chapter [The title of a ,(markup-ref "chapter").]) + (:section [The title of a ,(markup-ref "section").]) + (:subsection [The title of a ,(markup-ref "subsection").]) + (:subsubsection [The title 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.]) diff --git a/doc/user/markup.skb b/doc/user/markup.skb index 272bfbe..3607053 100644 --- a/doc/user/markup.skb +++ b/doc/user/markup.skb @@ -1,18 +1,27 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; markup.skb -- The Skribe standard markups +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* API */ ;*---------------------------------------------------------------------*/ -(chapter :title "Standard Markups" [ +(chapter :title "Standard Markups" :ident "std-markups" [ This chapter describes the forms composing Skribe texts. In XML/HTML these forms are called ,(emph "markups"). In LaTeX they are called diff --git a/doc/user/ornament.skb b/doc/user/ornament.skb index e65b9d1..5fc2832 100644 --- a/doc/user/ornament.skb +++ b/doc/user/ornament.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; ornament.skb -- The skribe ornaments +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Ornaments */ diff --git a/doc/user/package.skb b/doc/user/package.skb index ad989d0..c81dacb 100644 --- a/doc/user/package.skb +++ b/doc/user/package.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; package.skb -- Packages +;;; +;;; Copyright 2004, 2005 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Standard packages */ @@ -25,7 +34,7 @@ Skribe distribution.]) 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") ...)]) +(prgm "(skribe-load \"package.skr\" ...)") [where ,(it (tt "package.skr")) is the described package.] @@ -43,11 +52,12 @@ markup ,(code "abstract"):]) (doc-markup 'abstract `((:class "The node class.") (:postscript [The URL of the PostScript version of the paper.])) + :ident "abstract(acmproc)" :common-args '() :idx-note "acmproc" :idx-suffix " (acmproc)" :force-engines *api-engines* - :source "../skr/acmproc.skr")) + :source "skribilo/package/acmproc.scm")) (subsection :title (tt "jfp.skr") :ident "jfp" (index :index *package-index* "jfp.skr" :note "package") @@ -57,11 +67,12 @@ This package enables producing LaTeX documents conforming to the markup ,(code "abstract"):]) (doc-markup 'abstract `((:postscript [The URL of the PostScript version of the paper.])) + :ident "abstract(jfp)" :common-args '() :idx-note "jfp" :idx-suffix " (jfp)" :force-engines *api-engines* - :source "../skr/jfp.skr")) + :source "skribilo/package/jfp.scm")) (subsection :title (tt "lncs.skr") :ident "lncs" (index :index *package-index* "lncs.skr" :note "package") @@ -75,7 +86,7 @@ markup ,(code "abstract"):]) :idx-note "lncs" :idx-suffix " (lncs)" :force-engines *api-engines* - :source "../skr/lncs.skr"))) + :source "skribilo/package/lncs.scm"))) ;*---------------------------------------------------------------------*/ ;* french */ @@ -102,7 +113,7 @@ This package is to be used to authoring simple letters. It redefines the :idx-note "letter" :idx-suffix " (letter)" :force-engines *api-engines* - :source "../skr/letter.skr")) + :source "skribilo/package/letter.scm")) ;*---------------------------------------------------------------------*/ ;* Web */ diff --git a/doc/user/pie.skb b/doc/user/pie.skb new file mode 100644 index 0000000..ace37f2 --- /dev/null +++ b/doc/user/pie.skb @@ -0,0 +1,71 @@ +;;; pie.skb -- Pie charts. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;;; FIXME: This is a stub and must be completed! + +(chapter :title [Pie Charts] :ident "pie-charts" + + (p [Skribilo contains a pie-chart formatting package, located in the +,(tt [(skribilo package pie)]) module. It allows users to produces +represent numeric data as pie charts as in the following example:] + + (disp (pie :title [Use of Document Formatting Systems] + :fingers? #t :labels 'outside + :initial-angle 90 + :ident "pie-skribilo-rulez" + (slice :weight 10 :color "red" :detach? #t + (bold [Skribilo])) + (slice :weight 6 :color "green" "Skribe") + (slice :weight 6 :color "blue" "Lout") + (slice :weight 4 :color "lightgrey" "LaTeX") + (slice :weight 2 :color "yellow" "Docbook") + (slice :weight 1 :color "black" "others")))) + + (p [A default implementation, which uses ,(ref :text [Ploticus] :url +"http://ploticus.sf.net") as an external program, is available for all +engines. There is also a specific implementation for the Lout engine +which relies on Lout's own pie-chart package. In the latter case, you +don't need to have Ploticus installed, but you need it in the former.]) + (p [Currently it only supports slice-coloring, but support for +textures (particularly useful for black & white printouts) could be +added in the future.]) + + (section :title [Syntax] + + (p [Let us start with a simple example:] + + (example-produce + (example :legend "Example of a pie chart" + (prgm :file "src/pie1.skb")) + (disp (include "src/pie1.skb")))) + + (p [This illustrates the three markups provided by the ,(tt [pie]) +package, namely ,(tt [pie]), ,(tt [slice]), and ,(tt [sliceweight]). +This last markup returns the weight of the slice it is used in, be it as +a percentage or an absolute value. Note that the ,(tt [:total]) option +of ,(tt [pie]) can be used to create pie charts no entirely filled.]) + (p [Various options allow the pie layout to be controlled:] + + (example-produce + (example :legend "Specifying the layout of a pie chart" + (prgm :file "src/pie2.skb")) + (disp (include "src/pie2.skb")))))) + +;;; arch-tag: 60382016-3a63-4466-83e0-46a259cb39ab diff --git a/doc/user/prgm.skb b/doc/user/prgm.skb index c894614..6fb44c9 100644 --- a/doc/user/prgm.skb +++ b/doc/user/prgm.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; prgm.skb -- Computer programs +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* fib ... */ diff --git a/doc/user/sectioning.skb b/doc/user/sectioning.skb index 48bbc45..860821d 100644 --- a/doc/user/sectioning.skb +++ b/doc/user/sectioning.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; sectioning.skb -- Sectioning markups +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* dummy-section-output ... */ @@ -101,7 +110,7 @@ paragraphs.]) (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" + :source "skribilo/package/base.scm" :see-also '(document chapter section paragraph))) ;*--- blockquote -----------------------------------------------------*/ diff --git a/doc/user/skribe-config.skb b/doc/user/skribe-config.skb index 956af63..7c5e4bb 100644 --- a/doc/user/skribe-config.skb +++ b/doc/user/skribe-config.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; skribe-config.skb -- The skribe-config tool +;;; +;;; Copyright 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* The skribe-config tool */ @@ -29,16 +38,18 @@ 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)))))))])) +;; Options (FIXME) +; (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/doc/user/skribec.skb b/doc/user/skribec.skb index 0f00632..9ea2fad 100644 --- a/doc/user/skribec.skb +++ b/doc/user/skribec.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; skribec.skb -- The Skribe compiler +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* The Skribe compiler */ @@ -43,10 +52,10 @@ its possible targets which one to choose. These suffixes are: (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*)]) +;; Options (FIXME) +;;(section :title "OPTIONS" :number #f [ +;;,(mark "skribe compiler option") +;;,(compiler-options *skribe-bin*)]) ;; Environment variables (section :title "ENVIRONMENT VARIABLES" :number #f [ diff --git a/doc/user/skribeinfo.skb b/doc/user/skribeinfo.skb index 502cc73..6ce8f73 100644 --- a/doc/user/skribeinfo.skb +++ b/doc/user/skribeinfo.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; skribeinfo.skb -- The Skribeinfo compiler +;;; +;;; Copyright 2001, 2002, 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* The Skribeinfo compiler */ diff --git a/doc/user/slide.skb b/doc/user/slide.skb index c1111ee..3e903ad 100644 --- a/doc/user/slide.skb +++ b/doc/user/slide.skb @@ -1,19 +1,64 @@ -;*=====================================================================*/ -;* 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") +;;; slide.skb -- Slides +;;; +;;; Copyright 2004 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +;*---------------------------------------------------------------------*/ +;* dummy-slide-set-output ... */ +;*---------------------------------------------------------------------*/ +(define dummy-slide-set-output + (lambda (n e) + (let* ((a (markup-option n :author)) + (t (markup-option n :title)) + (b (markup-body n)) + (ta (table (tr (map (lambda (n) + (td :valign 'top :align 'center n)) + (if (list? a) a (list a))))))) + (skribe-eval (center (bold t)) e) + (skribe-eval (center ta) e) + (output b e)))) + +(define dummy-slide-output + (lambda (n e) + (let* ((t (markup-option n :title)) + (b (markup-body n))) + (skribe-eval (bold t) e) + (output b e)))) + +(define dummy-slide-vspace-output + (lambda (n e) + (skribe-eval (linebreak) e) + (skribe-eval (center (tt "[vspace]")) e) + (skribe-eval (linebreak) e))) + +(define dummy-slide-embed-output + (lambda (n e) + (skribe-eval (linebreak) e) + (skribe-eval (tt (or (markup-option n :alt) + (markup-option n :command))) + e))) ;*---------------------------------------------------------------------*/ ;* Computer programs */ ;*---------------------------------------------------------------------*/ -(chapter :title "Slide Package" +(chapter :title "Slide Package" (p [ This chapter describes the facilities Skribe offers authoring slides. @@ -27,7 +72,7 @@ second one tells Skribe to generate slides for the LaTeX prosper package.]) ;*---------------------------------------------------------------------*/ ;* slide ... @label slide@ */ ;*---------------------------------------------------------------------*/ -(section :title "Slide" +(section :title "Slides and Slide Topics" (p [A ,(code "slide") function call creates a slide.]) @@ -44,7 +89,33 @@ the vertical space size between the title and the body of the slide.]) 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")) + :source "skribilo/package/slide.scm") + + (p [Optionally, one may group slides into ,(emph [topics]) and +,(emph [subtopics]). Topics and subtopics are just logical grouping +under a given title that are meant to provide structure to a set of +slides. With their ,(code [:outline?]) option, these two markups can be +used to automatically produce an outline at the beginning of each new +(sub)topic, so that the audience knows what the talk is heading to.]) + + (doc-markup 'slide-topic + `((:title [The title of a topic.]) + (:outline? [A boolean (i.e., ,(code [#t]) or ,(code +[#f])) telling whether an outline should be produced at the beginning of +this topic. The outline will typically list the titles of the different +topics, as well as the titles of the slides under the current topic.])) + :source "skribilo/package/slide.scm") + + (p [The ,(code [slide-subtopic]) markup is similar:]) + + (doc-markup 'slide-subtopic + `((:title [The title of a subtopic.]) + (:outline? [A boolean (i.e., ,(code [#t]) or ,(code +[#f])) telling whether an outline should be produced at the beginning of +this subtopic. The outline will typically list the titles of the +different subtopics, as well as the titles of the slides under the +current subtopic.])) + :source "skribilo/package/slide.scm")) ;*---------------------------------------------------------------------*/ ;* slide-pause */ @@ -52,12 +123,12 @@ list ,(code "(split blinds box wipe dissolve glitter)").]) (section :title "Pause" (p [A ,(code "slide-pause") function call introduces a pause in the slide -projection.]) +projection. This may not be supported by all engines.]) (doc-markup 'slide-pause '() :common-args '() - :source "../skr/slide.skr")) + :source "skribilo/package/slide.scm")) ;*---------------------------------------------------------------------*/ ;* slide-vspace ... */ @@ -70,7 +141,7 @@ projection.]) '((:unit [The unit of the space.]) (#!rest val [The size of the vertical space.])) :common-args '() - :source "../skr/slide.skr")) + :source "skribilo/package/slide.scm")) ;*---------------------------------------------------------------------*/ ;* slide-embed ... */ @@ -92,7 +163,7 @@ to the embedded application.]) (:alt [An alternative Skribe expression to be used if the output format does not support embedded application.])) :common-args '() - :source "../skr/slide.skr")) + :source "skribilo/package/slide.scm")) ;*---------------------------------------------------------------------*/ ;* Example */ @@ -101,14 +172,29 @@ output format does not support embedded application.])) (p [Here is a complete example of Skribe slides:]) (if (and (engine-format? "html") - (not (equal? (engine-custom html-engine 'html-variant) "html4"))) + (not (equal? (engine-custom (find-engine 'html) 'html-variant) + "html4"))) ;; Show the example and its result (example-produce - (example :legend "Example of Skribe slides" + (example :legend "Example of Skribilo slides" (prgm :file "src/slides.skb")) - (disp (include "src/slides.skb"))) + (disp + (processor :combinator + (lambda (e1 e2) + (let ((e (copy-engine 'document-engine e2))) + (markup-writer 'document e + :options '(:title :author :ending) + :action dummy-slide-set-output) + (markup-writer 'slide e + :options '(:title :ident + :number :toc :vspace) + :action dummy-slide-output) + (markup-writer 'slide-vspace + :action dummy-slide-vspace-output) + (markup-writer 'slide-embed + :action dummy-slide-embed-output) + e)) + (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/doc/user/src/Makefile.am b/doc/user/src/Makefile.am new file mode 100644 index 0000000..6c61a1f --- /dev/null +++ b/doc/user/src/Makefile.am @@ -0,0 +1,11 @@ +EXTRA_DIST = api1.skb api10.skb api11.skb api12.skb api13.skb \ + api14.skb api15.skb api16.skb api17.skb api18.skb \ + api19.skb api2.skb api20-html.skb api20-lout.skb api3.skb \ + api4.skb api5.skb api6.skb api7.skb api8.skb \ + api9.skb bib1.sbib bib2.skb bib3.skb bib4.skb \ + bib5.skb bib6.skb eq1.skb eq2.skb index1.skb \ + index2.skb index3.skb links1.skb links2.skb pie1.skb pie2.skb \ + prgm1.skb prgm2.skb prgm3.skb slides.skb \ + start1.skb start2.skb start3.skb start4.skb start5.skb + +## arch-tag: 9614a784-cac2-4399-bd61-18c9172f48a8 diff --git a/doc/user/src/api14.skb b/doc/user/src/api14.skb index a3ede40..e9dd370 100644 --- a/doc/user/src/api14.skb +++ b/doc/user/src/api14.skb @@ -6,4 +6,4 @@ (center (figure :legend "The great Penguin" - (image :file "linux.gif"))) + (image :file "linux.png"))) diff --git a/doc/user/src/api16.skb b/doc/user/src/api16.skb index a9d5705..6be4283 100644 --- a/doc/user/src/api16.skb +++ b/doc/user/src/api16.skb @@ -1,5 +1,5 @@ -(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") +(image :file "linux.png" "A first image") +(image :height 50 :file "linux.png" "A smaller one") +(image :file "bsd.png" "A second image") +(image :width 50 :file "bsd.png") +(image :width 200 :height 40 :file "bsd.png") diff --git a/doc/user/src/api2.skb b/doc/user/src/api2.skb index 2c20965..4a89705 100644 --- a/doc/user/src/api2.skb +++ b/doc/user/src/api2.skb @@ -1,4 +1,4 @@ -(document :title "This is a Scribe document" +(document :title "This is a Skribilo 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"))) diff --git a/doc/user/src/api20-html.skb b/doc/user/src/api20-html.skb new file mode 100644 index 0000000..686efcb --- /dev/null +++ b/doc/user/src/api20-html.skb @@ -0,0 +1,2 @@ +[A simple ,(! "string"). A more annoying one ,(! "string"). +A last one with arguments ,(! "$1 $2" (bold 1) (it 2)).] diff --git a/doc/user/src/api20-lout.skb b/doc/user/src/api20-lout.skb new file mode 100644 index 0000000..89fb961 --- /dev/null +++ b/doc/user/src/api20-lout.skb @@ -0,0 +1,2 @@ +[A simple ,(! "string"). A more annoying one ,(! "@B { string }"). +A last one with arguments ,(! "@Underline { $1 $2 }" (bold 1) (it 2)).] diff --git a/doc/user/src/api20.skb b/doc/user/src/api20.skb deleted file mode 100644 index 686efcb..0000000 --- a/doc/user/src/api20.skb +++ /dev/null @@ -1,2 +0,0 @@ -[A simple ,(! "string"). A more annoying one ,(! "string"). -A last one with arguments ,(! "$1 $2" (bold 1) (it 2)).] diff --git a/doc/user/src/bib1.sbib b/doc/user/src/bib1.sbib index 3f1c04f..6afff71 100644 --- a/doc/user/src/bib1.sbib +++ b/doc/user/src/bib1.sbib @@ -12,6 +12,8 @@ (year "1991")) (misc bigloo + (author "Manuel Serrano") + (year "2006") (url "http://www.inria.fr/mimosa/fp/Bigloo")) (misc scheme:r4rs diff --git a/doc/user/src/eq1.skb b/doc/user/src/eq1.skb new file mode 100644 index 0000000..bbd0742 --- /dev/null +++ b/doc/user/src/eq1.skb @@ -0,0 +1,6 @@ +;; The golden ratio, phi. +(eq (eq:= (symbol "phi") + (eq:/ (eq:+ 1 (eq:sqrt 5)) + 2))) + + diff --git a/doc/user/src/eq2.skb b/doc/user/src/eq2.skb new file mode 100644 index 0000000..199fd7d --- /dev/null +++ b/doc/user/src/eq2.skb @@ -0,0 +1,3 @@ +;; The golden ratio, phi. +(eq '(= phi (/ (+ 1 (sqrt 5)) 2))) + diff --git a/doc/user/src/links1.skb b/doc/user/src/links1.skb index e0ce61c..e0b393b 100644 --- a/doc/user/src/links1.skb +++ b/doc/user/src/links1.skb @@ -1,6 +1,6 @@ [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). +,(ref :ident "std-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"). diff --git a/doc/user/src/pie1.skb b/doc/user/src/pie1.skb new file mode 100644 index 0000000..0d0fd0b --- /dev/null +++ b/doc/user/src/pie1.skb @@ -0,0 +1,13 @@ +;; A sad pie chart. +;; + +(pie :title [Casualties in the Israel-Lebanon 2006 Conflict (source: +English Wikipedia page, 2006-07-23)] + :total 450 ;; to show the uncertainty on figures + :ident "pie-lebanon-2006" + :labels 'outside :fingers? #t + + (slice :weight 8 :color "black" [Hezbollah militants]) + (slice :weight 42 :color "blue" [soldiers]) + (slice :weight 317 :color "red" :detach? #t + [civilians (,(sliceweight :percentage? #t)%)])) diff --git a/doc/user/src/pie2.skb b/doc/user/src/pie2.skb new file mode 100644 index 0000000..84b5394 --- /dev/null +++ b/doc/user/src/pie2.skb @@ -0,0 +1,14 @@ +;; Another sad pie chart. +;; + +(pie :title [Casualties of the Conflict in Iraq since 2003 (source: +English Wikipedia page, 2006-07-23)] + :ident "pie-iraq-2006" + :fingers? #f + :labels 'inside + :initial-angle 45 + :radius 2 + + (slice :weight 100000 :color "red" :detach? #t + [civilians (,(sliceweight :percentage? #t)%)]) + (slice :weight (+ 2555 229) :color #xeeeeee [soldiers])) diff --git a/doc/user/src/slides.skb b/doc/user/src/slides.skb index ac584d1..e5e6896 100644 --- a/doc/user/src/slides.skb +++ b/doc/user/src/slides.skb @@ -6,22 +6,28 @@ :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 "Table of Contents" :number #f :toc #f + (toc :chapter #f :section #f :subsection #f :subsubsection #f))) +;;; :slide #t))) + + (slide :title "Introduction" :vspace 0.3 + + (p [This is a simple slide, not grouped in any topic.])) - (slide :title "X11 client" :toc #t :vspace 0.3 + (slide-topic :title "Interactive Features" :outline? #t - (itemize - (item "xlock") - (item "xeyes") - (item "xterm"))) + (slide :title "X11 client" :toc #t :vspace 0.3 - (slide :title "Xclock" :toc #t :vspace 0.3 + (itemize + (item "xlock") + (item "xeyes") + (item "xterm"))) - (center (sf (underline "The Unix xclock client"))) - (slide-vspace 0.3) + (slide :title "Xclock" :toc #t :vspace 0.3 - (slide-pause) - (slide-embed :command "xlock" - :alt (frame "Can't run embedded application")))) + (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/doc/user/src/start3.skb b/doc/user/src/start3.skb index 0705966..65fa738 100644 --- a/doc/user/src/start3.skb +++ b/doc/user/src/start3.skb @@ -1,9 +1,9 @@ (document :title [Hello World!] -(section :title [A first Section] [ +(chapter :title [A first Section] [ This is a ,(bold [very]) ,(it [simple]) ,(color :fg [red] [text]).]) -(section :title [A second Section] [ +(chapter :title [A second Section] [ That section contains an ,(bold itemize) construction: ,(itemize (item [first item]) (item [second item]) diff --git a/doc/user/src/start4.skb b/doc/user/src/start4.skb index 3311925..31fba0c 100644 --- a/doc/user/src/start4.skb +++ b/doc/user/src/start4.skb @@ -1,13 +1,13 @@ -(document :title [Various links] [ +(document :title [Various links] -(section :title "A Section" [ + (chapter :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] [ + (chapter :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.])]) +of the Scribe User Manual.])) diff --git a/doc/user/src/start5.skb b/doc/user/src/start5.skb index 9e6b877..6977608 100644 --- a/doc/user/src/start5.skb +++ b/doc/user/src/start5.skb @@ -6,4 +6,4 @@ (itemize (map (lambda (x) (item (it (markup-option x :title)))) - sects))))) \ No newline at end of file + sects))))) diff --git a/doc/user/start.skb b/doc/user/start.skb index f3c1e28..0835b31 100644 --- a/doc/user/start.skb +++ b/doc/user/start.skb @@ -1,26 +1,34 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; start.skb -- Getting started with Skribe +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* 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.]) +(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!" [ @@ -148,7 +156,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 [ @@ -192,6 +201,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/doc/user/syntax.skb b/doc/user/syntax.skb index de60bd9..4b18d33 100644 --- a/doc/user/syntax.skb +++ b/doc/user/syntax.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; syntax.skb -- The syntax of Skribe +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* The Skribe syntax */ diff --git a/doc/user/table.skb b/doc/user/table.skb index c726d44..0408778 100644 --- a/doc/user/table.skb +++ b/doc/user/table.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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.skb -- Skribe tables +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Table ... */ @@ -66,6 +75,7 @@ attribute is only supported by HTML engines supporting (: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.]) + (:rowspan [The number of columns that the cell spans over.]) (#!rest node [The value of the cell.])) :writer-id 'tc :ignore-args '(m) diff --git a/doc/user/toc.skb b/doc/user/toc.skb index aa6c0dc..9650951 100644 --- a/doc/user/toc.skb +++ b/doc/user/toc.skb @@ -1,13 +1,22 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ +;;; toc.skb -- Table of contents +;;; +;;; Copyright 2003 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. ;*---------------------------------------------------------------------*/ ;* Sectioning */ @@ -21,6 +30,7 @@ inclusion of chapters in the table of contents.]) (:section [A boolean controlling sections.]) (:subsection [A boolean controlling subsections.]) + (:subsubsection [A boolean controlling subsubsections.]) (#!rest handle [An optional handle pointing to the node from which the table of contents if computed.])) :see-also '(document chapter section resolve handle)) diff --git a/doc/user/user.skb b/doc/user/user.skb index 07a6e03..5cfe209 100644 --- a/doc/user/user.skb +++ b/doc/user/user.skb @@ -1,21 +1,43 @@ -;*=====================================================================*/ -;* 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 */ -;*=====================================================================*/ - +;;; user.skb -- The Skribilo user manual. +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + ;*---------------------------------------------------------------------*/ ;* The Skribe documentation style */ ;*---------------------------------------------------------------------*/ -(skribe-load "web-book.skr") -(skribe-load "skr/env.skr") -(skribe-load "skr/manual.skr") -(skribe-load "skr/api.skr") +(use-modules (skribilo package web-book) + (skribilo documentation env) + (skribilo documentation manual) + (skribilo documentation api)) + + +;*---------------------------------------------------------------------*/ +;* Packages */ +;*---------------------------------------------------------------------*/ +(use-modules (skribilo package eq) + (skribilo package pie)) + +;; Load the compile-time configuration file. +(load "doc-config.scm") + +(if %have-ploticus? (set! %ploticus-program %ploticus-path)) ;*---------------------------------------------------------------------*/ ;* HTML custom */ @@ -26,40 +48,36 @@ (engine-custom-set! he 'body-width 100.)) ;*---------------------------------------------------------------------*/ -;* The various indexes */ +;* Lout custom */ ;*---------------------------------------------------------------------*/ -(define *markup-index* (make-index "markup")) -(define *custom-index* (make-index "custom")) -(define *function-index* (make-index "function")) -(define *package-index* (make-index "package")) +(let ((le (find-engine 'lout))) + (engine-custom-set! le 'document-type 'doc)) + ;*---------------------------------------------------------------------*/ ;* The document */ ;*---------------------------------------------------------------------*/ -(document :title "Skribe User Manual" +(document :title "Skribilo User Manual" + :keywords '("Skribilo" "Skribe" "User Manual" "text processing" + "HTML" "LaTeX" "Lout" "PostScript" "PDF") :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. [ -This is the documentation for Skribe version -,(color :fg "red" (skribe-release)).])))) - (linebreak 1) +(p :class "welcome" + [Welcome to the User Manual for Skribilo version ,(skribe-release). +If you are new to Skribilo, please read the ,(ref :ident "intro" +:text [introduction]) first.]) + ;;; Introduction -(section :title "Introduction" :number #f :toc #f [ +(chapter :title "Introduction" :ident "intro" :number #f :toc #t :file #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 @@ -68,13 +86,15 @@ 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 [ + (section :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.]) +any text description languages such as ,(ref :text [LaTeX] :url +"http://latex-project.org/"), ,(ref :text [Lout] :url +"http://lout.sf.net/") or HTML.]) - (subsection :title "Why using Skribe?" :number #f [ + (section :title "Why using Skribe?" :number #f [ There are three main reasons for using Skribe:] (itemize @@ -122,6 +142,12 @@ as HTML, Info pages, man pages, Postscript, etc.])))) ;;; Computer programs (include "prgm.skb") +;;; Equations +(include "eq.skb") + +;;; Pie charts +(if %have-ploticus? (include "pie.skb")) + ;;; Standard Library (include "lib.skb") @@ -151,12 +177,12 @@ as HTML, Info pages, man pages, Postscript, etc.])))) (begin (chapter :title "Table of contents" (toc :chapter #t :section #t :subsection #t)) - (section :title "Index" :number #f + (chapter :title "Index" :number #f :ident "Index" (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" + (chapter :title "Index" :ident "Index" (mark "global index") (the-index :column (if (engine-format? "latex") 2 3) *markup-index* *custom-index* *function-index* *package-index* diff --git a/doc/user/xmle.skb b/doc/user/xmle.skb index 4a1ee78..bd01db3 100644 --- a/doc/user/xmle.skb +++ b/doc/user/xmle.skb @@ -1,25 +1,34 @@ -;*=====================================================================*/ -;* 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)@ +;;; xmle.skb -- The documentation of the XML engine +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + ;*---------------------------------------------------------------------*/ ;* Document */ ;*---------------------------------------------------------------------*/ -(section :title "Xml engine" :file #t +(section :title "XML engine" :file #t (mark "xml-engine") - (index "Xml" :note "Engine") - (p [The Xml engine...]) + (index "XML" :note "Engine") + (p [The XML engine...]) - (subsection :title "The Xml customization" + (subsection :title "The XML customization" (doc-engine 'xml `() - :source "skr/xml.skr"))) + :source "skribilo/engine/xml.scm"))) diff --git a/emacs/Makefile b/emacs/Makefile deleted file mode 100644 index 52074cb..0000000 --- a/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/etc/ChangeLog b/etc/ChangeLog deleted file mode 100644 index 6987245..0000000 --- a/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/etc/Makefile b/etc/Makefile deleted file mode 100644 index 349fcf8..0000000 --- a/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/etc/Makefile.config b/etc/Makefile.config deleted file mode 100644 index 3ee672a..0000000 --- a/etc/Makefile.config +++ /dev/null @@ -1,9 +0,0 @@ -## Skribe (1.2d) configure -## Don't edit, file generated by etc/bigloo/configure -SKRIBERELEASE=1.2d -SKRIBEBETARELEASE=1.2d-beta.2 - -SYSTEM=bigloo -SKRIBE=$(BINDIR)/skribe.bigloo -SKRIBEINFO=$(BINDIR)/skribeinfo.bigloo -SKRIBEBIBTEX=$(BINDIR)/skribebibtex.bigloo diff --git a/etc/bigloo/Makefile b/etc/bigloo/Makefile deleted file mode 100644 index 82ffceb..0000000 --- a/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/etc/bigloo/Makefile.skb b/etc/bigloo/Makefile.skb deleted file mode 100644 index 51d6086..0000000 --- a/etc/bigloo/Makefile.skb +++ /dev/null @@ -1,158 +0,0 @@ -## Skribe (1.2d) configure -## Don't edit, file generated by etc/bigloo/configure - -TARGET=c - -SKRIBEDIR=/tmp/skribe1.2d/etc/bigloo/../.. -SKRIBEBINDIR=$(SKRIBEDIR)/bin -SKRIBELIBDIR=$(SKRIBEDIR)/lib -SKRIBEFILDIR=$(SKRIBEDIR)/lib - -DISTRIBDIR=/users/serrano/prgm/distrib - -INSTALL_BINDIR=/usr/local/bin -INSTALL_LIBDIR=/usr/local/lib -INSTALL_FILDIR=/usr/local/lib/skribe/1.2d -INSTALL_SKRDIR=/usr/local/share/skribe/1.2d/skr -INSTALL_EXTDIR=/usr/local/share/skribe/extensions -INSTALL_DOCDIR=/usr/local/doc/skribe-1.2d -INSTALL_MANDIR=$(DESTDIR)/users/serrano/house/man -INSTALL_HOSTHTTP= -INSTALL_MASK=755 - -RELEASE=2.7a - -POSIXOS=linux - -RM=/bin/rm - -INSTALLBEE=full - -BOOTDIR=/users/serrano/prgm/project/bigloo -BOOTBINDIR=/users/serrano/prgm/project/bigloo/bin -BOOTLIBDIR=/users/serrano/prgm/project/bigloo/lib/2.7a - -DESTDIR= -BINDIR=/users/serrano/prgm/project/bigloo/bin -LIBDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/lib -FILDIR=/users/serrano/prgm/project/bigloo/lib/2.7a -ZIPDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/lib/2.7a -SYSZIPDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/lib/2.7a -DLLDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/lib/2.7a -SYSDLLDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/lib/2.7a -MANDIR=$(DESTDIR)/users/serrano/house/man -INFODIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/info -DOCDIR=$(DESTDIR)/users/serrano/prgm/project/bigloo/manuals -TMP=/tmp - -NATIVEBACKEND=yes -LIBRARYNAME=bigloo - -CC=gcc -CFLAGS=-O3 -Wswitch -Wtrigraphs -CSTRIPFLAGS=-s -CPICFLAGS=-DBGL_NO_PIC -CFLAGS_P=$(CFLAGS) -pg -fno-inline -CGCFLAGS=-DSILENT -DNO_SIGNALS -DNO_DEBUGGING -Iinclude -DFINALIZE_ON_DEMAND -EXTRALIBS=-ldl -lm - -GCLIB=bigloogc -GCCUSTOM=yes -GCDIR=$(BOOTDIR)/gc-boehm -GCINCLUDE=-I$(GCDIR) -I$(GCDIR)/include -I$(GCDIR)/include/private - -EXTRA_LD_OPT= -SHRD_COMP=no -SHRD_BDE_OPT= -EXE_SUFFIX= -AS=gcc -c -x assembler-with-cpp - -AR=ar -ARFLAGS=qc -RANLIB=ranlib -SHAREDLIBRARYSUPPORT=yes -LD=ld -shared -LDFLAGS= -LDLIBS=-lc -LDPRELOADSUPPORT=yes -LDSONAME=-soname - -SHAREDSUFFIX=so - -DLOPENSUPPORT=yes - -CGCTHREADFLAGS=-DGC_LINUX_THREADS -D_REENTRANT -DGC_THREADS -DTHREAD_LOCAL_ALLOC -DFINALIZE_ON_DEMAND -PTHREADLIBS=-lpthread -STRIP=strip - -EMACS=emacs -EMACSDIR=/users/serrano/emacs/site-lisp/bigloo -EMACSBRAND=emacs21 -EWARN=-eval '(setq byte-compile-error-on-warn t)' - -BMASK=755 - -MAKEINFO=makeinfo -MAKEINFOOPT=-U oldinfo -TEXI2DVI=texi2dvi -TEXI2DVIOPT=-b -TEXI2HTML= -TEXI2HTMLOPT=-menu -monolithic -number -TEXI2PDF=texi2pdf -INSTALLINFO= -INSTALLINFODIROPT= - -JVMBACKEND=yes -JAVA=java -JFLAGS= -JVFLAGS=-noverify -JAVAC=javac -JCFLAGS=-O -ZIP=zip -ZFLAGS= -JAR=jar cmf -JSHELL=sh -JVMRECETTEBOOTPATH=-classpath ".:../lib/2.7a/bigloo_s.zip:objs_jvm" -JVMAPIBOOTPATH=-classpath ".:../../../../../lib/2.7a/bigloo_s.zip" -CYGWINJVMPATH= -JVMCLASSPATHSEP=":" - -DOTNETBACKEND=yes -DOTNETCSCC=cscc -DOTNETCSCCSTYLE=pnet -DOTNETASM=ilasm.pnet -DOTNETLD=cscc -DOTNETLDSTYLE=pnet - -DOTNETFTDLLPATH=-L../../../../../lib/2.7a -DOTNETLINKBIGLOODLL=-lbigloo_s-2.7a.dll - -JSMBACKEND=yes - -BFLAGS=-O3 - -SCRIPTEXTENSION= -C_OBJ_EXTENSION=o - -APIS=fthread pthread - - -BIGLOO=bigloo -BIGLOO_FILDIR=/users/serrano/prgm/project/bigloo/lib/2.7a -BIGLOO_LIBDIR=/users/serrano/prgm/project/bigloo/lib - -BLINKFLAGS=-no-hello -ld-relative -O3 -ldopt '' -BSAFEFLAGS=-no-hello -fno-reflection -g -BHEAPFLAGS=-unsafe -q -mkaddheap -mkaddlib -BCOMMONFLAGS=-no-hello -fno-reflection -O3 -BCFLAGS=-copt "$(CPICFLAGS)" -BJVMFLAGS=-jvm -jvm-purify -saw -jvm-env SKRIBEPATH - -AFILE=afile -JFILE=jfile -BTAGS=btags -BDEPEND=bdepend -SKRIBEINDENT=bpp - -RM=/bin/rm - diff --git a/etc/bigloo/Makefile.tpl b/etc/bigloo/Makefile.tpl deleted file mode 100644 index 24326c1..0000000 --- a/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/etc/bigloo/autoconf/Makefile b/etc/bigloo/autoconf/Makefile deleted file mode 100644 index c077107..0000000 --- a/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/etc/bigloo/autoconf/bfildir b/etc/bigloo/autoconf/bfildir deleted file mode 100755 index 128d5c7..0000000 --- a/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/etc/bigloo/autoconf/blibdir b/etc/bigloo/autoconf/blibdir deleted file mode 100755 index 603d484..0000000 --- a/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/etc/bigloo/autoconf/bversion b/etc/bigloo/autoconf/bversion deleted file mode 100755 index 1f24c86..0000000 --- a/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/etc/bigloo/autoconf/getbversion b/etc/bigloo/autoconf/getbversion deleted file mode 100755 index ff83b1c..0000000 --- a/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/etc/bigloo/autoconf/gmaketest b/etc/bigloo/autoconf/gmaketest deleted file mode 100755 index 1bedd72..0000000 --- a/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/etc/bigloo/configure b/etc/bigloo/configure deleted file mode 100755 index 9215911..0000000 --- a/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/etc/config b/etc/config deleted file mode 100644 index d9df69f..0000000 --- a/etc/config +++ /dev/null @@ -1,4 +0,0 @@ -# Automatically generated file (don't edit) -release=1.2d -skribeurl=http://www.inria.fr/mimosa/fp/Skribe -prefix=/usr/local diff --git a/etc/skribe-config b/etc/skribe-config deleted file mode 100644 index d12312b..0000000 --- a/etc/skribe-config +++ /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 /usr/local - ;; - --version|-v) - echo 1.2d - ;; - --extension-dir|-e) - echo /usr/local/share/skribe/extensions - ;; - --skr-dir|-k) - echo /usr/local/share/skribe/1.2d/skr - ;; - --doc-dir|-d) - echo /usr/local/doc/skribe-1.2d - ;; - --emacs-dir|-m) - echo /users/serrano/emacs/site-lisp/bigloo - ;; - --scheme|-s) - echo bigloo - ;; - --help|-h|-\?) - usage 0 1>&2 - ;; - *) - echo "bad option $1" 1>&2 - usage 1 1>&2 - ;; - esac - shift -done -exit 0 - diff --git a/etc/skribe-config.in b/etc/skribe-config.in deleted file mode 100644 index 2a03e26..0000000 --- a/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/etc/stklos/Makefile.config.in b/etc/stklos/Makefile.config.in deleted file mode 100644 index 13a60d8..0000000 --- a/etc/stklos/Makefile.config.in +++ /dev/null @@ -1,5 +0,0 @@ -SYSTEM=@SYSTEM@ -SKRIBE=@SKRIBE@ -SKRIBEINFO=@SKRIBEINFO@ -SKRIBEBIBTEX=@SKRIBEBIBTEX@ - diff --git a/etc/stklos/Makefile.in b/etc/stklos/Makefile.in deleted file mode 100644 index 186fd58..0000000 --- a/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/etc/stklos/Makefile.skb.in b/etc/stklos/Makefile.skb.in deleted file mode 100644 index 7568474..0000000 --- a/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/etc/stklos/configure b/etc/stklos/configure deleted file mode 100755 index e1d2526..0000000 --- a/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/etc/stklos/configure.in b/etc/stklos/configure.in deleted file mode 100644 index 956af77..0000000 --- a/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/examples/Makefile b/examples/Makefile deleted file mode 100644 index 7f47f6e..0000000 --- a/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/examples/slide/Makefile b/examples/slide/Makefile deleted file mode 100644 index c9b7a84..0000000 --- a/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/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/base.skr b/skr/base.skr deleted file mode 100644 index ec987ec..0000000 --- a/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/skr/context.skr b/skr/context.skr deleted file mode 100644 index 5bc5316..0000000 --- a/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/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/html.skr b/skr/html.skr deleted file mode 100644 index ebac5f2..0000000 --- a/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/skr/html4.skr b/skr/html4.skr deleted file mode 100644 index acb7068..0000000 --- a/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/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/latex-simple.skr b/skr/latex-simple.skr deleted file mode 100644 index dd2eccb..0000000 --- a/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/skr/latex.skr b/skr/latex.skr deleted file mode 100644 index bc20493..0000000 --- a/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/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/skr/xml.skr b/skr/xml.skr deleted file mode 100644 index 784b6f0..0000000 --- a/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.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/.arch-inventory b/src/.arch-inventory new file mode 100644 index 0000000..55c64c1 --- /dev/null +++ b/src/.arch-inventory @@ -0,0 +1,4 @@ +# Generated file. +precious ^skribilo$ + +# arch-tag: 6042e4ec-e23e-4bf2-be59-016a0ff89518 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/Makefile.am b/src/Makefile.am new file mode 100644 index 0000000..4a83f1a --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1,4 @@ +SUBDIRS = guile + +EXTRA_DIST = skribilo.in +bin_SCRIPTS = skribilo 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 e40638b..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 #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/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 397ba09..0000000 --- a/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/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/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..e410a87 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,5 @@ +SUBDIRS = skribilo + +guilemoduledir = $(GUILE_SITE) +dist_guilemodule_DATA = skribilo.scm +EXTRA_DIST = README diff --git a/src/guile/README b/src/guile/README new file mode 100644 index 0000000..6c5128f --- /dev/null +++ b/src/guile/README @@ -0,0 +1,63 @@ +Skribilo -*- Outline -*- +======== + +Skribilo is a port of Skribe to GNU Guile. + +Here are a few goals. + +* Usability + +** Integration with Guile's module system + +** Better error handling, automatic back-traces, etc. + +** Add useful markups + +- `document': add `:keywords' and `:language', maybe `:date' + +- numbered references + +- improved footnotes + +** Add an option to continuously watch a file and re-compile it + +* Font-ends (readers) + +** Implement a new front-end mechanism (see `(skribilo reader)') + +** Skribe front-end (read Skribe syntax) + +Done. + +** Texinfo front-end + +Use guile-library's `stexi'. + +** Simple markup front-end (à la `txt2tags', Emacs' outline mode, or Wiki) + +Almost done (Emacs `outline-mode'). + +* Back-ends (engines) + +** Easier to plug-in new back-ends (no need to modify the source) + +** Better HTML (or XHTML?) back-end + +** Lout back-end (including automatic `lout' invocation?) + +Done, except automatic invocation. + +** Info back-end + +* Packages + +** Pie charts + +** Equations + +* Toys + +** Document browser with guile-gnome + + +;;; arch-tag: 2d0a6235-5c09-4930-998c-56a4de2c0aca diff --git a/src/guile/skribilo.scm b/src/guile/skribilo.scm new file mode 100644 index 0000000..531b0fb --- /dev/null +++ b/src/guile/skribilo.scm @@ -0,0 +1,480 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code +main='(module-ref (resolve-module '\''(skribilo)) '\'main')' +exec ${GUILE-guile} --debug -l $0 -c "(apply $main (cdr (command-line)))" "$@" +!# + +;;;; skribilo.scm +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. + +;;;; Commentary: +;;;; +;;;; Usage: skribilo [ARGS] +;;;; +;;;; Process a skribilo document. +;;;; +;;;; Code: + + + +(define-module (skribilo) + :autoload (skribilo module) (make-run-time-module *skribilo-user-module*) + :autoload (skribilo engine) (*current-engine*) + :autoload (skribilo reader) (*document-reader*) + :use-module (skribilo utils syntax)) + +(use-modules (skribilo evaluator) + (skribilo debug) + (skribilo parameters) + (skribilo lib) + + (srfi srfi-39) + (ice-9 optargs) + (ice-9 getopt-long)) + + +;; Install the Skribilo module syntax reader. +(fluid-set! current-reader %skribilo-module-reader) + +(if (not (keyword? :kw)) + (error "guile-reader sucks")) + + + + +(define* (process-option-specs longname + :key (alternate #f) (arg #f) (help #f) + :rest thunk) + "Process STkLos-like option specifications and return getopt-long option +specifications." + `(,(string->symbol longname) + ,@(if alternate + `((single-char ,(string-ref alternate 0))) + '()) + (value ,(if arg #t #f)))) + +(define (raw-options->getopt-long options) + "Converts @var{options} to a getopt-long-compatible representation." + (map (lambda (option-specs) + (apply process-option-specs (car option-specs))) + options)) + +(define-macro (define-options binding . options) + `(define ,binding (quote ,(raw-options->getopt-long options)))) + +(define-options skribilo-options + (("reader" :alternate "R" :arg reader + (nothing))) + (("target" :alternate "t" :arg target + :help "sets the output format to ") + (set! engine (string->symbol target))) + (("load-path" :alternate "I" :arg path :help "adds to Skribe path") + (set! paths (cons path paths))) + (("bib-path" :alternate "B" :arg path :help "adds to bibliography path") + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("source-path" :alternate "S" :arg path :help "adds to source path") + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("image-path" :alternate "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*))) + (if (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))) + (if (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))) + (if (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)))))) + + +; (define skribilo-options +; ;; Skribilo options in getopt-long's format, as computed by +; ;; `raw-options->getopt-long'. +; `((target (single-char #\t) (value #f)) +; (I (value #f)) +; (B (value #f)) +; (S (value #f)) +; (P (value #f)) +; (split-chapters (single-char #\C) (value #f)) +; (preload (value #f)) +; (use-variant (single-char #\u) (value #f)) +; (base (single-char #\b) (value #f)) +; (rc-dir (single-char #\d) (value #f)) +; (no-init-file (value #f)) +; (output (single-char #\o) (value #f)) +; (help (single-char #\h) (value #f)) +; (options (value #f)) +; (version (single-char #\V) (value #f)) +; (query (single-char #\q) (value #f)) +; (verbose (single-char #\v) (value #f)) +; (warning (single-char #\w) (value #f)) +; (debug (single-char #\g) (value #f)) +; (no-color (value #f)) +; (custom (single-char #\c) (value #f)) +; (eval (single-char #\e) (value #f)))) + + +(define (skribilo-show-help) + (format #t "Usage: skribilo [OPTIONS] [INPUT] + +Processes a Skribilo/Skribe source file and produces its output. + + --reader=READER Use READER to parse the input file (by default, + the `skribe' reader is used) + --target=ENGINE Use ENGINE as the underlying engine + + --help Give this help list + --version Print program version +~%")) + +(define (skribilo-show-version) + (format #t "skribilo ~a~%" (skribilo-release))) + +;;;; ====================================================================== +;;;; +;;;; 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*))) + (if (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))) + (if (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))) + (if (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 + (if engine + (set! *skribe-engine* engine)))) + +;;;; ====================================================================== +;;;; +;;;; L O A D - R C +;;;; +;;;; ====================================================================== +(define *load-rc* #f) ;; FIXME: This should go somewhere else. + +(define (load-rc) + (if *load-rc* + (let ((file (make-path (*rc-directory*) (*rc-file*)))) + (if (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*)))) + +(define *skribilo-output-port* (make-parameter (current-output-port))) + +(define (doskribe) + (let ((output-port (current-output-port)) + (user-module (current-module))) + (dynamic-wind + (lambda () + ;; FIXME: Using this technique, anything written to `stderr' will + ;; also end up in the output file (e.g. Guile warnings). + (set-current-output-port (*skribilo-output-port*)) + (let ((user (make-run-time-module))) + (set-current-module user) + (*skribilo-user-module* user))) + (lambda () + ;;(format #t "engine is ~a~%" (*current-engine*)) + (evaluate-document-from-port (current-input-port) + (*current-engine*))) + (lambda () + (set-current-output-port output-port) + (set-current-module user-module) + (*skribilo-user-module* #f))))) + + + +;;;; ====================================================================== +;;;; +;;;; M A I N +;;;; +;;;; ====================================================================== +(define-public (skribilo . args) + (let* ((options (getopt-long (cons "skribilo" args) + skribilo-options)) + (reader-name (string->symbol + (option-ref options 'reader "skribe"))) + (engine (string->symbol + (option-ref options 'target "html"))) + (output-file (option-ref options 'output #f)) + (debugging-level (option-ref options 'debug "0")) + (warning-level (option-ref options 'warning "2")) + (load-path (option-ref options 'load-path ".")) + (bib-path (option-ref options 'bib-path ".")) + (source-path (option-ref options 'source-path ".")) + (image-path (option-ref options 'image-path ".")) + (preload '()) + (variants '()) + + (help-wanted (option-ref options 'help #f)) + (version-wanted (option-ref options 'version #f))) + + ;; Set up the debugging infrastructure. + (debug-enable 'debug) + (debug-enable 'backtrace) + (debug-enable 'procnames) + + (cond (help-wanted (begin (skribilo-show-help) (exit 1))) + (version-wanted (begin (skribilo-show-version) (exit 1)))) + + ;; Parse the most important options. + + (if (> (*debug*) 4) + (set! %load-hook + (lambda (file) + (format #t "~~ loading `~a'...~%" file)))) + + (parameterize ((*document-reader* (make-reader reader-name)) + (*current-engine* engine) + (*document-path* (cons load-path (*document-path*))) + (*bib-path* (cons bib-path (*bib-path*))) + (*source-path* (cons source-path + (append %load-path + (*source-path*)))) + (*image-path* (cons image-path (*image-path*))) + (*debug* (string->number debugging-level)) + (*warning* (string->number warning-level)) + (*verbose* (let ((v (option-ref options + 'verbose 0))) + (if (number? v) v + (if v 1 0))))) + + ;; Load the user rc file + ;;(load-rc) + + (for-each (lambda (f) + (skribe-load f :engine (*current-engine*))) + preload) + + ;; Load the specified variants. + (for-each (lambda (x) + (skribe-load (format #f "~a.skr" x) + :engine (*current-engine*))) + (reverse! variants)) + + (let ((files (option-ref options '() '()))) + + (if (> (length files) 2) + (error "you can specify at most one input file and one output file" + files)) + + (let* ((source-file (if (null? files) #f (car files)))) + + (if (and output-file (file-exists? output-file)) + (delete-file output-file)) + + (parameterize ((*destination-file* output-file) + (*source-file* source-file) + (*skribilo-output-port* + (if (string? output-file) + (open-output-file output-file) + (current-output-port)))) + + (setvbuf (*skribilo-output-port*) _IOFBF 16384) + + ;; (start-stack 7 + (if source-file + (with-input-from-file source-file doskribe) + (doskribe)))))))) + + +(define main skribilo) + +;;; skribilo ends here. diff --git a/src/guile/skribilo/.arch-inventory b/src/guile/skribilo/.arch-inventory new file mode 100644 index 0000000..d9ada5e --- /dev/null +++ b/src/guile/skribilo/.arch-inventory @@ -0,0 +1,5 @@ +# Object files generated by Guile-VM's compiler + configuration file +# generated at `configure'-time. +precious ^(.*\.go|config.scm)$ + +# arch-tag: c25ac71e-94bc-4246-8486-49e4179987b8 diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am new file mode 100644 index 0000000..48fa5ca --- /dev/null +++ b/src/guile/skribilo/Makefile.am @@ -0,0 +1,10 @@ +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 \ + source.scm parameters.scm verify.scm \ + writer.scm ast.scm location.scm \ + condition.scm + +SUBDIRS = utils reader engine package coloring biblio diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm new file mode 100644 index 0000000..542f629 --- /dev/null +++ b/src/guile/skribilo/ast.scm @@ -0,0 +1,602 @@ +;;; ast.scm -- Skribilo abstract syntax trees. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo ast) + :use-module (oop goops) + + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + :use-module (skribilo condition) + :use-module (skribilo utils syntax) + + :autoload (skribilo location) (location?) + :autoload (srfi srfi-1) (fold) + :export ( ast? ast-loc ast-loc-set! + ast-parent ast->string ast->file-location + ast-resolved? + + command? command-fmt command-body + unresolved? unresolved-proc + handle? handle-ast handle-body + node? node-options node-loc node-body + processor? processor-combinator processor-engine + + markup? markup-options is-markup? + markup-markup markup-body markup-body-set! + markup-ident markup-class + markup-option markup-option-set! + markup-option-add! markup-output + markup-parent markup-document markup-chapter + + container? container-options + container-ident container-body + container-env-get + + document? document-ident document-body + document-options document-end + document-lookup-node document-bind-node! + document-bind-nodes! + + ;; traversal + ast-fold + container-search-down search-down find-down find1-down + find-up find1-up + ast-document ast-chapter ast-section + + ;; error conditions + &ast-error &ast-orphan-error &ast-cycle-error + &markup-unknown-option-error &markup-already-bound-error + ast-orphan-error? ast-orphan-error:ast + ast-cycle-error? ast-cycle-error:object + markup-unknown-option-error? + markup-unknown-option-error:markup + markup-unknown-option-error:option + markup-already-bound-error? + markup-already-bound-error:markup + markup-already-bound-error:ident)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; The abstract syntax tree (AST) and its sub-types. These class form the +;;; core of a document: each part of a document is an instance of `' or +;;; one of its sub-classes. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Error conditions. +;;; + +(define-condition-type &ast-error &skribilo-error + ast-error?) + +(define-condition-type &ast-orphan-error &ast-error + ast-orphan-error? + (ast ast-orphan-error:ast)) + +(define-condition-type &ast-cycle-error &ast-error + ast-cycle-error? + (object ast-cycle-error:object)) + +(define-condition-type &markup-unknown-option-error &ast-error + markup-unknown-option-error? + (markup markup-unknown-option-error:markup) + (option markup-unknown-option-error:option)) + +(define-condition-type &markup-already-bound-error &ast-error + markup-already-bound-error? + (markup markup-already-bound-error:markup) + (ident markup-already-bound-error:ident)) + + +(define (handle-ast-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((ast-orphan-error? c) + (let* ((node (ast-orphan-error:ast c)) + (location (and (ast? node) (ast-loc node)))) + (format (current-error-port) "orphan node: ~a~a~%" + node + (if (location? location) + (string-append " " + (location-file location) ":" + (location-line location)) + "")))) + + ((ast-cycle-error? c) + (let ((object (ast-cycle-error:object c))) + (format (current-error-port) + "cycle found in AST: ~a~%" object))) + + ((markup-unknown-option-error? c) + (let ((markup (markup-unknown-option-error:markup c)) + (option (markup-unknown-option-error:option c))) + (format (current-error-port) + "~a: unknown markup option for `~a'~%" + option markup))) + + ((markup-already-bound-error? c) + (let ((markup (markup-already-bound-error:markup c)) + (ident (markup-already-bound-error:ident c))) + (format (current-error-port) + "`~a' (~a): markup identifier already bound~%" + ident + (if (markup? markup) + (markup-markup markup) + markup)))) + + (else + (format (current-error-port) "undefined resolution error: ~a~%" + c)))) + +(register-error-condition-handler! ast-error? handle-ast-error) + + + +;;; +;;; Abstract syntax tree (AST). +;;; + +;;FIXME: set! location in +(define-class () + ;; Parent of this guy. + (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) + + ;; Its source location. + (loc :init-value #f) + + ;; This slot is used as an optimization when resolving an AST: sub-parts of + ;; the tree are marked as resolved as soon as they are and don't need to be + ;; traversed again. + (resolved? :accessor ast-resolved? :init-value #f)) + + +(define (ast? obj) (is-a? obj )) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) +(define (ast-parent n) + (slot-ref n 'parent)) + + +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format #f "~a:~a:" (location-file l) (location-line l)) + ""))) + +(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-class () + (fmt :init-keyword :fmt) + (body :init-keyword :body)) + +(define (command? obj) (is-a? obj )) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (proc :init-keyword :proc)) + +(define (unresolved? obj) (is-a? obj )) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (ast :init-keyword :ast :init-value #f :getter handle-ast)) + +(define (handle? obj) (is-a? obj )) +(define (handle-ast obj) (slot-ref obj 'ast)) +(define (handle-body h) (slot-ref h 'body)) + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (required-options :init-keyword :required-options :init-value '()) + (options :init-keyword :options :init-value '()) + (body :init-keyword :body :init-value #f + :getter node-body)) + +(define (node? obj) (is-a? obj )) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + +(define-method (ast->string (ast )) + (ast->string (slot-ref ast 'body))) + + +;;; ====================================================================== +;;; +;;; +;;; +;;; ====================================================================== +(define-class () + (combinator :init-keyword :combinator :init-value (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-value 'unspecified) + (procedure :init-keyword :procedure :init-value (lambda (n e) n))) + +(define (processor? obj) (is-a? obj )) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + + + +;;; +;;; Markup. +;;; + +(define-class () + (ident :init-keyword :ident :getter markup-ident :init-value #f) + (class :init-keyword :class :getter markup-class :init-value #f) + (markup :init-keyword :markup :getter markup-markup)) + + +(define (markup? obj) (is-a? obj )) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) +(define (markup-body-set! m body) + (slot-set! m 'resolved? #f) + (slot-set! m 'body body)) + +(define (markup-option m opt) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (and (pair? c) (pair? (cdr c)) + (cadr c))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option") + (argument m)))))) + +(define (markup-option-set! m opt val) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (if (and (pair? c) (pair? (cdr c))) + (set-cdr! c (list val)) + (raise (condition (&markup-unknown-option-error + (markup m) + (option opt)))))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-set!") + (argument m)))))) + +(define (markup-option-add! m opt val) + (if (markup? m) + (slot-set! m 'options (cons (list opt val) + (slot-ref m 'options))) + (raise (condition (&invalid-argument-error + (proc-name "markup-option-add!") + (argument m)))))) + + +(define (is-markup? obj markup) + (and (is-a? obj ) + (eq? (slot-ref obj 'markup) markup))) + + +(define (markup-parent m) + (let ((p (slot-ref m 'parent))) + (if (eq? p 'unspecified) + (raise (condition (&ast-orphan-error (ast m)))) + p))) + +(define (markup-document m) + (let Loop ((p m) + (l #f)) + (cond + ((is-markup? p 'document) p) + ((or (eq? p 'unspecified) (not p)) l) + (else (Loop (slot-ref p 'parent) p))))) + +(define (markup-chapter m) + (let loop ((p m) + (l #f)) + (cond + ((is-markup? p 'chapter) p) + ((or (eq? p 'unspecified) (not p)) l) + (else (loop (slot-ref p 'parent) p))))) + + + + +(define-method (write (obj ) port) + (format port "#<~A (~A/~A) ~A>" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (object-address obj))) + +(define-method (write (node ) port) + (let ((proc (slot-ref node 'proc))) + (format port "#< (~A~A) ~A>" + proc + (let* ((name (or (procedure-name proc) "")) + (source (procedure-source proc)) + (file (and source (source-property source 'filename))) + (line (and source (source-property source 'line)))) + ;;(format (current-error-port) "src=~a~%" source) + (string-append name + (if file + (string-append " " file + (if line + (number->string line) + "")) + ""))) + (object-address node)))) + + + +;;; XXX: This was already commented out in the original Skribe source. +;;; +;; (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-class () + (env :init-keyword :env :init-value '())) + +(define (container? obj) (is-a? obj )) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + +(define (container-env-get m key) + (let ((c (assq key (slot-ref m 'env)))) + (and (pair? c) (cadr c)))) + + + +;;; +;;; Document. +;;; + +(define-class () + (node-table :init-thunk make-hash-table :getter document-node-table) + (nodes-bound? :init-value #f :getter document-nodes-bound?)) + + +(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 (document-lookup-node doc ident) + ;; Lookup the node with identifier IDENT (a string) in document DOC. + (hash-ref (document-node-table doc) ident)) + +(define (document-bind-node! doc node . ident) + ;; Bind NODE (a markup object) to DOC (a document object). + (let ((ident (if (null? ident) (markup-ident node) (car ident)))) + (if ident + (let ((handle (hash-get-handle (document-node-table doc) ident))) + ;;(format (current-error-port) "binding `~a' in `~a'~%" ident node) + (if (and (pair? handle) (not (eq? (cdr handle) node))) + (raise (condition (&markup-already-bound-error + (ident ident) + (markup node)))) + (hash-set! (document-node-table doc) ident node)))))) + +(define (document-bind-nodes! doc) + ;; Bind all the nodes contained in DOC if they are not already bound. + ;; Once, this is done, `document-lookup-node' can be used to search a node + ;; by its identifier. + + ;; We assume that unresolved nodes do not introduce any new identifier, + ;; hence this optimization. + (if (document-nodes-bound? doc) + #t + (begin + (ast-fold (lambda (node result) + (if (markup? node) (document-bind-node! doc node)) + #t) + #t ;; unused + doc) + (slot-set! doc 'nodes-bound? #t)))) + + +;;; +;;; AST traversal utilities. +;;; + +(define (ast-fold proc init ast) + ;; Apply PROC to each node in AST (per `node?'), in a way similar to `fold' + ;; (in SRFI-1). + (let loop ((ast ast) + (result init)) + (cond ((pair? ast) + (fold loop result ast)) + ((node? ast) + (loop (node-body ast) (proc ast result))) + (else result)))) + + +;; The procedures below are almost unchanged compared to Skribe 1.2d's +;; `lib.scm' file found in the `common' directory, written by Manuel Serrano +;; (I removed uses of `with-debug' et al., though). + + +(define (container-search-down pred 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 + '())))) + +(define (search-down pred 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 + '())))) + +(define (find-down pred obj) + (let loop ((obj obj)) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (if (pred obj) + (list (cons obj (loop (markup-body obj)))) + '())) + (else + (if (pred obj) + (list obj) + '()))))) + +(define (find1-down pred obj) + (let loop ((obj obj) + (stack '())) + (cond + ((memq obj stack) + (raise (condition (&ast-cycle-error (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)))) + +(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)))))) + +(define (find1-up pred obj) + (let loop ((obj obj)) + (cond + ((not (ast? obj)) + #f) + ((pred obj) + obj) + (else + (loop (ast-parent obj)))))) + +(define (ast-document m) + (find1-up document? m)) + +(define (ast-chapter m) + (find1-up (lambda (n) (is-markup? n 'chapter)) m)) + +(define (ast-section m) + (find1-up (lambda (n) (is-markup? n 'section)) m)) + + +;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7 + +;;; ast.scm ends here diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm new file mode 100644 index 0000000..1fb4b78 --- /dev/null +++ b/src/guile/skribilo/biblio.scm @@ -0,0 +1,382 @@ +;;; biblio.scm -- Bibliography functions. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA.main.st + + + +(define-module (skribilo biblio) + :use-module (skribilo utils strings) + :use-module (skribilo utils syntax) ;; `when', `unless' + + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :use-module (srfi srfi-1) + :autoload (skribilo condition) (&file-search-error) + + :autoload (skribilo reader) (%default-reader) + :autoload (skribilo parameters) (*bib-path*) + :autoload (skribilo ast) ( is-markup?) + + :use-module (ice-9 optargs) + :use-module (oop goops) + + :export (bib-table? make-bib-table default-bib-table + bib-add! bib-duplicate bib-for-each bib-map + skribe-open-bib-file parse-bib + + bib-load! resolve-bib resolve-the-bib make-bib-entry + + ;; sorting entries + bib-sort/authors bib-sort/idents bib-sort/dates)) + +;;; Author: Erick Gallesio, Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Provides the bibliography data type and basic bibliography handling, +;;; including simple procedures to sort bibliography entries. +;;; +;;; FIXME: This module need cleanup! +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;; FIXME: Should be a fluid? +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + + + +;;; ====================================================================== +;;; +;;; Utilities +;;; +;;; ====================================================================== + +(define (make-bib-table ident) + (make-hash-table)) + +(define (bib-table? obj) + (hash-table? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +(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)))) + +(define* (bib-for-each proc :optional (table (default-bib-table))) + (hash-for-each (lambda (ident entry) + (proc ident entry)) + table)) + +(define* (bib-map proc :optional (table (default-bib-table))) + (hash-map->list (lambda (ident entry) + (proc ident entry)) + table)) + + +;;; ====================================================================== +;;; +;;; BIB-DUPLICATE +;;; +;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format #f "duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format #f " using version of `~a'.\n" ofrom) + "") + (if from + (format #f " ignoring version of `~a'." from) + " ignoring redefinition.")))) + + +;;; ====================================================================== +;;; +;;; PARSE-BIB +;;; +;;; ====================================================================== +(define (parse-bib table port) + (let ((read %default-reader)) ;; FIXME: We should use a fluid + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-filename port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate ident from old) + (hash-set! 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 #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate key #f old) + (hash-set! 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 (search-path (*bib-path*) file))) + (if (string? path) + (begin + (when (> (*verbose*) 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format #f command path)) + path))) + (raise (condition (&file-search-error (file-name file) + (path (*bib-path*)))))))) + + +;;; +;;; High-level API. +;;; +;;; The contents of the file below are unchanged compared to Skribe 1.2d's +;;; `bib.scm' file found in the `common' directory. The copyright notice for +;;; this file was: +;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano +;;; + + +;*---------------------------------------------------------------------*/ +;* 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 (hash-ref table i))) + (if (is-markup? en '&bib-entry) + en + #f)))) + +;*---------------------------------------------------------------------*/ +;* make-bib-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-entry kind ident fields from) + (let* ((m (make + :markup '&bib-entry + :ident ident + :options `((kind ,kind) (from ,from)))) + (h (make :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) + (make + :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 + (make + :markup '&bib-entry-ident + :parent (car es) + :options `((number ,i)) + :body (make :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 (hash-map->list (lambda (key val) val) 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)) + (make + :markup '&the-bibliography + :options opts + :body fes)))) + + +;;; biblio.scm ends here diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am new file mode 100644 index 0000000..9442562 --- /dev/null +++ b/src/guile/skribilo/biblio/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/biblio +dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm + +## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657 diff --git a/src/guile/skribilo/biblio/abbrev.scm b/src/guile/skribilo/biblio/abbrev.scm new file mode 100644 index 0000000..9c88b6a --- /dev/null +++ b/src/guile/skribilo/biblio/abbrev.scm @@ -0,0 +1,170 @@ +;;; abbrev.scm -- Determining abbreviations. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo biblio abbrev) + :use-module (srfi srfi-13) + :autoload (skribilo ast) (markup? markup-body-set!) + :autoload (skribilo utils strings) (make-string-replace) + :autoload (ice-9 regex) (regexp-substitute/global) + :export (is-abbreviation? is-acronym? abbreviate-word + abbreviate-string abbreviate-markup + + %cs-conference-abbreviations + %ordinal-number-abbreviations + %common-booktitle-abbreviations)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Heuristics to identify or generate abbreviations. This module +;;; particularly targets booktitle abbreviations (in bibliography entries). +;;; +;;; Code: + +(define (is-abbreviation? str) + ;; Return #t if STR denotes an abbreviation or name initial. + (and (>= (string-length str) 2) + (char=? (string-ref str 1) #\.))) + +(define (is-acronym? str) + (string=? str (string-upcase str))) + +(define (abbreviate-word word) + (if (or (string=? "" word) + (and (>= (string-length word) 3) + (string=? "and" (substring word 0 3))) + (is-acronym? word)) + word + (let ((dash (string-index word #\-)) + (abbr (string (string-ref word 0) #\.))) + (if (not dash) + abbr + (string-append (string (string-ref word 0)) "-" + (abbreviate-word + (substring word (+ 1 dash) + (string-length word)))))))) + +(define (abbreviate-string subst title) + ;; Abbreviate common conference names within TITLE based on the SUBST list + ;; of regexp-substitution pairs (see examples below). This function also + ;; removes the abbreviation if it appears in parentheses right after the + ;; substitution regexp. Example: + ;; + ;; "Symposium on Operating Systems Principles (SOSP 2004)" + ;; + ;; yields + ;; + ;; "SOSP" + ;; + (let loop ((title title) + (subst subst)) + (if (null? subst) + title + (let* ((abbr (cdar subst)) + (abbr-rexp (string-append "( \\(" abbr "[^\\)]*\\))?")) + (to-replace (string-append (caar subst) abbr-rexp))) + (loop (regexp-substitute/global #f to-replace title + 'pre abbr 'post) + (cdr subst)))))) + +(define (abbreviate-markup subst markup) + ;; A version of `abbreviate-string' generalized to arbitrary markup + ;; objects. + (let loop ((markup markup)) + (cond ((string? markup) + (let ((purify (make-string-replace '((#\newline " ") + (#\tab " "))))) + (abbreviate-string subst (purify markup)))) + ((list? markup) + (map loop markup)) + ((markup? markup) + (markup-body-set! markup (loop (markup-body title))) + markup) + (else markup)))) + + +;;; +;;; Common English abbreviations. +;;; + +;; The following abbreviation alists may be passed to `abbreviate-string' +;; and `abbreviate-markup'. + +(define %cs-conference-abbreviations + ;; Common computer science conferences and their acronym. + '(("(Symposium [oO]n )?Operating Systems? Design and [iI]mplementation" + . "OSDI") + ("(Symposium [oO]n )?Operating Systems? Principles" + . "SOSP") + ("([wW]orkshop [oO]n )?Hot Topics [iI]n Operating Systems" + . "HotOS") + ("([cC]onference [oO]n )?[fF]ile [aA]nd [sS]torage [tT]echnologies" + . "FAST") + ("([tT]he )?([iI]nternational )?[cC]onference [oO]n [aA]rchitectural Support [fF]or Programming Languages [aA]nd Operating Systems" + . "ASPLOS") + ("([tT]he )?([iI]nternational )?[cC]onference [oO]n Peer-[tT]o-[pP]eer Computing" + . "P2P") + ("([iI]nternational )?[cC]onference [oO]n [dD]ata [eE]ngineering" + . "ICDE") + ("([cC]onference [oO]n )?[mM]ass [sS]torage [sS]ystems( [aA]nd [tT]echnologies)?" + . "MSS") + ("([sS]ymposium [oO]n )?[nN]etworked [sS]ystems [dD]esign [aA]nd [Ii]mplementation" + . "NSDI"))) + + +(define %ordinal-number-abbreviations + ;; The poor man's abbreviation system. + + ;; FIXME: Given the current `abbreviate-string', there is no clean way to + ;; make it ignore things like "twenty-first" (instead of yielding an awful + ;; "twenty-1st"). + '(("[Ff]irst" . "1st") + ("[sS]econd" . "2nd") + ("[Tt]hird" . "3rd") + ("[Ff]ourth" . "4th") + ("[Ff]ifth" . "5th") + ("[Ss]ixth" . "6th") + ("[Ss]eventh" . "7th") + ("[eE]ighth" . "8th") + ("[Nn]inth" . "9th") + ("[Tt]enth" . "10th") + ("[Ee]leventh" . "11th") + ("[Tt]welfth" . "12th") + ("[Tt]hirteenth" . "13th") + ("[Ff]ourteenth" . "14th") + ("[Ff]ifteenth" . "15th") + ("[Ss]ixteenth" . "16th") + ("[Ss]eventeenth" . "17th") + ("[Ee]ighteenth" . "18th") + ("[Nn]ineteenth" . "19th"))) + +(define %common-booktitle-abbreviations + ;; Common book title abbreviations. This is used by + ;; `abbreviate-booktitle'. + '(("[pP]roceedings?" . "Proc.") + ("[iI]nternational" . "Int.") + ("[sS]ymposium" . "Symp.") + ("[cC]onference" . "Conf."))) + + +;;; arch-tag: 34e0c5bb-592f-467b-b59a-d6f7d130ae4e + +;;; abbrev.scm ends here diff --git a/src/guile/skribilo/biblio/author.scm b/src/guile/skribilo/biblio/author.scm new file mode 100644 index 0000000..ea15f4c --- /dev/null +++ b/src/guile/skribilo/biblio/author.scm @@ -0,0 +1,136 @@ +;;; author.scm -- Handling author names. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo biblio author) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) + :use-module (skribilo biblio abbrev) + :autoload (skribilo ast) (markup-option markup-body markup-ident) + :autoload (skribilo lib) (skribe-error) + :autoload (skribilo utils strings) (make-string-replace) + :export (comma-separated->author-list + comma-separated->and-separated-authors + + extract-first-author-name + abbreviate-author-first-names + abbreviate-first-names + first-author-last-name + + bib-sort/first-author-last-name)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Heuristics to manipulate author names as strings. +;;; +;;; Code: + +(define (comma-separated->author-list authors) + ;; Return a list of strings where each individual string is an author + ;; name. AUTHORS is a string representing a list of author names separated + ;; by a comma. + + ;; XXX: I should use SRFI-13 instead. + (string-split authors #\,)) + +(define (comma-separated->and-separated-authors authors) + ;; Take AUTHORS, a string containing comma-separated author names, and + ;; return a string where author names are separated by " and " (suitable + ;; for BibTeX). + (string-join (comma-separated->author-list authors) + " and " 'infix)) + + +(define (extract-first-author-name names) + ;; Extract the name of the first author from string + ;; NAMES that is a comma-separated list of authors. + (let ((author-name-end (or (string-index names #\,) + (string-length names)))) + (substring names 0 author-name-end))) + +(define (abbreviate-author-first-names name) + ;; Abbreviate author first names + (let* ((components (string-split name #\space)) + (component-number (length components))) + (apply string-append + (append + (map (lambda (c) + (string-append (abbreviate-word c) " ")) + (list-head components + (- component-number 1))) + (list-tail components (- component-number 1)))))) + +(define (abbreviate-first-names names) + ;; Abbreviate first names in NAMES. NAMES is supposed to be + ;; something like "Ludovic Courtès, Marc-Olivier Killijian". + (let loop ((names ((make-string-replace '((#\newline " ") + (#\tab " "))) + names)) + (result "")) + (if (string=? names "") + result + (let* ((len (string-length names)) + (first-author-names-end (or (string-index names #\,) + len)) + (first-author-names (substring names 0 + first-author-names-end)) + (next (substring names + (min (+ 1 first-author-names-end) len) + len))) + (loop next + (string-append result + (if (string=? "" result) "" ", ") + (abbreviate-author-first-names + first-author-names))))))) + + +(define (first-author-last-name authors) + ;; Return a string containing exactly the last name of the first author. + ;; Author names in AUTHORS are assumed to be comma separated. + (let loop ((first-author (extract-first-author-name authors))) + (let ((space (string-index first-author #\space))) + (if (not space) + first-author + (loop (substring first-author (+ space 1) + (string-length first-author))))))) + +(define (bib-sort/first-author-last-name entries) + ;; May be passed as the `:sort' argument of `the-bibliography'. + (let ((check-author (lambda (e) + (if (not (markup-option e 'author)) + (skribe-error 'web + "No author for this bib entry" + (markup-ident e)) + #t)))) + (sort entries + (lambda (e1 e2) + (let* ((x1 (check-author e1)) + (x2 (check-author e2)) + (a1 (first-author-last-name + (markup-body (markup-option e1 'author)))) + (a2 (first-author-last-name + (markup-body (markup-option e2 'author))))) + (string-ci<=? a1 a2)))))) + + +;;; arch-tag: c9a1ef10-a2cd-4a06-bd35-fbdee1abf09a + +;;; author.scm ends here diff --git a/src/guile/skribilo/biblio/bibtex.scm b/src/guile/skribilo/biblio/bibtex.scm new file mode 100644 index 0000000..319df1d --- /dev/null +++ b/src/guile/skribilo/biblio/bibtex.scm @@ -0,0 +1,83 @@ +;;; bibtex.scm -- Handling BibTeX references. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo biblio bibtex) + :autoload (skribilo utils strings) (make-string-replace) + :autoload (skribilo ast) (markup-option ast->string) + :autoload (skribilo engine) (engine-filter find-engine) + :use-module (skribilo biblio author) + :use-module (srfi srfi-39) + :export (print-as-bibtex-entry)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A set of BibTeX tools, e.g., issuing a BibTeX entry from a `&bib-entry' +;;; markup object. +;;; +;;; Code: + +(define *bibtex-author-filter* + ;; Defines how the `author' field is to be filtered. + (make-parameter comma-separated->and-separated-authors)) + +(define (print-as-bibtex-entry entry) + "Display @code{&bib-entry} object @var{entry} as a BibTeX entry." + (let ((show-option (lambda (opt) + (let* ((o (markup-option entry opt)) + (f (make-string-replace '((#\newline " ")))) + (g (if (eq? opt 'author) + (lambda (a) + ((*bibtex-author-filter*) (f a))) + f))) + (if (not o) + #f + `(,(symbol->string opt) + " = \"" + ,(g (ast->string (markup-body o))) + "\",")))))) + (format #t "@~a{~a,~%" + (markup-option entry 'kind) + (markup-ident entry)) + (for-each (lambda (opt) + (let* ((o (show-option opt)) + (tex-filter (engine-filter + (find-engine 'latex))) + (filter (lambda (n) + (tex-filter (ast->string n)))) + (id (lambda (a) a))) + (if o + (display + (apply string-append + `(,@(map (if (eq? 'url opt) + id filter) + (cons " " o)) + "\n")))))) + '(author institution title + booktitle journal number + year month url pages address publisher)) + (display "}\n"))) + + +;;; arch-tag: 8b5913cc-9077-4e92-839e-c4c633b7bd46 + +;;; bibtex.scm ends here diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm new file mode 100644 index 0000000..8b6205f --- /dev/null +++ b/src/guile/skribilo/color.scm @@ -0,0 +1,621 @@ +;;; color.scm -- Color management. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo color) + :autoload (srfi srfi-60) (bitwise-and arithmetic-shift) + :export (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + +;; FIXME: This module should be generalized and the `skribe-' procedures +;; moved to `compat.scm'. + +;; FIXME: Use a fluid? Or remove it? +(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 (bitwise-and #xff (arithmetic-shift spec -16)) + (bitwise-and #xff (arithmetic-shift spec -8)) + (bitwise-and #xff spec))) + (else + (values 0 0 0)))) + +;;; +;;; SKRIBE-GET-USED-COLORS +;;; +(define (skribe-get-used-colors) + *used-colors*) + +;;; +;;; SKRIBE-USE-COLOR! +;;; +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am new file mode 100644 index 0000000..b952237 --- /dev/null +++ b/src/guile/skribilo/coloring/Makefile.am @@ -0,0 +1,16 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/coloring +dist_guilemodule_DATA = c.scm lisp.scm xml.scm \ + lisp-lex.l.scm xml-lex.l.scm c-lex.l.scm + + +EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l + +# Building the lexers with SILex. You must previously run +# `tla build-config ./arch-config' for this to run. +# +# Note: Those files should normally be part of the distribution, making +# this rule useless to the user. +%.l.scm: %.l + $(GUILE) -L $(top_srcdir)/src/guile/silex \ + -c '(load-from-path "lex.scm") (lex "$^" "$@")' + diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l new file mode 100644 index 0000000..7d7b1ce --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l @@ -0,0 +1,67 @@ +;;;; +;;;; c-lex.l -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:10 (eg) +;;;; + +space [ \n\9] +letter [_a-zA-Z] +alphanum [_a-zA-Z0-9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +;;Comments +/\*.*\*/ (new markup + (markup '&source-line-comment) + (body yytext)) +//.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) +[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text +[^\"a-zA-Z]+ (begin yytext) + + + +<> 'eof +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + + + + + + \ No newline at end of file diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm new file mode 100644 index 0000000..d78e09e --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l.scm @@ -0,0 +1,1225 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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 Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file c-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'lisp-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) +;;Comments + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((65 (35 (34 1 5) (= 47 4 1)) (96 (91 3 (95 1 2)) (97 1 (123 3 1)))) + (65 (= 34 err 1) (97 (91 err 1) (123 err 1))) (91 (35 (34 1 err) (65 1 + 3)) (96 (95 1 2) (97 1 (123 3 1)))) (95 (65 err (91 3 err)) (97 (96 3 + err) (123 3 err))) (47 (35 (34 1 err) (= 42 7 1)) (91 (48 6 (65 1 err)) + (97 1 (123 err 1)))) (= 34 8 5) (35 (11 (10 6 1) (34 6 9)) (91 (65 6 9) + (97 6 (123 9 6)))) (42 (11 (10 7 1) (= 34 10 7)) (91 (43 11 (65 7 10)) + (97 7 (123 10 7)))) err (= 10 err 9) (11 (10 10 err) (= 42 12 10)) (43 + (34 (= 10 1 7) (35 10 (42 7 11))) (65 (= 47 13 7) (97 (91 10 7) (123 10 + 7)))) (42 (= 10 err 10) (47 (43 12 10) (48 14 10))) (42 (11 (10 7 1) (= + 34 10 7)) (91 (43 11 (65 7 10)) (97 7 (123 10 7)))) (11 (10 10 err) (= + 42 12 10))) + '#((#f . #f) (4 . 4) (3 . 3) (3 . 3) (4 . 4) (#f . #f) (2 . 2) (4 . 4) + (0 . 0) (2 . 2) (#f . #f) (4 . 4) (#f . #f) (1 . 1) (1 . 1)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm new file mode 100644 index 0000000..d2a2b9f --- /dev/null +++ b/src/guile/skribilo/coloring/c.scm @@ -0,0 +1,93 @@ +;;;; +;;;; c.stk -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:12 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module (skribilo c) + :export (c java) + :import (skribe runtime)) + +(include "c-lex.stk") ;; SILex generated + + +(define *the-keys* #f) + +(define *c-keys* #f) +(define *java-keys* #f) + + +(define (fontifier s) + (let ((lex (c-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; C +;;;; +;;;; ====================================================================== +(define (init-c-keys) + (unless *c-keys* + (set! *c-keys* '(for while return break continue void + do if else typedef struct union goto switch case + static extern default))) + *c-keys*) + +(define (c-fontifier s) + (fluid-let ((*the-keys* (init-c-keys))) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;;;; ====================================================================== +;;;; +;;;; JAVA +;;;; +;;;; ====================================================================== +(define (init-java-keys) + (unless *java-keys* + (set! *java-keys* (append (init-c-keys) + '(public final class throw catch)))) + *java-keys*) + +(define (java-fontifier s) + (fluid-let ((*the-keys* (init-java-keys))) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) + diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l new file mode 100644 index 0000000..30b6a44 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l @@ -0,0 +1,86 @@ +;;; lisp-lex.l -- SILex input for the Lisp Languages +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +space [ \n\9] +letter [#?!_:a-zA-Z\-] +digit [0-9] + + +%% +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +\;.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) +\[|\] (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis +[ \n\9\(\)]+ (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) +[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if (*class-highlight*) + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + (*the-keys*)))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + + +<> 'eof +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm new file mode 100644 index 0000000..6ae7fe6 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l.scm @@ -0,0 +1,1249 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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 Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file lisp-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (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))))) + ))) + 'decision-trees + 0 + 0 + '#((40 (32 (9 1 (11 2 1)) (34 (33 2 1) (35 5 1))) (91 (59 (42 2 1) (60 4 + 1)) (93 (92 3 1) (94 3 1)))) (40 (32 (9 1 (11 err 1)) (34 (33 err 1) + (35 err 1))) (91 (59 (42 err 1) (60 err 1)) (93 (92 err 1) (94 err + 1)))) (32 (9 err (11 2 err)) (40 (33 2 err) (42 2 err))) err (= 10 err + 4) (= 34 6 5) err) + '#((#f . #f) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (#f . #f) (0 . 0)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm new file mode 100644 index 0000000..13bb6db --- /dev/null +++ b/src/guile/skribilo/coloring/lisp.scm @@ -0,0 +1,302 @@ +;;;; lisp.scm -- Lisp Family Fontification +;;;; +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. + + +(define-module (skribilo coloring lisp) + :use-module (skribilo utils syntax) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo utils strings) + :use-module (srfi srfi-39) + :use-module (ice-9 match) + :autoload (ice-9 regex) (make-regexp) + :autoload (skribilo reader) (make-reader) + :export (skribe scheme stklos bigloo lisp)) + + +(define *bracket-highlight* (make-parameter #t)) +(define *class-highlight* (make-parameter #t)) +(define *the-keys* (make-parameter '())) + +(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 read tab def?) + (let Loop ((exp (read inp))) + (unless (eof-object? exp) + (if (def? exp) + (let ((start (and (pair? exp) (source-property exp 'line))) + (stop (port-line inp))) + (source-read-lines (port-filename inp) start stop tab)) + (Loop (read inp)))))) + +;; Load the SILex-generated lexer. +(load-from-path "skribilo/coloring/lisp-lex.l.scm") + +(define (lisp-family-fontifier s) + (lexer-init 'port (open-input-string s)) + (let loop ((token (lexer)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (loop (lexer) + (cons token res))))) + + +;;;; ====================================================================== +;;;; +;;;; LISP +;;;; +;;;; ====================================================================== +(define (lisp-extractor iport def tab) + (definition-search + iport + read + tab + (lambda (exp) + (match 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) + (parameterize ((*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 + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro) (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? 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) + (parameterize ((*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 + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-generic 'define-method 'define-macro) + (fun . _) . _) + (and (eq? def fun) exp)) + (((or 'define 'define-module) (? 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) + (parameterize ((*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 + (make-reader 'skribe) + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro 'define-markup 'define-public) + (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? 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) + (parameterize ((*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 + %skribilo-module-reader + tab + (lambda (exp) + (match 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) + (? symbol? var) . _) + (and (eq? var def) exp)) + (else #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l new file mode 100644 index 0000000..aa7d312 --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 21-Dec-2003 22:38 (eg) +;;;; + +space [ \n\9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +'[^']*' (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<> 'eof +<> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + + \ No newline at end of file diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm new file mode 100644 index 0000000..d58e42b --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l.scm @@ -0,0 +1,1221 @@ +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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 Street, Fifth Floor, Boston, MA 02110-1301, USA. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file xml-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'xml-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((40 (35 (34 1 5) (39 1 4)) (61 (60 1 3) (= 62 2 1))) (40 (35 (34 1 + err) (39 1 err)) (61 (60 1 err) (= 62 err 1))) err (33 (11 (10 6 err) + (32 6 err)) (62 (34 7 6) (63 err 6))) (= 39 8 4) (= 34 9 5) (32 (= 10 + err 6) (62 (33 err 6) (63 err 6))) (33 (11 (10 6 err) (32 6 err)) (46 + (45 6 10) (= 62 err 6))) err err (33 (11 (10 6 err) (32 6 err)) (46 (45 + 6 11) (= 62 err 6))) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 13) (= + 62 12 11))) (= 45 14 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 15) + (= 62 12 11))) (= 45 16 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 + 15) (= 62 17 11))) (46 (45 12 16) (= 62 17 12)) (= 45 14 12)) + '#((#f . #f) (4 . 4) (3 . 3) (#f . #f) (#f . #f) (#f . #f) (3 . 3) (3 . + 3) (1 . 1) (0 . 0) (3 . 3) (3 . 3) (#f . #f) (3 . 3) (#f . #f) (3 . 3) + (#f . #f) (2 . 2)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm new file mode 100644 index 0000000..e3db36f --- /dev/null +++ b/src/guile/skribilo/coloring/xml.scm @@ -0,0 +1,82 @@ +;;; 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/condition.scm b/src/guile/skribilo/condition.scm new file mode 100644 index 0000000..4d61efb --- /dev/null +++ b/src/guile/skribilo/condition.scm @@ -0,0 +1,171 @@ +;;; condition.scm -- Skribilo SRFI-35 error condition hierarchy. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo condition) + :autoload (srfi srfi-1) (find) + :autoload (srfi srfi-34) (guard) + :use-module (srfi srfi-35) + :use-module (srfi srfi-39) + :export (&skribilo-error skribilo-error? + &invalid-argument-error invalid-argument-error? + &too-few-arguments-error too-few-arguments-error? + + &file-error file-error? + &file-search-error file-search-error? + &file-open-error file-open-error? + &file-write-error file-write-error? + + register-error-condition-handler! + lookup-error-condition-handler + + %call-with-skribilo-error-catch + call-with-skribilo-error-catch)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; Top-level of Skribilo's SRFI-35 error conditions. +;;; +;;; Code: + + +;;; +;;; Standard error conditions. +;;; + +(define-condition-type &skribilo-error &error + skribilo-error?) + + +;;; +;;; Generic errors. +;;; + +(define-condition-type &invalid-argument-error &skribilo-error + invalid-argument-error? + (proc-name invalid-argument-error:proc-name) + (argument invalid-argument-error:argument)) + +(define-condition-type &too-few-arguments-error &skribilo-error + too-few-arguments-error? + (proc-name too-few-arguments-error:proc-name) + (arguments too-few-arguments-error:arguments)) + + +;;; +;;; File errors. +;;; + +(define-condition-type &file-error &skribilo-error + file-error? + (file-name file-error:file-name)) + +(define-condition-type &file-search-error &file-error + file-search-error? + (path file-search-error:path)) + +(define-condition-type &file-open-error &file-error + file-open-error?) + +(define-condition-type &file-write-error &file-error + file-write-error?) + + + +;;; +;;; Adding new error conditions from other modules. +;;; + +(define %external-error-condition-alist '()) + +(define (register-error-condition-handler! pred handler) + (set! %external-error-condition-alist + (cons (cons pred handler) + %external-error-condition-alist))) + +(define (lookup-error-condition-handler c) + (let ((pair (find (lambda (pair) + (let ((pred (car pair))) + (pred c))) + %external-error-condition-alist))) + (if (pair? pair) + (cdr pair) + #f))) + + + +;;; +;;; Convenience functions. +;;; + +(define (%call-with-skribilo-error-catch thunk exit exit-val) + (guard (c ((invalid-argument-error? c) + (format (current-error-port) "in `~a': invalid argument: ~S~%" + (invalid-argument-error:proc-name c) + (invalid-argument-error:argument c)) + (exit exit-val)) + + ((too-few-arguments-error? c) + (format (current-error-port) "in `~a': too few arguments: ~S~%" + (too-few-arguments-error:proc-name c) + (too-few-arguments-error:arguments c))) + + ((file-search-error? c) + (format (current-error-port) "~a: not found in path `~S'~%" + (file-error:file-name c) + (file-search-error:path c)) + (exit exit-val)) + + ((file-open-error? c) + (format (current-error-port) "~a: cannot open file~%" + (file-error:file-name c)) + (exit exit-val)) + + ((file-write-error? c) + (format (current-error-port) "~a: cannot write to file~%" + (file-error:file-name c)) + (exit exit-val)) + + ((file-error? c) + (format (current-error-port) "file error: ~a~%" + (file-error:file-name c)) + (exit exit-val)) + + (;;(skribilo-error? c) + #t ;; XXX: The SRFI-35 currently in `guile-lib' doesn't work + ;; properly with non-direct super-types. + (let ((handler (lookup-error-condition-handler c))) + (if (procedure? handler) + (handler c) + (format (current-error-port) + "undefined skribilo error: ~S~%" + c))) + (exit exit-val))) + + (thunk))) + +(define-macro (call-with-skribilo-error-catch thunk) + `(call/cc (lambda (cont) + (%call-with-skribilo-error-catch ,thunk cont #f)))) + +;;; arch-tag: 285010f9-06ea-4c39-82c2-6c3604f668b3 + +;;; conditions.scm ends here diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in new file mode 100644 index 0000000..545612c --- /dev/null +++ b/src/guile/skribilo/config.scm.in @@ -0,0 +1,20 @@ +;;; -*- Scheme -*- +;;; + +(define-module (skribilo config)) + +(define-public (skribilo-release) "1.2") +(define-public (skribilo-url) "http://www.nongnu.org/skribilo/") +(define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") +(define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") +(define-public (skribilo-default-path) "@SKRIBILO_SKR_PATH@") +(define-public (skribilo-scheme) "guile") + +;; Compatibility. + +(define-public skribe-release skribilo-release) +(define-public skribe-url skribilo-url) +(define-public skribe-doc-dir skribilo-doc-directory) +(define-public skribe-ext-dir skribilo-extension-directory) +(define-public skribe-default-path skribilo-default-path) +(define-public skribe-scheme skribilo-scheme) diff --git a/src/guile/skribilo/debug.scm b/src/guile/skribilo/debug.scm new file mode 100644 index 0000000..f7709a0 --- /dev/null +++ b/src/guile/skribilo/debug.scm @@ -0,0 +1,168 @@ +;;; debug.scm -- Debugging facilities. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (srfi srfi-17) + :use-module (srfi srfi-39) + :export-syntax (debug-item with-debug)) + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Parameters. +;;; + +;; Current debugging level. +(define-public *debug* + (make-parameter 0 (lambda (val) + (cond ((number? val) val) + ((string? val) + (string->number val)) + (else + (error "*debug*: wrong argument type" + val)))))) + +;; Whether to use colors. +(define-public *debug-use-colors?* (make-parameter #t)) + +;; Where to spit debugging output. +(define-public *debug-port* (make-parameter (current-output-port))) + +;; Whether to debug individual items. +(define-public *debug-item?* (make-parameter #f)) + +;; Watched (debugged) symbols (procedure names). +(define-public *watched-symbols* (make-parameter '())) + + + +;;; +;;; Implementation. +;;; + +(define *debug-depth* (make-parameter 0)) +(define *debug-margin* (make-parameter "")) +(define *margin-level* (make-parameter 0)) + + + +;; +;; 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 (*debug-use-colors?*) + (equal? (getenv "TERM") "xterm")) + (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-macro (debug-item . args) + `(if (*debug-item?*) (%do-debug-item ,@args))) + +(define-public (%do-debug-item . args) + (begin + (display (*debug-margin*) (*debug-port*)) + (display (debug-color (- (*debug-depth*) 1) "- ") (*debug-port*)) + (for-each (lambda (a) (display a (*debug-port*))) args) + (newline (*debug-port*)))) + +;;(define-macro (debug-item . args) +;; `()) + + +;;; +;;; %with-debug-margin +;;; +(define (%with-debug-margin margin thunk) + (parameterize ((*debug-depth* (+ (*debug-depth*) 1)) + (*debug-margin* (string-append (*debug-margin*) margin))) + (thunk))) + +;;; +;;; %with-debug +;;; +(define-public (%do-with-debug lvl lbl thunk) + (parameterize ((*margin-level* lvl) + (*debug-item?* #t)) + (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))) + +(define-macro (with-debug level label . body) + ;; We have this as a macro in order to avoid procedure calls in the + ;; non-debugging case. Unfortunately, the macro below duplicates BODY, + ;; which has a negative impact on memory usage and startup time (XXX). + (if (number? level) + `(if (or (>= (*debug*) ,level) + (memq ,label (*watched-symbols*))) + (%do-with-debug ,level ,label (lambda () ,@body)) + (begin ,@body)) + (error "with-debug: syntax error"))) + + +; 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)) + +;;; debug.scm ends here diff --git a/src/guile/skribilo/engine.scm b/src/guile/skribilo/engine.scm new file mode 100644 index 0000000..06667ad --- /dev/null +++ b/src/guile/skribilo/engine.scm @@ -0,0 +1,390 @@ +;;; engine.scm -- Skribilo engines. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo engine) + :use-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (skribilo lib) + + ;; `(skribilo writer)' depends on this module so it needs to be loaded + ;; after we defined `' and the likes. + :autoload (skribilo writer) () + + :use-module (oop goops) + :use-module (ice-9 optargs) + :autoload (srfi srfi-39) (make-parameter) + + :export ( engine? engine-ident engine-format + engine-customs engine-filter engine-symbol-table + + *current-engine* + default-engine default-engine-set! + make-engine copy-engine find-engine lookup-engine + engine-custom engine-custom-set! engine-custom-add! + engine-format? engine-add-writer! + processor-get-engine + push-default-engine pop-default-engine + + engine-loaded? when-engine-is-loaded)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +;; Note on writers +;; --------------- +;; +;; `writers' here is an `eq?' hash table where keys are markup names +;; (symbols) and values are lists of markup writers (most of the time, the +;; list will only contain one writer). Each of these writer may define a +;; predicate or class that may further restrict its applicability. +;; +;; `free-writers' is a list of writers that may apply to *any* kind of +;; markup. These are typically define by passing `#t' to `markup-writer' +;; instead of a symbol: +;; +;; (markup-writer #f (find-engine 'xml) +;; :before ... +;; ...) +;; +;; The XML engine contains an example of such free writers. Again, these +;; writers may define a predicate or a class restricting their applicability. +;; +;; The distinction between these two kinds of writers is mostly performance: +;; "free writers" are rarely used and markup-specific are the most common +;; case which we want to be fast. Therefore, for the latter case, we can't +;; afford traversing a list of markups, evaluating each and every markup +;; predicate. +;; +;; For more details, see `markup-writer-get' and `lookup-markup-writer' in +;; `(skribilo writer)'. + +(define-class () + (ident :init-keyword :ident :init-value '???) + (format :init-keyword :format :init-value "raw") + (info :init-keyword :info :init-value '()) + (version :init-keyword :version + :init-value 'unspecified) + (delegate :init-keyword :delegate :init-value #f) + (writers :init-thunk make-hash-table) + (free-writers :init-value '()) + (filter :init-keyword :filter :init-value #f) + (customs :init-keyword :custom :init-value '()) + (symbol-table :init-keyword :symbol-table :init-value '())) + + +(define (engine? obj) + (is-a? obj )) + +(define (engine-ident obj) + (slot-ref obj 'ident)) + +(define (engine-format obj) + (slot-ref obj 'format)) + +(define (engine-customs obj) + (slot-ref obj 'customs)) + +(define (engine-filter obj) + (slot-ref obj 'filter)) + +(define (engine-symbol-table obj) + (slot-ref obj 'symbol-table)) + + + +;;; +;;; Default engines. +;;; + +(define *default-engine* #f) +(define *default-engines* '()) + + +(define (default-engine) + *default-engine*) + + +(define (default-engine-set! e) + (with-debug 5 'default-engine-set! + (debug-item "engine=" e) + + (if (not (engine? e)) + (skribe-error 'default-engine-set! "bad engine ~S" e)) + (set! *default-engine* e) + (set! *default-engines* (cons e *default-engines*)) + e)) + + +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + + +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + + +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + (else (*current-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))) + 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))) + + ;; XXX: We don't use `list-copy' here because writer lists are only + ;; consed, never mutated. + + ;(slot-set! new 'free-writers (list-copy (slot-ref e 'free-writers))) + + (let ((new-writers (make-hash-table))) + (hash-for-each (lambda (m w*) + (hashq-set! new-writers m w*)) + (slot-ref e 'writers)) + (slot-set! new 'writers new-writers)) + + new)) + + + +;;; +;;; Engine loading. +;;; + +;; Each engine is to be stored in its own module with the `(skribilo engine)' +;; hierarchy. The `engine-id->module-name' procedure returns this module +;; name based on the engine name. + +(define (engine-id->module-name id) + `(skribilo engine ,id)) + +(define (engine-loaded? id) + "Check whether engine @var{id} is already loaded." + ;; Trick taken from `resolve-module' in `boot-9.scm'. + (nested-ref the-root-module + `(%app modules ,@(engine-id->module-name id)))) + +;; A mapping of engine names to hooks. +(define %engine-load-hook (make-hash-table)) + +(define (consume-load-hook! id) + (with-debug 5 'consume-load-hook! + (let ((hook (hashq-ref %engine-load-hook id))) + (if hook + (begin + (debug-item "running hook " hook " for engine " id) + (hashq-remove! %engine-load-hook id) + (run-hook hook)))))) + +(define (when-engine-is-loaded id thunk) + "Run @var{thunk} only when engine with identifier @var{id} is loaded." + (if (engine-loaded? id) + (begin + ;; Maybe the engine had already been loaded via `use-modules'. + (consume-load-hook! id) + (thunk)) + (let ((hook (or (hashq-ref %engine-load-hook id) + (let ((hook (make-hook))) + (hashq-set! %engine-load-hook id hook) + hook)))) + (add-hook! hook thunk)))) + + +(define* (lookup-engine id :key (version 'unspecified)) + "Look for an engine named @var{name} (a symbol) in the @code{(skribilo +engine)} module hierarchy. If no such engine was found, an error is raised, +otherwise the requested engine is returned." + (with-debug 5 'lookup-engine + (debug-item "id=" id " version=" version) + + (let* ((engine (symbol-append id '-engine)) + (m (resolve-module (engine-id->module-name id)))) + (if (module-bound? m engine) + (let ((e (module-ref m engine))) + (if e (consume-load-hook! id)) + e) + (error "no such engine" id))))) + +(define* (find-engine id :key (version 'unspecified)) + (false-if-exception (apply lookup-engine (list id version)))) + + + + + +;;; +;;; Engine methods. +;;; + +(define (engine-custom e id) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (cadr c) + 'unspecified))) + + +(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))))) + +(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))))) + +(define (engine-add-writer! e ident pred upred opt before action + after class valid) + ;; Add a writer to engine E. If IDENT is a symbol, then it should denote + ;; a markup name and the writer being added is specific to that markup. If + ;; IDENT is `#t' (for instance), then it is assumed to be a ``free writer'' + ;; that may apply to any kind of markup for which PRED returns true. + + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (if (not (is-a? e )) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (if pred + (check-procedure "predicate" pred 2)) + + ;; check the correctness of the validation proc + (if valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (if (symbol? ident) + (let ((writers (slot-ref e 'writers))) + (hashq-set! writers ident + (cons n (hashq-ref writers ident '())))) + (slot-set! e 'free-writers + (cons n (slot-ref e 'free-writers)))) + n)) + + + +;;; +;;; Current engine. +;;; + +;;; `(skribilo module)' must be loaded before the first `find-engine' call. +(use-modules (skribilo module)) + +;; At this point, we're almost done with the bootstrap process. +;(format #t "base engine: ~a~%" (lookup-engine 'base)) + +(define *current-engine* + ;; By default, use the HTML engine. + (make-parameter (lookup-engine 'html) + (lambda (val) + (cond ((symbol? val) (lookup-engine val)) + ((engine? val) val) + (else + (error "invalid value for `*current-engine*'" + val)))))) + + +;;; engine.scm ends here 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/base.scm b/src/guile/skribilo/engine/base.scm new file mode 100644 index 0000000..8418e8b --- /dev/null +++ b/src/guile/skribilo/engine/base.scm @@ -0,0 +1,479 @@ +;;; base.scm -- BASE Skribe engine +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine base)) + +;*---------------------------------------------------------------------*/ +;* 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 #f "?~a@~a " k s)) + (else + (format #f "?~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) + "") + ;; FIXME: Since we don't support + ;; `:&skribe-eval-location', we could set up a + ;; `parameterize' thing around `skribe-eval' to + ;; provide it with the right location information. + ((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/src/guile/skribilo/engine/context.scm b/src/guile/skribilo/engine/context.scm new file mode 100644 index 0000000..c9e0986 --- /dev/null +++ b/src/guile/skribilo/engine/context.scm @@ -0,0 +1,1382 @@ +;;;; +;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 23-Sep-2004 17:21 (eg) +;;;; Last file update: 3-Nov-2004 12:54 (eg) +;;;; + +(define-skribe-module (skribilo engine context)) + +;;;; ====================================================================== +;;;; 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 #f "$~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 #f "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 #f "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/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm new file mode 100644 index 0000000..6232b96 --- /dev/null +++ b/src/guile/skribilo/engine/html.scm @@ -0,0 +1,2313 @@ +;;; html.scm -- HTML engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine html) + :autoload (skribilo parameters) (*destination-file*) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:))) + + +;; Keep a reference to the base engine. +(define base-engine (find-engine 'base)) + +(if (not (engine? base-engine)) + (error "bootstrap problem: base engine broken" base-engine)) + +;*---------------------------------------------------------------------*/ +;* html-file-default ... */ +;*---------------------------------------------------------------------*/ +(define html-file-default + ;; Default implementation of the `file-name-proc' custom. + (let ((table '()) + (filename (tmpnam))) + (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 #f "~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? (*destination-file*)) + (prefix (*destination-file*))) + "")) + (s (or (and (string? (*destination-file*)) + (suffix (*destination-file*))) + "html")) + (nm (get-file-name b s))) + (markup-option-add! node filename nm) + nm)) + ((document? node) + (*destination-file*)) + (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-engine ... */ +;*---------------------------------------------------------------------*/ +(define-public 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 #f) + (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 #f) + (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 #f) + (right-margin-foreground #f) + ;; author configuration + (author-font #f) + ;; title configuration + (title-font #f) + (title-background #f) + (title-foreground #f) + (file-title-separator " -- ") + ;; html file naming + (file-name-proc ,html-file-default) + ;; index configuration + (index-header-font-size #f) ;; +2. + ;; chapter configuration + (chapter-number->string number->string) + (chapter-file #f) + ;; section configuration + (section-title-start "

") + (section-title-stop "

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

") + (subsection-title-stop "

") + (subsection-title-background #f) + (subsection-title-foreground #f) + (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 #f) + (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-file ... */ +;*---------------------------------------------------------------------*/ +(define (html-file n e) + (let ((proc (or (engine-custom e 'file-name-proc) html-file-default))) + (proc n e))) + +;*---------------------------------------------------------------------*/ +;* 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-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 #f "~a." (car cnts))) + (else + (let loop ((cnts cnts)) + (if (null? (cdr cnts)) + (format #f "~a" (car cnts)) + (format #f "~a.~a" (car cnts) (loop (cdr cnts)))))))) + +;*---------------------------------------------------------------------*/ +;* html-width ... */ +;*---------------------------------------------------------------------*/ +(define-public (html-width width) + (cond + ((and (integer? width) (exact? width)) + (format #f "~A" width)) + ((real? width) + (format #f "~A%" (inexact->exact (round width)))) + ((string? width) + width) + (else + (skribe-error 'html-width "bad width" width)))) + +;*---------------------------------------------------------------------*/ +;* html-class ... */ +;*---------------------------------------------------------------------*/ +(define-public (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-public (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 :keywords) + :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-meta ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-meta + :before "string (or (markup-body n) '())))) + (output (keyword-list->comma-separated kw*) e))) + :after "\">\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 "skribilo-left-margin") + (html-margin body #f #f #f #f "skribilo-body") + (html-margin rm rmfn rms rmbg rmfg "skribilo-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 "skribilo-left-margin") + (html-margin body #f #f #f #f "skribilo-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 "skribilo-body") + (html-margin rm rmfn rms rmbg rmfg "skribilo-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 #f "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)) + (else #f)))) + 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 + (list (hrule) + (p :class "ending" + (font :size -1 + (list "This HTML page was " + "produced by " + (ref :text "Skribilo" + :url (skribilo-url)) + "." + (linebreak) + "Last update: " + (s19:date->string + (s19:current-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 "
" + (if (html-color-spec? tbg) + (string-append "bgcolor=\"" 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-public (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? (*destination-file*)) + (let ((f (format #f "~a.sui" (prefix (*destination-file*))))) + (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)) + (output name e) + (if nfn (printf "\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 #f "illegal identifier `~a'" id) + c)) + (display " ") + ;; blank columns + (col level) + ;; number + (printf "~a" + (html-container-number c e)) + ;; title + (printf "" + (- 4 level)) + (printf "" + (if (and (*destination-file*) + (string=? f (*destination-file*))) + "" + (strip-ref-base (or f (*destination-file*) ""))) + (string-canonicalize id)) + (output (markup-option c :title) e) + (display "") + (display "\n") + ;; the children + (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) + + (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)))) + (meta (new markup + (markup '&html-meta) + (ident (string-append id "-meta")) + (class (markup-class n)) + (parent n) + (body (markup-option (ast-document n) :keywords)))) + (head (new markup + (markup '&html-head) + (ident (string-append id "-head")) + (class (markup-class n)) + (parent n) + (body (list header meta)))) + (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 "

") + +;*---------------------------------------------------------------------*/ +;* ~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '~ + :before " " + :after #f + :action #f) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:label) + :action (lambda (n e) + (printf "~a" + (string-canonicalize (container-ident n)) + (markup-option n :label)))) + +;*---------------------------------------------------------------------*/ +;* 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) + (let ((ident (and (markup? item) + (markup-ident item)))) + (display "") + (if ident ;; produce an anchor + (printf "\n\n" + (string-canonicalize ident))) + (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) + (let ((ident (and (markup? item) + (markup-ident item)))) + (display "") + (if ident ;; produce an anchor + (printf "\n\n" ident)) + (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) + "skribilo-ref"))) + (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/src/guile/skribilo/engine/html4.scm b/src/guile/skribilo/engine/html4.scm new file mode 100644 index 0000000..48550ef --- /dev/null +++ b/src/guile/skribilo/engine/html4.scm @@ -0,0 +1,168 @@ +;;;; +;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; 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-skribe-module (skribilo engine html4)) + +(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 #f "~a%" + (+ 100 + (* 20 (inexact->exact (truncate sz)))))) + ((number? sz) + sz) + (else + (skribe-error 'font + (format #f + "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/src/guile/skribilo/engine/latex-simple.scm b/src/guile/skribilo/engine/latex-simple.scm new file mode 100644 index 0000000..638c158 --- /dev/null +++ b/src/guile/skribilo/engine/latex-simple.scm @@ -0,0 +1,103 @@ +(define-skribe-module (skribilo engine latex-simple)) + +;;; +;;; 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/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm new file mode 100644 index 0000000..8d5b88f --- /dev/null +++ b/src/guile/skribilo/engine/latex.scm @@ -0,0 +1,1784 @@ +;;; latex.scm -- LaTeX engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine latex)) + +;*---------------------------------------------------------------------*/ +;* 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 #f "\\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 #f "$~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 #f "~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 #f "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 #f "~a-above" id)) + (class "table-line-above")) + e)) + ((above hsides) + (printf "{~a}" cols) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format #f "~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 #f "~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/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm new file mode 100644 index 0000000..893ab2e --- /dev/null +++ b/src/guile/skribilo/engine/lout.scm @@ -0,0 +1,2891 @@ +;;; lout.scm -- A Lout engine. +;;; +;;; Copyright 2004, 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;;; Taken from `lcourtes@laas.fr--2004-libre', +;;; `skribe-lout--main--0.2--patch-15'. +;;; Based on `latex.skr', copyright 2003, 2004 Manuel Serrano. + + +(define-skribe-module (skribilo engine lout) + :autoload (ice-9 popen) (open-output-pipe) + :autoload (ice-9 rdelim) (read-line)) + + + +;*---------------------------------------------------------------------*/ +;* lout-verbatim-encoding ... */ +;*---------------------------------------------------------------------*/ +(define-public lout-verbatim-encoding + '((#\/ "\"/\"") + (#\\ "\"\\\\\"") + (#\| "\"|\"") + (#\& "\"&\"") + (#\@ "\"@\"") + (#\" "\"\\\"\"") + (#\{ "\"{\"") + (#\} "\"}\"") + (#\$ "\"$\"") + (#\# "\"#\"") + (#\_ "\"_\"") + (#\~ "\"~\""))) + +;*---------------------------------------------------------------------*/ +;* lout-encoding ... */ +;*---------------------------------------------------------------------*/ +(define-public lout-encoding + `(,@lout-verbatim-encoding + (#\ç "{ @Char ccedilla }") + (#\Ç "{ @Char Ccdeilla }") + (#\â "{ @Char acircumflex }") + (#\Â "{ @Char Acircumflex }") + (#\à "{ @Char agrave }") + (#\À "{ @Char Agrave }") + (#\é "{ @Char eacute }") + (#\É "{ @Char Eacute }") + (#\è "{ @Char egrave }") + (#\È "{ @Char Egrave }") + (#\ê "{ @Char ecircumflex }") + (#\Ê "{ @Char Ecircumflex }") + (#\ù "{ @Char ugrave }") + (#\Ù "{ @Char Ugrave }") + (#\û "{ @Char ucircumflex }") + (#\Û "{ @Char Ucircumflex }") + (#\ø "{ @Char oslash }") + (#\ô "{ @Char ocircumflex }") + (#\Ô "{ @Char Ocircumflex }") + (#\ö "{ @Char odieresis }") + (#\Ö "{ @Char Odieresis }") + (#\î "{ @Char icircumflex }") + (#\Î "{ @Char Icircumflex }") + (#\ï "{ @Char idieresis }") + (#\Ï "{ @Char Idieresis }") + (#\] "\"]\"") + (#\[ "\"[\"") + (#\» "{ @Char guillemotright }") + (#\« "{ @Char guillemotleft }"))) + + +;; XXX: This is just here for experimental purposes. +(define lout-french-punctuation-encoding + (let ((space (lambda (before after thing) + (string-append "{ " + (if before + (string-append "{ " before " @Wide {} }") + "") + "\"" thing "\"" + (if after + (string-append "{ " after " @Wide {} }") + "") + " }")))) + `((#\; ,(space "0.5s" #f ";")) + (#\? ,(space "0.5s" #f ";")) + (#\! ,(space "0.5s" #f ";"))))) + +(define lout-french-encoding + (let ((punctuation (map car lout-french-punctuation-encoding))) + (append (let loop ((ch lout-encoding) + (purified '())) + (if (null? ch) + purified + (loop (cdr ch) + (if (member (car ch) punctuation) + purified + (cons (car ch) purified))))) + lout-french-punctuation-encoding))) + +;*---------------------------------------------------------------------*/ +;* lout-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define (lout-symbol-table sym math) + `(("iexcl" "{ @Char exclamdown }") + ("cent" "{ @Char cent }") + ("pound" "{ @Char sterling }") + ("yen" "{ @Char yen }") + ("section" "{ @Char section }") + ("mul" "{ @Char multiply }") + ("copyright" "{ @Char copyright }") + ("lguillemet" "{ @Char guillemotleft }") + ("not" "{ @Char logicalnot }") + ("degree" "{ @Char degree }") + ("plusminus" "{ @Char plusminus }") + ("micro" "{ @Char mu }") + ("paragraph" "{ @Char paragraph }") + ("middot" "{ @Char periodcentered }") + ("rguillemet" "{ @Char guillemotright }") + ("1/4" "{ @Char onequarter }") + ("1/2" "{ @Char onehalf }") + ("3/4" "{ @Char threequarters }") + ("iquestion" "{ @Char questiondown }") + ("Agrave" "{ @Char Agrave }") + ("Aacute" "{ @Char Aacute }") + ("Acircumflex" "{ @Char Acircumflex }") + ("Atilde" "{ @Char Atilde }") + ("Amul" "{ @Char Adieresis }") ;;; FIXME: Why `mul' and not `uml'?! + ("Aring" "{ @Char Aring }") + ("AEligature" "{ @Char oe }") + ("Oeligature" "{ @Char OE }") ;;; FIXME: Should be `OEligature'?! + ("Ccedilla" "{ @Char Ccedilla }") + ("Egrave" "{ @Char Egrave }") + ("Eacute" "{ @Char Eacute }") + ("Ecircumflex" "{ @Char Ecircumflex }") + ("Euml" "{ @Char Edieresis }") + ("Igrave" "{ @Char Igrave }") + ("Iacute" "{ @Char Iacute }") + ("Icircumflex" "{ @Char Icircumflex }") + ("Iuml" "{ @Char Idieresis }") + ("ETH" "{ @Char Eth }") + ("Ntilde" "{ @Char Ntilde }") + ("Ograve" "{ @Char Ograve }") + ("Oacute" "{ @Char Oacute }") + ("Ocircumflex" "{ @Char Ocircumflex }") + ("Otilde" "{ @Char Otilde }") + ("Ouml" "{ @Char Odieresis }") + ("times" ,(sym "multiply")) + ("Oslash" "{ @Char oslash }") + ("Ugrave" "{ @Char Ugrave }") + ("Uacute" "{ @Char Uacute }") + ("Ucircumflex" "{ @Char Ucircumflex }") + ("Uuml" "{ @Char Udieresis }") + ("Yacute" "{ @Char Yacute }") + ("szlig" "{ @Char germandbls }") + ("agrave" "{ @Char agrave }") + ("aacute" "{ @Char aacute }") + ("acircumflex" "{ @Char acircumflex }") + ("atilde" "{ @Char atilde }") + ("amul" "{ @Char adieresis }") + ("aring" "{ @Char aring }") + ("aeligature" "{ @Char ae }") + ("oeligature" "{ @Char oe }") + ("ccedilla" "{ @Char ccedilla }") + ("egrave" "{ @Char egrave }") + ("eacute" "{ @Char eacute }") + ("ecircumflex" "{ @Char ecircumflex }") + ("euml" "{ @Char edieresis }") + ("igrave" "{ @Char igrave }") + ("iacute" "{ @Char iacute }") + ("icircumflex" "{ @Char icircumflex }") + ("iuml" "{ @Char idieresis }") + ("ntilde" "{ @Char ntilde }") + ("ograve" "{ @Char ograve }") + ("oacute" "{ @Char oacute }") + ("ocurcumflex" "{ @Char ocircumflex }") ;; FIXME: `ocIrcumflex' + ("otilde" "{ @Char otilde }") + ("ouml" "{ @Char odieresis }") + ("divide" "{ @Char divide }") + ("oslash" "{ @Char oslash }") + ("ugrave" "{ @Char ugrave }") + ("uacute" "{ @Char uacute }") + ("ucircumflex" "{ @Char ucircumflex }") + ("uuml" "{ @Char udieresis }") + ("yacute" "{ @Char yacute }") + ("ymul" "{ @Char ydieresis }") ;; FIXME: `yUMl' + ;; Greek + ("Alpha" ,(sym "Alpha")) + ("Beta" ,(sym "Beta")) + ("Gamma" ,(sym "Gamma")) + ("Delta" ,(sym "Delta")) + ("Epsilon" ,(sym "Epsilon")) + ("Zeta" ,(sym "Zeta")) + ("Eta" ,(sym "Eta")) + ("Theta" ,(sym "Theta")) + ("Iota" ,(sym "Iota")) + ("Kappa" ,(sym "Kappa")) + ("Lambda" ,(sym "Lambda")) + ("Mu" ,(sym "Mu")) + ("Nu" ,(sym "Nu")) + ("Xi" ,(sym "Xi")) + ("Omicron" ,(sym "Omicron")) + ("Pi" ,(sym "Pi")) + ("Rho" ,(sym "Rho")) + ("Sigma" ,(sym "Sigma")) + ("Tau" ,(sym "Tau")) + ("Upsilon" ,(sym "Upsilon")) + ("Phi" ,(sym "Phi")) + ("Chi" ,(sym "Chi")) + ("Psi" ,(sym "Psi")) + ("Omega" ,(sym "Omega")) + ("alpha" ,(sym "alpha")) + ("beta" ,(sym "beta")) + ("gamma" ,(sym "gamma")) + ("delta" ,(sym "delta")) + ("epsilon" ,(sym "epsilon")) + ("zeta" ,(sym "zeta")) + ("eta" ,(sym "eta")) + ("theta" ,(sym "theta")) + ("iota" ,(sym "iota")) + ("kappa" ,(sym "kappa")) + ("lambda" ,(sym "lambda")) + ("mu" ,(sym "mu")) + ("nu" ,(sym "nu")) + ("xi" ,(sym "xi")) + ("omicron" ,(sym "omicron")) + ("pi" ,(sym "pi")) + ("rho" ,(sym "rho")) + ("sigmaf" ,(sym "sigmaf")) ;; FIXME! + ("sigma" ,(sym "sigma")) + ("tau" ,(sym "tau")) + ("upsilon" ,(sym "upsilon")) + ("phi" ,(sym "phi")) + ("chi" ,(sym "chi")) + ("psi" ,(sym "psi")) + ("omega" ,(sym "omega")) + ("thetasym" ,(sym "thetasym")) + ("piv" ,(sym "piv")) ;; FIXME! + ;; punctuation + ("bullet" ,(sym "bullet")) + ("ellipsis" ,(sym "ellipsis")) + ("weierp" "{ @Sym weierstrass }") + ("image" ,(sym "Ifraktur")) + ("real" ,(sym "Rfraktur")) + ("tm" ,(sym "trademarksans")) ;; alt: @Sym trademarkserif + ("alef" ,(sym "aleph")) + ("<-" ,(sym "arrowleft")) + ("<--" "{ { 1.6 1 } @Scale { @Sym arrowleft } }") ;; copied from `eqf' + ("uparrow" ,(sym "arrowup")) + ("->" ,(sym "arrowright")) + ("-->" "{ { 1.6 1 } @Scale { @Sym arrowright } }") + ("downarrow" ,(sym "arrowdown")) + ("<->" ,(sym "arrowboth")) + ("<-->" "{ { 1.6 1 } @Scale { @Sym arrowboth } }") + ("<+" ,(sym "carriagereturn")) + ("<=" ,(sym "arrowdblleft")) + ("<==" "{ { 1.6 1 } @Scale { @Sym arrowdblleft } }") + ("Uparrow" ,(sym "arrowdblup")) + ("=>" ,(sym "arrowdblright")) + ("==>" "{ { 1.6 1 } @Scale { @Sym arrowdblright } }") + ("Downarrow" ,(sym "arrowdbldown")) + ("<=>" ,(sym "arrowdblboth")) + ("<==>" "{ { 1.6 1 } @Scale { @Sym arrowdblboth } }") + ;; Mathematical operators (we try to avoid `@Eq' since it + ;; requires to `@SysInclude { eq }' -- one solution consists in copying + ;; the symbol definition from `eqf') + ("forall" "{ { Symbol Base } @Font \"\\042\" }") + ("partial" ,(sym "partialdiff")) + ("exists" "{ { Symbol Base } @Font \"\\044\" }") + ("emptyset" "{ { Symbol Base } @Font \"\\306\" }") + ("infinity" ,(sym "infinity")) + ("nabla" "{ { Symbol Base } @Font \"\\321\" }") + ("in" ,(sym "element")) + ("notin" ,(sym "notelement")) + ("ni" "{ 180d @Rotate @Sym element }") + ("prod" ,(sym "product")) + ("sum" ,(sym "summation")) + ("asterisk" ,(sym "asteriskmath")) + ("sqrt" ,(sym "radical")) + ("propto" ,(math "propto")) + ("angle" ,(sym "angle")) + ("and" ,(math "bwedge")) + ("or" ,(math "bvee")) + ("cap" ,(math "bcap")) + ("cup" ,(math "bcup")) + ("integral" ,(math "int")) + ("models" ,(math "models")) + ("vdash" ,(math "vdash")) + ("dashv" ,(math "dashv")) + ("sim" ,(sym "similar")) + ("cong" ,(sym "congruent")) + ("approx" ,(sym "approxequal")) + ("neq" ,(sym "notequal")) + ("equiv" ,(sym "equivalence")) + ("le" ,(sym "lessequal")) + ("ge" ,(sym "greaterequal")) + ("subset" ,(sym "propersubset")) + ("supset" ,(sym "propersuperset")) + ("subseteq" ,(sym "reflexsubset")) + ("supseteq" ,(sym "reflexsuperset")) + ("oplus" ,(sym "circleplus")) + ("otimes" ,(sym "circlemultiply")) + ("perp" ,(sym "perpendicular")) + ("mid" ,(sym "bar")) + ("lceil" ,(sym "bracketlefttp")) + ("rceil" ,(sym "bracketrighttp")) + ("lfloor" ,(sym "bracketleftbt")) + ("rfloor" ,(sym "bracketrightbt")) + ("langle" ,(sym "angleleft")) + ("rangle" ,(sym "angleright")) + ;; Misc + ("loz" "{ @Lozenge }") + ("spades" ,(sym "spade")) + ("clubs" ,(sym "club")) + ("hearts" ,(sym "heart")) + ("diams" ,(sym "diamond")) + ("euro" "{ @Euro }") + ;; Lout + ("dag" "{ @Dagger }") + ("ddag" "{ @DaggerDbl }") + ("circ" ,(math "circle")) + ("top" ,(math "top")) + ("bottom" ,(math "bot")) + ("lhd" ,(math "triangleleft")) + ("rhd" ,(math "triangleright")) + ("parallel" ,(math "dbar")))) + + +;;; Debugging support + +(define *lout-debug?* #f) + +(define-macro (lout-debug fmt . args) + `(if *lout-debug?* + (with-output-to-port (current-error-port) + (lambda () + (printf (string-append ,fmt "~%") ,@args + (current-error-port)))) + #t)) + +(define-public (lout-tagify ident) + ;; Return an "clean" identifier (a string) based on `ident' (a string), + ;; suitable for Lout as an `@Tag' value. + (let ((tag-encoding '((#\, "-") + (#\( "-") + (#\) "-") + (#\[ "-") + (#\] "-") + (#\/ "-") + (#\| "-") + (#\& "-") + (#\@ "-") + (#\! "-") + (#\? "-") + (#\: "-") + (#\; "-"))) + (tag (string-canonicalize ident))) + ((make-string-replace tag-encoding) tag))) + + +;; Default values of various customs (procedures) + +(define (lout-definitions engine) + ;; Return a string containing a set of useful Lout definitions that should + ;; be inserted at the beginning of the output document. + (let ((leader (engine-custom engine 'toc-leader)) + (leader-space (engine-custom engine 'toc-leader-space))) + (apply string-append + `("# @SkribeMark implements Skribe's marks " + "(i.e. cross-references)\n" + "def @SkribeMark\n" + " right @Tag\n" + "{\n" + " @PageMark @Tag\n" + "}\n\n" + + "# @SkribiloLeaders is used in `toc'\n" + "# (this is mostly copied from the expert's guide)\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. + ;; This is the default implementation, i.e. the default value of the + ;; `doc-cover-sheet-proc' custom. + (let ((title (markup-option doc :title)) + (author (markup-option doc :author)) + (date-line (engine-custom engine 'date-line)) + (cover-sheet? (engine-custom engine 'cover-sheet?)) + (multi-column? (> (engine-custom engine 'column-number) 1))) + + (if multi-column? + ;; In single-column document, `@FullWidth' yields a blank page. + (display "\n@FullWidth {")) + (display "\n//3.0fx\n") + (display "\n@Center 1.4f @Font @B { cragged nohyphen 1.4fx } @Break { ") + (if title + (output title engine) + (display "The Lout Document")) + (display " }\n") + (display "//1.7fx\n") + (if date-line + (begin + (display "@Center { ") + (output date-line engine) + (display " }\n//1.4fx\n"))) + (if author + (begin + (display "@Center { ") + (output author engine) + (display " }\n") + (display "//4fx\n"))) + (if multi-column? + (display "\n} # @FullWidth\n")))) + +(define (lout-split-external-link markup) + ;; Shorten `markup', an URL `url-ref' markup, by splitting it into an URL + ;; `ref' followed by plain text. This is useful because Lout's + ;; @ExternalLink symbols are unbreakable to the embodied text should _not_ + ;; be too large (otherwise it is scaled down). + (let* ((url (markup-option markup :url)) + (text (or (markup-option markup :text) url))) + (lout-debug "lout-split-external-link: text=~a" text) + (cond ((pair? text) + ;; no need to go recursive here: we'll get called again later + `(,(ref :url url :text (car text)) ,@(cdr text))) + + ((string? text) + (let ((len (string-length text))) + (if (> (- len 8) 2) + ;; don't split on a whitespace or it will vanish + (let ((split (let loop ((where 10)) + (if (= 0 where) + 10 + (if (char=? (string-ref text + (- where 1)) + #\space) + (loop (- where 1)) + where))))) + `(,(ref :url url :text (substring text 0 split)) + ,(substring text split len))) + (list markup)))) + + ((markup? text) + (let ((kind (markup-markup text))) + (lout-debug "lout-split-external-link: kind=~a" kind) + (if (member kind '(bold it underline)) + ;; get the ornament markup out of the `:text' argument + (list (apply (eval kind (interaction-environment)) + (list (ref :url url + :text (markup-body text))))) + ;; otherwise, leave it as is + (list markup)))) + + (else (list markup))))) + +(define (lout-make-toc-entry node engine) + ;; Default implementation of the `toc-entry-proc' custom that produces the + ;; number and title of `node' for use in the table of contents. + (let ((num (markup-option node :number)) + (title (markup-option node :title)) + (lang (engine-custom engine 'initial-language))) + (if num + (begin + (if (is-markup? node 'chapter) (display "@B { ")) + (printf "~a. |2s " (lout-structure-number-string node)) + (output title engine) + (if (is-markup? node 'chapter) (display " }"))) + (if (is-markup? node 'chapter) + (output (bold title) engine) + (output title engine))))) + +(define (lout-bib-refs-sort/number entry1 entry2) + ;; Default implementation of the `bib-refs-sort-proc' custom. Compare + ;; bibliography entries `entry1' and `entry2' (of type `&bib-entry') for + ;; use by `sort' in `bib-ref+'. + (let ((ident1 (markup-option entry1 :title)) + (ident2 (markup-option entry2 :title))) + (if (and (markup? ident1) (markup? ident2)) + (< (markup-option ident1 'number) + (markup-option ident2 'number)) + (begin + (fprint (current-error-port) "i1: " ident1 ", " entry1) + (fprint (current-error-port) "i2: " ident2 ", " entry2))))) + +(define (lout-pdf-bookmark-title node engine) + ;; Default implementation of the `pdf-bookmark-title-proc' custom that + ;; returns a title (a string) for the PDF bookmark of `node'. + (let ((number (lout-structure-number-string node))) + (string-append (if (string=? number "") "" (string-append number ". ")) + (ast->string (markup-option node :title))))) + +(define (lout-pdf-bookmark-node? node engine) + ;; Default implementation of the `pdf-bookmark-node-pred' custom that + ;; returns a boolean. + (or (is-markup? node 'chapter) + (is-markup? node 'section) + (is-markup? node 'subsection) + (is-markup? node 'slide))) + + + + +;*---------------------------------------------------------------------*/ +;* lout-engine ... */ +;*---------------------------------------------------------------------*/ +(define lout-engine + (make-engine 'lout + :version 0.2 + :format "lout" + :delegate (find-engine 'base) + :filter (make-string-replace lout-encoding) + :custom `(;; The underlying Lout document type, i.e. one + ;; of `doc', `report', `book' or `slides'. + (document-type doc) + + ;; Document style file include line (a string + ;; such as `@Include { doc-style.lout }') or + ;; `auto' (symbol) in which case the include + ;; file is deduced from `document-type'. + (document-include auto) + + (includes "@SysInclude { tbl }\n") + (initial-font "Palatino Base 10p") + (initial-break + ,(string-append "unbreakablefirst " + "unbreakablelast " + "hyphen adjust 1.2fx")) + + ;; The document's language, used for hyphenation + ;; and other things. + (initial-language "English") + + ;; Number of columns. + (column-number 1) + + ;; First page number. + (first-page-number 1) + + ;; Page orientation, `portrait', `landscape', + ;; `reverse-portrait' or `reverse-landscape'. + (page-orientation portrait) + + ;; For reports, whether to produce a cover + ;; sheet. The `doc-cover-sheet-proc' custom may + ;; also honor this custom for `doc' documents. + (cover-sheet? #t) + + ;; For reports, the date line. + (date-line #t) + + ;; For reports, an abstract. + (abstract #f) + + ;; For reports, title/name of the abstract. If + ;; `#f', the no abstract title will be + ;; produced. If `#t', a default name in the + ;; current language is chosen. + (abstract-title #t) + + ;; Whether to optimize pages. + (optimize-pages? #f) + + ;; For docs, the procedure that produces the + ;; Lout code for the cover sheet or title. + (doc-cover-sheet-proc + ,lout-make-doc-cover-sheet) + + ;; Procedure used to sort bibliography + ;; references when several are referred to at + ;; the same time, as in: + ;; (ref :bib '("smith03" "jones98")) . + ;; By default they are sorted by number. If + ;; `#f' is given, they are left as is. + (bib-refs-sort-proc + ,lout-bib-refs-sort/number) + + ;; Lout code for paragraph gaps (similar to + ;; `@PP' with `@ParaGap' equal to `1.0vx' by + ;; default) + (paragraph-gap + "\n//1.0vx @ParaIndent @Wide &{0i}\n") + + ;; For multi-page tables, it may be + ;; useful to set this to `#t'. However, + ;; this looks kind of buggy. + (use-header-rows? #f) + + ;; Tells whether to use Skribe's footnote + ;; numbers or Lout's numbering scheme (the + ;; latter may be better, typography-wise). + (use-skribe-footnote-numbers? #t) + + ;; A procedure that is passed the engine + ;; and produces Lout definitions. + (inline-definitions-proc ,lout-definitions) + + ;; A procedure that takes a URL `ref' markup and + ;; returns a list containing (maybe) one such + ;; `ref' markup. This custom can be used to + ;; modified the way URLs are rendered. The + ;; default value is a procedure that limits the + ;; size of Lout's @ExternalLink symbols since + ;; they are unbreakable. In order to completely + ;; disable use of @ExternalLinks, just set it to + ;; `markup-body'. + (transform-url-ref-proc + ,lout-split-external-link) + + ;; Leader used in the table of contents entries. + (toc-leader ".") + + ;; Inter-leader spacing in the TOC entries. + (toc-leader-space "2.5s") + + ;; Procedure that takes a large-scale structure + ;; (chapter, section, etc.) and the engine and + ;; produces the number and possibly title of + ;; this structure for use the TOC. + (toc-entry-proc ,lout-make-toc-entry) + + ;; The Lout program name, only useful when using + ;; `lout-illustration' on other back-ends. + (lout-program-name "lout") + + ;; Title and author information in the PDF + ;; document information. If `#t', the + ;; document's `:title' and `:author' are used. + (pdf-title #t) + (pdf-author #t) + + ;; Keywords (a list of string) in the PDF + ;; document information. This custom is deprecated, + ;; use the `:keywords' option of `document' instead. + (pdf-keywords #f) + + ;; Extra PDF information, an alist of key-value + ;; pairs (string pairs). + (pdf-extra-info (("SkribeVersion" + ,(skribe-release)))) + + ;; Tells whether to produce PDF "docinfo" + ;; (meta-information with title, author, + ;; keywords, etc.). + (make-pdf-docinfo? #t) + + ;; Tells whether a PDF outline + ;; (aka. "bookmarks") should be produced. + (make-pdf-outline? #t) + + ;; Procedure that takes a node and an engine and + ;; return a string representing the title of + ;; that node's PDF bookmark. + (pdf-bookmark-title-proc ,lout-pdf-bookmark-title) + + ;; Procedure that takes a node and an engine and + ;; returns true if that node should have a PDF + ;; outline entry. + (pdf-bookmark-node-pred ,lout-pdf-bookmark-node?) + + ;; Procedure that takes a node and an engine and + ;; returns true if the bookmark for that node + ;; should be closed ("folded") when the user + ;; opens the PDF document. + (pdf-bookmark-closed-pred + ,(lambda (n e) + (not (is-markup? n 'chapter)))) + + ;; color + (color? #t) + + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (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")) + + :symbol-table (lout-symbol-table + (lambda (m) + ;; We don't use `@Sym' because it doesn't + ;; work within `@Eq'. + (string-append "{ { Symbol Base } @Font " + "@Char \"" m "\" }")) + (lambda (m) + (format #f "{ @Eq { ~a } }" m))))) + + +;; So that calls to `markup-writer' automatically use `lout-engine'... +(push-default-engine lout-engine) + + + +;; User-level implementation of PDF bookmarks. +;; +;; Basically, Lout code is produced that produces (via `@Graphic') PostScript +;; code. That PostScript code is a `pdfmark' command (see Adobe's "pdfmark +;; Reference Manual") which, when converted to PDF (e.g. with `ps2pdf'), +;; produces a PDF outline, aka. "bookmarks" (see "PDF Reference, Fifth +;; Edition", section 8.2.2). + +(define (lout-internal-dest-name ident) + ;; Return the Lout-generated `pdfmark' named destination for `ident'. This + ;; function mimics Lout's `ConvertToPDFName ()', in `z49.c' (Lout's + ;; PostScript back-end). In Lout, `ConvertToPDFName ()' produces + ;; destination names for the `/Dest' function of the `pdfmark' operator. + ;; This implementation is valid as of Lout 3.31 and hopefully it won't + ;; change in the future. + (string-append "LOUT" + (list->string (map (lambda (c) + (if (or (char-alphabetic? c) + (char-numeric? c)) + c + #\_)) + (string->list ident))))) + +(define (lout-pdf-bookmark node children closed? engine) + ;; Return the PostScript `pdfmark' operation (a string) that creates a PDF + ;; bookmark for node `node'. `children' is the number of children of + ;; `node' in the PDF outline. If `closed?' is true, then the bookmark will + ;; be close (i.e. its children are hidden). + ;; + ;; Note: Here, we use a `GoTo' action, while we could instead simply + ;; produce a `/Page' attribute without having to use the + ;; `lout-internal-dest-name' hack. The point for doing this is that Lout's + ;; `@PageOf' operator doesn't return an "actual" page number within the + ;; document, but rather a "typographically correct" page number (e.g. `i' + ;; for the cover sheet, `1' for the second page, etc.). See + ;; http://lists.planix.com/pipermail/lout-users/2005q1/003925.html for + ;; details. + (let* ((filter-title (make-string-replace `(,@lout-verbatim-encoding + (#\newline " ")))) + (make-bookmark-title (lambda (n e) + (filter-title + ((engine-custom + engine 'pdf-bookmark-title-proc) + n e)))) + (ident (markup-ident node))) + (string-append "[" + (if (= 0 children) + "" + (string-append "\"/\"Count " + (if closed? "-" "") + (number->string children) " ")) + "\"/\"Title \"(\"" (make-bookmark-title node engine) + "\")\" " + (if (not ident) "" + (string-append "\"/\"Action \"/\"GoTo \"/\"Dest \"/\"" + (lout-internal-dest-name ident) " ")) + "\"/\"OUT pdfmark\n"))) + +(define (lout-pdf-outline node engine . children) + ;; Return the PDF outline string (in the form of a PostScript `pdfmark' + ;; command) for `node' whose child nodes are assumed to be `children', + ;; unless `node' is a document. + (let* ((choose-node? (lambda (n) + ((engine-custom engine 'pdf-bookmark-node-pred) + n engine))) + (nodes (if (document? node) + (filter choose-node? (markup-body node)) + children))) + (apply string-append + (map (lambda (node) + (let* ((children (filter choose-node? (markup-body node))) + (closed? ((engine-custom engine + 'pdf-bookmark-closed-pred) + node engine)) + (bm (lout-pdf-bookmark node (length children) + closed? engine))) + (string-append bm (apply lout-pdf-outline + `(,node ,engine ,@children))))) + nodes)))) + +(define-public (lout-embedded-postscript-code postscript) + ;; Return a string embedding PostScript code `postscript' into Lout code. + (string-append "\n" + "{ @BackEnd @Case {\n" + " PostScript @Yield {\n" + postscript + " }\n" + "} } @Graphic { }\n")) + +(define-public (lout-pdf-docinfo doc engine) + ;; Produce PostScript code that will produce PDF document information once + ;; converted to PDF. + (let* ((filter-string (make-string-replace `(,@lout-verbatim-encoding + (#\newline " ")))) + (docinfo-field (lambda (key value) + (string-append "\"/\"" key " \"(\"" + (filter-string value) + "\")\"\n"))) + (author (let ((a (engine-custom engine 'pdf-author))) + (if (or (string? a) (ast? a)) + a + (markup-option doc :author)))) + (title (let ((t (engine-custom engine 'pdf-title))) + (if (or (string? t) (ast? t)) + t + (markup-option doc :title)))) + (keywords (or (engine-custom engine 'pdf-keywords) + (map ast->string + (or (markup-option doc :keywords) '())))) + (extra-fields (engine-custom engine 'pdf-extra-info))) + + (string-append "[ " + (if title + (docinfo-field "Title" (ast->string title)) + "") + (if author + (docinfo-field "Author" + (or (cond ((markup? author) + (ast->string + (or (markup-option + author :name) + (markup-option + author :affiliation)))) + ((string? author) author) + (else (ast->string author))) + "")) + "") + (if (pair? keywords) + (docinfo-field "Keywords" + (apply string-append + (keyword-list->comma-separated + keywords))) + "") + ;; arbitrary key-value pairs, see sect. 4.7, "Info + ;; dictionary" of the `pdfmark' reference. + (if (or (not extra-fields) (null? extra-fields)) + "" + (apply string-append + (map (lambda (p) + (docinfo-field (car p) (cadr p))) + extra-fields))) + "\"/\"DOCINFO pdfmark\n"))) + +(define-public (lout-output-pdf-meta-info doc engine) + ;; Produce PDF bookmarks (aka. "outline") for document `doc', as well as + ;; document meta-information (or "docinfo"). This function makes sure that + ;; both are only produced once, and only if the relevant customs ask for + ;; them. + (if (and doc (engine-custom engine 'make-pdf-outline?) + (not (markup-option doc '&pdf-outline-produced?))) + (begin + (display + (lout-embedded-postscript-code (lout-pdf-outline doc engine))) + (markup-option-add! doc '&pdf-outline-produced? #t))) + (if (and doc (engine-custom engine 'make-pdf-docinfo?) + (not (markup-option doc '&pdf-docinfo-produced?))) + (begin + (display + (lout-embedded-postscript-code (lout-pdf-docinfo doc engine))) + (markup-option-add! doc '&pdf-docinfo-produced? #t)))) + + + +;*---------------------------------------------------------------------*/ +;* lout ... */ +;*---------------------------------------------------------------------*/ +(define-markup (!lout fmt #!rest opt) + (if (engine-format? "lout") + (apply ! fmt opt) + #f)) + +;*---------------------------------------------------------------------*/ +;* lout-width ... */ +;*---------------------------------------------------------------------*/ +(define (lout-width width) + (cond ((inexact? width) ;; a relative size (XXX: was `flonum?') + ;; FIXME: Hack ahead: assuming A4 with a 2.5cm margin + ;; on both sides + (let* ((orientation (let ((lout (find-engine 'lout))) + (or (and lout + (engine-custom lout + 'page-orientation)) + 'portrait))) + (margins 5) + (paper-width (case orientation + ((portrait reverse-portrait) + (- 21 margins)) + (else (- 29.7 margins))))) + (string-append (number->string (* paper-width + (/ (abs width) 100.))) + "c"))) + ((string? width) ;; an engine-dependent width + width) + (else ;; an absolute "pixel" size + (string-append (number->string width) "p")))) + +;*---------------------------------------------------------------------*/ +;* lout-font-size ... */ +;*---------------------------------------------------------------------*/ +(define (lout-font-size size) + (case size + ((4) "3.5f") + ((3) "2.0f") + ((2) "1.5f") + ((1) "1.2f") + ((0) "1.0f") + ((-1) "0.8f") + ((-2) "0.5f") + ((-3) "0.3f") + ((-4) "0.2f") + (else (if (number? size) + (if (< size 0) "0.3f" "1.5f") + "1.0f")))) + +(define-public (lout-color-specification skribe-color) + ;; Return a Lout color name, ie. a string which is either an English color + ;; name or something like "rgb 0.5 0.2 0.6". `skribe-color' is a string + ;; representing a Skribe color such as "black" or "#ffffff". + (let ((b&w? (let ((lout (find-engine 'lout))) + (and lout (not (engine-custom lout 'color?))))) + (actual-color + (if (and (string? skribe-color) + (char=? (string-ref skribe-color 0) #\#)) + (string->number (substring skribe-color 1 + (string-length skribe-color)) + 16) + skribe-color))) + (receive (r g b) + (skribe-color->rgb actual-color) + (apply format #f + (cons "rgb ~a ~a ~a" + (map (if b&w? + (let ((avg (exact->inexact (/ (+ r g b) + (* 256 3))))) + (lambda (x) avg)) + (lambda (x) + (exact->inexact (/ x 256)))) + (list r g b))))))) + +;*---------------------------------------------------------------------*/ +;* ~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '~ :before "~" :action #f) + +(define (lout-page-orientation orientation) + ;; Return a string representing the Lout page orientation name for symbol + ;; `orientation'. + (let* ((alist '((portrait . "Portrait") + (landscape . "Landscape") + (reverse-portrait . "ReversePortrait") + (reverse-landscape . "ReverseLandscape"))) + (which (assoc orientation alist))) + (if (not which) + (skribe-error 'lout + "`page-orientation' should be either `portrait' or `landscape'" + orientation) + (cdr which)))) + + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :keywords :env) + :before (lambda (n e) ;; `e' is the engine + (let* ((doc-type (let ((d (engine-custom e 'document-type))) + (if (string? d) + (begin + (engine-custom-set! e 'document-type + (string->symbol d)) + (string->symbol d)) + d))) + (doc-style? (eq? doc-type 'doc)) + (slides? (eq? doc-type 'slides)) + (doc-include (engine-custom e 'document-include)) + (includes (engine-custom e 'includes)) + (font (engine-custom e 'initial-font)) + (lang (engine-custom e 'initial-language)) + (break (engine-custom e 'initial-break)) + (column-number (engine-custom e 'column-number)) + (first-page-number (engine-custom e 'first-page-number)) + (page-orientation (engine-custom e 'page-orientation)) + (title (markup-option n :title))) + + ;; Add this markup option, used by + ;; `lout-start-large-scale-structure' et al. + (markup-option-add! n '&substructs-started? #f) + + (if (eq? doc-include 'auto) + (case doc-type + ((report) (display "@SysInclude { report }\n")) + ((book) (display "@SysInclude { book }\n")) + ((doc) (display "@SysInclude { doc }\n")) + ((slides) (display "@SysInclude { slides }\n")) + (else (skribe-error + 'lout + "`document-type' should be one of `book', `report', `doc' or `slides'" + doc-type))) + (printf "# Custom document includes\n~a\n" doc-include)) + + (if includes + (printf "# Additional user includes\n~a\n" includes) + (display "@SysInclude { tbl }\n")) + + ;; Write additional Lout definitions + (display (lout-definitions e)) + + (case doc-type + ((report) (display "@Report\n")) + ((book) (display "@Book\n")) + ((doc) (display "@Document\n")) + ((slides) (display "@OverheadTransparencies\n"))) + + (display (string-append " @InitialSpace { tex } " + "# avoid having too many spaces\n")) + + ;; The `doc' style doesn't have @Title, @Author and the likes + (if (not doc-style?) + (begin + (display " @Title { ") + (if title + (output title e) + (display "The Lout-Skribe Book")) + (display " }\n") + + ;; The author + (let* ((author (markup-option n :author))) + + (display " @Author { ") + (output author e) + (display " }\n") + + ;; Lout reports support `@Institution' while books + ;; don't. + (if (and (eq? doc-type 'report) + (is-markup? author 'author)) + (let ((institution (markup-option author + :affiliation))) + (if institution + (begin + (printf " @Institution { ") + (output institution e) + (printf " }\n")))))))) + + ;; Lout reports make it possible to choose whether to prepend + ;; a cover sheet (books and docs don't). Same for a date + ;; line. + (if (eq? doc-type 'report) + (let ((cover-sheet? (engine-custom e 'cover-sheet?)) + (date-line (engine-custom e 'date-line)) + (abstract (engine-custom e 'abstract)) + (abstract-title (engine-custom e 'abstract-title))) + (display (string-append " @CoverSheet { " + (if cover-sheet? + "Yes" "No") + " }\n")) + (display " @DateLine { ") + (if (string? date-line) + (output date-line e) + (display (if date-line "Yes" "No"))) + (display " }\n") + + (if abstract + (begin + (if (not (eq? abstract-title #t)) + (begin + (display " @AbstractTitle { ") + (cond + ((not abstract-title) #t) + (else (output abstract-title e))) + (display " }\n"))) + + (display " @Abstract {\n") + (output abstract e) + (display "\n}\n"))))) + + (printf " @OptimizePages { ~a }\n" + (if (engine-custom e 'optimize-pages?) + "Yes" "No")) + + (printf " @InitialFont { ~a }\n" + (cond ((string? font) font) + ((symbol? font) + (string-append (symbol->string font) + " Base 10p")) + ((number? font) + (string-append "Palatino Base " + (number->string font) + "p")) + (#t + (skribe-error + 'lout 'initial-font + "Should be a Lout font name, a symbol, or a number")))) + (printf " @InitialBreak { ~a }\n" + (if break break "adjust 1.2fx hyphen")) + (if (not slides?) + (printf " @ColumnNumber { ~a }\n" + (if (number? column-number) + column-number 1))) + (printf " @FirstPageNumber { ~a }\n" + (if (number? first-page-number) + first-page-number 1)) + (printf " @PageOrientation { ~a }\n" + (lout-page-orientation page-orientation)) + (printf " @InitialLanguage { ~a }\n" + (if lang lang "English")) + + ;; FIXME: Insert a preface for text preceding the first ch. + ;; FIXME: Create an @Introduction for the first chapter + ;; if its title is "Introduction" (for books). + + (display "//\n\n") + + (if doc-style? + ;; `doc' documents don't have @Title and the likes so + ;; we need to implement them "by hand" + (let ((make-cover-sheet + (engine-custom e 'doc-cover-sheet-proc))) + (display "@Text @Begin\n") + (if make-cover-sheet + (make-cover-sheet n e) + (lout-make-doc-cover-sheet n e)))) + + (if doc-style? + ;; Putting it here will only work with `doc' documents. + (lout-output-pdf-meta-info n e)))) + + :after (lambda (n e) + (let ((doc-type (engine-custom e 'document-type))) + (if (eq? doc-type 'doc) + (begin + (if (markup-option n '&substructs-started?) + (display "\n@EndSections\n")) + (display "\n@End @Text\n"))) + (display "\n\n# Lout document ends here.\n")))) + + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address + :phone :photo :align) + + :action (lambda (n e) + (let ((doc-type (engine-custom e 'document-type)) + (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)) + (photo (markup-option n :photo))) + + (define (row x) + (display "\n//1.5fx\n@Center { ") + (output x e) + (display " }\n")) + + (if email + (row (list (if name name "") + (! " <@I{") + (cond ((string? email) email) + ((markup? email) + (markup-body email)) + (#t "")) + (! "}> "))) + (if name (row name))) + + (if title (row title)) + + ;; In reports, the affiliation is passed to `@Institution'. + ;; However, books do not have an `@Institution' parameter. + (if (and affiliation (not (eq? doc-type 'report))) + (row affiliation)) + + (if address (row address)) + (if phone (row phone)) + (if url (row (it url))) + (if photo (row photo))))) + + +(define (lout-toc-entry node depth engine) + ;; Produce a TOC entry of depth `depth' (a integer greater than or equal to + ;; zero) for `node' using engine `engine'. The Lout code here is mostly + ;; copied from Lout's `dsf' (see definition of `@Item'). + (let ((ident (markup-ident node)) + (entry-proc (engine-custom engine 'toc-entry-proc))) + (if (markup-option node :toc) + (begin + (display "@LP\n") + (if ident + ;; create an internal for PDF navigation + (printf "{ ~a } @LinkSource { " (lout-tagify ident))) + + (if (> depth 0) + (printf "|~as " (number->string (* 6 depth)))) + (display " @HExpand { ") + + ;; output the number and title of this node + (entry-proc node engine) + + (display " &1rt @OneCol { ") + (printf " @SkribiloLeaders & @PageOf { ~a }" + (lout-tagify (markup-ident node))) + (display " &0io } }") + + (if ident (display " }")) + (display "\n"))))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options '(:class :chapter :section :subsection) + :action (lambda (n e) + (display "\n# toc\n") + (if (markup-option n :chapter) + (let ((chapters (filter (lambda (n) + (or (is-markup? n 'chapter) + (is-markup? n 'slide))) + (markup-body (ast-document n))))) + (for-each (lambda (c) + (let ((sections + (search-down (lambda (n) + (is-markup? n 'section)) + c))) + (lout-toc-entry c 0 e) + (if (markup-option n :section) + (for-each + (lambda (s) + (lout-toc-entry s 1 e) + (if (markup-option n :subsection) + (let ((subs + (search-down + (lambda (n) + (is-markup? + n 'subsection)) + s))) + (for-each + (lambda (s) + (lout-toc-entry s 2 e)) + subs)))) + sections)))) + chapters))))) + +(define lout-book-markup-alist + '((chapter . "Chapter") + (section . "Section") + (subsection . "SubSection") + (subsubsection . "SubSubSection"))) + +(define lout-report-markup-alist + '((chapter . "Section") + (section . "SubSection") + (subsection . "SubSubSection") + (subsubsection . #f))) + +(define lout-slides-markup-alist + '((slide . "Overhead"))) + +(define lout-doc-markup-alist lout-report-markup-alist) + +(define (lout-structure-markup skribe-markup engine) + ;; Return the Lout structure name for `skribe-markup' (eg. "Chapter" for + ;; `chapter' markups when `engine''s document type is `book'). + (let ((doc-type (engine-custom engine 'document-type)) + (assoc-ref (lambda (alist key) + (and-let* ((as (assoc key alist))) (cdr as))))) + (case doc-type + ((book) (assoc-ref lout-book-markup-alist skribe-markup)) + ((report) (assoc-ref lout-report-markup-alist skribe-markup)) + ((doc) (assoc-ref lout-doc-markup-alist skribe-markup)) + ((slides) (assoc-ref lout-slides-markup-alist skribe-markup)) + (else + (skribe-error 'lout + "`document-type' should be one of `book', `report', `doc' or `slides'" + doc-type))))) + +(define-public (lout-structure-number-string markup) + ;; Return a structure number string such as "1.2". + ;; FIXME: External code has started to rely on this. This should be + ;; generalized and moved elsewhere. + (let loop ((struct markup)) + (if (document? struct) + "" + (let ((parent-num (loop (ast-parent struct))) + (num (markup-option struct :number))) + (string-append parent-num + (if (string=? "" parent-num) "" ".") + (if (number? num) (number->string num) "")))))) + +;*---------------------------------------------------------------------*/ +;* lout-block-before ... */ +;*---------------------------------------------------------------------*/ +(define (lout-block-before n e) + ;; Produce the Lout code that introduces node `n', a large-scale + ;; structure (chapter, section, etc.). + (let ((lout-markup (lout-structure-markup (markup-markup n) e)) + (title (markup-option n :title)) + (number (markup-option n :number)) + (ident (markup-ident n))) + + (if (not lout-markup) + (begin + ;; the fallback method (i.e. when there exists no equivalent + ;; Lout markup) + (display "\n//1.8vx\n@B { ") + (output title e) + (display " }\n@SkribeMark { ") + (display (lout-tagify ident)) + (display " }\n//0.8vx\n\n")) + (begin + (printf "\n@~a\n @Title { " lout-markup) + (output title e) + (printf " }\n") + + (if (number? number) + (printf " @BypassNumber { ~a }\n" + (lout-structure-number-string n)) + (if (not number) + ;; this trick hides the section number + (printf " @BypassNumber { } # unnumbered\n"))) + + (cond ((string? ident) + (begin + (display " @Tag { ") + (display (lout-tagify ident)) + (display " }\n"))) + ((symbol? ident) + (begin + (display " @Tag { ") + (display (lout-tagify (symbol->string ident))) + (display " }\n"))) + (#t + (skribe-error 'lout + "Node identifiers should be strings" + ident))) + + (display "\n@Begin\n"))))) + +(define (lout-block-after n e) + ;; Produce the Lout code that terminates node `n', a large-scale + ;; structure (chapter, section, etc.). + (let ((lout-markup (lout-structure-markup (markup-markup n) e))) + (if (not lout-markup) + (printf "\n\n//0.3vx\n\n") ;; fallback method + (printf "\n\n@End @~a\n\n" lout-markup)))) + + +(define (lout-markup-child-type skribe-markup) + ;; Return the child markup type of `skribe-markup' (e.g. for `chapter', + ;; return `section'). + (let loop ((structs '(document chapter section subsection subsubsection))) + (if (null? structs) + #f + (if (eq? (car structs) skribe-markup) + (cadr structs) + (loop (cdr structs)))))) + +(define (lout-start-large-scale-structure markup engine) + ;; Perform the necessary step and produce output as a result of starting + ;; large-scale structure `markup' (ie. a chapter, section, subsection, + ;; etc.). + (let* ((doc-type (engine-custom engine 'document-type)) + (doc-style? (eq? doc-type 'doc)) + (parent (ast-parent markup)) + (markup-type (markup-markup markup)) + (lout-markup-name (lout-structure-markup markup-type + engine))) + (lout-debug "start-struct: markup=~a parent=~a" + markup parent) + + ;; add an `&substructs-started?' option to the markup + (markup-option-add! markup '&substructs-started? #f) + + (if (and lout-markup-name + parent (or doc-style? (not (document? parent)))) + (begin + (if (not (markup-option parent '&substructs-started?)) + ;; produce an `@BeginSubSections' or equivalent; `doc'-style + ;; documents need to preprend an `@BeginSections' before the + ;; first section while other styles don't. + (printf "\n@Begin~as\n" lout-markup-name)) + + ;; FIXME: We need to make sure that PARENT is a large-scale + ;; structure, otherwise it won't have the `&substructs-started?' + ;; option (e.g., if PARENT is a `color' markup). I need to clarify + ;; this. + (if (memq (markup-markup parent) + '(document chapter section subsection subsubsection)) + ;; update the `&substructs-started?' option of the parent + (markup-option-set! parent '&substructs-started? #t)) + + (lout-debug "start-struct: updated parent: ~a" + (markup-option parent '&substructs-started?)))) + + ;; output the `@Section @Title { ... } @Begin' thing + (lout-block-before markup engine))) + +(define (lout-end-large-scale-structure markup engine) + ;; Produce Lout code for ending structure `markup' (a chapter, section, + ;; subsection, etc.). + (let* ((doc-type (engine-custom engine 'document-type)) + (doc-style? (eq? doc-type 'doc)) + (markup-type (markup-markup markup)) + (lout-markup-name (lout-structure-markup markup-type + engine))) + + (if (and lout-markup-name + (markup-option markup '&substructs-started?) + (or doc-style? (not (document? markup)))) + (begin + ;; produce an `@EndSubSections' or equivalent; `doc'-style + ;; documents need to issue an `@EndSections' after the last section + ;; while other types of documents don't. + (lout-debug "end-struct: closing substructs for ~a" markup) + (printf "\n@End~as\n" + (lout-structure-markup (lout-markup-child-type markup-type) + engine)) + (markup-option-set! markup '&substructs-started? #f))) + + (lout-block-after markup engine))) + + +;*---------------------------------------------------------------------*/ +;* section ... .. @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (document? (ast-parent n))) + + :before (lambda (n e) + (lout-start-large-scale-structure n e) + + ;; `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 lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* section ... . @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'chapter)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'section)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :validate (lambda (n e) + (is-markup? (ast-parent n) 'subsection)) + :before lout-start-large-scale-structure + :after lout-end-large-scale-structure) + + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :options '() + :validate (lambda (n e) + (or (eq? 'doc (engine-custom e 'document-type)) + (memq (and (markup? (ast-parent n)) + (markup-markup (ast-parent n))) + '(chapter section subsection subsubsection slide)))) + :before (lambda (n e) + (let ((gap (engine-custom e 'paragraph-gap))) + (display (if (string? gap) gap "\n@PP\n"))))) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:label) + :before (lambda (n e) + (let ((label (markup-option n :label)) + (use-number? + (engine-custom e 'use-skribe-footnote-numbers?))) + (if (or (and (number? label) use-number?) label) + (printf "{ @FootNote @Label { ~a } { " + (if label label "")) + (printf "{ @FootNote ~a{ " + (if (not number) "@Label { } " ""))))) + :after (lambda (n e) + (display " } }"))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :action (lambda (n e) + (display "\n@LP\n"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '() + :action "\n@LP\n@FullWidthRule\n@LP\n") + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:fg :bg :width) + ;; FIXME: `:bg' not supported + ;; FIXME: `:width' is not supported either. Rather use `frame' for that + ;; kind of options. + :before (lambda (n e) + (let* ((w (markup-option n :width)) + (fg (markup-option n :fg))) + (printf "{ ~a } @Color { " (lout-color-specification fg)))) + + :after (lambda (n e) + (display " }"))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + ;; @Box won't span over several pages so this may cause + ;; problems if large frames are used. The workaround here consists + ;; in using an @Tbl with one single cell. + :options '(:width :border :margin :bg) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (margin (markup-option n :margin)) + (border (markup-option n :border)) + (bg (markup-option n :bg))) + + ;; The user manual seems to expect `frame' to imply a + ;; linebreak. However, the LaTeX engine doesn't seem to + ;; agree. + ;(display "\n@LP") + (printf (string-append "\n@Tbl # frame\n" + " rule { yes }\n")) + (if border (printf " rulewidth { ~a }\n" + (lout-width border))) + (if width (printf " width { ~a }\n" + (lout-width width))) + (if margin (printf " margin { ~a }\n" + (lout-width margin))) + (if bg (printf " paint { ~a }\n" + (lout-color-specification bg))) + (display "{ @Row format { @Cell A } A { ")) + +; (printf "\n@Box linewidth { ~a } margin { ~a } { " +; (lout-width (markup-option n :width)) +; (lout-width (markup-option n :margin))) + ) + :after (lambda (n e) + (display " } }\n"))) + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size :face) + :before (lambda (n e) + (let ((face (markup-option n :face)) + (size (lout-font-size (markup-option n :size)))) + (printf "\n~a @Font { " size))) + :after (lambda (n e) + (display " }\n"))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (display "\n@LP") + (case (markup-option n :side) + ((center) + (display "\n@Center { # flush-center\n")) + ((left) + (display "\n# flush-left\n")) + ((right) + (display (string-append "\n@Right " + "{ rragged hyphen } @Break " + "{ # flush-right\n"))))) + :after (lambda (n e) + (case (markup-option n :side) + ((left) + (display "")) + (else + (display "\n}"))) + (display " # flush\n"))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + ;; Note: We prepend and append a newline in order to make sure + ;; things work as expected. + :before "\n@LP\n@Center {" + :after "}\n@LP\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre + :before "\n@LP lines @Break lout @Space { # pre\n" + :after "\n} # pre\n") + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before "\nlines @Break lout @Space {\n" + :after "\n} # @Break\n") + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +;; Program lines appear within a `lines @Break' block. +(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 (lambda (n e) + (let ((symbol (markup-option n :symbol))) + (if symbol + (begin + (display "\n@List style { ") + (output symbol e) + (display " } # itemize\n")) + (display "\n@BulletList # itemize\n")))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before (lambda (n e) + (let ((symbol (markup-option n :symbol))) + (if symbol + (printf "\n@List style { ~a } # enumerate\n" + symbol) + (display "\n@NumberedList # enumerate\n")))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) ;; `symbol' doesn't make sense here + :before "\n@TaggedList # description\n" + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (display "@DropTagItem { ") + (for-each (lambda (i) + (output i e) + (display " ")) + (if (pair? k) k (list k))) + (display " } { ") + (output (markup-body item) e) + (display " }\n"))) + (markup-body n))) + :after "\n@EndList\n") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :before "\n@LI { " + :after " }") + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :before "\n@ID {" + :after "\n} # @ID\n") + +;*---------------------------------------------------------------------*/ +;* 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 "\n@Figure\n") + (display " @Tag { ") + (display (lout-tagify ident)) + (display " }\n") + (printf " @BypassNumber { ~a }\n" + (cond ((number? number) number) + ((not number) "") + (else number))) + (display " @InitialLanguage { ") + (display (engine-custom e 'initial-language)) + (display " }\n") + + (if legend + (begin + (lout-debug "figure: ~a, \"~a\"" ident legend) + (printf " @Caption { ") + (output legend e) + (printf " }\n"))) + (printf " @Location { ~a }\n" + (if mc? "PageTop" "ColTop")) + (printf "{\n") + (output (markup-body n) e))) + :after (lambda (n e) + (display "}\n"))) + + +;*---------------------------------------------------------------------*/ +;* lout-table-column-number ... */ +;* ------------------------------------------------------------- */ +;* This function computes how columns are contained by the table. */ +;*---------------------------------------------------------------------*/ +(define (lout-table-column-number t) + (define (row-columns row) + (let loop ((cells (markup-body row)) + (nbcols 0)) + (if (null? cells) + nbcols + (loop (cdr cells) + (+ nbcols (markup-option (car cells) :colspan)))))) + (let loop ((rows (markup-body t)) + (nbcols 0)) + (if (null? rows) + nbcols + (loop (cdr rows) + (max (row-columns (car rows)) nbcols))))) + +(define (lout-table-cell-indent align) + ;; Return the Lout name (a string) for cell alignment `align' (a symbol). + (case align + ((center #f #t) "ctr") + ((right) "right") + ((left) "left") + (else (skribe-error 'td align + "Unknown alignment type")))) + +(define (lout-table-cell-vindent align) + ;; Return the Lout name (a string) for cell alignment `align' (a symbol). + (case align + ((center #f #t) "ctr") + ((top) "top") + ((bottom) "foot") + (else (skribe-error 'td align + "Unknown alignment type")))) + +(define (lout-table-cell-vspan cell-letter row-vspan) + ;; Return the vspan information (an alist) for the cell whose + ;; letter is `cell-letter', within the row whose vspan information + ;; is given by `row-vspan'. If the given cell doesn't span over + ;; rows, then #f is returned. + (and-let* ((as (assoc cell-letter row-vspan))) + (cdr as))) + +(define (lout-table-cell-vspan-start? vspan-alist) + ;; For the cell whose vspan information is given by `vspan-alist', + ;; return #t if that cell starts spanning vertically. + (and vspan-alist + (cdr (assoc 'start? vspan-alist)))) + +(define-macro (char+int c i) + `(integer->char (+ ,i (char->integer ,c)))) + +(define-macro (-- i) + `(- ,i 1)) + + +(define (lout-table-cell-option-string cell) + ;; Return the Lout cell option string for `cell'. + (let ((align (markup-option cell :align)) + (valign (markup-option cell :valign)) + (width (markup-option cell :width)) + (bg (markup-option cell :bg))) + (string-append (lout-table-cell-rules cell) " " + (string-append + "indent { " + (lout-table-cell-indent align) + " } ") + (string-append + "indentvertical { " + (lout-table-cell-vindent valign) + " } ") + (if (not width) "" + (string-append "width { " + (lout-width width) + " } ")) + (if (not bg) "" + (string-append "paint { " + (lout-color-specification bg) + " } "))))) + +(define (lout-table-cell-format-string cell vspan-alist) + ;; Return a Lout cell format string for `cell'. It uses the `&cell-name' + ;; markup option of its cell as its Lout cell name and `vspan-alist' as the + ;; source of information regarding its vertical spanning (#f means that + ;; `cell' is not vertically spanned). + (let ((cell-letter (markup-option cell '&cell-name)) + (cell-options (lout-table-cell-option-string cell)) + (colspan (if vspan-alist + (cdr (assoc 'hspan vspan-alist)) + (markup-option cell :colspan))) + (vspan-start? (and vspan-alist + (cdr (assoc 'start? vspan-alist))))) + (if (and (not vspan-start?) vspan-alist) + "@VSpan" + (let* ((cell-fmt (string-append "@Cell " cell-options + (string cell-letter)))) + (string-append + (if (> colspan 1) + (string-append (if (and vspan-start? vspan-alist) + "@StartHVSpan " "@StartHSpan ") + cell-fmt + (let pool ((cnt (- colspan 1)) + (span-cells "")) + (if (= cnt 0) + span-cells + (pool (- cnt 1) + (string-append span-cells + " | @HSpan"))))) + (string-append (if (and vspan-alist vspan-start?) + "@StartVSpan " "") + cell-fmt))))))) + + +(define (lout-table-row-format-string row) + ;; Return a Lout row format string for row `row'. It uses the `&cell-name' + ;; markup option of its cell as its Lout cell name. + + ;; FIXME: This function has become quite ugly + (let ((cells (markup-body row)) + (row-vspan (markup-option row '&vspan-alist))) + + (let loop ((cells cells) + (cell-letter #\A) + (delim "") + (fmt "")) + (lout-debug "looping on cell ~a" cell-letter) + + (if (null? cells) + + ;; The final `|' prevents the rightmost column to be + ;; expanded to full page width (see sect. 6.11, p. 133). + (if row-vspan + ;; In the end, there can be vspan columns left so we need to + ;; mark them + (let final-loop ((cell-letter cell-letter) + (fmt fmt)) + (let* ((cell-vspan (lout-table-cell-vspan cell-letter + row-vspan)) + (hspan (if cell-vspan + (cdr (assoc 'hspan cell-vspan)) + 1))) + (lout-debug "final-loop: ~a ~a" cell-letter cell-vspan) + (if (not cell-vspan) + (string-append fmt " |") + (final-loop (integer->char + (+ hspan (char->integer cell-letter))) + (string-append fmt " | @VSpan |"))))) + + (string-append fmt " |")) + + (let* ((cell (car cells)) + (vspan-alist (lout-table-cell-vspan cell-letter row-vspan)) + (vspan-start? (lout-table-cell-vspan-start? vspan-alist)) + (colspan (if vspan-alist + (cdr (assoc 'hspan vspan-alist)) + (markup-option cell :colspan))) + (cell-format + (lout-table-cell-format-string cell vspan-alist))) + + (loop (if (or (not vspan-alist) vspan-start?) + (cdr cells) + cells) ;; don't skip pure vspan cells + + ;; next cell name + (char+int cell-letter colspan) + + " | " ;; the cell delimiter + (string-append fmt delim cell-format))))))) + + + +;; A row vspan alist describes the cells of a row that span vertically +;; and it looks like this: +;; +;; ((#\A . ((start? . #t) (hspan . 1) (vspan . 3))) +;; (#\C . ((start? . #f) (hspan . 2) (vspan . 1)))) +;; +;; which means that cell `A' start spanning vertically over three rows +;; including this one, while cell `C' is an "empty" cell that continues +;; the vertical spanning of a cell appearing on some previous row. +;; +;; The running "global" (or "table-wide") vspan alist looks the same +;; except that it doesn't have the `start?' tags. + +(define (lout-table-compute-row-vspan-alist row global-vspan-alist) + ;; Compute the vspan alist of row `row' based on the current table vspan + ;; alist `global-vspan-alist'. As a side effect, this function stores the + ;; Lout cell name (a character between #\A and #\Z) as the value of markup + ;; option `&cell-name' of each cell. + (if (pair? (markup-body row)) + ;; Mark the first cell as such. + (markup-option-add! (car (markup-body row)) '&first-cell? #t)) + + (let cell-loop ((cells (markup-body row)) + (cell-letter #\A) + (row-vspan-alist '())) + (lout-debug "cell: ~a ~a" cell-letter + (if (null? cells) '() (car cells))) + + (if (null? cells) + + ;; In the end, we must retain any vspan cell that occurs after the + ;; current cell name (note: we must add a `start?' tag at this point + ;; since the global table vspan alist doesn't have that). + (let ((additional-cells (filter (lambda (c) + (char>=? (car c) cell-letter)) + global-vspan-alist))) + (lout-debug "compute-row-vspan-alist returning: ~a + ~a (~a)" + row-vspan-alist additional-cells + (length global-vspan-alist)) + (append row-vspan-alist + (map (lambda (c) + `(,(car c) . ,(cons '(start? . #f) (cdr c)))) + additional-cells))) + + (let* ((current-cell-vspan (assoc cell-letter global-vspan-alist)) + (hspan (if current-cell-vspan + (cdr (assoc 'hspan (cdr current-cell-vspan))) + (markup-option (car cells) :colspan)))) + + (if (null? (cdr cells)) + ;; Mark the last cell as such + (markup-option-add! (car cells) '&last-cell? #t)) + + (cell-loop (if current-cell-vspan + cells ;; this cell is vspanned, so don't skip it + (cdr cells)) + + ;; next cell name + (char+int cell-letter (or hspan 1)) + + (begin ;; updating the row vspan alist + (lout-debug "cells: ~a" (length cells)) + (lout-debug "current-cell-vspan for ~a: ~a" + cell-letter current-cell-vspan) + + (if current-cell-vspan + + ;; this cell is currently vspanned, ie. a previous + ;; row defined a vspan for it and that it is still + ;; spanning on this row + (cons `(,cell-letter + . ((start? . #f) + (hspan . ,(cdr + (assoc + 'hspan + (cdr current-cell-vspan)))))) + row-vspan-alist) + + ;; this cell is not currently vspanned + (let ((vspan (markup-option (car cells) :rowspan))) + (lout-debug "vspan-option for ~a: ~a" + cell-letter vspan) + + (markup-option-add! (car cells) + '&cell-name cell-letter) + (if (and vspan (> vspan 1)) + (cons `(,cell-letter . ((start? . #t) + (hspan . ,hspan) + (vspan . ,vspan))) + row-vspan-alist) + row-vspan-alist))))))))) + +(define (lout-table-update-table-vspan-alist table-vspan-alist + row-vspan-alist) + ;; Update `table-vspan-alist' based on `row-vspan-alist', the alist + ;; representing vspan cells for the last row that has been read." + (lout-debug "update-table-vspan: ~a and ~a" + table-vspan-alist row-vspan-alist) + + (let ((new-vspan-cells (filter (lambda (cell) + (cdr (assoc 'start? (cdr cell)))) + row-vspan-alist))) + + ;; Append the list of new vspan cells described in `row-vspan-alist' + (let loop ((cells (append table-vspan-alist new-vspan-cells)) + (result '())) + (if (null? cells) + (begin + (lout-debug "update-table-vspan returning: ~a" result) + result) + (let* ((cell (car cells)) + (cell-letter (car cell)) + (cell-hspan (cdr (assoc 'hspan (cdr cell)))) + (cell-vspan (-- (cdr (assoc 'vspan (cdr cell)))))) + (loop (cdr cells) + (if (> cell-vspan 0) + + ;; Keep information about this vspanned cell + (cons `(,cell-letter . ((hspan . ,cell-hspan) + (vspan . ,cell-vspan))) + result) + + ;; Vspan for this cell has been done so we can remove + ;; it from the running table vspan alist + result))))))) + +(define (lout-table-mark-vspan! tab) + ;; Traverse the rows of table `tab' and add them an `&vspan-alist' option + ;; that describes which of its cells are to be vertically spanned. + (let loop ((rows (markup-body tab)) + (global-vspan-alist '())) + (if (null? rows) + + ;; At this point, each row holds its own vspan information alist (the + ;; `&vspan-alist' option) so we don't care anymore about the running + ;; table vspan alist + #t + + (let* ((row (car rows)) + (row-vspan-alist (lout-table-compute-row-vspan-alist + row global-vspan-alist))) + + ;; Bind the row-specific vspan information to the row object + (markup-option-add! row '&vspan-alist row-vspan-alist) + + (if (null? (cdr rows)) + ;; Mark the last row as such + (markup-option-add! row '&last-row? #t)) + + (loop (cdr rows) + (lout-table-update-table-vspan-alist global-vspan-alist + row-vspan-alist)))))) + +(define (lout-table-first-row? row) + (markup-option row '&first-row?)) + +(define (lout-table-last-row? row) + (markup-option row '&last-row?)) + +(define (lout-table-first-cell? cell) + (markup-option cell '&first-cell?)) + +(define (lout-table-last-cell? cell) + (markup-option cell '&last-cell?)) + +(define (lout-table-row-rules row) + ;; Return a string representing the Lout option string for + ;; displaying rules of `row'. + (let* ((table (ast-parent row)) + (frames (markup-option table :frame)) + (rules (markup-option table :rules)) + (first? (lout-table-first-row? row)) + (last? (lout-table-last-row? row))) + (string-append (if (and first? + (member frames '(above hsides box border))) + "ruleabove { yes } " "") + (if (and last? + (member frames '(below hsides box border))) + "rulebelow { yes } " "") + ;; rules + (case rules + ((header) + ;; We consider the first row to be a header row. + (if first? "rulebelow { yes }" "")) + ((rows all) + ;; We use redundant rules because coloring + ;; might make them disappear otherwise. + (string-append (if first? "" "ruleabove { yes } ") + (if last? "" "rulebelow { yes }"))) + (else ""))))) + +(define (lout-table-cell-rules cell) + ;; Return a string representing the Lout option string for + ;; displaying rules of `cell'. + (let* ((row (ast-parent cell)) + (table (ast-parent row)) + (frames (markup-option table :frame)) + (rules (markup-option table :rules)) + (first? (lout-table-first-cell? cell)) + (last? (lout-table-last-cell? cell))) + (string-append (if (and first? + (member frames '(vsides lhs box border))) + "ruleleft { yes } " "") + (if (and last? + (member frames '(vsides rhs box border))) + "ruleright { yes } " "") + ;; rules + (case rules + ((cols all) + ;; We use redundant rules because coloring + ;; might make them disappear otherwise. + (string-append (if last? "" "ruleright { yes } ") + (if first? "" "ruleleft { yes }"))) + (else ""))))) + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:frame :rules :border :width :cellpadding) + ;; XXX: `:cellstyle' `separate' and `:cellspacing' not supported + ;; by Lout's @Tbl. + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (cp (markup-option n :cellpadding)) + (rows (markup-body n))) + + (define (cell-width row col) + (let ((cells (markup-body row)) + (bg (markup-option row :bg))) + (let loop ((cells cells) + (c 0)) + (if (pair? cells) + (let* ((ce (car cells)) + (width (markup-option ce :width)) + (colspan (markup-option ce :colspan))) + (if (= col c) + (if (number? width) width 0) + (loop (cdr cells) (+ c colspan)))) + 0)))) + + (define (col-width col) + (let loop ((rows rows) + (width 0)) + (if (null? rows) + (if (= width 0) + 0 + width) + (loop (cdr rows) + (max width (cell-width (car rows) col)))))) + + (if (pair? (markup-body n)) + ;; Mark the first row as such + (markup-option-add! (car (markup-body n)) + '&first-row? #t)) + + ;; Mark each row with vertical spanning information + (lout-table-mark-vspan! n) + + (display "\n@Tbl # table\n") + + (if (number? border) + (printf " rulewidth { ~a }\n" + (lout-width (markup-option n :border)))) + (if (number? cp) + (printf " margin { ~ap }\n" + (number->string cp))) + + (display "{\n"))) + + :after (lambda (n e) + (let ((header-rows (or (markup-option n '&header-rows) 0))) + ;; Issue an `@EndHeaderRow' symbol for each `@HeaderRow' symbol + ;; previously produced. + (let ((cnt header-rows)) + (if (> cnt 0) + (display "\n@EndHeaderRow")))) + + (display "\n} # @Tbl\n"))) + +;*---------------------------------------------------------------------*/ +;* 'tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '(:bg) + :action (lambda (row e) + (let* ((bg (markup-option row :bg)) + (bg-color (if (not bg) "" + (string-append + "paint { " + (lout-color-specification bg) " } "))) + (first-row? (markup-option row '&first-row?)) + (header-row? (any (lambda (n) + (eq? (markup-option n 'markup) + 'th)) + (markup-body row))) + (fmt (lout-table-row-format-string row)) + (rules (lout-table-row-rules row))) + + ;; Use `@FirstRow' and `@HeaderFirstRow' for the first + ;; row. `@HeaderFirstRow' seems to be buggy though. + ;; (see section 6.1, p.119 of the User's Guide). + + (printf "\n@~aRow ~aformat { ~a }" + (if first-row? "First" "") + bg-color fmt) + (display (string-append " " rules)) + (output (markup-body row) e) + + (if (and header-row? (engine-custom e 'use-header-rows?)) + ;; `@HeaderRow' symbols are not actually printed + ;; (see section 6.11, p. 134 of the User's Guide) + ;; FIXME: This all seems buggy on the Lout side. + (let* ((tab (ast-parent row)) + (hrows (and (markup? tab) + (or (markup-option tab '&header-rows) + 0)))) + (if (not (is-markup? tab 'table)) + (skribe-error 'lout + "tr's parent not a table!" tab)) + (markup-option-add! tab '&header-rows (+ hrows 1)) + (printf "\n@Header~aRow ~aformat { ~a }" + "" ; (if first-row? "First" "") + bg-color fmt) + (display (string-append " " rules)) + + ;; the cells must be produced once here + (output (markup-body row) e)))))) + +;*---------------------------------------------------------------------*/ +;* tc */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(markup :width :align :valign :colspan :rowspan :bg) + :before (lambda (cell e) + (printf "\n ~a { " (markup-option cell '&cell-name))) + :after (lambda (cell e) + (display " }"))) + + +;*---------------------------------------------------------------------*/ +;* 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 url ;; maybe we should run `wget' then? :-) + (skribe-error 'lout "Image URLs not supported" url)) + (if (not (string? img)) + (skribe-error 'lout "Illegal image" file) + (begin + (if width + (printf "\n~a @Wide" (lout-width width))) + (if height + (printf "\n~a @High" (lout-width height))) + (if zoom + (printf "\n~a @Scale" zoom)) + (printf "\n@IncludeGraphic { \"~a\" }\n" img)))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +;; Each ornament is enclosed in braces to allow such things as +;; "he,(bold "ll")o" to work without adding an extra space. +(markup-writer 'roman :before "{ @R { " :after " } }") +(markup-writer 'underline :before "{ @Underline { " :after " } }") +(markup-writer 'code :before "{ @F { " :after " } }") +(markup-writer 'var :before "{ @F { " :after " } }") +(markup-writer 'sc :before "{ @S {" :after " } }") +(markup-writer 'sf :before "{ { Helvetica Base } @Font { " :after " } }") +(markup-writer 'sub :before "{ @Sub { " :after " } }") +(markup-writer 'sup :before "{ @Sup { " :after " } }") +(markup-writer 'tt :before "{ @F { " :after " } }") + + +;; `(bold (it ...))' and `(it (bold ...))' should both lead to `@BI { ... }' +;; instead of `@B { @I { ... } }' (which is different). +;; Unfortunately, it is not possible to use `ast-parent' and +;; `find1-up' to check whether `it' (resp. `bold') was invoked within +;; a `bold' (resp. `it') markup, hence the `&italics' and `&bold' +;; option trick. FIXME: This would be much more efficient if +;; `ast-parent' would work as expected. + +;; FIXME: See whether `@II' can be useful. Use SRFI-39 parameters. + +(markup-writer 'it + :before (lambda (node engine) + (let ((bold-children (search-down (lambda (n) + (is-markup? n 'bold)) + node))) + (map (lambda (b) + (markup-option-add! b '&italics #t)) + bold-children) + (printf "{ ~a { " + (if (markup-option node '&bold) + "@BI" "@I")))) + :after " } }") + +(markup-writer 'emph + :before (lambda (n e) + (invoke (writer-before (markup-writer-get 'it e)) + n e)) + :after (lambda (n e) + (invoke (writer-after (markup-writer-get 'it e)) + n e))) + +(markup-writer 'bold + :before (lambda (node engine) + (let ((it-children (search-down (lambda (n) + (or (is-markup? n 'it) + (is-markup? n 'emph))) + node))) + (map (lambda (i) + (markup-option-add! i '&bold #t)) + it-children) + (printf "{ ~a { " + (if (markup-option node '&italics) + "@BI" "@B")))) + :after " } }") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "{ @Char guillemotleft }\" \"" + :after "\" \"{ @Char guillemotright }") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :before " @I { " + :action (lambda (n e) + (let ((text (markup-option n :text))) + (output (or text (markup-body n)) e))) + :after " }") + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :action (lambda (n e) + (if (markup-ident n) + (begin + (display "{ @SkribeMark { ") + (display (lout-tagify (markup-ident n))) + (display " } }")) + (skribe-error 'lout "mark: Node has no identifier" n)))) + +(define (lout-page-of ident) + ;; Return a string for the `@PageOf' statement for `ident'. + (let ((tag (lout-tagify ident))) + (string-append ", { " tag " } @CrossLink { " + "p. @PageOf { " tag " } }"))) + + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection + :figure :mark :handle :ident :page) + :action (lambda (n e) + (let ((url (markup-option n :url)) + (text (markup-option n :text)) + (mark (markup-option n :mark)) + (handle (markup-option n :handle)) + (chapter (markup-option n :chapter)) + (section (markup-option n :section)) + (subsection (markup-option n :subsection)) + (subsubsection (markup-option n :subsubsection)) + (show-page-num? (markup-option n :page))) + + ;; A handle to the target is automagically passed + ;; as the body of each `ref' instance (see `api.scm'). + (let* ((target (handle-ast (markup-body n))) + (ident (markup-ident target)) + (title (markup-option target :title)) + (number (markup-option target :number))) + (lout-debug "ref: target=~a ident=~a" target ident) + (if text (output text e)) + + ;; Marks don't have a number + (if (eq? (markup-markup target) 'mark) + (printf (lout-page-of ident)) + (begin + ;; Don't output a section/whatever number + ;; when text is provided in order to be + ;; consistent with the HTML back-end. + ;; Sometimes (eg. for user-defined markups), + ;; we don't even know how to reference them + ;; anyway. + (if (not text) + (printf " @NumberOf { ~a }" + (lout-tagify ident))) + (if show-page-num? + (printf (lout-page-of ident))))))))) + + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let ((entry (handle-ast (markup-body n)))) + (output (markup-option entry :title) e))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + ;; When several references are passed. Strangely enough, the list of + ;; entries passed to this writer (as its body) contains both `bib-ref' and + ;; `bib-entry' objects, hence the `canonicalize-entry' function below. + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let* ((entries (markup-body n)) + (canonicalize-entry (lambda (x) + (cond + ((is-markup? x 'bib-entry) x) + ((is-markup? x 'bib-ref) + (handle-ast (markup-body x))) + (else + (skribe-error + 'lout + "bib-ref+: invalid entry type" + x))))) + (help-proc (lambda (proc) + (lambda (e1 e2) + (proc (canonicalize-entry e1) + (canonicalize-entry e2))))) + (sort-proc (engine-custom e 'bib-refs-sort-proc))) + (let loop ((rs (if sort-proc + (sort entries (help-proc sort-proc)) + entries))) + (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 ((url (markup-option n :url)) + (text (markup-option n :text)) + (transform (engine-custom e 'transform-url-ref-proc))) + (if (or (not transform) + (markup-option n '&transformed)) + (begin + (printf "{ \"~a\" @ExternalLink { " url) + (if text ;; FIXME: Should be (not (string-index text #\space)) + (output text e) + (let ((filter-url (make-string-replace + `((#\/ "\"/\"&-") + (#\. ".&-") + (#\- "&-") + (#\_ "_&-") + ,@lout-verbatim-encoding + (#\newline ""))))) + ;; Filter the URL in a way to give Lout hints on + ;; where hyphenation should take place. + (fprint (current-error-port) "Here!!!" filter-url) + (display (filter-url url) e))) + (printf " } }")) + (begin + (markup-option-add! n '&transformed #t) + (output (transform n) e)))))) + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before "{ @I {" ;; FIXME: Not tested + :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) + ;; Compute the length (in characters) of the longest entry label + ;; so that the label width of the list is adjusted. + (let loop ((entries (markup-body n)) + (label-width 0)) + (if (null? entries) + (begin + (display "\n# the-bibliography\n@LP\n") + ;; usually, the tag with be something like "[7]", hence + ;; the `+ 1' below (`[]' is narrower than 2f) + (printf "@TaggedList labelwidth { ~af }\n" + (+ 1 label-width))) + (loop (cdr entries) + (let ((entry-length + (let liip ((e (car entries))) + (cond + ((markup? e) + (cond ((is-markup? e '&bib-entry) + (liip (markup-option e :title))) + ((is-markup? e '&bib-entry-ident) + (liip (markup-option e 'number))) + (else + (liip (markup-body e))))) + ((string? e) + (string-length e)) + ((number? e) + (liip (number->string e))) + ((list? e) + (apply + (map liip e))) + (else 0))))) +; (fprint (current-error-port) +; "node=" (car entries) +; " body=" (markup-body (car entries)) +; " title=" (markup-option (car entries) +; :title) +; " len=" entry-length) + (if (> label-width entry-length) + label-width + entry-length)))))) + :after (lambda (n e) + (display "\n@EndList # the-bibliography (end)\n"))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :before "@TagItem " + :action (lambda (n e) + (display " { ") + (output n e (markup-writer-get '&bib-entry-label e)) + (display " } { ") + (output n e (markup-writer-get '&bib-entry-body e)) + (display " }")) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* &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 (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 " \"[\"" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "\"]\" ") + +;*---------------------------------------------------------------------*/ +;* &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 "@Center { ") ;; FIXME: Needs to be rewritten. + (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-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-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :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)))) + + +;*---------------------------------------------------------------------*/ +;* Illustrations */ +;*---------------------------------------------------------------------*/ +(define-public (lout-illustration . args) + ;; FIXME: This should be a markup. + + ;; Introduce a Lout illustration (such as a diagram) whose code is either + ;; the body of `lout-illustration' or the contents of `file'. For engines + ;; other than Lout, an EPS file is produced and then converted if needed. + ;; The `:alt' option is equivalent to HTML's `alt' attribute for the `img' + ;; markup, i.e. it is passed as the body of the `image' markup for + ;; non-Lout back-ends. + + (define (file-contents file) + ;; Return the contents (a string) of file `file'. + (with-input-from-file file + (lambda () + (let loop ((contents "") + (line (read-line))) + (if (eof-object? line) + contents + (loop (string-append contents line "\n") + (read-line))))))) + + (define (illustration-header) + ;; Return a string denoting the header of a Lout illustration. + (let ((lout (find-engine 'lout))) + (string-append "@SysInclude { picture }\n" + (engine-custom lout 'includes) + "\n\n@Illustration\n" + " @InitialFont { " + (engine-custom lout 'initial-font) + " }\n" + " @InitialBreak { " + (engine-custom lout 'initial-break) + " }\n" + " @InitialLanguage { " + (engine-custom lout 'initial-language) + " }\n" + " @InitialSpace { tex }\n" + "{\n"))) + + (define (illustration-ending) + ;; Return a string denoting the end of a Lout illustration. + "\n}\n") + + (let* ((opts (the-options args '(file ident alt))) + (file* (assoc ':file opts)) + (ident* (assoc ':ident opts)) + (alt* (assoc ':alt opts)) + (file (and file* (cadr file*))) + (ident (and ident* (cadr ident*))) + (alt (or (and alt* (cadr alt*)) "An illustration"))) + + (let ((contents (if (not file) + (car (the-body args)) + (file-contents file)))) + (if (engine-format? "lout") + (! contents) ;; simply inline the illustration + (let* ((lout (find-engine 'lout)) + (output (string-append (or ident + (symbol->string + (gensym 'lout-illustration))) + ".eps")) + (port (open-output-pipe + (string-append (or (engine-custom lout + 'lout-program-name) + "lout") + " -o " output + " -EPS")))) + + ;; send the illustration to Lout's standard input + (display (illustration-header) port) + (display contents port) + (display (illustration-ending) port) + + (let ((exit-val (status:exit-val (close-pipe port)))) + (if (not (eqv? 0 exit-val)) + (skribe-error 'lout-illustration + "lout exited with error code" exit-val))) + + (if (not (file-exists? output)) + (skribe-error 'lout-illustration "file not created" + output)) + + (let ((file-info (false-if-exception (stat output)))) + (if (or (not file-info) + (= 0 (stat:size file-info))) + (skribe-error 'lout-illustration + "empty output file" output))) + + ;; the image (FIXME: Should set its location) + (image :file output alt)))))) + + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(pop-default-engine) + + +;; Local Variables: -- +;; mode: Scheme -- +;; coding: latin-1 -- +;; scheme-program-name: "guile" -- +;; End: -- diff --git a/src/guile/skribilo/engine/xml.scm b/src/guile/skribilo/engine/xml.scm new file mode 100644 index 0000000..81e9f27 --- /dev/null +++ b/src/guile/skribilo/engine/xml.scm @@ -0,0 +1,115 @@ +;;; xml.scm -- Generic XML engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo engine xml)) + +;*---------------------------------------------------------------------*/ +;* 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/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm new file mode 100644 index 0000000..8502d51 --- /dev/null +++ b/src/guile/skribilo/evaluator.scm @@ -0,0 +1,203 @@ +;;; eval.scm -- Skribilo evaluator. +;;; +;;; Copyright 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005,2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo evaluator) + :export (evaluate-document evaluate-document-from-port + load-document include-document *load-options*) + :autoload (skribilo parameters) (*verbose* *document-path*) + :autoload (skribilo location) () + :autoload (skribilo ast) (ast? markup?) + :autoload (skribilo engine) (*current-engine* + engine? find-engine engine-ident) + :autoload (skribilo reader) (*document-reader*) + + :autoload (skribilo verify) (verify) + :autoload (skribilo resolve) (resolve!) + + :autoload (skribilo module) (*skribilo-user-module*)) + + +(use-modules (skribilo utils syntax) + (skribilo condition) + (skribilo debug) + (skribilo output) + (skribilo lib) + + (ice-9 optargs) + (oop goops) + (srfi srfi-1) + (srfi srfi-13) + (srfi srfi-34) + (srfi srfi-35) + (srfi srfi-39)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; %EVALUATE +;;; +(define (%evaluate expr) + ;; Evaluate EXPR, an arbitrary S-expression that may contain calls to the + ;; markup functions defined in a markup package such as + ;; `(skribilo package base)', e.g., `(bold "hello")'. + (let ((result (eval expr (*skribilo-user-module*)))) + + (if (ast? result) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (slot-set! result 'loc + (make + :file file :line line :pos column)))) + + result)) + + + +;;; +;;; EVALUATE-DOCUMENT +;;; +(define* (evaluate-document a e :key (env '())) + ;; Argument A must denote an AST of something like that, not just an + ;; S-exp. + (with-debug 2 'evaluate-document + (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))))) + +;;; +;;; EVALUATE-DOCUMENT-FROM-PORT +;;; +(define* (evaluate-document-from-port port engine + :key (env '()) + (reader (*document-reader*))) + (with-debug 2 'evaluate-document-from-port + (debug-item "engine=" engine) + (debug-item "reader=" reader) + + (let ((e (if (symbol? engine) (find-engine engine) engine))) + (debug-item "e=" e) + (if (not (engine? e)) + (skribe-error 'evaluate-document-from-port "cannot find engine" engine) + (let loop ((exp (reader port))) + (with-debug 10 'evaluate-document-from-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (evaluate-document (%evaluate exp) e :env env) + (loop (reader port)))))))) + + +;;; +;;; LOAD-DOCUMENT +;;; + +;; Options that may make sense to a specific back-end or package. +(define-public *load-options* (make-parameter '())) + +;; List of the names of files already loaded. +(define *loaded-files* (make-parameter '())) + +(define* (load-document file :key (engine #f) (path #f) :allow-other-keys + :rest opt) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt=" opt) + + (let* ((ei (*current-engine*)) + (path (append (cond + ((not path) (*document-path*)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (raise (condition (&invalid-argument-error + (proc-name 'load-document) + (argument 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)))))) + + (unless (and (string? filep) (file-exists? filep)) + (raise (condition (&file-search-error + (file-name file) + (path path))))) + + ;; Pass the additional options to the back-end and/or packages being + ;; used. + (parameterize ((*load-options* opt)) + + ;; Load this file if not already done + ;; FIXME: Shouldn't we remove this logic? -- Ludo'. + (unless (member filep (*loaded-files*)) + (cond + ((> (*verbose*) 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> (*verbose*) 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + + ;; Load it + (with-input-from-file filep + (lambda () + (evaluate-document-from-port (current-input-port) ei))) + + (*loaded-files* (cons filep (*loaded-files*)))))))) + +;;; +;;; INCLUDE-DOCUMENT +;;; +(define* (include-document file :key (path (*document-path*)) + (reader (*document-reader*))) + (unless (every string? path) + (raise (condition (&invalid-argument-error (proc-name 'include-document) + (argument path))))) + + (let ((full-path (search-path path file))) + (unless (and (string? full-path) (file-exists? full-path)) + (raise (condition (&file-search-error + (file-name file) + (path path))))) + + (when (> (*verbose*) 0) + (format (current-error-port) " [including file: ~S]\n" full-path)) + + (with-input-from-file full-path + (lambda () + (let Loop ((exp (reader (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (reader (current-input-port)) + (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/index.scm b/src/guile/skribilo/index.scm new file mode 100644 index 0000000..33f8d15 --- /dev/null +++ b/src/guile/skribilo/index.scm @@ -0,0 +1,170 @@ +;;; index.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo index) + :use-syntax (skribilo utils syntax) + :use-syntax (skribilo lib) + + :use-module (skribilo lib) + :use-module (skribilo ast) + :use-module (srfi srfi-39) + + ;; XXX: The use of `mark' here introduces a cross-dependency between + ;; `index' and `package base'. Thus, we require that each of these two + ;; modules autoloads the other one. + :autoload (skribilo package base) (mark) + + :export (index? make-index-table *index-table* + default-index resolve-the-index)) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; A library of functions dealing with the creation of indices in +;;; documents. +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `index.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* index? ... */ +;*---------------------------------------------------------------------*/ +(define (index? obj) + (hash-table? obj)) + +;*---------------------------------------------------------------------*/ +;* *index-table* ... */ +;*---------------------------------------------------------------------*/ +(define *index-table* (make-parameter #f)) + +;*---------------------------------------------------------------------*/ +;* make-index-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-index-table ident) + (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* default-index ... */ +;*---------------------------------------------------------------------*/ +(define (default-index) + (if (not (*index-table*)) + (*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 (lambda (t) + (hash-map->list + (lambda (key val) val) t)) + indexes))) + (sorted (map sort-entries-bucket + (merge-buckets + (sort entries + (lambda (e1 e2) + (string-cistring (gensym s)) :text s)) + (h (new handle (loc loc) (ast m))) + (r (ref :handle h :text s))) + (ast-loc-set! m loc) + (ast-loc-set! r loc) + (loop next-refs + (cons r lrefs) + (append lr (cons m body))))))))))) + + +;;; index.scm ends here diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm new file mode 100644 index 0000000..21b2a4d --- /dev/null +++ b/src/guile/skribilo/lib.scm @@ -0,0 +1,239 @@ +;;; +;;; lib.scm -- Utilities +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo lib) + :use-module (skribilo utils syntax) + :export (skribe-eval-location skribe-ast-error skribe-error + skribe-type-error + skribe-warning skribe-warning/ast + skribe-message + + type-name %procedure-arity) + + :export-syntax (new define-markup define-simple-markup + define-simple-container define-processor-markup) + + :use-module (skribilo config) + :use-module (skribilo ast) + + ;; useful for `new' to work well with + :autoload (skribilo source) () + + :use-module (skribilo reader) + :use-module (skribilo parameters) + :use-module (skribilo location) + + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (ice-9 optargs)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; NEW +;;; + +(define %types-module (current-module)) + +(define-macro (new class . parameters) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo ast)' 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 +;;; +(define-macro (define-markup bindings . body) + ;; This is just an `(ice-9 optargs)' kind of `lambda*', with DSSSL + ;; keyword-style conversion enabled. However, using `(ice-9 optargs)', the + ;; `#:rest' argument can only appear last, which is not what Skribe/DSSSL + ;; expect, hence `fix-rest-arg'. + (define (fix-rest-arg args) + (let loop ((args args) + (result '()) + (rest-arg #f)) + (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))) + `(define*-public ,(cons name (fix-rest-arg opts)) ,@body))) + + +;;; +;;; DEFINE-SIMPLE-MARKUP +;;; +(define-macro (define-simple-markup markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string + (gensym ',(symbol->string 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 ',(symbol->string 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))))) + + + +;;; +;;; TYPE-NAME +;;; +(define (type-name obj) + (cond ((string? obj) "string") + ((ast? obj) "ast") + ((list? obj) "list") + ((pair? obj) "pair") + ((number? obj) "number") + ((char? obj) "character") + ((keyword? obj) "keyword") + (else (with-output-to-string + (lambda () (write obj)))))) + +;;; +;;; 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 (format #f "~a:~a: ~a: ~a ~s" (location-file l) + (location-line l) proc msg shape)) + (error (format #f "~a: ~a ~s " proc msg shape))))) + +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error (format #f "~a: ~a ~s" 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)) + + +;;; +;;; SKRIBE-WARNING & SKRIBE-WARNING/AST +;;; +(define (%skribe-warn level file line lst) + (let ((port (current-error-port))) + (if (or (not file) (not line)) + (begin + ;; XXX: This is a bit hackish, but it proves to be quite useful. + (set! file (port-filename (current-input-port))) + (set! line (port-line (current-input-port))))) + (when (and file line) + (format port "~a:~a: " file line)) + (format port "warning: ") + (for-each (lambda (x) (format port "~a " x)) lst) + (newline port))) + + +(define (skribe-warning level . obj) + (if (>= (*warning*) level) + (%skribe-warn level #f #f obj))) + + +(define (skribe-warning/ast level ast . obj) + (if (>= (*warning*) level) + (let ((l (ast-loc ast))) + (if (location? l) + (%skribe-warn level (location-file l) (location-line l) obj) + (%skribe-warn level #f #f obj))))) + +;;; +;;; SKRIBE-MESSAGE +;;; +(define (skribe-message fmt . obj) + (when (> (*verbose*) 0) + (apply format (current-error-port) fmt obj))) + + +;;; +;;; %PROCEDURE-ARITY +;;; +(define (%procedure-arity proc) + (car (procedure-property proc 'arity))) + +;;; lib.scm ends here diff --git a/src/guile/skribilo/location.scm b/src/guile/skribilo/location.scm new file mode 100644 index 0000000..7c870fa --- /dev/null +++ b/src/guile/skribilo/location.scm @@ -0,0 +1,69 @@ +;;; location.scm -- Skribilo source location. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo location) + :use-module (oop goops) + :use-module ((skribilo utils syntax) :select (%skribilo-module-reader)) + :export ( location? ast-location + location-file location-line location-pos)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; An abstract data type to keep track of source locations. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +(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 #f "~a, line ~a" file line)) + "no source location"))) + + +;;; arch-tag: d68fa45d-a200-465e-a3c2-eb2861907f83 + +;;; location.scm ends here. diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm new file mode 100644 index 0000000..ac8eee0 --- /dev/null +++ b/src/guile/skribilo/module.scm @@ -0,0 +1,153 @@ +;;; module.scm -- Integration of Skribe code as Guile modules. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo module) + :autoload (skribilo reader) (make-reader) + :use-module (skribilo debug) + :use-module (srfi srfi-1) + :use-module (ice-9 optargs) + :use-module (srfi srfi-39) + :use-module (skribilo utils syntax) + :export (make-run-time-module *skribilo-user-module*)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This (fake) module defines a macro called `define-skribe-module' which +;;; allows to package Skribe code (which uses Skribe built-ins and most +;;; importantly a Skribe syntax) as a Guile module. This module +;;; automatically exports the macro as a core binding so that future +;;; `use-modules' referring to Skribe modules will work as expected. +;;; +;;; Code: + +(define %skribilo-user-imports + ;; List of modules that should be imported by any good Skribilo module. + '((srfi srfi-1) ;; lists + (srfi srfi-13) ;; strings + (ice-9 optargs) ;; `define*' + + (skribilo package base) ;; the core markups + (skribilo utils syntax) ;; `unless', `when', etc. + (skribilo utils compat) ;; `skribe-load-path', etc. + (skribilo utils keywords) ;; `the-body', `the-options' + (skribilo utils strings) ;; `make-string-replace', etc. + (skribilo module) + (skribilo ast) ;; `', `document?', etc. + (skribilo config) + (skribilo biblio) + (skribilo lib) ;; `define-markup', `unwind-protect', etc. + (skribilo resolve) + (skribilo engine) + (skribilo writer) + (skribilo output) + (skribilo evaluator) + (skribilo debug) + (skribilo location) + )) + +(define %skribilo-user-autoloads + ;; List of auxiliary modules that may be lazily autoloaded. + '(((skribilo engine lout) . (!lout + lout-illustration + ;; FIXME: The following should eventually be + ;; removed from here. + lout-structure-number-string)) + ((skribilo engine latex) . (!latex LaTeX TeX)) + ((skribilo engine html) . (html-markup-class html-class + html-width)) + ((skribilo utils images) . (convert-image)) + ((skribilo index) . (index? make-index-table default-index + resolve-the-index)) + ((skribilo source) . (source-read-lines source-fontify + language? language-extractor + language-fontifier source-fontify)) + ((skribilo coloring lisp) . (skribe scheme lisp)) + ((skribilo coloring xml) . (xml)) + ((skribilo prog) . (make-prog-body resolve-line)) + ((skribilo color) . + (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) + ((skribilo sui) . (load-sui)) + + ((ice-9 and-let-star) . (and-let*)) + ((ice-9 receive) . (receive)))) + + + +;; The very macro to turn a legacy Skribe file (which uses Skribe's syntax) +;; into a Guile module. + +(define-macro (define-skribe-module name . options) + `(begin + (define-module ,name + :use-module ((skribilo reader) :select (%default-reader)) + :use-module (srfi srfi-1) + ,@(append-map (lambda (mod) + (list :autoload (car mod) (cdr mod))) + %skribilo-user-autoloads) + ,@options) + + ;; Pull all the bindings that Skribe code may expect, plus those needed + ;; to actually create and read the module. + ;; TODO: These should be auto-loaded. + ,(cons 'use-modules %skribilo-user-imports) + + ;; Change the current reader to a Skribe-compatible reader. If this + ;; primitive is not provided by Guile (i.e., version <= 1.7.2), then it + ;; should be provided by `guile-reader' (version >= 0.3) as a core + ;; binding and installed by `(skribilo utils syntax)'. + (fluid-set! current-reader %default-reader))) + + +;; Make it available to the top-level module. +(module-define! the-root-module + 'define-skribe-module define-skribe-module) + + + + +;;; +;;; MAKE-RUN-TIME-MODULE +;;; +(define (make-run-time-module) + "Return a new module that imports all the necessary bindings required for +execution of Skribilo/Skribe code." + (let* ((the-module (make-module)) + (autoloads (map (lambda (name+bindings) + (make-autoload-interface the-module + (car name+bindings) + (cdr name+bindings))) + %skribilo-user-autoloads))) + (set-module-name! the-module '(skribilo-user)) + (module-use-interfaces! the-module + (cons the-root-module + (append (map resolve-interface + %skribilo-user-imports) + autoloads))) + the-module)) + +;; The current module in which the document is evaluated. +(define *skribilo-user-module* (make-parameter (make-run-time-module))) + + +;;; module.scm ends here diff --git a/src/guile/skribilo/output.scm b/src/guile/skribilo/output.scm new file mode 100644 index 0000000..a33c040 --- /dev/null +++ b/src/guile/skribilo/output.scm @@ -0,0 +1,228 @@ +;;; output.scm -- Skribilo output stage. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo output) + :autoload (skribilo engine) (engine-ident processor-get-engine) + :autoload (skribilo writer) (writer? writer-ident lookup-markup-writer) + :autoload (skribilo location) (location?) + :use-module (skribilo ast) + :use-module (skribilo debug) + :use-module (skribilo utils syntax) + :use-module (oop goops) + + :use-module (skribilo condition) + :use-module (srfi srfi-35) + :use-module (srfi srfi-34) + :use-module (srfi srfi-39) + + :export (output + *document-being-output* + &output-error &output-unresolved-error &output-writer-error + output-error? output-unresolved-error? output-writer-error?)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Error conditions. +;;; + +(define-condition-type &output-error &skribilo-error + output-error?) + +(define-condition-type &output-unresolved-error &output-error + output-unresolved-error? + (ast output-unresolved-error:ast)) + +(define-condition-type &output-writer-error &output-error + output-writer-error? + (writer output-writer-error:writer)) + + +(define (handle-output-error c) + ;; Issue a user-friendly error message for error condition C. + (cond ((output-unresolved-error? c) + (let* ((node (output-unresolved-error:ast c)) + (location (and (ast? node) (ast-loc node)))) + (format (current-error-port) "unresolved node: ~a~a~%" + node + (if (location? location) + (string-append " " + (location-file location) ":" + (location-line location)) + "")))) + ((output-writer-error? c) + (format (current-error-port) "invalid writer: ~a~%" + (output-writer-error:writer c))) + (else + (format (current-error-port) "undefined output error: ~a~%" + c)))) + +(register-error-condition-handler! output-error? + handle-output-error) + + + +;;; +;;; Output method. +;;; + +;; The document being output. Note: This is only meant to be used by the +;; compatibility layer in order to implement things like `find-markups'! +(define *document-being-output* (make-parameter #f)) + +(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)) + (raise (condition (&output-writer-error (writer writer))))) + (else + (raise (condition (&output-writer-error (writer writer))))))))) + + + +;;; +;;; OUT implementations +;;; +(define-method (out node e) + #f) + +(define-method (out (node ) e) + ;; Only needed by the compatibility layer. + (parameterize ((*document-being-output* node)) + (next-method))) + +(define-method (out (node ) e) + (let loop ((n* node)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (raise (condition (&invalid-argument-error + (proc-name output) + (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) + (raise (condition (&too-few-arguments-error + (proc-name "output") + (arguments 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 + (raise (condition (&too-few-arguments-error + (proc-name "output") + (arguments 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) + (raise (condition (&output-unresolved-error (ast n))))) + + +(define-method (out (node ) e) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (%out/writer node e w) + (output (slot-ref node 'body) e)))) diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am new file mode 100644 index 0000000..693f088 --- /dev/null +++ b/src/guile/skribilo/package/Makefile.am @@ -0,0 +1,7 @@ +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 \ + eq.scm pie.scm base.scm + +SUBDIRS = slide eq pie diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm new file mode 100644 index 0000000..61eafd5 --- /dev/null +++ b/src/guile/skribilo/package/acmproc.scm @@ -0,0 +1,164 @@ +;;; acmproc.scm -- The Skribe style for ACMPROC articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;*---------------------------------------------------------------------*/ +;* 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/base.scm b/src/guile/skribilo/package/base.scm new file mode 100644 index 0000000..bbb2a62 --- /dev/null +++ b/src/guile/skribilo/package/base.scm @@ -0,0 +1,1410 @@ +;;; base.scm -- The base markup package of Skribe/Skribilo. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package base) + :use-syntax (skribilo lib) + :use-syntax (skribilo reader) + :use-syntax (skribilo utils syntax) + :use-syntax (ice-9 optargs) + + :use-module (skribilo ast) + :use-module (skribilo resolve) + :use-module (skribilo utils keywords) + :autoload (srfi srfi-1) (every any filter) + :autoload (skribilo evaluator) (include-document) + :autoload (skribilo engine) (engine?) + + ;; optional ``sub-packages'' + :autoload (skribilo biblio) (default-bib-table resolve-bib + bib-load! bib-add!) + :autoload (skribilo color) (skribe-use-color!) + :autoload (skribilo source) (language? source-read-lines source-fontify) + :autoload (skribilo prog) (make-prog-body resolve-line) + :autoload (skribilo index) (make-index-table) + + :replace (symbol)) + +(fluid-set! current-reader (make-reader 'skribe)) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; This module contains all the core markups of Skribe/Skribilo. +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `api.scm' file found in the `common' directory. + + + +;*---------------------------------------------------------------------*/ +;* include ... */ +;*---------------------------------------------------------------------*/ +(define-markup (include file) + (if (not (string? file)) + (skribe-error 'include "Illegal file (string expected)" file) + (include-document file))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(define-markup (document #!rest + opts + #!key + (ident #f) (class "document") + (title #f) (html-title #f) (author #f) + (ending #f) (keywords '()) (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 '())))))) + +;*---------------------------------------------------------------------*/ +;* keyword-list->comma-separated ... */ +;*---------------------------------------------------------------------*/ +(define-public (keyword-list->comma-separated kw*) + ;; Turn the the list of keywords (which may be strings or other markups) + ;; KW* into a markup where the elements of KW* are comma-separated. This + ;; may commonly be used in handling the `:keywords' option of `document'. + (let loop ((kw* kw*) (result '())) + (if (null? kw*) + (reverse! result) + (loop (cdr kw*) + (cons* (if (pair? (cdr kw*)) ", " "") + (car kw*) result))))) + +;*---------------------------------------------------------------------*/ +;* 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) + (subsubsection #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) + (:subsubsection ,subsubsection) + ,@(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) + + +;*---------------------------------------------------------------------*/ +;* ~ (unbreakable space) ... */ +;*---------------------------------------------------------------------*/ +(define-markup (~ #!rest opts #!key (class #f)) + (new markup + (markup '~) + (ident (symbol->string (gensym "~"))) + (class class) + (required-options '()) + (options (the-options opts :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* 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 #f "~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) + (result '())) + (cond + ((null? lst) + (reverse! result)) + ((pair? (car lst)) + (loop (car lst) result)) + (else + (let ((r (car lst))) + (if (not (is-markup? r markup)) + (skribe-warning 2 + for + (format #f "illegal `~a' element, `~a' expected" + (if (markup? r) + (markup-markup r) + (type-name r)) + markup))) + (loop (cdr lst) (cons r result))))))))) + +;*---------------------------------------------------------------------*/ +;* 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 #f "frame should be one of \"~a\"" frame-vals) + frame)) + ((and rules (not (memq rules rules-vals))) + (skribe-error 'table + (format #f "rules should be one of \"~a\"" rules-vals) + rules)) + ((not (or (memq cellstyle cells-vals) + (string? cellstyle) + (number? cellstyle))) + (skribe-error 'table + (format #f "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) (rowspan 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) (rowspan 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) (rowspan 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 (let ((a (procedure-property procedure 'arity))) + (and (pair? a) + (let ((compulsory (car a)) + (optional (cadr a)) + (rest? (caddr a))) + (or rest? + (>= (+ compulsory optional) 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-hash-table)) + +;*---------------------------------------------------------------------*/ +;* 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 (symbol->string (gensym bs))) + (class class) + (options (the-options opts :ident :class :text)) + (body text)))) + (hash-set! *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 #f "can't find `~a': " kind))) + (if (ast? ast) + (begin + (skribe-warning/ast 1 ast 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string (gensym "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 (gensym "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 (gensym "handle-ref"))) + (class class) + (required-options '(:text)) + (options `((kind handle) ,@(the-options opts :ident :class))) + (body text))) + (define (do-title-ref title kind) + (if (not (string? title)) + (skribe-type-error 'ref "illegal reference" title "string") + (new unresolved + (proc (lambda (n e env) + (let* ((doc (ast-document n)) + (s (find1-down + (lambda (n) + (and (is-markup? n kind) + (equal? (markup-option n :title) + title))) + doc))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "title-ref"))) + (class class) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,title) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n title (or kind 'title))))))))) + (define (do-ident-ref 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 (gensym "ident-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 (hash-ref *mark-table* mark))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string (gensym "mark-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 (gensym "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)))) ; FIXME: This prevents source location + ; info to be provided in the warning msg + (define (bib-ref text) + (if (pair? text) + (new markup + (markup 'bib-ref+) + (ident (symbol->string (gensym "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 (gensym "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 (gensym "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 (do-ident-ref ident #f)) + (chapter (do-title-ref chapter 'chapter)) + (section (do-title-ref section 'section)) + (subsection (do-title-ref subsection 'subsection)) + (subsubsection (do-title-ref subsubsection 'subsubsection)) + (figure (do-ident-ref 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 "mark")))) + (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) + + (let ((handle (hash-get-handle table ename))) + (if (not handle) + (hash-set! table ename (list new)) + (set-cdr! handle (cons new (cdr handle))))) + + 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)))))))) + + +;;; This part comes from the file `skribe.skr' in the original Skribe +;;; distribution. + +;*---------------------------------------------------------------------*/ +;* 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-public (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define-public (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/eq.scm b/src/guile/skribilo/package/eq.scm new file mode 100644 index 0000000..4f5020e --- /dev/null +++ b/src/guile/skribilo/package/eq.scm @@ -0,0 +1,439 @@ +;;; eq.scm -- An equation formatting package. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package eq) + :autoload (skribilo ast) (markup?) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo module) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :autoload (skribilo package base) (it symbol sub sup) + :autoload (skribilo engine lout) (lout-illustration) + :use-module (ice-9 optargs)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This package defines a set of markups for formatting equations. The user +;;; may either use the standard Scheme prefix notation to represent +;;; equations, or directly use the specific markups (which looks more +;;; verbose). +;;; +;;; FIXME: This is incomplete. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Utilities. +;;; + +(define %operators + '(/ * + - = != ~= < > <= >= sqrt expt sum product script + in notin apply)) + +(define %symbols + ;; A set of symbols that are automatically recognized within an `eq' quoted + ;; list. + '(;; lower-case Greek + alpha beta gamma delta epsilon zeta eta theta iota kappa + lambda mu nu xi omicron pi rho sigma tau upsilon phi chi omega + + ;; upper-case Greek + Alpha Beta Gamma Delta Epsilon Zeta Eta Theta Iota Kappa + Lambda Mu Nu Xi Omicron Pi Rho Sigma Tau Upsilon Phi Chi Omega + + ;; Hebrew + alef + + ;; mathematics + ellipsis weierp image real forall partial exists + emptyset infinity in notin nabla nipropto angle and or cap cup + sim cong approx neq equiv le ge subset supset subseteq supseteq + oplus otimes perp mid lceil rceil lfloor rfloor langle rangle)) + + +(define (make-fast-member-predicate lst) + (let ((h (make-hash-table))) + ;; initialize a hash table equivalent to LST + (for-each (lambda (s) (hashq-set! h s #t)) lst) + + ;; the run-time, fast, definition + (lambda (sym) + (hashq-ref h sym #f)))) + +(define-public known-operator? (make-fast-member-predicate %operators)) +(define-public known-symbol? (make-fast-member-predicate %symbols)) + +(define-public equation-markup-name? + (make-fast-member-predicate (map (lambda (s) + (symbol-append 'eq: s)) + %operators))) + +(define-public (equation-markup? m) + "Return true if @var{m} is an instance of one of the equation sub-markups." + (and (markup? m) + (equation-markup-name? (markup-markup m)))) + +(define-public (equation-markup-name->operator m) + "Given symbol @var{m} (an equation markup name, e.g., @code{eq:+}), return +a symbol representing the mathematical operator denoted by @var{m} (e.g., +@code{+})." + (if (equation-markup-name? m) + (string->symbol (let ((str (symbol->string m))) + (substring str + (+ 1 (string-index str #\:)) + (string-length str)))) + #f)) + + +;;; +;;; Operator precedence. +;;; + +(define %operator-precedence + ;; FIXME: This needs to be augmented. + '((+ . 1) + (- . 1) + (* . 2) + (/ . 2) + (sum . 3) + (product . 3) + (= . 0) + (< . 0) + (> . 0) + (<= . 0) + (>= . 0))) + +(define-public (operator-precedence op) + (let ((p (assq op %operator-precedence))) + (if (pair? p) (cdr p) 0))) + + + +;;; +;;; Turning an S-exp into an `eq' markup. +;;; + +(define %rebindings + (map (lambda (sym) + (list sym (symbol-append 'eq: sym))) + %operators)) + +(define (eq:symbols->strings equation) + "Turn symbols located in non-@code{car} positions into strings." + (cond ((list? equation) + (if (or (null? equation) (null? (cdr equation))) + equation + (cons (car equation) ;; XXX: not tail-recursive + (map eq:symbols->strings (cdr equation))))) + ((symbol? equation) + (if (known-symbol? equation) + `(symbol ,(symbol->string equation)) + (symbol->string equation))) + (else equation))) + +(define-public (eq-evaluate equation) + "Evaluate @var{equation}, an sexp (list) representing an equation, e.g. +@code{'(+ a (/ b 3))}." + (eval `(let ,%rebindings ,(eq:symbols->strings equation)) + (current-module))) + + + +;;; +;;; Markup. +;;; + +(define-markup (eq :rest opts :key (ident #f) (inline? #f) + (renderer #f) (class "eq")) + (new markup + (markup 'eq) + (ident (or ident (symbol->string (gensym "eq")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + result + (loop (cdr body) + (if (markup? (car body)) + (car body) ;; the `eq:*' markups were used + ;; directly + (eq-evaluate (car body))) ;; a quoted list was + ;; passed + )))))) + +(define-simple-markup eq:/) +(define-simple-markup eq:*) +(define-simple-markup eq:+) +(define-simple-markup eq:-) + +(define-simple-markup eq:=) +(define-simple-markup eq:!=) +(define-simple-markup eq:~=) +(define-simple-markup eq:<) +(define-simple-markup eq:>) +(define-simple-markup eq:>=) +(define-simple-markup eq:<=) + +(define-simple-markup eq:sqrt) +(define-simple-markup eq:expt) + +(define-markup (eq:sum :rest opts :key (ident #f) (class "eq:sum") + (from #f) (to #f)) + (new markup + (markup 'eq:sum) + (ident (or ident (symbol->string (gensym "eq:sum")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:product :rest opts :key (ident #f) (class "eq:product") + (from #f) (to #f)) + (new markup + (markup 'eq:product) + (ident (or ident (symbol->string (gensym "eq:product")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (eq:script :rest opts :key (ident #f) (class "eq:script") + (sub #f) (sup #f)) + (new markup + (markup 'eq:script) + (ident (or ident (symbol->string (gensym "eq:script")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-simple-markup eq:in) +(define-simple-markup eq:notin) + +(define-markup (eq:apply :rest opts :key (ident #f) (class "eq:apply")) + ;; This markup may receive either a list of arguments or arguments + ;; compatible with the real `apply'. Note: the real `apply' can take N + ;; non-list arguments but the last one has to be a list. + (new markup + (markup 'eq:apply) + (ident (or ident (symbol->string (gensym "eq:apply")))) + (options (the-options opts)) + (body (let loop ((body (the-body opts)) + (result '())) + (if (null? body) + (reverse! result) + (let ((first (car body))) + (if (list? first) + (if (null? (cdr body)) + (append (reverse! result) first) + (skribe-error 'eq:apply + "wrong argument type" + body)) + (loop (cdr body) (cons first result))))))))) + + + +;;; +;;; Text-based rendering. +;;; + + +(markup-writer 'eq (find-engine 'base) + :action (lambda (node engine) + ;; The `:renderer' option should be a symbol (naming an engine + ;; class) or an engine or engine class. This allows the use of + ;; another engine to render equations. For instance, equations + ;; may be rendered using the Lout engine within an HTML + ;; document. + (let ((renderer (markup-option node :renderer))) + (cond ((not renderer) ;; default: use the current engine + (output (it (markup-body node)) engine)) + ((symbol? renderer) + (case renderer + ;; FIXME: We should have an `embed' slot for each + ;; engine class similar to `lout-illustration'. + ((lout) + (let ((lout-code + (with-output-to-string + (lambda () + (output node (find-engine 'lout)))))) + (output (lout-illustration + :ident (markup-ident node) + lout-code) + engine))) + (else + (skribe-error 'eq "invalid renderer" renderer)))) + ;; FIXME: `engine?' and `engine-class?' + (else + (skribe-error 'eq "`:renderer' -- wrong argument type" + renderer)))))) + +(define-macro (simple-markup-writer op . obj) + ;; Note: The text-only rendering is less ambiguous if we parenthesize + ;; without taking operator precedence into account. + (let ((precedence (operator-precedence op))) + `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((o (car operands)) + (nested-eq? (equation-markup? o)) + (need-paren? + (and nested-eq? +; (< (operator-precedence +; (equation-markup-name->operator +; (markup-markup o))) +; ,precedence) + ) + )) + + (display (if need-paren? "(" "")) + (output o engine) + (display (if need-paren? ")" "")) + (if (pair? (cdr operands)) + (begin + (display " ") + (output ,(if (null? obj) + (symbol->string op) + (car obj)) + engine) + (display " "))) + (loop (cdr operands))))))))) + +(simple-markup-writer +) +(simple-markup-writer -) +(simple-markup-writer /) +(simple-markup-writer * (symbol "times")) + +(simple-markup-writer =) +(simple-markup-writer != (symbol "neq")) +(simple-markup-writer ~= (symbol "approx")) +(simple-markup-writer <) +(simple-markup-writer >) +(simple-markup-writer >= (symbol "ge")) +(simple-markup-writer <= (symbol "le")) + +(markup-writer 'eq:sqrt (find-engine 'base) + :action (lambda (node engine) + (display "sqrt(") + (output (markup-body node) engine) + (display ")"))) + +(define-macro (simple-binary-markup-writer op obj) + `(markup-writer ',(symbol-append 'eq: op) (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let ((first (car body)) + (second (cadr body))) + (display (if (equation-markup? first) "(" " ")) + (output first engine) + (display (if (equation-markup? first) ")" " ")) + (output ,obj engine) + (display (if (equation-markup? second) "(" "")) + (output second engine) + (display (if (equation-markup? second) ")" ""))) + (skribe-error ',(symbol-append 'eq: op) + "wrong argument type" + body)))))) + +(markup-writer 'eq:expt (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let ((first (car body)) + (second (cadr body))) + (display (if (equation-markup? first) "(" "")) + (output first engine) + (display (if (equation-markup? first) ")" "")) + (output (sup second) engine)))))) + +(simple-binary-markup-writer in (symbol "in")) +(simple-binary-markup-writer notin (symbol "notin")) + +(markup-writer 'eq:apply (find-engine 'base) + :action (lambda (node engine) + (let ((func (car (markup-body node)))) + (output func engine) + (display "(") + (let loop ((operands (cdr (markup-body node)))) + (if (null? operands) + #t + (begin + (output (car operands) engine) + (if (not (null? (cdr operands))) + (display ", ")) + (loop (cdr operands))))) + (display ")")))) + +(markup-writer 'eq:sum (find-engine 'base) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to))) + (output (symbol "Sigma") engine) + (display "(") + (output from engine) + (display ", ") + (output to engine) + (display ", ") + (output (markup-body node) engine) + (display ")")))) + +(markup-writer 'eq:prod (find-engine 'base) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to))) + (output (symbol "Pi") engine) + (display "(") + (output from engine) + (display ", ") + (output to engine) + (display ", ") + (output (markup-body node) engine) + (display ")")))) + +(markup-writer 'eq:script (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node)) + (sup* (markup-option node :sup)) + (sub* (markup-option node :sub))) + (output body engine) + (output (sup sup*) engine) + (output (sub sub*) engine)))) + + + + +;;; +;;; Initialization. +;;; + +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package eq lout)))) + + +;;; arch-tag: 58764650-2684-47a6-8cc7-6288f2b474da + +;;; eq.scm ends here diff --git a/src/guile/skribilo/package/eq/Makefile.am b/src/guile/skribilo/package/eq/Makefile.am new file mode 100644 index 0000000..c7b4f93 --- /dev/null +++ b/src/guile/skribilo/package/eq/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/eq +dist_guilemodule_DATA = lout.scm + +## arch-tag: 3e816c9a-7989-4baa-b38b-a095a5428ba1 diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm new file mode 100644 index 0000000..c487b85 --- /dev/null +++ b/src/guile/skribilo/package/eq/lout.scm @@ -0,0 +1,217 @@ +;;; lout.scm -- Lout implementation of the `eq' package. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package eq lout) + :use-module (skribilo package eq) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :use-module (ice-9 optargs)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Initialization. +;;; + +(let ((lout (find-engine 'lout))) + (if (not lout) + (skribe-error 'eq "Lout engine not found" lout) + (let ((includes (engine-custom lout 'includes))) + ;; Append the `eq' include file + (engine-custom-set! lout 'includes + (string-append includes "\n" + "@SysInclude { eq }\n"))))) + + +;;; +;;; Simple markup writers. +;;; + + +(markup-writer 'eq (find-engine 'lout) + :options '(:inline?) + :before "{ " + :action (lambda (node engine) + (display (if (markup-option node :inline?) + "@E { " + "@Eq { ")) + (let ((eq (markup-body node))) + ;;(fprint (current-error-port) "eq=" eq) + (output eq engine))) + :after " } }") + + + +(define-macro (simple-lout-markup-writer sym . args) + (let* ((lout-name (if (null? args) + (symbol->string sym) + (car args))) + (parentheses? (if (or (null? args) (null? (cdr args))) + #t + (cadr args))) + (precedence (operator-precedence sym)) + + ;; Note: We could use `pmatrix' here but it precludes line-breaking + ;; within equations. + (open-par `(if need-paren? "{ @VScale ( }" "")) + (close-par `(if need-paren? "{ @VScale ) }" ""))) + + `(markup-writer ',(symbol-append 'eq: sym) + (find-engine 'lout) + :action (lambda (node engine) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (< (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column + (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " + ,(if parentheses? + open-par + ""))) + (output op engine) + (display (string-append ,(if parentheses? + close-par + "") + " }")) + (if (pair? (cdr operands)) + (display ,(string-append " " + lout-name + " "))) + (loop (cdr operands))))))))) + + +;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their +;; operands do not need to be enclosed in parentheses. OTOH, since we use a +;; horizontal bar of `/', we don't need to parenthesize its arguments. + + +(simple-lout-markup-writer +) +(simple-lout-markup-writer * "times") +(simple-lout-markup-writer - "-") +(simple-lout-markup-writer / "over" #f) +(simple-lout-markup-writer =) +(simple-lout-markup-writer <) +(simple-lout-markup-writer >) +(simple-lout-markup-writer <=) +(simple-lout-markup-writer >=) + +(define-macro (binary-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node))) + (if (= (length body) 2) + (let* ((first (car body)) + (second (cadr body)) + (parentheses? (equation-markup? first))) + (display " { { ") + (if parentheses? (display "(")) + (output first engine) + (if parentheses? (display ")")) + (display ,(string-append " } " lout-name " { ")) + (output second engine) + (display " } } ")) + (skribe-error ,(symbol-append 'eq: sym) + "wrong number of arguments" + body)))))) + +(binary-lout-markup-writer expt "sup") +(binary-lout-markup-writer in "element") +(binary-lout-markup-writer notin "notelement") + +(markup-writer 'eq:apply (find-engine 'lout) + :action (lambda (node engine) + (let ((func (car (markup-body node)))) + (output func engine) + (display "(") + (let loop ((operands (cdr (markup-body node)))) + (if (null? operands) + #t + (begin + (output (car operands) engine) + (if (not (null? (cdr operands))) + (display ", ")) + (loop (cdr operands))))) + (display ")")))) + + + +;;; +;;; Sums, products, integrals, etc. +;;; + +(define-macro (range-lout-markup-writer sym lout-name) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let ((from (markup-option node :from)) + (to (markup-option node :to)) + (body (markup-body node))) + (display ,(string-append " { big " lout-name + " from { ")) + (output from engine) + (display " } to { ") + (output to engine) + (display " } { ") + (output body engine) + (display " } } "))))) + +(range-lout-markup-writer sum "sum") +(range-lout-markup-writer product "prod") + +(markup-writer 'eq:script (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node)) + (sup (markup-option node :sup)) + (sub (markup-option node :sub))) + (display " { { ") + (output body engine) + (display " } ") + (if sup + (begin + (display (if sub " supp { " " sup { ")) + (output sup engine) + (display " } "))) + (if sub + (begin + (display " on { ") + (output sub engine) + (display " } "))) + (display " } ")))) + + +;;; arch-tag: 2a1410e5-977e-4600-b781-3d57f4409b35 diff --git a/src/guile/skribilo/package/french.scm b/src/guile/skribilo/package/french.scm new file mode 100644 index 0000000..a23d1da --- /dev/null +++ b/src/guile/skribilo/package/french.scm @@ -0,0 +1,30 @@ +;;; french.scm -- French Skribe style +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..913b3e3 --- /dev/null +++ b/src/guile/skribilo/package/jfp.scm @@ -0,0 +1,328 @@ +;;; jfp.scm -- The Skribe style for JFP articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..91d45be --- /dev/null +++ b/src/guile/skribilo/package/letter.scm @@ -0,0 +1,157 @@ +;;; letter.scm -- Skribe style for letters +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..8ffa7da --- /dev/null +++ b/src/guile/skribilo/package/lncs.scm @@ -0,0 +1,158 @@ +;;; lncs.scm -- The Skribe style for LNCS articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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/pie.scm b/src/guile/skribilo/package/pie.scm new file mode 100644 index 0000000..8ccf858 --- /dev/null +++ b/src/guile/skribilo/package/pie.scm @@ -0,0 +1,314 @@ +;;; pie.scm -- An pie-chart formatting package. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package pie) + :autoload (skribilo ast) (markup? markup-ident ast-parent) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) ;; `skribe-error' et al. + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :use-module (skribilo utils strings) ;; `make-string-replace' + :use-module (skribilo module) + :autoload (skribilo color) (skribe-color->rgb) + :autoload (skribilo package base) (bold) + :autoload (skribilo engine lout) (lout-illustration) + :autoload (ice-9 popen) (open-output-pipe) + :use-module (ice-9 optargs) + :export (%ploticus-program %ploticus-debug? + pie-sliceweight-value pie-remove-markup)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Markup. +;;; + +(define-markup (pie :rest opts + :key (ident #f) (title "Pie Chart") + (initial-angle 0) (total #f) (radius 3) + (fingers? #t) (labels 'outside) + (class "pie")) + (new container + (markup 'pie) + (ident (or ident (symbol->string (gensym "pie")))) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (slice :rest opts + :key (ident #f) (weight 1) (color "white") (detach? #f)) + (new container + (markup 'slice) + (ident (or ident (symbol->string (gensym "slice")))) + (weight weight) + (color color) + (detach? detach?) + (options (the-options opts)) + (body (the-body opts)))) + +(define-markup (sliceweight :rest opts + :key (ident #f) (percentage? #f)) + (new markup + (markup 'sliceweight) + (ident (or ident (symbol->string (gensym "sliceweight")))) + (percentage? percentage?) + (options (the-options opts)) + (body '()))) + + + +;;; +;;; Helper functions. +;;; + +(define (make-rounder pow10) + ;; Return a procedure that round to 10 to the -POW10. + (let ((times (expt 10.0 pow10))) + (lambda (x) + (/ (round (* x times)) times)))) + +(define (pie-sliceweight-value sw-node pct?) + "Return the value that should be displayed by `sw-node', a + `sliceweight' markup node. If `pct?' is true, then this value + should be a percentage." + (let* ((the-slice (ast-parent sw-node)) + (weight (and the-slice (markup-option the-slice :weight)))) + (if (not the-slice) + (skribe-error 'lout + "`sliceweight' node not within a `slice' body" + sw-node) + (if pct? + (let* ((the-pie (ast-parent the-slice)) + (total (and the-pie + (markup-option the-pie + '&total-weight)))) + (if (not the-pie) + (skribe-error 'lout + "`slice' not within a `pie' body" + the-slice) + (* 100.0 (/ weight total)))) ;; flonum (FIXME: precision) + + weight)))) + +(define (pie-remove-markup node) + "Remove markup from `node', ie. turn something like `(it \"hello\")' into +the string \"hello\". Implement `sliceweight' markups too." + (define percentage-round (make-rounder 2)) + + (if (markup? node) + (if (and node (is-markup? node 'sliceweight)) + (let* ((pct? (markup-option node :percentage?)) + (value (pie-sliceweight-value node pct?))) + (number->string (percentage-round value))) + (pie-remove-markup (markup-body node))) + (if (list? node) + (apply string-append (map pie-remove-markup node)) + node))) + +(define strip-newlines (make-string-replace '((#\newline " ")))) + +(define (select-output-format engine) + ;; Choose an ouptut format suitable for ENGINE. + (define %supported-formats '("png" "ps" "eps" "svg" "svgz")) + (define %default-format "png") + + (let ((fmt (engine-custom engine 'image-format))) + (cond ((string? fmt) fmt) + ((and (list? fmt) (not (null? fmt))) + (let ((f (car fmt))) + (if (member f %supported-formats) + f + %default-format))) + (else %default-format)))) + + +;;; +;;; Default implementation (`base' engine). +;;; + +;; Ploticus-based implementation of pie charts, suitable for most engines. +;; See http://ploticus.sf.net for info about Ploticus. + +(define %ploticus-program "ploticus") +(define %ploticus-debug? #f) + +(define (color-spec->ploticus color-spec) + (define round (make-rounder 2)) + + (call-with-values (lambda () (skribe-color->rgb color-spec)) + (lambda (r g b) + (format #f "rgb(~a,~a,~a)" + (round (/ r 255.0)) + (round (/ g 255.0)) + (round (/ b 255.0)))))) + +(define (ploticus-script pie) + (let* ((weights (map (lambda (slice) + (markup-option slice :weight)) + (markup-body pie))) + (colors (map (lambda (slice) + (let ((c (markup-option slice :color))) + (string-append (color-spec->ploticus c) + " "))) + (markup-body pie))) + (total-weight (or (if (number? (markup-option pie + :total)) + (markup-option pie :total) + #f) + (apply + weights))) + + ;; Attach useful information to the pie and its slices + (-/- (markup-option-add! pie '&total-weight total-weight)) + + ;; One slice label per line -- so we need to remove + ;; newlines from labels. + (labels (map (lambda (b) + (strip-newlines (pie-remove-markup b))) + (markup-body pie))) + +; (flat-title (map pie-remove-markup +; (markup-option pie :title))) + (detached (map (lambda (slice) + (let ((d (markup-option slice + :detach?))) + (cond ((number? d) d) + (d 0.5) ;; default + (#t 0)))) + (markup-body pie))) + + (initial-angle (or (markup-option pie :initial-angle) + 0)) + (radius (or ;;FIXME + (markup-option pie :radius) 3)) + (max-radius (+ radius (apply max detached))) + + ;; center coordinates must take into account (i) the + ;; maxium radius when detached slices are considered and + ;; (ii) the fact that labels may get displayed to the + ;; left of the pie. + ;; FIXME: labels to the left (ii) end up being truncated + ;; when the radius is e.g. < 2. + (center `(,(+ max-radius + (* max-radius max-radius)) . + ,(* max-radius max-radius)))) + + (apply string-append + (append (list "#proc getdata\n" "data: ") + (map (lambda (weight) + (string-append (number->string weight) + "\n")) + weights) + `("\n" +; "#proc page\n" +; "title " ,@flat-title +; "\n" + "#proc pie\n" + "total: " + ,(number->string total-weight) + "\n" + "datafield: " "1" "\n") + `("firstslice: " ,(number->string initial-angle) "\n") + `("radius: " ,(number->string radius) "\n") + `("center: " ,(number->string (car center)) + " " ,(number->string (cdr center)) "\n") + `("labelmode: " + ,(case (markup-option + pie :labels) + ((outside) "line+label") + ((inside) "labelonly") + ((legend) "legend") + (else "legend")) + "\n" + "labels: " ,@(map (lambda (label) + (string-append label "\n")) + labels) + "\n") + `("explode: " + ,@(map (lambda (number) + (string-append (number->string number) + " ")) + detached) + "\n") + `("colors: " ,@colors "\n"))))) + +(markup-writer 'pie (find-engine 'base) + :action (lambda (node engine) + (let* ((fmt (select-output-format engine)) + (pie-file (string-append (markup-ident node) "." + fmt)) + (port (open-output-pipe + (string-append %ploticus-program + " -o " pie-file + " -cm -" fmt " -stdin"))) + (script (ploticus-script node))) + + + (if %ploticus-debug? + (format (current-error-port) "** Ploticus script: ~a" + script)) + + (display script port) + + (let ((exit-val (status:exit-val (close-pipe port)))) + (if (not (eqv? 0 exit-val)) + (skribe-error 'pie/ploticus + "ploticus exited with error code" + exit-val))) + + (if (not (file-exists? pie-file)) + (skribe-error 'ploticus + "Ploticus did not create the image file" + script)) + + (if (markup-option node :title) + (output (list (bold (markup-option node :title)) + (linebreak)) + engine)) + + (output (image :file pie-file + :class (markup-option node :class) + (or (markup-option node :title) + "A Pie Chart")) + engine)))) + +(markup-writer 'slice (find-engine 'base) + :action (lambda (node engine) + ;; Nothing to do here + (error "slice: this writer should never be invoked"))) + +(markup-writer 'sliceweight (find-engine 'base) + :action (lambda (node engine) + ;; Nothing to do here. + (error "sliceweight: this writer should never be invoked"))) + + +;;; +;;; Initialization. +;;; + +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package pie lout)))) + + +;;; arch-tag: 8095d8f6-b810-4619-9fdb-23fb94a77ee3 diff --git a/src/guile/skribilo/package/pie/Makefile.am b/src/guile/skribilo/package/pie/Makefile.am new file mode 100644 index 0000000..3b4fafd --- /dev/null +++ b/src/guile/skribilo/package/pie/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/pie +dist_guilemodule_DATA = lout.scm + +## arch-tag: e6a03451-14c9-4331-8b96-71bde92ac142 diff --git a/src/guile/skribilo/package/pie/lout.scm b/src/guile/skribilo/package/pie/lout.scm new file mode 100644 index 0000000..61dbcb7 --- /dev/null +++ b/src/guile/skribilo/package/pie/lout.scm @@ -0,0 +1,132 @@ +;;; lout.scm -- Lout implementation of the `pie' package. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package pie lout) + :use-module (skribilo package pie) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo utils keywords) ;; `the-options', etc. + :autoload (skribilo engine lout) (lout-color-specification) + :use-module (ice-9 optargs)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Helper functions. +;;; + +(let ((lout (find-engine 'lout))) + (if lout + (engine-custom-set! lout 'includes + (string-append (engine-custom lout 'includes) + "\n@SysInclude { pie } # Pie Charts\n")))) + + + +;;; +;;; Writers. +;;; + +(markup-writer 'pie (find-engine 'lout) + :before (lambda (node engine) + (let* ((weights (map (lambda (slice) + (markup-option slice :weight)) + (markup-body node))) + (total-weight (or (if (number? (markup-option node + :total)) + (markup-option node :total) + #f) + (apply + weights)))) + + (if (= 0 total-weight) + (skribe-error 'lout + "Slices weight sum should not be zero" + total-weight)) + + ;; Attach useful information to the pie and its slices + (markup-option-add! node '&total-weight total-weight) + + (display "\n@Pie\n") + (display " abovecaption { ") + (if (markup-option node :title) + (output (markup-option node :title) engine)) + (display " }\n") + (format #t " totalweight { ~a }\n" total-weight) + (format #t " initialangle { ~a }\n" + (or (markup-option node :initial-angle) 0)) + (format #t " finger { ~a }\n" + (case (markup-option node :labels) + ((outside) (if (markup-option node :fingers?) + "yes" "no")) + (else "no"))) + + ;; We assume `:radius' to be centimeters + (if (markup-option node :radius) + (format #t " radius { ~ac }\n" + (markup-option node :radius))) + + (format #t " labelradius { ~a }\n" + (case (markup-option node :labels) + ((outside #f) "external") ; FIXME: options are + ; not availble within + ; :before? (hence the #f) + + ((inside) "internal") + (else + (skribe-error 'lout + "`:labels' should be one of 'inside or 'outside." + (markup-option node :labels))))) + (display "{\n"))) + :after "\n} # @Pie\n") + +(markup-writer 'slice (find-engine 'lout) + :options '(:weight :detach? :color) + :action (lambda (node engine) + (display " @Slice\n") + (format #t " detach { ~a }\n" + (if (markup-option node :detach?) + "yes" + "no")) + (format #t " paint { ~a }\n" + (lout-color-specification (markup-option node + :color))) + (format #t " weight { ~a }\n" + (markup-option node :weight)) + + (display " label { ") + (output (markup-body node) engine) + (display " }\n"))) + +(markup-writer 'sliceweight (find-engine 'base) + ;; This writer should work for every engine, provided the `pie' markup has + ;; a proper `&total-weight' option. + :action (lambda (node engine) + (let ((pct? (markup-option node :percentage?))) + (output (number->string + (pie-sliceweight-value node pct?)) + engine)))) + +;;; arch-tag: b5221e30-f80e-4b72-a281-83ce19ddb755 diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm new file mode 100644 index 0000000..902cdb5 --- /dev/null +++ b/src/guile/skribilo/package/scribe.scm @@ -0,0 +1,240 @@ +;;; scribe.scm -- Scribe Compatibility kit +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..28d4e83 --- /dev/null +++ b/src/guile/skribilo/package/sigplan.scm @@ -0,0 +1,166 @@ +;;; sigplan.scm -- The Skribe style for ACMPROC articles. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..86969aa --- /dev/null +++ b/src/guile/skribilo/package/skribe.scm @@ -0,0 +1,85 @@ +;;; skribe.scm -- The standard Skribe style (always loaded). +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +;*---------------------------------------------------------------------*/ +;* 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..7f731e3 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,274 @@ +;;; slide.scm -- Overhead transparencies. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-skribe-module (skribilo package slide)) + + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define-public &slide-load-options (skribe-load-options)) + + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) + +;*---------------------------------------------------------------------*/ +;* 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)) + (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) + +;; Extend the definition of `ref'. +;; FIXME: This technique breaks `ref' for some reason. +; (set! ref +; (lambda args +; ;; Filter out ARGS and look for a `:slide' keyword argument. +; (let loop ((slide #f) +; (opt '()) +; (args args)) +; (if (null? args) +; (set! opt (reverse! opt)) +; (let ((s? (eq? (car args) :slide))) +; (loop (if s? (cadr args) #f) +; (if s? opt (cons (car args) opt)) +; (if s? (cddr args) (cdr args))))) + +; (format (current-error-port) +; "slide.scm:ref: slide=~a opt=~a~%" slide opt) + +; (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)))) + + + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define-public (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* slide-topic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-topic #!rest opt + #!key title (outline? #t) + (ident #f) (class "slide-topic")) + (new container + (markup 'slide-topic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-topic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-subtopic ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-subtopic #!rest opt + #!key title (outline? #f) + (ident #f) (class "slide-subtopic")) + (new container + (markup 'slide-subtopic) + (required-options '(:title :outline?)) + (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (options `((:outline? ,outline?) + ,@(the-options opt :outline?))) + (body (the-body opt)))) + + + +;;; +;;; Initialization. +;;; + +(format (current-error-port) "Slides initializing...~%") + +;; Register specific implementations for lazy loading. +(when-engine-is-loaded 'base + (lambda () + (resolve-module '(skribilo package slide base)))) +(when-engine-is-loaded 'latex + (lambda () + (resolve-module '(skribilo package slide latex)))) +(when-engine-is-loaded 'html + (lambda () + (resolve-module '(skribilo package slide html)))) +(when-engine-is-loaded 'lout + (lambda () + (resolve-module '(skribilo package slide lout)))) + diff --git a/src/guile/skribilo/package/slide/Makefile.am b/src/guile/skribilo/package/slide/Makefile.am new file mode 100644 index 0000000..53320fa --- /dev/null +++ b/src/guile/skribilo/package/slide/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package/slide +dist_guilemodule_DATA = base.scm latex.scm html.scm lout.scm + +## arch-tag: 56b5fa5c-bb6a-4692-b929-74bdd032431c diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm new file mode 100644 index 0000000..c8e652c --- /dev/null +++ b/src/guile/skribilo/package/slide/base.scm @@ -0,0 +1,185 @@ +;;; base.scm -- Overhead transparencies, `base' engine. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo package slide base) + :use-module (skribilo utils syntax) + + :use-module (skribilo package slide) + :use-module (skribilo writer) + :use-module (skribilo engine) + :use-module (skribilo ast) + :autoload (skribilo output) (output) + :autoload (skribilo package base) (symbol color itemize item) + + :use-module (srfi srfi-1) + + :export (%slide-outline-title %slide-outline-itemize-symbols)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Simple markups. +;;; +(let ((be (find-engine 'base))) + + ;; 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)))) + + +;;; +;;; Helper functions for the default topic/subtopic handling. +;;; + +(define (make-subtopic-list node recurse?-proc make-entry-proc + itemize-symbols) + ;; Make a list of the subtopic of `node'. Go recursive if `recurse?-proc' + ;; returns true. `make-entry-proc' is passed a node and returns an entry + ;; (a markup) for this node. `itemize-symbols' is a (circular) list + ;; containing the symbols to be passed to `itemize'. + (let* ((subtopic? (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide)))) + (subtopic-types (if (is-markup? node 'slide-topic) + '(slide-subtopic slide) + '(slide-topic)))) + (if (subtopic? node) + '() + (apply itemize + `(,@(if (is-markup? (car itemize-symbols) 'symbol) + `(:symbol ,(car itemize-symbols)) + '()) + ,@(map (lambda (t) + (item + (make-entry-proc t) + (if (recurse?-proc t) + (make-subtopic-list t recurse?-proc + make-entry-proc + (cdr itemize-symbols)) + '()))) + (filter (lambda (n) + (and (markup? n) + (member (markup-markup n) + subtopic-types))) + (markup-body node)))))))) + +(define (make-topic-list current-topic recurse? make-entry-proc) + ;; Make a full topic list of the document which contains + ;; `current-topic'. Here, `make-entry-proc' takes a topic node and + ;; the current topic node as its arguments. + (let ((doc (ast-document current-topic))) + (make-subtopic-list doc + (lambda (t) + (and recurse? (eq? t current-topic))) + (lambda (t) + (make-entry-proc t current-topic)) + %slide-outline-itemize-symbols))) + +(define (make-topic-entry topic current-topic) + ;; Produce an entry for `topic'. Colorize it based on the fact + ;; that the current topic is `current-topic' (it may need to be + ;; hightlighted). + (let ((title (markup-option topic :title)) + (current? (eq? topic current-topic))) + (color :fg (if current? "#000000" "#666666") + (apply (if current? bold (lambda (x) x)) + (list (markup-option topic :title)))))) + + +;;; +;;; Default topic/subtopic handling. +;;; + +;; Title for the automatically-generated outline slide. +(define %slide-outline-title "") + +;; Circular list of symbols to be passed to `itemize' in outlines. +(define %slide-outline-itemize-symbols + (let loop ((names '(#t "-" "bullet" "->" "middot"))) + (if (null? names) + '() + (cons (if (string? (car names)) + (symbol (car names)) + (car names)) + (loop (cdr names)))))) + + +(define (make-outline-slide topic engine) + (let ((parent-topic (if (is-markup? topic 'slide-topic) + topic + (find1-up (lambda (n) + (is-markup? n 'slide-topic)) + topic)))) + (output (slide :title %slide-outline-title :toc #f + :class (markup-option topic :class) + ;; The mark below is needed for cross-referencing by PDF + ;; bookmarks. + (if (markup-ident topic) (mark (markup-ident topic)) "") + (p (make-topic-list parent-topic #t + make-topic-entry))) + engine))) + + +(markup-writer 'slide-topic (find-engine 'base) + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (if (markup-option n :outline?) + (make-outline-slide n e)) + + (output (markup-body n) e))) + +(markup-writer 'slide-subtopic (find-engine 'base) + ;; FIXME: Largely untested. + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (if (markup-option n :outline?) + (make-outline-slide n e)) + + (output (markup-body n) e))) + + +;;; arch-tag: 1187ce0c-3ffc-4248-b68b-a7c77d6598b9 diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm new file mode 100644 index 0000000..d47ef82 --- /dev/null +++ b/src/guile/skribilo/package/slide/html.scm @@ -0,0 +1,144 @@ +;;; html.scm -- HTML implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide html) + :use-module (skribilo package slide)) + + +(define-public (%slide-html-initialize!) + (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 #f "~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 "
"))))) + + +;*---------------------------------------------------------------------*/ +;* 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 topics/subtopics. +;;; + +(markup-writer 'slide-topic (find-engine 'html) + :options '(:title :outline? :class :ident) + :action (lambda (n e) + (let ((title (markup-option n :title)) + (body (markup-body n))) + (display "\n

") + (if (markup-ident n) + (printf "" (markup-ident n))) + (output title e) + (display "


\n") + (display "\n
") + (for-each (lambda (s) + (output (markup-option s :title) e) + (display " -- ")) + (filter (lambda (n) + (or (is-markup? n 'slide-subtopic) + (is-markup? n 'slide))) + (markup-body n))) + (display "\n
") + (display "\n

\n") + + ;; the slides + (output (markup-body n) e)))) + + +;;; +;;; Initialization. +;;; + +(%slide-html-initialize!) + + +;;; arch-tag: 8be0cdf2-b755-4baa-baf6-739cdd00e193 diff --git a/src/guile/skribilo/package/slide/latex.scm b/src/guile/skribilo/package/slide/latex.scm new file mode 100644 index 0000000..e187d3c --- /dev/null +++ b/src/guile/skribilo/package/slide/latex.scm @@ -0,0 +1,394 @@ +;;; latex.scm -- LaTeX implementation of the `slide' package. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide latex) + :use-module (skribilo package slide)) + + +(define-public %slide-latex-mode 'seminar) + +(define-public (%slide-latex-initialize!) + (skribe-message "LaTeX slides setup...\n") + (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-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") + +;*---------------------------------------------------------------------*/ +;* 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) + +;;; FIXME: We shouldn't load `latex.scm' from here. Instead, we should +;;; register a hook on its load. +(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 #f "~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))))) + + + +;;; +;;; Initialization. +;;; + +(%slide-latex-initialize!) + +;;; arch-tag: b99e2c65-55f7-462c-8482-f47c7e223538 diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm new file mode 100644 index 0000000..d53cff1 --- /dev/null +++ b/src/guile/skribilo/package/slide/lout.scm @@ -0,0 +1,151 @@ +;;; lout.scm -- Lout implementation of the `slide' package. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-skribe-module (skribilo package slide lout) + :use-module (skribilo utils syntax) + + ;; XXX: If changing the following `autoload' to `use-module' doesn't work, + ;; then you need to fix your Guile. See this thread about + ;; `make-autoload-interface': + ;; + ;; http://article.gmane.org/gmane.lisp.guile.devel/5748 + ;; http://lists.gnu.org/archive/html/guile-devel/2006-03/msg00004.html . + + :autoload (skribilo engine lout) (lout-tagify lout-output-pdf-meta-info + lout-verbatim-encoding)) + + +(fluid-set! current-reader %skribilo-module-reader) + +;;; TODO: +;;; +;;; Make some more PS/PDF trickery. + +(format (current-error-port) "Lout slides setup...~%") + +(let ((le (find-engine 'lout))) + + ;; FIXME: Automatically switching to `slides' is problematic, e.g., for the + ;; user manual which embeds slides. +; ;; Automatically switch to the `slides' document type. +; (engine-custom-set! le 'document-type 'slides)) + + (markup-writer 'slide le + :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 le + :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 le + ;; 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 le + :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))))))))) + + + +;;; +;;; Customs for a nice handling of topics/subtopics. +;;; + +(let ((lout (find-engine 'lout))) + (if lout + (begin + (engine-custom-set! lout 'pdf-bookmark-node-pred + (lambda (n e) + (or (is-markup? n 'slide) + (is-markup? n 'slide-topic) + (is-markup? n 'slide-subtopic)))) + (engine-custom-set! lout 'pdf-bookmark-closed-pred + (lambda (n e) #f))))) + + +;;; arch-tag: 0c717553-5cbb-46ed-937a-f844b6aeb145 diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm new file mode 100644 index 0000000..6d1b7a5 --- /dev/null +++ b/src/guile/skribilo/package/web-article.scm @@ -0,0 +1,241 @@ +;;; web-article.scm -- A Skribe style for producing web articles +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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..49197f1 --- /dev/null +++ b/src/guile/skribilo/package/web-book.scm @@ -0,0 +1,121 @@ +;;; web-book.scm -- The Skribe web book style. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(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 (let ((text (bold "main page")) + (bg (engine-custom e 'background))) + (if bg (color :fg bg text) text)))) + (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 (let ((title (bold (markup-option n :title))) + (bg (engine-custom e 'background))) + (if bg (color :fg title) 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 (let ((text (bold (if chap "Chapters" "Sections"))) + (bg (engine-custom e 'background))) + (if bg (color :fg bg text) text)))) + (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/parameters.scm b/src/guile/skribilo/parameters.scm new file mode 100644 index 0000000..5893851 --- /dev/null +++ b/src/guile/skribilo/parameters.scm @@ -0,0 +1,88 @@ +;;; parameters.scm -- Skribilo settings as parameter objects. +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo parameters) + :use-module (srfi srfi-39)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines parameter objects that may be used to specify +;;; run-time parameters of a Skribilo process. +;;; +;;; Code: + + +;;; +;;; Switches. +;;; + +(define (make-expect pred pred-name parameter) + (let ((msg (string-append parameter ": " pred-name " expected"))) + (lambda (val) + (if (pred val) + val + (error msg val))))) + +(define-macro (define-number-parameter name) + `(define-public ,name + (make-parameter 0 + (make-expect number? "number" ,(symbol->string name))))) + +(define-number-parameter *verbose*) +(define-number-parameter *warning*) + +(define-public *load-rc-file?* (make-parameter #f)) + +;;; +;;; Paths. +;;; + + +(define-macro (define-path-parameter name) + `(define-public ,name + (make-parameter (list ".") + (make-expect list? "list" ,(symbol->string name))))) + + +(define-path-parameter *document-path*) +(define-path-parameter *bib-path*) +(define-path-parameter *source-path*) +(define-path-parameter *image-path*) + + +;;; +;;; Files. +;;; + +(define-public *destination-file* (make-parameter "output.html")) +(define-public *source-file* (make-parameter "default-input-file.skb")) + +;; Base prefix to remove from hyperlinks. +(define-public *ref-base* (make-parameter "")) + +;;; TODO: Skribe used to have other parameters as global variables. See +;;; which ones need to be kept. + + +;;; arch-tag: 3c0d2e18-b997-4615-8a3d-b6622ae28874 + +;;; parameters.scm ends here diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm new file mode 100644 index 0000000..266d607 --- /dev/null +++ b/src/guile/skribilo/prog.scm @@ -0,0 +1,220 @@ +;;; prog.scm -- All the stuff for the prog markup +;;; +;;; Copyright 2003 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo prog) + :use-module (ice-9 regex) + :autoload (ice-9 receive) (receive) + :use-module (skribilo lib) ;; `new' + :autoload (skribilo ast) (node? node-body) + :export (make-prog-body resolve-line)) + +;;; ====================================================================== +;;; +;;; COMPATIBILITY +;;; +;;; ====================================================================== +(define pregexp-match string-match) +(define pregexp-replace (lambda (rx str what) + (regexp-substitute/global #f rx str + 'pre what 'post))) +(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* ... */ +;*---------------------------------------------------------------------*/ +;; FIXME: Removed that global. Rework the thing. +(define *lines* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m line-ident b) + (let* ((n (list (mark line-ident) b))) + (hash-set! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hash-ref *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)) + ((list? 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)))))) + ((list? 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 #f "~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* ((line-ident (symbol->string (gensym "&prog-line"))) + (n (new markup + (markup '&prog-line) + (ident line-ident) + (body (if m (make-line-mark m line-ident l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) + diff --git a/src/guile/skribilo/reader.scm b/src/guile/skribilo/reader.scm new file mode 100644 index 0000000..871d92c --- /dev/null +++ b/src/guile/skribilo/reader.scm @@ -0,0 +1,106 @@ +;;; reader.scm -- Skribilo's front-end (aka. reader) interface. +;;; +;;; Copyright 2005 Ludovic Courtès +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader) + :use-module (srfi srfi-9) ;; records + :use-module (srfi srfi-17) ;; generalized `set!' + :use-module (srfi srfi-39) ;; parameter objects + :use-module (skribilo condition) + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :export (%make-reader lookup-reader make-reader + %default-reader *document-reader* + + &reader-search-error reader-search-error? + reader-search-error:reader) + :export-syntax (define-reader define-public-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module contains Skribilo's front-end (aka. ``reader'') interface. +;;; Skribilo's default reader is `(skribilo reader skribe)' which provides a +;;; reader for the Skribe syntax. +;;; +;;; Code: + +(define-record-type + (%make-reader name version make) + reader? + (name reader:name reader:set-name!) ;; a symbol + (version reader:version reader:set-version!) ;; a string + (make reader:make reader:set-make!)) ;; a one-argument proc + ;; that returns a reader + ;; proc + +(define-public reader:name + (getter-with-setter reader:name reader:set-name!)) + +(define-public reader:version + (getter-with-setter reader:version reader:set-version!)) + +(define-public reader:make + (getter-with-setter reader:make reader:set-make!)) + +(define-macro (define-reader name version make-proc) + `(define reader-specification + (%make-reader (quote ,name) ,version ,make-proc))) + +(define-macro (define-public-reader name version make-proc) + `(define-reader ,name ,version ,make-proc)) + + +;;; Error condition. + +(define-condition-type &reader-search-error &skribilo-error + reader-search-error? + (reader reader-search-error:reader)) + + + +;;; The mechanism below is inspired by Guile-VM code written by K. Nishida. + +(define (lookup-reader name) + "Look for a reader named @var{name} (a symbol) in the @code{(skribilo +reader)} module hierarchy. If no such reader was found, an error is +raised." + (let ((m (false-if-exception + (resolve-module `(skribilo reader ,name))))) + (if (and (module? m) + (module-bound? m 'reader-specification)) + (module-ref m 'reader-specification) + (raise (condition (&reader-search-error (reader name))))))) + +(define (make-reader name) + "Look for reader @var{name} and instantiate it." + (let* ((spec (lookup-reader name)) + (make (reader:make spec))) + (make))) + +(define %default-reader (make-reader 'skribe)) + + +;;; Current document reader. + +(define *document-reader* (make-parameter %default-reader)) + + +;;; reader.scm ends here diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..807e4a7 --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm outline.scm diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm new file mode 100644 index 0000000..09792f5 --- /dev/null +++ b/src/guile/skribilo/reader/outline.scm @@ -0,0 +1,426 @@ +;;; outline.scm -- A reader for Emacs' outline syntax. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader outline) + :use-module (skribilo utils syntax) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-11) + + :autoload (ice-9 rdelim) (read-line) + :autoload (ice-9 regex) (make-regexp) + + :export (reader-specification + make-outline-reader)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for Emacs' outline-mode syntax. +;;; +;;; Code: + +;;; TODO: +;;; +;;; - add source position information; +;;; - handle `blockquote' (indented paragraph); +;;; - handle sublists (indented lists) --- optional; +;;; - handle inline Skribe code: `\n{skribe\n(table (tr ... ))\n}\n' + + + + +;;; +;;; Tools. +;;; + +(define (apply-any procs args) + "Apply the procedure listed in @var{procs} to @var{args} until one of these +procedure returns true." + (let loop ((procs procs)) + (if (null? procs) + #f + (let ((result (apply (car procs) args))) + (if result result (loop (cdr procs))))))) + +(define (make-markup name body) + "Return a clean markup form, i.e., an s-exp whose @code{car} is a symbol +equal to @var{name}, a markup name." + (cond ((list? body) + (cond ((null? body) `(,name)) + ((symbol? (car body)) `(,name ,body)) + (else `(,name ,@body)))) + (else + (list name body)))) + + +(define (append-trees . trees) + "Append markup trees @var{trees}. Trees whose car is a symbol (e.g., +@code{(bold \"paf\")} will be considered as sub-trees of the resulting tree." + (let loop ((trees trees) + (result '())) + (if (null? trees) + result + (let ((tree (car trees))) + (loop (cdr trees) + (append result + (if (list? tree) + (cond ((null? tree) '()) + ((symbol? (car tree)) (list tree)) + (else tree)) + (list tree)))))))) + +(define (null-string? s) + (and (string? s) (string=? s ""))) + + +(define empty-line-rx (make-regexp "^([[:space:]]*|;.*)$")) +(define (empty-line? s) + "Return true if string @var{s} denotes an ``empty'' line, i.e., a blank +line or a line comment." + (regexp-exec empty-line-rx s)) + + + +;;; +;;; In-line markup, i.e., markup that doesn't span over multiple lines. +;;; + +(define %inline-markup + ;; Note: the order matters because, for instance, URLs must be searched for + ;; _before_ italics (`/italic/'). + `(("_([^_]+)_" . + ,(lambda (m) + (values (match:prefix m) ;; before + (match:substring m 1) ;; body + (match:suffix m) ;; after + (lambda (body) `(emph ,body))))) ;; process-body + ("(f|ht)tp://[a-zA-Z0-9\\._~%/-]+" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m) + (match:suffix m) + (lambda (url) `(ref :url ,url))))) + ("\\/([^\\/]+)\\/" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(it ,body))))) + ("\\*([^\\*]+)\\*" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(bold ,body))))) + ("``(([^`^'])+)''" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(q ,body))))) + ("`(([^`^'])+)'" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(tt ,body))))))) + +(define (make-markup-processor rx proc) + (lambda (line) + (let ((match (regexp-exec rx line))) + (if match + (proc match) + #f)))) + +(define (make-line-processor markup-alist) + "Returns a @dfn{line processor}. A line processor is a procedure that +takes a string and returns a list." + (let* ((markups (map (lambda (rx+proc) + (cons (make-regexp (car rx+proc) regexp/extended) + (cdr rx+proc))) + markup-alist)) + (procs (map (lambda (rx+proc) + (make-markup-processor (car rx+proc) (cdr rx+proc))) + markups))) + (lambda (line) + (let self ((line line)) + ;;(format #t "self: ~a~%" line) + (cond ((string? line) + (let ((result (apply-any procs (list line)))) + (if result + (let-values (((before body after proc-body) + result)) + (let ((body+ + (if (string=? (string-append before body after) + line) + body (self body)))) + (if (and (null-string? before) + (null-string? after)) + (proc-body body+) + (append-trees (self before) + (proc-body body+) + (self after))))) + line))) + (else + (error "line-processor: internal error" line))))))) + +(define %line-processor + (make-line-processor %inline-markup)) + + + +;;; +;;; Large-scale structures: paragraphs, chapters, sections, etc. +;;; + +(define (process-paragraph line line-proc port) + (let loop ((line line) + (result '())) + (if (or (eof-object? line) (empty-line? line)) + (cons 'p result) + (loop (read-line port) + (let ((line (line-proc line))) + (append-trees result line "\n")))))) + +(define (make-list-processor rx node-type extract-line-proc line-proc + end-of-node?) + "Return a procedure (a @dfn{list processor}) that takes a line and a port +and returns an AST node of type @var{node-type} (a symbol, typically +@code{itemize} or @code{enumerate}) along with a line. If the processor is +not triggered, i.e., it is passed a line that does not match @var{rx}, then +it returns @code{#f}." + (lambda (line port) + (let ((match (regexp-exec rx line))) + (if (not match) + #f + (let loop ((line line) + (contiguous-empty-lines 0) + (item '()) + (body '())) + (if (eof-object? line) + (let ((body (if (null? item) + body + (cons `(item ,@(reverse! item)) body)))) + (values line `(,node-type ,@(reverse! body)))) + (let ((match (regexp-exec rx line))) + (cond (match + ;; reading the first line of an item + (loop (read-line port) 0 + (append-trees + (line-proc (extract-line-proc match))) + body)) + + ((and (procedure? end-of-node?) + (end-of-node? line)) + (values line + `(,node-type ,@(reverse! body)))) + + ((empty-line? line) + (cond ((>= contiguous-empty-lines 1) + ;; end of list + (values line + `(,node-type ,@(reverse! body)))) + + ((= contiguous-empty-lines 0) + ;; end of item: add ITEM to BODY + (loop (read-line port) 1 '() + (cons (make-markup 'item item) + body))) + + (else + ;; skipping empty line + (loop (read-line port) + (+ 1 contiguous-empty-lines) + item body)))) + + (else + ;; reading an item: add LINE to ITEM + (loop (read-line port) 0 + (append-trees item (line-proc line)) + body)))))))))) + +(define (make-node-processor rx node-type title-proc line-proc + subnode-procs end-of-node?) + "Return a procedure that reads the given string and return an AST node of +type @var{node-type} or @code{#f}. When the original string matches the node +header, then the rest of the node is read from @var{port}. +@var{subnode-procs} is a list of node processors for node types subordinate +to @var{node-type}." + (lambda (line port) + (let ((match (regexp-exec rx line))) + (if (not match) + #f + (let ((title (line-proc (title-proc match)))) + (let loop ((line (read-line port)) + (body '())) + + (let ((subnode (and (not (eof-object? line)) + (apply-any subnode-procs + (list line port))))) + (cond (subnode + (let-values (((line node) subnode)) + (loop line (cons node body)))) + + ((or (eof-object? line) + (regexp-exec rx line) + (and (procedure? end-of-node?) + (end-of-node? line))) + (values line + `(,node-type :title ,title ,@(reverse! body)))) + + ((empty-line? line) + (loop (read-line port) body)) + + (else + (let ((par (process-paragraph line line-proc port))) + (loop (read-line port) + (cons par body)))))))))))) + + +(define (node-markup-line? line) + (define node-rx (make-regexp "^\\*+ (.+)$" regexp/extended)) + (regexp-exec node-rx line)) + +(define %list-processors + (list (make-list-processor (make-regexp "^[-~o] (.+)$" regexp/extended) + 'itemize + (lambda (m) (match:substring m 1)) + %line-processor + node-markup-line?) + (make-list-processor (make-regexp "^([0-9]+)\\.? (.+)$" + regexp/extended) + 'enumerate + (lambda (m) (match:substring m 2)) + %line-processor + node-markup-line?))) + +(define %node-processors + (let* ((subsubsection-proc + (make-node-processor (make-regexp "^\\*\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + %list-processors ;; no further subnodes + node-markup-line?)) + (subsection-proc + (make-node-processor (make-regexp "^\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsubsection-proc)) + node-markup-line?)) + (section-proc + (make-node-processor (make-regexp "^\\*\\* (.+)$" regexp/extended) + 'section + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsection-proc)) + node-markup-line?))) + (list (make-node-processor (make-regexp "^\\* (.+)$" regexp/extended) + 'chapter + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list section-proc)) + #f)))) + + + + +;;; +;;; The top-level parser. +;;; + +(define (make-document-processor node-procs line-proc) + (lambda (line port) + (let self ((line line) + (doc '())) + ;;(format #t "doc-proc: ~a~%" line) + (if (eof-object? line) + (if (null? doc) + line + (reverse! doc)) + (if (empty-line? line) + (self (read-line port) doc) + (let ((result (apply-any node-procs (list line port)))) + (if result + (let-values (((line node) result)) + (self line (cons node doc))) + (let ((par (process-paragraph line line-proc port))) + (self (read-line port) + (cons par doc)))))))))) + + +(define* (outline-reader :optional (port (current-input-port))) + (define modeline-rx + (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$")) + (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended)) + (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended)) + + (let ((doc-proc (make-document-processor %node-processors %line-processor))) + + (let loop ((title #f) + (author #f) + (line (read-line port))) + + (if (eof-object? line) + (if (or title author) + `(document :title ,title :author (author :name ,author) '()) + line) + (if (or (empty-line? line) + (regexp-exec modeline-rx line)) + (loop title author (read-line port)) + (let ((title-match (regexp-exec title-rx line))) + (if title-match + (loop (match:substring title-match 1) + author (read-line port)) + (let ((author-match (regexp-exec author-rx line))) + (if author-match + (loop title (match:substring author-match 1) + (read-line port)) + + ;; Let's go. + `(document :title ,title + :author (author :name ,author) + ,@(doc-proc line port))))))))))) + + +(define* (make-outline-reader :optional (version "0.1")) + outline-reader) + + + +;;; The reader specification. + +(define-reader outline "0.1" make-outline-reader) + + +;;; arch-tag: 53473e73-c811-4eed-a0b4-22ada4d6ef08 + +;;; outline.scm ends here + diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm new file mode 100644 index 0000000..d3dbb5f --- /dev/null +++ b/src/guile/skribilo/reader/skribe.scm @@ -0,0 +1,113 @@ +;;; skribe.scm -- A reader for the Skribe syntax. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader skribe) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-1) + + ;; the Scheme reader composition framework + :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) + + :export (reader-specification + make-skribe-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for the Skribe syntax, i.e. roughly R5RS Scheme plus DSSSL-style +;;; keywords and sk-exps (expressions introduced using a square bracket). +;;; +;;; Code: + +;;; Note: We need guile-reader 0.2 at least. + +(define* (make-skribe-reader #:optional (version "1.2d")) + "Return a Skribe reader (a procedure) suitable for version @var{version} of +the Skribe syntax." + (if (string> version "1.2d") + (error "make-skribe-reader: unsupported version" version) + %skribe-reader)) + +(define (make-colon-free-token-reader tr) + ;; Stolen from `guile-reader' 0.3. + "If token reader @var{tr} handles the @code{:} (colon) character, remove it +from its specification and return the new token reader." + (let* ((spec (r:token-reader-specification tr)) + (proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (char=? chr #\:))) + spec) + proc))) + +(define &sharp-reader + ;; The reader for what comes after a `#' character. + (let* ((dsssl-keyword-reader ;; keywords à la `#!key' + (r:make-token-reader #\! + (r:token-reader-procedure + (r:standard-token-reader 'keyword))))) + (r:make-reader (cons dsssl-keyword-reader + (map r:standard-token-reader + '(character srfi-4 vector + number+radix boolean + srfi30-block-comment + srfi62-sexp-comment))) + #f ;; use default fault handler + 'reader/record-positions))) + +(define (%make-skribe-reader) + (let ((colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (symbol-misc-chars-tr + ;; Make sure `:' is handled only by the keyword token reader. + (make-colon-free-token-reader + (r:standard-token-reader 'r6rs-symbol-misc-chars)))) + + + ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since + ;; they consider square brackets as delimiters. + (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader) + colon-keywords + symbol-misc-chars-tr + (map r:standard-token-reader + `(whitespace + sexp string r6rs-number + r6rs-symbol-lower-case + r6rs-symbol-upper-case + 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)) + + + +;;; The reader specification. + +(define-reader skribe "1.2d" make-skribe-reader) + +;;; skribe.scm ends here diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm new file mode 100644 index 0000000..ba5af6a --- /dev/null +++ b/src/guile/skribilo/resolve.scm @@ -0,0 +1,296 @@ +;;; resolve.scm -- Skribilo reference resolution. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo resolve) + :use-module (skribilo debug) + :use-module (skribilo ast) + :use-module (skribilo utils syntax) + + :use-module (oop goops) + :use-module (srfi srfi-39) + + :use-module (skribilo condition) + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + + :export (resolve! resolve-search-parent resolve-children resolve-children* + find1 resolve-counter resolve-parent resolve-ident + *document-being-resolved*)) + +(fluid-set! current-reader %skribilo-module-reader) + + + + +;;; +;;; Resolving nodes. +;;; + +;; The document being resolved. Note: This is only meant to be used by the +;; compatibility layer in order to implement things like `find-markups'! +(define *document-being-resolved* (make-parameter #f)) + +(define *unresolved* (make-parameter #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) + + (if (document? ast) + ;; Bind nodes prior to resolution so that unresolved nodes can + ;; lookup nodes by identifier using `document-lookup-node' or + ;; `resolve-ident'. + (document-bind-nodes! ast)) + + (parameterize ((*unresolved* #f)) + (let Loop ((ast ast)) + (*unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if (*unresolved*) + (begin + (debug-item "iterating over ast " ast) + (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 + ((null? n*) + ast) + ((list? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (Loop (cdr n*))) + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (set-cdr! n* (do-resolve! (cdr n*) engine env))) + (else + (raise (condition (&invalid-argument-error + (proc-name "do-resolve!") + (argument n*)))))))) + + +(define-method (do-resolve! (node ) engine env) + (if (ast-resolved? node) + node + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent)) + (unresolved? (*unresolved*))) + (with-debug 5 'do-resolve + (debug-item "body=" body) + (parameterize ((*unresolved* #f)) + (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)) + (slot-set! node 'resolved? (not (*unresolved*)))) + + (*unresolved* (or unresolved? (not (ast-resolved? node)))) + 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) + (parameterize ((*document-being-resolved* node)) + (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 (proc node engine env)) + (loc (ast-loc node))) + (when (ast? res) + (ast-loc-set! res loc) + (slot-set! res 'parent (assq 'parent env))) + (debug-item "res=" res) + (*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) + (raise (condition (&ast-orphan-error (ast 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)) + (raise (condition (&ast-orphan-error (ast 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'. +;;; +;;; This function kind of sucks because the document where IDENT is to be +;;; searched is not explictly passed. Thus, using `document-lookup-node' is +;;; recommended instead of using this function. +;;; + +(define (resolve-ident ident markup n e) + ;; Search for a node with identifier IDENT and markup type MARKUP. N is + ;; typically an `' node and the node lookup should be performed + ;; in its parent document. E is the "environment" (an alist). + (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)) + (raise (condition (&invalid-argument-error ;; type error + (proc-name "resolve-ident") + (argument ident)))) + (let* ((doc (ast-document n)) + (result (and doc (document-lookup-node doc ident)))) + (if (or (not markup) + (and (markup? result) (eq? (markup-markup result) markup))) + result + #f))))) + diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm new file mode 100644 index 0000000..a61de4f --- /dev/null +++ b/src/guile/skribilo/source.scm @@ -0,0 +1,208 @@ +;;;; source.scm -- Highlighting source files. +;;;; +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; + +(define-module (skribilo source) + :export ( language? language-extractor language-fontifier + source-read-lines source-read-definition source-fontify) + + :use-module (srfi srfi-35) + :autoload (srfi srfi-34) (raise) + :autoload (srfi srfi-13) (string-prefix-length) + :autoload (skribilo condition) (&file-search-error &file-open-error) + + :use-module (skribilo utils syntax) + :use-module (skribilo parameters) + :use-module (skribilo lib) + :use-module (oop goops) + :use-module (ice-9 rdelim)) + + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Class definition. +;;; + +(define-class () + (name :init-keyword :name :init-value #f :getter langage-name) + (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 )) + + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (search-path (*source-path*) file))) + (if (or (not (string? p)) (not (file-exists? p))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*))))) + (with-input-from-file p + (lambda () + (if (> (*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 0) ;; In Guile, line nums are 0-origined. + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) + (= (string-prefix-length 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) + (= (string-prefix-length 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 (search-path (*source-path*) file))) + (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))) + (raise (condition (&file-search-error (file-name file) + (path (*source-path*)))))) + + (else + (let ((ip (open-input-file p))) + (if (> (*verbose*) 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (raise (condition (&file-open-error (file-name p)))) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) diff --git a/src/guile/skribilo/sui.scm b/src/guile/skribilo/sui.scm new file mode 100644 index 0000000..e0a9b19 --- /dev/null +++ b/src/guile/skribilo/sui.scm @@ -0,0 +1,199 @@ +;;; sui.scm +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo sui) + :use-module (skribilo utils syntax) + :use-module (skribilo lib) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :autoload (skribilo parameters) (*verbose*) + :autoload (skribilo reader) (make-reader) + + :export (load-sui sui-ref->url sui-title sui-file sui-key + sui-find-ref sui-search-ref sui-filter)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano +;;; Commentary: +;;; +;;; Library dealing with Skribe URL Indexes (SUI). +;;; +;;; Code: + + +;;; The contents of the file below are (almost) unchanged compared to Skribe +;;; 1.2d's `sui.scm' file found in the `common' directory. + + +;*---------------------------------------------------------------------*/ +;* *sui-table* ... */ +;*---------------------------------------------------------------------*/ +(define *sui-table* (make-hash-table)) + +;*---------------------------------------------------------------------*/ +;* 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 (hash-ref *sui-table* path))) + (or sexp + (begin + (when (> (*verbose*) 0) + (format (current-error-port) " [loading sui: ~a]\n" path)) + (let ((p (open-input-file path)) + (read (make-reader 'skribe))) + (if (not (input-port? p)) + (skribe-error 'load-sui + "Can't find `Skribe Url Index' file" + path) + (unwind-protect + (let ((sexp (read p))) + (match sexp + (('sui (? string?) . _) + (hash-set! *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 #f "~a/~a#~a" dir (or file base) mark))))) + +;*---------------------------------------------------------------------*/ +;* sui-title ... */ +;*---------------------------------------------------------------------*/ +(define (sui-title sexp) + (match 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 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 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 sui + (('sui (? string?) . refs) + (let loop ((refs refs) + (res '())) + (if (pair? refs) + (if (and (pred1 (car refs))) + (loop (cdr refs) + (cons (filter pred2 (cdar refs)) res)) + (loop (cdr refs) res)) + (reverse! res)))) + (else + (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/src/guile/skribilo/utils/Makefile.am b/src/guile/skribilo/utils/Makefile.am new file mode 100644 index 0000000..9d9df6f --- /dev/null +++ b/src/guile/skribilo/utils/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/utils +dist_guilemodule_DATA = syntax.scm compat.scm files.scm images.scm \ + keywords.scm strings.scm + +## arch-tag: 3a18b64b-1da2-417b-8338-2c534bca277f diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm new file mode 100644 index 0000000..118f294 --- /dev/null +++ b/src/guile/skribilo/utils/compat.scm @@ -0,0 +1,309 @@ +;;; compat.scm -- Skribe compatibility module. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo utils compat) + :use-module (skribilo utils syntax) + :use-module (skribilo utils files) + :use-module (skribilo parameters) + :use-module (skribilo evaluator) + :use-module (srfi srfi-1) + :autoload (srfi srfi-13) (string-rindex) + :use-module (srfi srfi-34) + :use-module (srfi srfi-35) + :use-module (ice-9 optargs) + :autoload (skribilo ast) (ast? document? document-lookup-node) + :autoload (skribilo condition) (file-search-error? &file-search-error) + :autoload (skribilo reader) (make-reader) + :autoload (skribilo lib) (type-name) + :autoload (skribilo resolve) (*document-being-resolved*) + :autoload (skribilo output) (*document-being-output*) + :use-module (skribilo debug) + + :re-export (file-size) ;; re-exported from `(skribilo utils files)' + :replace (gensym)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines symbols for compatibility with Skribe 1.2. +;;; +;;; Code: + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; gensym +;;; + +(define %gensym-orig (module-ref the-root-module 'gensym)) + +(define gensym + ;; In Skribe, `gensym' accepts a symbol. Guile's `gensym' accepts only + ;; strings (or no argument). + (lambda obj + (apply %gensym-orig + (cond ((null? obj) '()) + ((symbol? (car obj)) (list (symbol->string (car obj)))) + ((string? (car obj)) (list (car obj))) + (else (skribe-error 'gensym "invalid argument" obj)))))) + + +;;; +;;; Global variables that have been replaced by parameter objects +;;; in `(skribilo parameters)'. +;;; +;;; FIXME: There's not much we can do about these variables (as opposed to +;;; the _accessors_ below). Perhaps we should just not define them? +;;; + +;;; Switches +(define-public *skribe-verbose* 0) +(define-public *skribe-warning* 5) +(define-public *load-rc* #t) + + +;;; Path variables +(define-public *skribe-path* #f) +(define-public *skribe-bib-path* '(".")) +(define-public *skribe-source-path* '(".")) +(define-public *skribe-image-path* '(".")) + + +(define-public *skribe-rc-directory* + (string-append (getenv "HOME") "/" ".skribilo")) + + +;;; In and out ports +(define-public *skribe-src* '()) +(define-public *skribe-dest* #f) + +;;; Engine +(define-public *skribe-engine* 'html) ;; Use HTML by default + +;;; Misc +(define-public *skribe-chapter-split* '()) +(define-public *skribe-ref-base* #f) +(define-public *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter +(define-public *skribe-variants* '()) + + + +;;; +;;; Accessors mapped to parameter objects. +;;; + +(define-public skribe-path *document-path*) +(define-public skribe-image-path *image-path*) +(define-public skribe-source-path *source-path*) +(define-public skribe-bib-path *bib-path*) + +(define-public (skribe-path-set! path) (*document-path* path)) +(define-public (skribe-image-path-set! path) (*image-path* path)) +(define-public (skribe-source-path-set! path) (*source-path* path)) +(define-public (skribe-bib-path-set! path) (*bib-path* path)) + + + +;;; +;;; Evaluator. +;;; + +(define %skribe-known-files + ;; Like of Skribe package files and their equivalent Skribilo module. + '(("web-book.skr" . (skribilo package web-book)) + ("web-article.skr" . (skribilo package web-article)) + ("slide.skr" . (skribilo package slide)) + ("sigplan.skr" . (skribilo package sigplan)) + ("scribe.skr" . (skribilo package scribe)) + ("lncs.skr" . (skribilo package lncs)) + ("letter.skr" . (skribilo package letter)) + ("jfp.skr" . (skribilo package jfp)) + ("french.skr" . (skribilo package french)) + ("acmproc.skr" . (skribilo package acmproc)))) + +(define*-public (skribe-load file :rest args) + (guard (c ((file-search-error? c) + ;; Regular file loading failed. Try built-ins. + (let ((mod-name (assoc-ref %skribe-known-files file))) + (if mod-name + (begin + (if (> (*verbose*) 1) + (format (current-error-port) + " skribe-load: `~a' -> `~a'~%" + file mod-name)) + (let ((mod (false-if-exception + (resolve-module mod-name)))) + (if (not mod) + (raise c) + (begin + (set-module-uses! + (current-module) + (cons mod (module-uses (current-module)))) + #t)))) + (raise c))))) + + ;; Try a regular `load-document'. + (apply load-document file args))) + + +(define-public skribe-include include-document) +(define-public skribe-load-options *load-options*) + +(define-public skribe-eval evaluate-document) +(define-public skribe-eval-port evaluate-document-from-port) + +(set! %skribe-reader #f) +(define*-public (skribe-read #:optional (port (current-input-port))) + (if (not %skribe-reader) + (set! %skribe-reader (make-reader 'skribe))) + (%skribe-reader port)) + + + +;;; +;;; Node lookup (formerly provided by `ast.scm'). +;;; + +(define-public (bind-markup! node) + (let ((doc (or (*document-being-resolved*) + (*document-being-output*)))) + (if (document? doc) + (document-bind-node! doc node) + (error "Sorry, unable to achieve `bind-markup!'. Use `document-bind-node!' instead." + node)))) + +(define-public (find-markups ident) + (let ((doc (or (*document-being-resolved*) + (*document-being-output*)))) + (if (document? doc) + (let ((result (document-lookup-node doc ident))) + (if result + (list result) + #f)) + (error "Sorry, unable to achieve `find-markups'. Use `document-lookup-node' instead." + ident)))) + +(define-public (find-markup-ident ident) + (or (find-markups ident) '())) + + + +;;; +;;; Debugging facilities. +;;; + +(define-public (set-skribe-debug! val) + (*debug* val)) + +(define-public (no-debug-color) + (*debug-use-colors?* #f)) + +(define-public skribe-debug *debug*) + +(define-public (add-skribe-debug-symbol s) + (*watched-symbols* (cons s *watched-symbols*))) + + + +;;; +;;; Compatibility with Bigloo. +;;; + +(define-public (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-public (directory->list str) + (map basename (glob (string-append str "/*") (string-append "/.*")))) + +(define-macro (printf . args) `(format #t ,@args)) +(export-syntax printf) +(define-public fprintf format) + +(define-public (fprint port . args) + (if port + (with-output-to-port port + (lambda () + (for-each display args) + (display "\n"))))) + + + +(define-public prefix file-prefix) +(define-public suffix file-suffix) +(define-public system->string system) ;; FIXME +(define-public any? any) +(define-public every? every) +(define-public (find-file/path file path) + (search-path path file)) + +(define-public process-input-port #f) ;process-input) +(define-public process-output-port #f) ;process-output) +(define-public process-error-port #f) ;process-error) + +;;; hash tables +(define-public make-hashtable make-hash-table) +(define-public hashtable? hash-table?) +(define-public hashtable-get (lambda (h k) (hash-ref h k #f))) +(define-public hashtable-put! hash-set!) +(define-public (hashtable-update! table key update-proc init-value) + ;; This is a Bigloo-specific API. + (let ((handle (hash-get-handle table key))) + (if (not handle) + (hash-set! table key init-value) + (set-cdr! handle (update-proc (cdr handle)))))) + +(define-public (hashtable->list h) + (hash-map->list (lambda (key val) val) h)) + +(define-public (find-runtime-type obj) + (type-name obj)) + + +;;; +;;; Miscellaneous. +;;; + +(use-modules ((srfi srfi-19) #:renamer (symbol-prefix-proc 's19:))) + +(define-public (date) + (s19:date->string (s19:current-date) "~c")) + +(define-public (correct-arity? proc argcount) + (let ((a (procedure-property proc 'arity))) + (and (pair? a) + (let ((compulsory (car a)) + (optional (cadr a)) + (rest? (caddr a))) + (or rest? + (>= (+ compulsory optional) argcount)))))) + + +;;; compat.scm ends here diff --git a/src/guile/skribilo/utils/files.scm b/src/guile/skribilo/utils/files.scm new file mode 100644 index 0000000..6d89d4d --- /dev/null +++ b/src/guile/skribilo/utils/files.scm @@ -0,0 +1,55 @@ +;;; files.scm -- File-related utilities. +;;; +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils files) + :export (file-prefix file-suffix file-size)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module defines filesystem-related utility functions. +;;; +;;; Code: + +(define (file-size file) + (let ((file-info (false-if-exception (stat file)))) + (if file-info + (stat:size file-info) + #f))) + +(define (file-prefix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot (substring fn 0 dot) fn)) + "./SKRIBILO-OUTPUT")) + +(define (file-suffix fn) + (if fn + (let ((dot (string-rindex fn #\.))) + (if dot + (substring fn (+ dot 1) (string-length fn)) + "")) + #f)) + + +;;; arch-tag: b63d2a9f-a254-4e2d-8d85-df773bbc4a9b + +;;; files.scm ends here diff --git a/src/guile/skribilo/utils/images.scm b/src/guile/skribilo/utils/images.scm new file mode 100644 index 0000000..24405d6 --- /dev/null +++ b/src/guile/skribilo/utils/images.scm @@ -0,0 +1,99 @@ +;;; images.scm -- Images handling utilities. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils images) + :export (convert-image + *fig-convert-program* *bitmap-convert-program*) + + :autoload (skribilo utils files) (file-suffix file-prefix) + :autoload (skribilo parameters) (*image-path* *verbose*) + :autoload (skribilo condition) (&file-search-error) + :autoload (srfi srfi-34) (raise) + :use-module (srfi srfi-35) + :use-module (srfi srfi-39)) + +;;; Author: Erick Gallesio, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides convenience functions to handle image files, notably +;;; for format conversion via ImageMagick's `convert'. +;;; +;;; Code: + +(define *fig-convert-program* (make-parameter "fig2dev -L")) +(define *generic-convert-program* (make-parameter "convert")) + +(define (builtin-convert-image from fmt dir) + (let* ((s (file-suffix from)) + (f (string-append (file-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 (*fig-convert-program*) " " + fmt " " from " > " to) + (string-append (*generic-convert-program*) " " + from " " to)))) + (cond + ((> (*verbose*) 1) + (format (current-error-port) " [converting image: ~S (~S)]" from c)) + ((> (*verbose*) 0) + (format (current-error-port) " [converting image: ~S]" from))) + (and (zero? (system c)) + to)))))) + +(define (convert-image file formats) + (let ((path (search-path (*image-path*) file))) + (if (not path) + (raise (condition (&file-search-error (file-name file) + (path (*image-path*))))) + (let ((suf (file-suffix file))) + (if (member suf formats) + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) + #f))) + (if dir + (let* ((dest (basename path)) + (dest-path (string-append dir "/" dest))) + (if (not (string=? path dest-path)) + (copy-file path dest-path)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? (*destination-file*)) + (dirname (*destination-file*)) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + + +;;; arch-tag: a1992fa8-6073-4cd7-a018-80e2cc8d537c + +;;; images.scm ends here diff --git a/src/guile/skribilo/utils/keywords.scm b/src/guile/skribilo/utils/keywords.scm new file mode 100644 index 0000000..1bcd5dc --- /dev/null +++ b/src/guile/skribilo/utils/keywords.scm @@ -0,0 +1,99 @@ +;;; keywords.scm -- Convenience procedures for keyword-argument handling. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils keywords) + :export (the-body the-options list-split)) + +;;; Author: Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides convenience functions to handle keyword arguments. +;;; These are typically used by markup functions. +;;; +;;; Code: + +(define (the-body opt+) + ;; Filter out the keyword arguments from 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)))))) + +(define (the-options opt+ . out) + ;; Return a list made of keyword arguments (i.e., each time, a keyword + ;; followed by its associated value). The OUT argument should be a list + ;; containing keyword argument names to be filtered out (e.g., + ;; `(#:ident)'). + (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))))) + +(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))))) + +;;; arch-tag: 3e9066d5-6d7d-4da5-922b-cc3d4ba8476e + +;;; keywords.scm ends here diff --git a/src/guile/skribilo/utils/strings.scm b/src/guile/skribilo/utils/strings.scm new file mode 100644 index 0000000..e8e8f8f --- /dev/null +++ b/src/guile/skribilo/utils/strings.scm @@ -0,0 +1,145 @@ +;;; strings.scm -- Convenience functions to manipulate strings. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils strings) + :export (strip-ref-base string-canonicalize + make-string-replace) + :autoload (skribilo parameters) (*ref-base*) + :use-module (skribilo lib) + :use-module (srfi srfi-13)) + + +;;; +;;; Utilities. +;;; + +(define (strip-ref-base file) + ;; Given FILE, a file path (a string), remove `(*ref-base*)' from it. + ;; This is useful, e.g., for hyperlinks. + (if (not (string? (*ref-base*))) + file + (let ((l (string-length (*ref-base*)))) + (cond + ((not (> (string-length file) (+ l 2))) + file) + ((not (string-contains file (*ref-base*) 0 l)) + file) + ((not (char=? (string-ref file l) #\/)) + file) + (else + (substring file (+ l 1) (string-length file))))))) + + +(define (string-canonicalize old) + ;; Return a string that is a canonical summarized representation of string + ;; OLD. This is a one-way function. + (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)))))) + + + + +;;; +;;; String writing. +;;; + +;; +;; (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 + (let ((chars (make-hash-table))) + + ;; Setup a hash table equivalent to LST. + (for-each (lambda (chr) + (hashq-set! chars (car chr) (cadr chr))) + lst) + + ;; Help the GC. + (set! lst #f) + + (lambda (str) + (let ((out (open-output-string))) + (string-for-each (lambda (ch) + (let ((res (hashq-ref chars ch #f))) + (display (if res res ch) out))) + str) + (get-output-string out))))) + +(define %html-replacements + '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) + +(define %string->html + (%make-general-string-replace %html-replacements)) + +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (charhtml) + (else + (%make-general-string-replace lst))))) + diff --git a/src/guile/skribilo/utils/syntax.scm b/src/guile/skribilo/utils/syntax.scm new file mode 100644 index 0000000..44bff09 --- /dev/null +++ b/src/guile/skribilo/utils/syntax.scm @@ -0,0 +1,81 @@ +;;; syntax.scm -- Syntactic candy for Skribilo modules. +;;; +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo utils syntax) + :use-module (skribilo reader) + :use-module (system reader library) + :use-module (system reader compat) ;; make sure `current-reader' exists + :use-module (system reader confinement) + :export (%skribe-reader %skribilo-module-reader) + :export-syntax (unwind-protect unless when)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides syntactic candy for Skribilo modules, i.e., a syntax +;;; similar to Guile's default syntax with a few extensions, plus various +;;; convenience macros. +;;; +;;; Code: + +(define %skribilo-module-reader + ;; The syntax used to read Skribilo modules. + (apply make-alternate-guile-reader + '(colon-keywords no-scsh-block-comments + srfi30-block-comments srfi62-sexp-comments) + (lambda (chr port read) + (let ((file (port-filename port)) + (line (port-line port)) + (column (port-column port))) + (error (string-append + (if (string? file) + (format #f "~a:~a:~a: " file line column) + "") + "unexpected character in Skribilo module") + chr))) + + ;; By default, don't record positions: this yields a nice read + ;; performance improvement. + (if (memq 'debug (debug-options)) + (list 'reader/record-positions) + '()))) + +(define %skribe-reader + ;; The Skribe syntax reader. + (make-reader 'skribe)) + + +(define-macro (unwind-protect expr1 expr2) + ;; This is no completely correct. + `(dynamic-wind + (lambda () #f) + (lambda () ,expr1) + (lambda () ,expr2))) + +(define-macro (unless condition . exprs) + `(if (not ,condition) (begin ,@exprs))) + +(define-macro (when condition . exprs) + `(if ,condition (begin ,@exprs))) + +;;; arch-tag: 9a0e0638-64f0-480a-ab19-49e8bfcbcd9b + +;;; syntax.scm ends here diff --git a/src/guile/skribilo/verify.scm b/src/guile/skribilo/verify.scm new file mode 100644 index 0000000..052b5cc --- /dev/null +++ b/src/guile/skribilo/verify.scm @@ -0,0 +1,160 @@ +;;; verify.scm -- Skribe AST verification. +;;; +;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo verify) + :autoload (skribilo engine) (engine-ident processor-get-engine) + :autoload (skribilo writer) (writer? writer-options lookup-markup-writer) + :autoload (skribilo lib) (skribe-warning/ast skribe-warning + skribe-error) + :export (verify)) + +(use-modules (skribilo debug) + (skribilo ast) + (skribilo utils syntax) + (oop goops)) + +(fluid-set! current-reader %skribilo-module-reader) + + + +(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 #f "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 #f "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 #f "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) + +;;; verify.scm ends here \ No newline at end of file diff --git a/src/guile/skribilo/writer.scm b/src/guile/skribilo/writer.scm new file mode 100644 index 0000000..b16819d --- /dev/null +++ b/src/guile/skribilo/writer.scm @@ -0,0 +1,261 @@ +;;; writer.scm -- Markup writers. +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo writer) + :export ( writer? write-object writer-options writer-ident + writer-before writer-action writer-after writer-class + + invoke markup-writer markup-writer-get markup-writer-get* + lookup-markup-writer copy-markup-writer) + + :use-module (skribilo utils syntax) + :autoload (srfi srfi-1) (find filter) + :autoload (skribilo engine) (engine? engine-ident? default-engine)) + + +(use-modules (skribilo debug) + (skribilo output) + (skribilo ast) + (skribilo lib) + + (oop goops) + (ice-9 optargs)) + + +(fluid-set! current-reader %skribilo-module-reader) + + + +;;; +;;; Class definition. +;;; + +(define-class () + (ident :init-keyword :ident :init-value '??? :getter writer-ident) + (class :init-keyword :class :init-value 'unspecified + :getter writer-class) + (pred :init-keyword :pred :init-value 'unspecified) + (upred :init-keyword :upred :init-value 'unspecified) + (options :init-keyword :options :init-value '() :getter writer-options) + (verified? :init-keyword :verified? :init-value #f) + (validate :init-keyword :validate :init-value #f) + (before :init-keyword :before :init-value #f :getter writer-before) + (action :init-keyword :action :init-value #f :getter writer-action) + (after :init-keyword :after :init-value #f :getter writer-after)) + +(define (writer? obj) + (is-a? obj )) + +(define-method (write (obj ) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (object-address obj))) + + + +;;; +;;; Writer methods. +;;; + +(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))))) + + + +(define (make-writer-predicate markup predicate class) + (define (%always-true n e) #t) + + (let* ((t2 (if class + (lambda (n e) + (and (equal? (markup-class n) class))) + #f))) + (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 + (if (procedure? t2) + (lambda (n e) + (and (t2 n e) (predicate n e))) + predicate))) + t2))) + + +;;; +;;; `markup-writer' +;;; + +(define* (markup-writer markup ;; #:optional (engine #f) + #:key (predicate #f) (class #f) (options '()) + (validate #f) + (before #f) + (action 'unspecified) + (after #f) + #:rest engine) + ;;; FIXME: `lambda*' sucks and fails when both optional arguments and + ;;; keyword arguments are used together. In particular, if ENGINE is not + ;;; specified by the caller but other keyword arguments are specified, it + ;;; will consider the value of ENGINE to be the first keyword found. + +; (let ((e (or engine (default-engine)))) + (let ((e (or (if (and (list? engine) (not (keyword? (car engine)))) + (car engine) + #f) + (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)))))) + + + +;;; +;;; Finding a markup writer. +;;; + +(define (lookup-markup-writer node e) + ;; Find the writer that applies best to NODE. See also `markup-writer-get' + ;; and `markup-writer-get*'. + + (define (matching-writer writers) + (find (lambda (w) + (let ((pred (slot-ref w 'pred))) + (if (procedure? pred) + (pred node e) + #t))) + writers)) + + (let* ((writers (slot-ref e 'writers)) + (node-writers (hashq-ref writers (markup-markup node) '())) + (delegate (slot-ref e 'delegate))) + + (or (matching-writer node-writers) + (matching-writer (slot-ref e 'free-writers)) + (and (engine? delegate) + (lookup-markup-writer node delegate))))) + + +(define* (markup-writer-get markup :optional engine :key (class #f) (pred #f)) + ;; Get a markup writer for MARKUP (a symbol) in ENGINE, with class CLASS + ;; and user predicate PRED. [FIXME: Useless since PRED is a procedure and + ;; therefore not comparable?] + + (define (matching-writer writers) + (find (lambda (w) + (and (if class (equal? (writer-class w) class) #t) + (or (unspecified? pred) + (eq? (slot-ref w 'upred) pred)))) + writers)) + + (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* ((writers (slot-ref e 'writers)) + (markup-writers (hashq-ref writers markup '())) + (delegate (slot-ref e 'delegate))) + + (or (matching-writer markup-writers) + (and (engine? delegate) + (markup-writer-get markup delegate + :class class :pred pred)))))))) + + +(define* (markup-writer-get* markup #:optional engine #:key (class #f)) + ;; Finds all writers, recursively going through the engine hierarchy, that + ;; match MARKUP with optional CLASS attribute. + + (define (matching-writers writers) + (filter (lambda (w) + (or (not class) + (equal? (writer-class w) class))) + writers)) + + (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* ((writers (slot-ref e 'writers)) + (markup-writers (hashq-ref writers markup '())) + (delegate (slot-ref e 'delegate))) + + (append (matching-writers writers) + (if (engine? delegate) + (markup-writer-get* markup delegate :class class) + '()))))))) + + +(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)))) + +;;; writer.scm ends here diff --git a/src/skribe-config.in b/src/skribe-config.in new file mode 100644 index 0000000..2a03e26 --- /dev/null +++ b/src/skribe-config.in @@ -0,0 +1,64 @@ +#!/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/src/skribilo.in b/src/skribilo.in new file mode 100755 index 0000000..8d49f84 --- /dev/null +++ b/src/skribilo.in @@ -0,0 +1,40 @@ +#!/bin/sh + +# Copyright 2005, 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +# USA. + +# The `skribilo' executable. + +# Note: In Guile 1.8+ (or 1.9), when Guile is run in batch mode with +# `--debug', it produces a clean stack trace when an exception is +# raised and uncaught. On earlier versions, it behaves as if +# `--debug' had not been passed, not displaying a stack trace. See +# http://lists.gnu.org/archive/html/guile-devel/2006-01/msg00022.html +# for details. +# +# In any case, don't pass `--debug' by default (for performance +# reason). When needed, the use should explicitly set the `GUILE' +# environment variable to, e.g., "guile --debug". + +main='(module-ref (resolve-module '\''(skribilo)) '\'main')' +exec ${GUILE-@GUILE@} -c " +(use-modules (skribilo condition)) + +(call-with-skribilo-error-catch + (lambda () + (apply $main (cdr (command-line)))))" "$@" 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))) -) diff --git a/tools/Makefile b/tools/Makefile deleted file mode 100644 index 200db45..0000000 --- a/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/tools/skribebibtex/bigloo/Makefile b/tools/skribebibtex/bigloo/Makefile deleted file mode 100644 index c2a4cc1..0000000 --- a/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/tools/skribebibtex/bigloo/main.scm b/tools/skribebibtex/bigloo/main.scm deleted file mode 100644 index 3ff89de..0000000 --- a/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/tools/skribebibtex/bigloo/skribebibtex.scm b/tools/skribebibtex/bigloo/skribebibtex.scm deleted file mode 100644 index b581537..0000000 --- a/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/tools/skribebibtex/stklos/Makefile b/tools/skribebibtex/stklos/Makefile deleted file mode 100644 index 3e31d88..0000000 --- a/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/tools/skribebibtex/stklos/bibtex-lex.l b/tools/skribebibtex/stklos/bibtex-lex.l index 03b4871..fa43b69 100644 --- a/tools/skribebibtex/stklos/bibtex-lex.l +++ b/tools/skribebibtex/stklos/bibtex-lex.l @@ -16,7 +16,7 @@ ;;;; ;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/tools/skribebibtex/stklos/bibtex-parser.y b/tools/skribebibtex/stklos/bibtex-parser.y index 50236a9..77b619a 100644 --- a/tools/skribebibtex/stklos/bibtex-parser.y +++ b/tools/skribebibtex/stklos/bibtex-parser.y @@ -16,7 +16,7 @@ ;;;; ;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] diff --git a/tools/skribebibtex/stklos/main.stk b/tools/skribebibtex/stklos/main.stk index 3225658..db1b031 100644 --- a/tools/skribebibtex/stklos/main.stk +++ b/tools/skribebibtex/stklos/main.stk @@ -16,7 +16,7 @@ ;;;; ;;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;;; USA. ;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] -- cgit v1.2.3 From bdfed985ba33fe739a058da5395f9519ccb364cf Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 11 Oct 2006 07:44:12 +0000 Subject: Lout engine: Honor `date-line' for slides. * src/guile/skribilo/engine/lout.scm (document): Honor `date-line' for `slides' (was only honored for `report'). git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-2 --- src/guile/skribilo/engine/lout.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 893ab2e..f087d55 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -1051,23 +1051,25 @@ (output institution e) (printf " }\n")))))))) + (if (memq doc-type '(report slides)) + (let ((date-line (engine-custom e 'date-line))) + (display " @DateLine { ") + (if (or (string? date-line) (ast? date-line)) + (output date-line e) + (display (if date-line "Yes" "No"))) + (display " }\n"))) + ;; Lout reports make it possible to choose whether to prepend ;; a cover sheet (books and docs don't). Same for a date ;; line. (if (eq? doc-type 'report) (let ((cover-sheet? (engine-custom e 'cover-sheet?)) - (date-line (engine-custom e 'date-line)) (abstract (engine-custom e 'abstract)) (abstract-title (engine-custom e 'abstract-title))) (display (string-append " @CoverSheet { " (if cover-sheet? "Yes" "No") " }\n")) - (display " @DateLine { ") - (if (string? date-line) - (output date-line e) - (display (if date-line "Yes" "No"))) - (display " }\n") (if abstract (begin -- cgit v1.2.3 From d70f8ef391dd4a71ad26bbf76c6f33b0f7b47390 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 12 Oct 2006 16:01:47 +0000 Subject: prog: Fixed line number output (`&prog-line'). * src/guile/skribilo/engine/base.scm: Use `srfi-13'. (&prog-line): Use the `:number' markup option rather than the ident as the line number. * src/guile/skribilo/prog.scm: Use `%skribilo-module-reader'. (make-prog-body): Pass the line number as a `:number' markup option in the `&prog-line' markup. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-62 --- src/guile/skribilo/engine/base.scm | 12 +++++++++--- src/guile/skribilo/prog.scm | 10 ++++++++-- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm index 8418e8b..d49b732 100644 --- a/src/guile/skribilo/engine/base.scm +++ b/src/guile/skribilo/engine/base.scm @@ -1,6 +1,7 @@ ;;; base.scm -- BASE Skribe engine ;;; ;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 Ludovic Courtès ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -18,7 +19,8 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine base)) +(define-skribe-module (skribilo engine base) + :use-module (srfi srfi-13)) ;*---------------------------------------------------------------------*/ ;* base-engine ... */ @@ -457,8 +459,12 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&prog-line :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) + (let ((num (markup-option n :number))) + (if (number? num) + (skribe-eval + (it (string-append (string-pad (number->string num) 3) + ": ")) + e)))) :after "\n") ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm index 266d607..2f531cd 100644 --- a/src/guile/skribilo/prog.scm +++ b/src/guile/skribilo/prog.scm @@ -24,8 +24,13 @@ :autoload (ice-9 receive) (receive) :use-module (skribilo lib) ;; `new' :autoload (skribilo ast) (node? node-body) + :use-module (skribilo utils syntax) + :export (make-prog-body resolve-line)) +(fluid-set! current-reader %skribilo-module-reader) + + ;;; ====================================================================== ;;; ;;; COMPATIBILITY @@ -211,8 +216,9 @@ (extract-mark (car lines) mark regexp) (let* ((line-ident (symbol->string (gensym "&prog-line"))) (n (new markup - (markup '&prog-line) - (ident line-ident) + (markup '&prog-line) + (ident line-ident) + (options `((:number ,lnum))) (body (if m (make-line-mark m line-ident l) l))))) (loop (cdr lines) (+ lnum 1) -- cgit v1.2.3 From adf1188cc0997265df8b2ab4447852355a2a10d8 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 12 Oct 2006 16:06:26 +0000 Subject: doc: Fixed the Fibonacci example in ``Computer Programs''. * doc/user/prgm.skb: Use title case for the chapter title. * doc/user/src/prgm2.skb: Fixed the line numbers for `fib'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-63 --- doc/user/prgm.skb | 2 +- doc/user/src/prgm2.skb | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/user/prgm.skb b/doc/user/prgm.skb index 6fb44c9..1007268 100644 --- a/doc/user/prgm.skb +++ b/doc/user/prgm.skb @@ -29,7 +29,7 @@ ;*---------------------------------------------------------------------*/ ;* Computer programs */ ;*---------------------------------------------------------------------*/ -(chapter :title "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 diff --git a/doc/user/src/prgm2.skb b/doc/user/src/prgm2.skb index 5b5644b..2996cc8 100644 --- a/doc/user/src/prgm2.skb +++ b/doc/user/src/prgm2.skb @@ -5,8 +5,8 @@ ;!start (frame :width 100. - (prog :line 11 :mark #f - (source :language skribe :file "prgm.skb" :start 11 :stop 24))) + (prog :line 21 :mark #f + (source :language skribe :file "prgm.skb" :start 20 :stop 27))) ;!stop (p [Here is the source of the frame above:]) -- cgit v1.2.3 From e70968b7c7c309ce262794880ddb3a74beb48c64 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 12 Oct 2006 16:08:13 +0000 Subject: prog: Fixed line number output (`&prog-line'). * src/guile/skribilo/engine/base.scm: Use `srfi-13'. (&prog-line): Use the `:number' markup option rather than the ident as the line number. * src/guile/skribilo/prog.scm: Use `%skribilo-module-reader'. (make-prog-body): Pass the line number as a `:number' markup option in the `&prog-line' markup. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-3 --- src/guile/skribilo/engine/base.scm | 12 +++++++++--- src/guile/skribilo/prog.scm | 10 ++++++++-- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm index 8418e8b..d49b732 100644 --- a/src/guile/skribilo/engine/base.scm +++ b/src/guile/skribilo/engine/base.scm @@ -1,6 +1,7 @@ ;;; base.scm -- BASE Skribe engine ;;; ;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 Ludovic Courtès ;;; ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -18,7 +19,8 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine base)) +(define-skribe-module (skribilo engine base) + :use-module (srfi srfi-13)) ;*---------------------------------------------------------------------*/ ;* base-engine ... */ @@ -457,8 +459,12 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&prog-line :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) + (let ((num (markup-option n :number))) + (if (number? num) + (skribe-eval + (it (string-append (string-pad (number->string num) 3) + ": ")) + e)))) :after "\n") ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/prog.scm b/src/guile/skribilo/prog.scm index 266d607..2f531cd 100644 --- a/src/guile/skribilo/prog.scm +++ b/src/guile/skribilo/prog.scm @@ -24,8 +24,13 @@ :autoload (ice-9 receive) (receive) :use-module (skribilo lib) ;; `new' :autoload (skribilo ast) (node? node-body) + :use-module (skribilo utils syntax) + :export (make-prog-body resolve-line)) +(fluid-set! current-reader %skribilo-module-reader) + + ;;; ====================================================================== ;;; ;;; COMPATIBILITY @@ -211,8 +216,9 @@ (extract-mark (car lines) mark regexp) (let* ((line-ident (symbol->string (gensym "&prog-line"))) (n (new markup - (markup '&prog-line) - (ident line-ident) + (markup '&prog-line) + (ident line-ident) + (options `((:number ,lnum))) (body (if m (make-line-mark m line-ident l) l))))) (loop (cdr lines) (+ lnum 1) -- cgit v1.2.3 From 8704dcc76f1419fe915b53d574bf2f8e72a28be8 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 12 Oct 2006 16:08:38 +0000 Subject: doc: Fixed the Fibonacci example in ``Computer Programs''. * doc/user/prgm.skb: Use title case for the chapter title. * doc/user/src/prgm2.skb: Fixed the line numbers for `fib'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-4 --- doc/user/prgm.skb | 2 +- doc/user/src/prgm2.skb | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/user/prgm.skb b/doc/user/prgm.skb index 6fb44c9..1007268 100644 --- a/doc/user/prgm.skb +++ b/doc/user/prgm.skb @@ -29,7 +29,7 @@ ;*---------------------------------------------------------------------*/ ;* Computer programs */ ;*---------------------------------------------------------------------*/ -(chapter :title "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 diff --git a/doc/user/src/prgm2.skb b/doc/user/src/prgm2.skb index 5b5644b..2996cc8 100644 --- a/doc/user/src/prgm2.skb +++ b/doc/user/src/prgm2.skb @@ -5,8 +5,8 @@ ;!start (frame :width 100. - (prog :line 11 :mark #f - (source :language skribe :file "prgm.skb" :start 11 :stop 24))) + (prog :line 21 :mark #f + (source :language skribe :file "prgm.skb" :start 20 :stop 27))) ;!stop (p [Here is the source of the frame above:]) -- cgit v1.2.3 From 7639d83aaa159c6b34d8b3c4a06d0634679ab9f1 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 16 Oct 2006 14:55:25 +0000 Subject: Lout engine: Honor `inline-definitions-proc'. * src/guile/skribilo/engine/lout.scm (document): Invoke the procedure defined by the `inline-definitions-proc' rather than directly invoking `lout-definitions'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-64 --- src/guile/skribilo/engine/lout.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index f087d55..82e98d7 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -558,7 +558,7 @@ ;; also honor this custom for `doc' documents. (cover-sheet? #t) - ;; For reports, the date line. + ;; For reports and slides, the date line. (date-line #t) ;; For reports, an abstract. @@ -604,7 +604,7 @@ (use-skribe-footnote-numbers? #t) ;; A procedure that is passed the engine - ;; and produces Lout definitions. + ;; and returns Lout definitions (a string). (inline-definitions-proc ,lout-definitions) ;; A procedure that takes a URL `ref' markup and @@ -1012,7 +1012,7 @@ (display "@SysInclude { tbl }\n")) ;; Write additional Lout definitions - (display (lout-definitions e)) + (display ((engine-custom e 'inline-definitions-proc) e)) (case doc-type ((report) (display "@Report\n")) -- cgit v1.2.3 From f87559762f5faa6ce3ff093bfdd1e823a416676f Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 16 Oct 2006 18:18:40 +0000 Subject: Lout engine: Honor `inline-definitions-proc'. * src/guile/skribilo/engine/lout.scm (document): Invoke the procedure defined by the `inline-definitions-proc' rather than directly invoking `lout-definitions'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-5 --- src/guile/skribilo/engine/lout.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index f087d55..82e98d7 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -558,7 +558,7 @@ ;; also honor this custom for `doc' documents. (cover-sheet? #t) - ;; For reports, the date line. + ;; For reports and slides, the date line. (date-line #t) ;; For reports, an abstract. @@ -604,7 +604,7 @@ (use-skribe-footnote-numbers? #t) ;; A procedure that is passed the engine - ;; and produces Lout definitions. + ;; and returns Lout definitions (a string). (inline-definitions-proc ,lout-definitions) ;; A procedure that takes a URL `ref' markup and @@ -1012,7 +1012,7 @@ (display "@SysInclude { tbl }\n")) ;; Write additional Lout definitions - (display (lout-definitions e)) + (display ((engine-custom e 'inline-definitions-proc) e)) (case doc-type ((report) (display "@Report\n")) -- cgit v1.2.3 From adb2f652cd8d6075f0718a19f4942f6b5b573d07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 16 Oct 2006 21:14:12 +0000 Subject: color.scm: Added support for `lightred'. :-) * src/guile/skribilo/color.scm (*skribe-rgb-alist*): Added `lightred'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-6 --- ChangeLog | 13 +++++++++++++ src/guile/skribilo/color.scm | 3 ++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index c805653..9b5753b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,19 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-10-16 21:09:47 GMT Ludovic Courtes patch-79 + + Summary: + color.scm: Added support for `lightred'. :-) + Revision: + skribilo--devel--1.2--patch-79 + + * src/guile/skribilo/color.scm (*skribe-rgb-alist*): Added `lightred'. + + modified files: + ChangeLog src/guile/skribilo/color.scm + + 2006-09-04 09:15:58 GMT Ludovic Courtes patch-74 Summary: diff --git a/src/guile/skribilo/color.scm b/src/guile/skribilo/color.scm index 8b6205f..6b3aa7b 100644 --- a/src/guile/skribilo/color.scm +++ b/src/guile/skribilo/color.scm @@ -571,7 +571,8 @@ ("darkcyan" . "0 139 139") ("darkmagenta" . "139 0 139") ("darkred" . "139 0 0") - ("lightgreen" . "144 238 144"))) + ("lightgreen" . "144 238 144") + ("lightred" . "255 127 127"))) (define (%convert-color str) -- cgit v1.2.3 From 1b8ca0c62843d8879f44439614bcb0bc32fde930 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 23 Oct 2006 17:20:10 +0000 Subject: Added a `:arguments' keyword to `slide-embed'. * src/guile/skribilo/package/slide.scm (slide-embed): Added an `arguments' keyword. * doc/user/slide.skb: Updated the markup documentation. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-66 --- doc/user/slide.skb | 3 +++ src/guile/skribilo/package/slide.scm | 1 + 2 files changed, 4 insertions(+) diff --git a/doc/user/slide.skb b/doc/user/slide.skb index 3e903ad..f937a75 100644 --- a/doc/user/slide.skb +++ b/doc/user/slide.skb @@ -153,6 +153,8 @@ projection. This may not be supported by all engines.]) (doc-markup 'slide-embed `((:command [The binary file for running the embedded application.]) + (:arguments [Additional arguments to be passed to the +application (a list of strings).]) (:geometry-opt [The name of the geometry option to be sent to the embedded application.]) (:geometry [The geometry value to be sent.]) @@ -192,6 +194,7 @@ output format does not support embedded application.])) (markup-writer 'slide-vspace :action dummy-slide-vspace-output) (markup-writer 'slide-embed + :options '(:command :arguments :alt) :action dummy-slide-embed-output) e)) (include "src/slides.skb")))) diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index 7f731e3..c0a8473 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -146,6 +146,7 @@ (define-markup (slide-embed #!rest opt #!key command + (arguments '()) (geometry-opt "-geometry") (geometry #f) (rgeometry #f) (transient #f) (transient-opt #f) -- cgit v1.2.3 From 9fa09dca79ef41ff3e713203b6abde1d32b45723 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 23 Oct 2006 17:22:10 +0000 Subject: Lout engine: Implemented `slide-embed'. * src/guile/skribilo/engine/lout.scm (lout-definitions): Renamed `@SkribeMark' to `@SkribiloMark'. Added `@SkribiloEmbed'. * src/guile/skribilo/package/slide/lout.scm: No longer use `define-skribe-module'. (slide-embed): Use `@SkribiloEmbed' (works fine). git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-67 --- src/guile/skribilo/engine/lout.scm | 32 ++++++++++++++++--- src/guile/skribilo/package/slide/lout.scm | 53 ++++++++++++++++++------------- 2 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 82e98d7..d40f36a 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -378,9 +378,9 @@ (let ((leader (engine-custom engine 'toc-leader)) (leader-space (engine-custom engine 'toc-leader-space))) (apply string-append - `("# @SkribeMark implements Skribe's marks " + `("# @SkribiloMark implements Skribe's marks " "(i.e. cross-references)\n" - "def @SkribeMark\n" + "def @SkribiloMark\n" " right @Tag\n" "{\n" " @PageMark @Tag\n" @@ -389,7 +389,29 @@ "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" "def @SkribiloLeaders { " - ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n" + + "# Embedding an application in PDF (``Launch'' actions)\n" + "# (tested with XPdf 3.1 and Evince 0.4.0)\n" + "def @SkribiloEmbed\n" + " left command\n" + " import @PSLengths\n" + " named borderwidth { 1p }\n" + " right body\n" + "{\n" + " {\n" + " \"[ /Rect [0 0 xsize ysize]\"\n" + " \" /Color [0 0 1]\"\n" + " \" /Border [ 0 0 \" borderwidth \" ]\"\n" + " \" /Action /Launch\"\n" + " \" /File (\" command \")\"\n" + " \" /Subtype /Link\"\n" + " \"/ANN\"\n" + " \"pdfmark\"\n" + " }\n" + " @Graphic body\n" + "}\n\n")))) + (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -1319,7 +1341,7 @@ ;; Lout markup) (display "\n//1.8vx\n@B { ") (output title e) - (display " }\n@SkribeMark { ") + (display " }\n@SkribiloMark { ") (display (lout-tagify ident)) (display " }\n//0.8vx\n\n")) (begin @@ -2382,7 +2404,7 @@ :action (lambda (n e) (if (markup-ident n) (begin - (display "{ @SkribeMark { ") + (display "{ @SkribiloMark { ") (display (lout-tagify (markup-ident n))) (display " } }")) (skribe-error 'lout "mark: Node has no identifier" n)))) diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm index d53cff1..f3c9a61 100644 --- a/src/guile/skribilo/package/slide/lout.scm +++ b/src/guile/skribilo/package/slide/lout.scm @@ -18,9 +18,17 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo package slide lout) +(define-module (skribilo package slide lout) :use-module (skribilo utils syntax) + :autoload (skribilo utils strings) (make-string-replace) + :use-module (skribilo engine) + :use-module (skribilo writer) + :autoload (skribilo output) (output) + :use-module (skribilo ast) + + :use-module (srfi srfi-13) ;; `string-join' + ;; XXX: If changing the following `autoload' to `use-module' doesn't work, ;; then you need to fix your Guile. See this thread about ;; `make-autoload-interface': @@ -34,6 +42,7 @@ (fluid-set! current-reader %skribilo-module-reader) + ;;; TODO: ;;; ;;; Make some more PS/PDF trickery. @@ -83,7 +92,7 @@ (and (pair? (markup-body n)) (number? (car (markup-body n))))) :action (lambda (n e) - (printf "\n//~a~a # slide-vspace\n" + (format #t "\n//~a~a # slide-vspace\n" (car (markup-body n)) (case (markup-option n :unit) ((cm) "c") @@ -94,6 +103,25 @@ "Unknown vspace unit" (markup-option n :unit))))))) + (markup-writer 'slide-embed le + :options '(:command :arguments :alt :geometry :geometry-opt) + :action (lambda (n e) + (let ((command (markup-option n :command)) + (args (markup-option n :arguments)) + (alt (markup-option n :alt)) + (geometry (markup-option n :geometry)) + (geometry-opt (markup-option n :geometry-opt)) + (filter (make-string-replace lout-verbatim-encoding))) + (format #t "~%\"~a\" @SkribiloEmbed { " + (string-append command " " + (if (and geometry-opt geometry) + (string-append geometry-opt " " + geometry " ") + "") + (string-join args " "))) + (output alt e) + (format #t " }\n")))) + (markup-writer 'slide-pause le ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. ;; << /Type /Action @@ -109,26 +137,7 @@ ;; For movies, see ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . - (markup-writer 'slide-embed le - :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))))))))) + ) -- cgit v1.2.3 From 243aa4a26a7c087f4216eb3b537f355bc31a6d19 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 23 Oct 2006 17:25:00 +0000 Subject: Added a `:arguments' keyword to `slide-embed'. * src/guile/skribilo/package/slide.scm (slide-embed): Added an `arguments' keyword. * doc/user/slide.skb: Updated the markup documentation. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-7 --- doc/user/slide.skb | 3 +++ src/guile/skribilo/package/slide.scm | 1 + 2 files changed, 4 insertions(+) diff --git a/doc/user/slide.skb b/doc/user/slide.skb index 3e903ad..f937a75 100644 --- a/doc/user/slide.skb +++ b/doc/user/slide.skb @@ -153,6 +153,8 @@ projection. This may not be supported by all engines.]) (doc-markup 'slide-embed `((:command [The binary file for running the embedded application.]) + (:arguments [Additional arguments to be passed to the +application (a list of strings).]) (:geometry-opt [The name of the geometry option to be sent to the embedded application.]) (:geometry [The geometry value to be sent.]) @@ -192,6 +194,7 @@ output format does not support embedded application.])) (markup-writer 'slide-vspace :action dummy-slide-vspace-output) (markup-writer 'slide-embed + :options '(:command :arguments :alt) :action dummy-slide-embed-output) e)) (include "src/slides.skb")))) diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index 7f731e3..c0a8473 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -146,6 +146,7 @@ (define-markup (slide-embed #!rest opt #!key command + (arguments '()) (geometry-opt "-geometry") (geometry #f) (rgeometry #f) (transient #f) (transient-opt #f) -- cgit v1.2.3 From 867c18c525470e0a298c2b839f578016be17257b Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 23 Oct 2006 17:25:54 +0000 Subject: Lout engine: Implemented `slide-embed'. * src/guile/skribilo/engine/lout.scm (lout-definitions): Renamed `@SkribeMark' to `@SkribiloMark'. Added `@SkribiloEmbed'. * src/guile/skribilo/package/slide/lout.scm: No longer use `define-skribe-module'. (slide-embed): Use `@SkribiloEmbed' (works fine). git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-8 --- src/guile/skribilo/engine/lout.scm | 32 ++++++++++++++++--- src/guile/skribilo/package/slide/lout.scm | 53 ++++++++++++++++++------------- 2 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 82e98d7..d40f36a 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -378,9 +378,9 @@ (let ((leader (engine-custom engine 'toc-leader)) (leader-space (engine-custom engine 'toc-leader-space))) (apply string-append - `("# @SkribeMark implements Skribe's marks " + `("# @SkribiloMark implements Skribe's marks " "(i.e. cross-references)\n" - "def @SkribeMark\n" + "def @SkribiloMark\n" " right @Tag\n" "{\n" " @PageMark @Tag\n" @@ -389,7 +389,29 @@ "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" "def @SkribiloLeaders { " - ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n" + + "# Embedding an application in PDF (``Launch'' actions)\n" + "# (tested with XPdf 3.1 and Evince 0.4.0)\n" + "def @SkribiloEmbed\n" + " left command\n" + " import @PSLengths\n" + " named borderwidth { 1p }\n" + " right body\n" + "{\n" + " {\n" + " \"[ /Rect [0 0 xsize ysize]\"\n" + " \" /Color [0 0 1]\"\n" + " \" /Border [ 0 0 \" borderwidth \" ]\"\n" + " \" /Action /Launch\"\n" + " \" /File (\" command \")\"\n" + " \" /Subtype /Link\"\n" + " \"/ANN\"\n" + " \"pdfmark\"\n" + " }\n" + " @Graphic body\n" + "}\n\n")))) + (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -1319,7 +1341,7 @@ ;; Lout markup) (display "\n//1.8vx\n@B { ") (output title e) - (display " }\n@SkribeMark { ") + (display " }\n@SkribiloMark { ") (display (lout-tagify ident)) (display " }\n//0.8vx\n\n")) (begin @@ -2382,7 +2404,7 @@ :action (lambda (n e) (if (markup-ident n) (begin - (display "{ @SkribeMark { ") + (display "{ @SkribiloMark { ") (display (lout-tagify (markup-ident n))) (display " } }")) (skribe-error 'lout "mark: Node has no identifier" n)))) diff --git a/src/guile/skribilo/package/slide/lout.scm b/src/guile/skribilo/package/slide/lout.scm index d53cff1..f3c9a61 100644 --- a/src/guile/skribilo/package/slide/lout.scm +++ b/src/guile/skribilo/package/slide/lout.scm @@ -18,9 +18,17 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo package slide lout) +(define-module (skribilo package slide lout) :use-module (skribilo utils syntax) + :autoload (skribilo utils strings) (make-string-replace) + :use-module (skribilo engine) + :use-module (skribilo writer) + :autoload (skribilo output) (output) + :use-module (skribilo ast) + + :use-module (srfi srfi-13) ;; `string-join' + ;; XXX: If changing the following `autoload' to `use-module' doesn't work, ;; then you need to fix your Guile. See this thread about ;; `make-autoload-interface': @@ -34,6 +42,7 @@ (fluid-set! current-reader %skribilo-module-reader) + ;;; TODO: ;;; ;;; Make some more PS/PDF trickery. @@ -83,7 +92,7 @@ (and (pair? (markup-body n)) (number? (car (markup-body n))))) :action (lambda (n e) - (printf "\n//~a~a # slide-vspace\n" + (format #t "\n//~a~a # slide-vspace\n" (car (markup-body n)) (case (markup-option n :unit) ((cm) "c") @@ -94,6 +103,25 @@ "Unknown vspace unit" (markup-option n :unit))))))) + (markup-writer 'slide-embed le + :options '(:command :arguments :alt :geometry :geometry-opt) + :action (lambda (n e) + (let ((command (markup-option n :command)) + (args (markup-option n :arguments)) + (alt (markup-option n :alt)) + (geometry (markup-option n :geometry)) + (geometry-opt (markup-option n :geometry-opt)) + (filter (make-string-replace lout-verbatim-encoding))) + (format #t "~%\"~a\" @SkribiloEmbed { " + (string-append command " " + (if (and geometry-opt geometry) + (string-append geometry-opt " " + geometry " ") + "") + (string-join args " "))) + (output alt e) + (format #t " }\n")))) + (markup-writer 'slide-pause le ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. ;; << /Type /Action @@ -109,26 +137,7 @@ ;; For movies, see ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . - (markup-writer 'slide-embed le - :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))))))))) + ) -- cgit v1.2.3 From 85ce5551bc2af12450d10527f925181bd048e6bc Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 08:55:24 +0000 Subject: Lout engine: Added a `lout-program-arguments' custom. * src/guile/skribilo/engine/lout.scm (lout-engine)[lout-program-arguments]: New custom. (lout-illustration): Honor it. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-68 --- src/guile/skribilo/engine/lout.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index d40f36a..9b25f30 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -657,6 +657,10 @@ ;; `lout-illustration' on other back-ends. (lout-program-name "lout") + ;; Additional arguments that should be passed to + ;; Lout, e.g., `("-I foo" "-I bar")'. + (lout-program-arguments '()) + ;; Title and author information in the PDF ;; document information. If `#t', the ;; document's `:title' and `:author' are used. @@ -2872,11 +2876,13 @@ (gensym 'lout-illustration))) ".eps")) (port (open-output-pipe - (string-append (or (engine-custom lout - 'lout-program-name) - "lout") - " -o " output - " -EPS")))) + (apply string-append + (or (engine-custom lout 'lout-program-name) + "lout") + " -o " output + " -EPS " + (engine-custom lout + 'lout-program-arguments))))) ;; send the illustration to Lout's standard input (display (illustration-header) port) -- cgit v1.2.3 From 43d1ade366511da4dfd6af3f507a6713fb1ef0e7 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 12:41:54 +0000 Subject: slide: Improved HTML output, especially wrt. the use of CSS. * src/guile/skribilo/package/slide.scm (slide-topic): Pass CLASS as the `class' slot rather than as an option. (slide-subtopic): Likewise. * src/guile/skribilo/package/slide/base.scm (make-outline-slide): Use `(markup-class topic)' instead of `(markup-option topic :class)'. * src/guile/skribilo/package/slide/html.scm: Use a native Guile module. Use `format' instead of `printf'. (%slide-html-initialize): Simply issue `div' tags when a class is specified. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-69 --- src/guile/skribilo/package/slide.scm | 10 ++- src/guile/skribilo/package/slide/base.scm | 2 +- src/guile/skribilo/package/slide/html.scm | 123 +++++++++++++++++++++--------- 3 files changed, 96 insertions(+), 39 deletions(-) diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index c0a8473..898f105 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -228,13 +228,14 @@ ;*---------------------------------------------------------------------*/ (define-markup (slide-topic #!rest opt #!key title (outline? #t) - (ident #f) (class "slide-topic")) + (ident #f) (class #f)) (new container (markup 'slide-topic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-topic)))) + (class class) (options `((:outline? ,outline?) - ,@(the-options opt :outline?))) + ,@(the-options opt :outline? :class))) (body (the-body opt)))) ;*---------------------------------------------------------------------*/ @@ -242,13 +243,14 @@ ;*---------------------------------------------------------------------*/ (define-markup (slide-subtopic #!rest opt #!key title (outline? #f) - (ident #f) (class "slide-subtopic")) + (ident #f) (class #f)) (new container (markup 'slide-subtopic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (class class) (options `((:outline? ,outline?) - ,@(the-options opt :outline?))) + ,@(the-options opt :outline? :class))) (body (the-body opt)))) diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm index c8e652c..1eeb25f 100644 --- a/src/guile/skribilo/package/slide/base.scm +++ b/src/guile/skribilo/package/slide/base.scm @@ -155,7 +155,7 @@ (is-markup? n 'slide-topic)) topic)))) (output (slide :title %slide-outline-title :toc #f - :class (markup-option topic :class) + :class (markup-class topic) ;; The mark below is needed for cross-referencing by PDF ;; bookmarks. (if (markup-ident topic) (mark (markup-ident topic)) "") diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index d47ef82..8fcbfed 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -18,43 +18,77 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo package slide html) - :use-module (skribilo package slide)) +(define-module (skribilo package slide html) + :use-module (skribilo utils syntax) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :autoload (skribilo resolve) (resolve!) + :autoload (skribilo output) (output) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo engine html) (html-width html-title-authors) + :use-module (skribilo package slide) + :use-module ((skribilo package base) :select (ref))) + + +(fluid-set! current-reader %skribilo-module-reader) + + + (define-public (%slide-html-initialize!) (let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") + (display "HTML slides setup...\n" (current-error-port)) + ;; &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)) + (format #t "" (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 #f "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) + (t (markup-option n :title)) + (class (markup-class n))) + (if class + (let ((title-class (string-append class "-title"))) + ;; When a class is specified, let the user play + ;; with CSS. + (format #t "\n
" class) + (format #t "\n\n" + (markup-ident n)) + (format #t "
" title-class) + (format #t "~a / ~a -- " nb (slide-number)) + (output t e) + (display "
\n") + (output (markup-body n) e) + (display "\n
\n")) + ;; When no class is specified, do HTML tricks. + (evaluate-document + (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 #f "~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 "
"))))) @@ -76,23 +110,23 @@ (tbg (engine-custom e 'title-background)) (tfg (engine-custom e 'title-foreground)) (tfont (engine-custom e 'title-font))) - (printf "
\n" + (format #t "
\n" (html-width (slide-body-width e))) (if (string? tbg) - (printf "
" tbg) + (format #t "" tbg) (display "")) (if (string? tfg) - (printf "" tfg)) + (format #t "" tfg)) (if title (begin (display "
") (if (string? tfont) (begin - (printf "" tfont) + (format #t "" tfont) (output title e) (display "")) (begin - (printf "
") + (display "
") (output title e) (display ""))) (display "
\n"))) @@ -113,22 +147,43 @@ :options '(:title :outline? :class :ident) :action (lambda (n e) (let ((title (markup-option n :title)) - (body (markup-body n))) - (display "\n

") + (body (markup-body n)) + (class (markup-class n))) + ;; top-level class + (if class (format #t "\n
" class)) + + ;; the title + (if class + (format #t "\n
" class) + (display "\n

")) (if (markup-ident n) - (printf "" (markup-ident n))) + (format #t "" (markup-ident n))) (output title e) - (display "


\n") - (display "\n
") + (if class + (display "
\n") + (display "


\n")) + + ;; pointers to the slides + (if class + (format #t "\n
" + class) + (display "\n
")) (for-each (lambda (s) - (output (markup-option s :title) e) - (display " -- ")) + (let* ((title (markup-option s :title)) + (ident (markup-ident s)) + (sref (ref :text title :ident ident)) + (sref* (resolve! sref e `((parent ,n))))) + (output sref* e) + (display " -- "))) (filter (lambda (n) (or (is-markup? n 'slide-subtopic) (is-markup? n 'slide))) (markup-body n))) (display "\n
") - (display "\n

\n") + + (if class + (display "\n
\n") + (display "\n

\n")) ;; the slides (output (markup-body n) e)))) -- cgit v1.2.3 From c63e6405a4e1b5d28a2a69b4623263dc37cbd4f2 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 13:03:46 +0000 Subject: slide/html: Issue only one anchor per slide. * src/guile/skribilo/package/slide/html.scm (%slide-html-initialize!)[slide]: Issue only one anchor per slide. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-70 --- src/guile/skribilo/package/slide/html.scm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index 8fcbfed..024e1fd 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -50,8 +50,8 @@ (markup-writer 'slide he :options '(:title :number :transition :toc :bg) :before (lambda (n e) - (format #t "" (markup-ident n)) - (display "
\n")) + (display "
\n") + (format #t "" (markup-ident n))) :action (lambda (n e) (let ((nb (markup-option n :number)) (t (markup-option n :title)) @@ -61,8 +61,6 @@ ;; When a class is specified, let the user play ;; with CSS. (format #t "\n
" class) - (format #t "\n\n" - (markup-ident n)) (format #t "
" title-class) (format #t "~a / ~a -- " nb (slide-number)) (output t e) -- cgit v1.2.3 From 3fb6f9a17400d8365519e05a79f09c6c1322eedd Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 15:04:26 +0000 Subject: Lout engine: Added a `lout-program-arguments' custom. * src/guile/skribilo/engine/lout.scm (lout-engine)[lout-program-arguments]: New custom. (lout-illustration): Honor it. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-9 --- src/guile/skribilo/engine/lout.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index d40f36a..9b25f30 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -657,6 +657,10 @@ ;; `lout-illustration' on other back-ends. (lout-program-name "lout") + ;; Additional arguments that should be passed to + ;; Lout, e.g., `("-I foo" "-I bar")'. + (lout-program-arguments '()) + ;; Title and author information in the PDF ;; document information. If `#t', the ;; document's `:title' and `:author' are used. @@ -2872,11 +2876,13 @@ (gensym 'lout-illustration))) ".eps")) (port (open-output-pipe - (string-append (or (engine-custom lout - 'lout-program-name) - "lout") - " -o " output - " -EPS")))) + (apply string-append + (or (engine-custom lout 'lout-program-name) + "lout") + " -o " output + " -EPS " + (engine-custom lout + 'lout-program-arguments))))) ;; send the illustration to Lout's standard input (display (illustration-header) port) -- cgit v1.2.3 From 6a06d0449967e85c3aa806736e1a27c9db99db71 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 15:04:52 +0000 Subject: slide: Improved HTML output, especially wrt. the use of CSS. * src/guile/skribilo/package/slide.scm (slide-topic): Pass CLASS as the `class' slot rather than as an option. (slide-subtopic): Likewise. * src/guile/skribilo/package/slide/base.scm (make-outline-slide): Use `(markup-class topic)' instead of `(markup-option topic :class)'. * src/guile/skribilo/package/slide/html.scm: Use a native Guile module. Use `format' instead of `printf'. (%slide-html-initialize): Simply issue `div' tags when a class is specified. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-10 --- src/guile/skribilo/package/slide.scm | 10 ++- src/guile/skribilo/package/slide/base.scm | 2 +- src/guile/skribilo/package/slide/html.scm | 123 +++++++++++++++++++++--------- 3 files changed, 96 insertions(+), 39 deletions(-) diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm index c0a8473..898f105 100644 --- a/src/guile/skribilo/package/slide.scm +++ b/src/guile/skribilo/package/slide.scm @@ -228,13 +228,14 @@ ;*---------------------------------------------------------------------*/ (define-markup (slide-topic #!rest opt #!key title (outline? #t) - (ident #f) (class "slide-topic")) + (ident #f) (class #f)) (new container (markup 'slide-topic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-topic)))) + (class class) (options `((:outline? ,outline?) - ,@(the-options opt :outline?))) + ,@(the-options opt :outline? :class))) (body (the-body opt)))) ;*---------------------------------------------------------------------*/ @@ -242,13 +243,14 @@ ;*---------------------------------------------------------------------*/ (define-markup (slide-subtopic #!rest opt #!key title (outline? #f) - (ident #f) (class "slide-subtopic")) + (ident #f) (class #f)) (new container (markup 'slide-subtopic) (required-options '(:title :outline?)) (ident (or ident (symbol->string (gensym 'slide-subtopic)))) + (class class) (options `((:outline? ,outline?) - ,@(the-options opt :outline?))) + ,@(the-options opt :outline? :class))) (body (the-body opt)))) diff --git a/src/guile/skribilo/package/slide/base.scm b/src/guile/skribilo/package/slide/base.scm index c8e652c..1eeb25f 100644 --- a/src/guile/skribilo/package/slide/base.scm +++ b/src/guile/skribilo/package/slide/base.scm @@ -155,7 +155,7 @@ (is-markup? n 'slide-topic)) topic)))) (output (slide :title %slide-outline-title :toc #f - :class (markup-option topic :class) + :class (markup-class topic) ;; The mark below is needed for cross-referencing by PDF ;; bookmarks. (if (markup-ident topic) (mark (markup-ident topic)) "") diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index d47ef82..8fcbfed 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -18,43 +18,77 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo package slide html) - :use-module (skribilo package slide)) +(define-module (skribilo package slide html) + :use-module (skribilo utils syntax) + :use-module (skribilo ast) + :use-module (skribilo engine) + :use-module (skribilo writer) + :autoload (skribilo resolve) (resolve!) + :autoload (skribilo output) (output) + :autoload (skribilo evaluator) (evaluate-document) + :autoload (skribilo engine html) (html-width html-title-authors) + :use-module (skribilo package slide) + :use-module ((skribilo package base) :select (ref))) + + +(fluid-set! current-reader %skribilo-module-reader) + + + (define-public (%slide-html-initialize!) (let ((he (find-engine 'html))) - (skribe-message "HTML slides setup...\n") + (display "HTML slides setup...\n" (current-error-port)) + ;; &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)) + (format #t "" (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 #f "~a / ~a -- " nb - (slide-number))) - t))) - (tr (td (hrule))) - (tr (td :width 100. :align 'left - (markup-body n)))) - (linebreak))) - e))) + (t (markup-option n :title)) + (class (markup-class n))) + (if class + (let ((title-class (string-append class "-title"))) + ;; When a class is specified, let the user play + ;; with CSS. + (format #t "\n
" class) + (format #t "\n\n" + (markup-ident n)) + (format #t "
" title-class) + (format #t "~a / ~a -- " nb (slide-number)) + (output t e) + (display "
\n") + (output (markup-body n) e) + (display "\n
\n")) + ;; When no class is specified, do HTML tricks. + (evaluate-document + (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 #f "~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 "
"))))) @@ -76,23 +110,23 @@ (tbg (engine-custom e 'title-background)) (tfg (engine-custom e 'title-foreground)) (tfont (engine-custom e 'title-font))) - (printf "
\n" + (format #t "
\n" (html-width (slide-body-width e))) (if (string? tbg) - (printf "
" tbg) + (format #t "" tbg) (display "")) (if (string? tfg) - (printf "" tfg)) + (format #t "" tfg)) (if title (begin (display "
") (if (string? tfont) (begin - (printf "" tfont) + (format #t "" tfont) (output title e) (display "")) (begin - (printf "
") + (display "
") (output title e) (display ""))) (display "
\n"))) @@ -113,22 +147,43 @@ :options '(:title :outline? :class :ident) :action (lambda (n e) (let ((title (markup-option n :title)) - (body (markup-body n))) - (display "\n

") + (body (markup-body n)) + (class (markup-class n))) + ;; top-level class + (if class (format #t "\n
" class)) + + ;; the title + (if class + (format #t "\n
" class) + (display "\n

")) (if (markup-ident n) - (printf "" (markup-ident n))) + (format #t "" (markup-ident n))) (output title e) - (display "


\n") - (display "\n
") + (if class + (display "
\n") + (display "


\n")) + + ;; pointers to the slides + (if class + (format #t "\n
" + class) + (display "\n
")) (for-each (lambda (s) - (output (markup-option s :title) e) - (display " -- ")) + (let* ((title (markup-option s :title)) + (ident (markup-ident s)) + (sref (ref :text title :ident ident)) + (sref* (resolve! sref e `((parent ,n))))) + (output sref* e) + (display " -- "))) (filter (lambda (n) (or (is-markup? n 'slide-subtopic) (is-markup? n 'slide))) (markup-body n))) (display "\n
") - (display "\n

\n") + + (if class + (display "\n
\n") + (display "\n

\n")) ;; the slides (output (markup-body n) e)))) -- cgit v1.2.3 From 3fbd7575228bd70bf077272f7c1a6320e3f94084 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 25 Oct 2006 15:05:17 +0000 Subject: slide/html: Issue only one anchor per slide. * src/guile/skribilo/package/slide/html.scm (%slide-html-initialize!)[slide]: Issue only one anchor per slide. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-11 --- src/guile/skribilo/package/slide/html.scm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/guile/skribilo/package/slide/html.scm b/src/guile/skribilo/package/slide/html.scm index 8fcbfed..024e1fd 100644 --- a/src/guile/skribilo/package/slide/html.scm +++ b/src/guile/skribilo/package/slide/html.scm @@ -50,8 +50,8 @@ (markup-writer 'slide he :options '(:title :number :transition :toc :bg) :before (lambda (n e) - (format #t "" (markup-ident n)) - (display "
\n")) + (display "
\n") + (format #t "" (markup-ident n))) :action (lambda (n e) (let ((nb (markup-option n :number)) (t (markup-option n :title)) @@ -61,8 +61,6 @@ ;; When a class is specified, let the user play ;; with CSS. (format #t "\n
" class) - (format #t "\n\n" - (markup-ident n)) (format #t "
" title-class) (format #t "~a / ~a -- " nb (slide-number)) (output t e) -- cgit v1.2.3 From 7aa414f8e82b4faa0742a22b9dc092a44dabdf9e Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Sat, 11 Nov 2006 17:39:17 +0000 Subject: lout engine: Fixed the default value of `lout-program-arguments'. * src/guile/skribilo/engine/lout.scm (lout-engine): Set default value of `lout-program-arguments' to `()'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-71 --- src/guile/skribilo/engine/lout.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 9b25f30..ddbb7b7 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -659,7 +659,7 @@ ;; Additional arguments that should be passed to ;; Lout, e.g., `("-I foo" "-I bar")'. - (lout-program-arguments '()) + (lout-program-arguments ()) ;; Title and author information in the PDF ;; document information. If `#t', the -- cgit v1.2.3 From 5708adbcc1e6b4333f675fb98130beca8b92c506 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Sat, 11 Nov 2006 17:40:09 +0000 Subject: lout engine: Fixed the default value of `lout-program-arguments'. * src/guile/skribilo/engine/lout.scm (lout-engine): Set default value of `lout-program-arguments' to `()'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-12 --- src/guile/skribilo/engine/lout.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 9b25f30..ddbb7b7 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -659,7 +659,7 @@ ;; Additional arguments that should be passed to ;; Lout, e.g., `("-I foo" "-I bar")'. - (lout-program-arguments '()) + (lout-program-arguments ()) ;; Title and author information in the PDF ;; document information. If `#t', the -- cgit v1.2.3 From 3d912da3bea0c47492125f59ae71209116fa522a Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 12 Nov 2006 12:54:10 +0000 Subject: Added the `(skribilo biblio template)' module. * src/guile/skribilo/engine/base.scm: Autoload `(skribilo biblio template)'. (&bib-entry-url): New writer. (&bib-entry-body)[output-fields]: Removed. Moved to the new module as `output-bib-entry-template'. Use it, as well as `make-bib-entry-template/default'. (&bib-entry-title): Don't produce bold text. (&bib-entry-booktitle): New writer. (&bib-entry-journal): New writer. * src/guile/skribilo/biblio/Makefile.am (dist_guilemodule_DATA): Added `template.scm'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-13 --- ChangeLog | 199 +++++++++++++++++++++++++++++++++ src/guile/skribilo/biblio/Makefile.am | 2 +- src/guile/skribilo/biblio/template.scm | 194 ++++++++++++++++++++++++++++++++ src/guile/skribilo/engine/base.scm | 121 +++++++------------- 4 files changed, 433 insertions(+), 83 deletions(-) create mode 100644 src/guile/skribilo/biblio/template.scm diff --git a/ChangeLog b/ChangeLog index 9b5753b..ba057f9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,106 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-11-11 22:59:55 GMT Ludovic Courtes patch-82 + + Summary: + Added the `(skribilo biblio template)' module. + Revision: + skribilo--devel--1.2--patch-82 + + * src/guile/skribilo/engine/base.scm: Autoload `(skribilo biblio + template)'. + (&bib-entry-url): New writer. + (&bib-entry-body)[output-fields]: Removed. Moved to the new module as + `output-bib-entry-template'. Use it, as well as + `make-bib-entry-template/default'. + (&bib-entry-title): Don't produce bold text. + (&bib-entry-booktitle): New writer. + (&bib-entry-journal): New writer. + + * src/guile/skribilo/biblio/Makefile.am (dist_guilemodule_DATA): Added + `template.scm'. + + new files: + src/guile/skribilo/biblio/template.scm + + modified files: + ChangeLog src/guile/skribilo/biblio/Makefile.am + src/guile/skribilo/engine/base.scm + + +2006-11-11 17:44:08 GMT Ludovic Courtes patch-81 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-81 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 71) + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 12) + + - lout engine: Fixed the default value of `lout-program-arguments'. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-71 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-12 + + +2006-11-11 17:03:53 GMT Ludovic Courtes patch-80 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-80 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 65-70) + + - Merge from skribilo@sv.gnu.org--2006 + - Added a `:arguments' keyword to `slide-embed'. + - Lout engine: Implemented `slide-embed'. + - Lout engine: Added a `lout-program-arguments' custom. + - slide: Improved HTML output, especially wrt. the use of CSS. + - slide/html: Issue only one anchor per slide. + + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 6-11) + + - color.scm: Added support for `lightred'. :-) + - Added a `:arguments' keyword to `slide-embed'. + - Lout engine: Implemented `slide-embed'. + - Lout engine: Added a `lout-program-arguments' custom. + - slide: Improved HTML output, especially wrt. the use of CSS. + - slide/html: Issue only one anchor per slide. + + modified files: + ChangeLog doc/user/slide.skb + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/package/slide.scm + src/guile/skribilo/package/slide/base.scm + src/guile/skribilo/package/slide/html.scm + src/guile/skribilo/package/slide/lout.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-65 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-66 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-67 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-68 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-69 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-70 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-6 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-7 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-8 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-9 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-10 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-11 + + 2006-10-16 21:09:47 GMT Ludovic Courtes patch-79 Summary: @@ -15,6 +115,105 @@ ChangeLog src/guile/skribilo/color.scm +2006-10-16 18:20:03 GMT Ludovic Courtes patch-78 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-78 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 64) + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 5) + + - Lout engine: Honor `inline-definitions-proc'. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-64 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-5 + + +2006-10-15 20:46:11 GMT Ludovic Courtes patch-77 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-77 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 62-63) + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 3-4) + + - prog: Fixed line number output (`&prog-line'). + - doc: Fixed the Fibonacci example in ``Computer Programs''. + + modified files: + ChangeLog doc/user/prgm.skb doc/user/src/prgm2.skb + src/guile/skribilo/engine/base.scm src/guile/skribilo/prog.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-62 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-63 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-3 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-4 + + +2006-10-11 07:55:00 GMT Ludovic Courtes patch-76 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-76 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 60-61) + + - slide: Propagate the `outline?' parameter in `slide-(sub)?topic'. + - Lout engine: Honor `date-line' for slides. + + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (base, patch 1-2) + + - tag of lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-59 + - slide: Propagate the `outline?' parameter in `slide-(sub)?topic'. + - Lout engine: Honor `date-line' for slides. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + src/guile/skribilo/package/slide.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-60 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-61 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--base-0 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-2 + + +2006-09-14 17:31:46 GMT Ludovic Courtes patch-75 + + Summary: + Adding missing patch logs from `lcourtes@laas.fr--2005-libre'. + Revision: + skribilo--devel--1.2--patch-75 + + + modified files: + ChangeLog + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-55 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-56 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-57 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-58 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-59 + + 2006-09-04 09:15:58 GMT Ludovic Courtes patch-74 Summary: diff --git a/src/guile/skribilo/biblio/Makefile.am b/src/guile/skribilo/biblio/Makefile.am index 9442562..ee81406 100644 --- a/src/guile/skribilo/biblio/Makefile.am +++ b/src/guile/skribilo/biblio/Makefile.am @@ -1,4 +1,4 @@ guilemoduledir = $(GUILE_SITE)/skribilo/biblio -dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm +dist_guilemodule_DATA = bibtex.scm author.scm abbrev.scm template.scm ## arch-tag: aeffaead-c3f0-47f3-a0b3-bb3e22da2657 diff --git a/src/guile/skribilo/biblio/template.scm b/src/guile/skribilo/biblio/template.scm new file mode 100644 index 0000000..da0c948 --- /dev/null +++ b/src/guile/skribilo/biblio/template.scm @@ -0,0 +1,194 @@ +;;; template.scm -- Template system for bibliography entries. +;;; +;;; Copyright 2003, 2004 Manuel Serrano +;;; Copyright 2006 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo biblio template) + :use-module (skribilo ast) + :autoload (skribilo lib) (skribe-error) + :autoload (skribilo output) (output) + + :use-module (ice-9 optargs) + + :use-module (skribilo utils syntax) + + :export (output-bib-entry-template + make-bib-entry-template/default + make-bib-entry-template/skribe)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Manuel Serrano, Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides a helper procedure to output bibliography entries +;;; according to a given template, as well as ready-to-use templates. A +;;; template only contains part of the style information for a bibliography +;;; entry. Specific style information can be added by modifying the markup +;;; writers for `&bib-entry-author', `&bib-entry-title', etc. (see `(skribilo +;;; package base)' for details). +;;; +;;; Code: + + +;;; +;;; Outputting a bibliography entry template for a specific entry. +;;; + +(define* (output-bib-entry-template bib engine template + :optional (get-field markup-option)) + ;; Output the fields of BIB (a bibliography entry) for ENGINE according to + ;; TEMPLATE. Example of templates are found below (e.g., + ;; `make-bib-entry-template/default'). + (let loop ((template template) + (pending #f) + (armed #f)) + (cond + ((null? template) + 'done) + ((pair? (car template)) + (if (eq? (caar template) 'or) + (let ((o1 (cadr (car template)))) + (if (get-field bib o1) + (loop (cons o1 (cdr template)) + pending + #t) + (let ((o2 (caddr (car template)))) + (loop (cons o2 (cdr template)) + pending + armed)))) + (let ((o (get-field bib (cadr (car template))))) + (if o + (begin + (if (and pending armed) + (output pending engine)) + (output (caar template) engine) + (output o engine) + (if (pair? (cddr (car template))) + (output (caddr (car template)) engine)) + (loop (cdr template) #f #t)) + (loop (cdr template) pending armed))))) + ((symbol? (car template)) + (let ((o (get-field bib (car template)))) + (if o + (begin + (if (and armed pending) + (output pending engine)) + (output o engine) + (loop (cdr template) #f #t)) + (loop (cdr template) pending armed)))) + ((null? (cdr template)) + (output (car template) engine)) + ((string? (car template)) + (loop (cdr template) + (if pending pending (car template)) + armed)) + (else + (skribe-error 'output-bib-fields + "Illegal templateiption" + (car template)))))) + + +;;; +;;; Example bibliography entry templates. +;;; + +(define (make-bib-entry-template/default kind) + ;; The default bibliography entry template. + (case kind + ((techreport) + `(author ". " (or title url documenturl) ". " + number ", " institution ", " + address ", " month " " year ", " + ("pp. " pages) ".")) + ((article) + `(author ". " (or title url documenturl) ". " + "In " journal ", " volume + ("(" number ")") ", " + address ", " month " " year ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author ". " (or title url documenturl) ". " + "In " booktitle ", " + (series ", ") + ("(" number ")") + ("pp. " pages ", ") + ;; FIXME: Addr., month., pub. + year ".")) + ((book) ;; FIXME: Title should be in italics + '(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 + (", " url) ".")) + (else + '(author ". " (or title url documenturl) ". " + publisher ", " address + ", " month " " year ", " + ("pp. " pages) ".")))) + +(define (make-bib-entry-template/skribe kind) + ;; The awful template found by default in Skribe. + (case 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) ".")))) + + +;;; arch-tag: 5931579f-b606-442d-9a45-6047c94da5a2 + +;;; template.scm ends here diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm index d49b732..3b70f66 100644 --- a/src/guile/skribilo/engine/base.scm +++ b/src/guile/skribilo/engine/base.scm @@ -20,6 +20,8 @@ ;;; USA. (define-skribe-module (skribilo engine base) + :autoload (skribilo biblio template) (make-bib-entry-template/default + output-bib-entry-template) :use-module (srfi srfi-13)) ;*---------------------------------------------------------------------*/ @@ -217,92 +219,32 @@ :action (lambda (n e) (output (markup-option n :title) e)) :after "]") +;*---------------------------------------------------------------------*/ +;* &bib-entry-author ... */ +;*---------------------------------------------------------------------*/ +; (markup-writer '&bib-entry-author +; :action (lambda (n e) +; (let ((names (markup-body n))) +; (skribe-eval +; (sc (abbreviate-first-names names)) e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let ((url (markup-body n))) + (skribe-eval + (ref :text (it url) :url url) e)))) + ;*---------------------------------------------------------------------*/ ;* &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) ".")))))) + (let* ((kind (markup-option n 'kind)) + (template (make-bib-entry-template/default kind))) + (output-bib-entry-template n e template)))) ;*---------------------------------------------------------------------*/ ;* &bib-entry-ident ... */ @@ -316,7 +258,22 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&bib-entry-title :action (lambda (n e) - (skribe-eval (bold (markup-body n)) e))) + (skribe-eval (markup-body n)) e)) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-booktitle ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-booktitle + :action (lambda (n e) + (let ((title (markup-body n))) + (skribe-eval (it title) e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-journal ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-journal + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) ;*---------------------------------------------------------------------*/ ;* &bib-entry-publisher ... */ -- cgit v1.2.3 From ac3be3e363a8c8b496f5eeff5ac6c62f2b14780e Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 12 Nov 2006 12:55:51 +0000 Subject: Lout engine: Make URLs breakable; make bibliography defaults sane. * src/guile/skribilo/engine/lout.scm (lout-split-external-link): Use `!lout' and `lout-make-url-breakable'. (lout-make-url-breakable): New, taken from `url-ref'. (url-ref): Use it. (&bib-entry-title): Don't issue bold text. (&bib-entry-url): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-14 --- ChangeLog | 18 ++++++++++++++++++ src/guile/skribilo/engine/lout.scm | 36 ++++++++++++++++++++---------------- 2 files changed, 38 insertions(+), 16 deletions(-) diff --git a/ChangeLog b/ChangeLog index ba057f9..f0cafb4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,24 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-11-11 23:02:57 GMT Ludovic Courtes patch-83 + + Summary: + Lout engine: Make URLs breakable; make bibliography defaults sane. + Revision: + skribilo--devel--1.2--patch-83 + + * src/guile/skribilo/engine/lout.scm (lout-split-external-link): Use + `!lout' and `lout-make-url-breakable'. + (lout-make-url-breakable): New, taken from `url-ref'. + (url-ref): Use it. + (&bib-entry-title): Don't issue bold text. + (&bib-entry-url): Likewise. + + modified files: + ChangeLog src/guile/skribilo/engine/lout.scm + + 2006-11-11 22:59:55 GMT Ludovic Courtes patch-82 Summary: diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index ddbb7b7..92977e7 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -472,7 +472,8 @@ (loop (- where 1)) where))))) `(,(ref :url url :text (substring text 0 split)) - ,(substring text split len))) + ,(!lout (lout-make-url-breakable + (substring text split len))))) (list markup)))) ((markup? text) @@ -2518,6 +2519,19 @@ (loop (cdr rs))))))))) :after "]") +;*---------------------------------------------------------------------*/ +;* lout-make-url-breakable ... */ +;*---------------------------------------------------------------------*/ +(define-public lout-make-url-breakable + ;; Make the given string (which is assumed to be a URL) breakable. + (make-string-replace `((#\/ "\"/\"&0ik{}") + (#\. ".&0ik{}") + (#\- "-&0ik{}") + (#\_ "_&0ik{}") + (#\@ "\"@\"&0ik{}") + ,@lout-verbatim-encoding + (#\newline "")))) + ;*---------------------------------------------------------------------*/ ;* url-ref ... */ ;*---------------------------------------------------------------------*/ @@ -2531,19 +2545,9 @@ (markup-option n '&transformed)) (begin (printf "{ \"~a\" @ExternalLink { " url) - (if text ;; FIXME: Should be (not (string-index text #\space)) - (output text e) - (let ((filter-url (make-string-replace - `((#\/ "\"/\"&-") - (#\. ".&-") - (#\- "&-") - (#\_ "_&-") - ,@lout-verbatim-encoding - (#\newline ""))))) - ;; Filter the URL in a way to give Lout hints on - ;; where hyphenation should take place. - (fprint (current-error-port) "Here!!!" filter-url) - (display (filter-url url) e))) + (if text + (output text e) + (display (lout-make-url-breakable url) e)) (printf " } }")) (begin (markup-option-add! n '&transformed #t) @@ -2630,7 +2634,7 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&bib-entry-title :action (lambda (n e) - (let* ((t (bold (markup-body n))) + (let* ((t (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))) @@ -2652,7 +2656,7 @@ :action (lambda (n e) (let* ((en (handle-ast (ast-parent n))) (url (markup-option en 'url)) - (t (bold (markup-body url)))) + (t (it (markup-body url)))) (skribe-eval (ref :url (markup-body url) :text t) e)))) ;*---------------------------------------------------------------------*/ -- cgit v1.2.3 From 69e3db9b7750f8f0642701551de033fef07cc276 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 13 Nov 2006 09:59:50 +0000 Subject: Lout engine: Better cover sheet for `doc' documents. * src/guile/skribilo/engine/lout.scm (lout-make-doc-cover-sheet): Improved spacing. Moved `date-line' after `author'. Provide a default value for `date-line' when it's `#t'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-73 --- src/guile/skribilo/engine/lout.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 92977e7..db93257 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -432,18 +432,22 @@ (output title engine) (display "The Lout Document")) (display " }\n") - (display "//1.7fx\n") - (if date-line - (begin - (display "@Center { ") - (output date-line engine) - (display " }\n//1.4fx\n"))) + (display "//2.0fx\n") (if author (begin (display "@Center { ") (output author engine) (display " }\n") - (display "//4fx\n"))) + (display "//4.6fx\n"))) + (if date-line + (begin + (display "@Center { ") + (output (if (eq? #t date-line) + (strftime "%e %B %Y" (localtime (current-time))) + date-line) + engine) + (display " }\n//1.7fx\n"))) + (display "//0.5fx\n") (if multi-column? (display "\n} # @FullWidth\n")))) -- cgit v1.2.3 From a5f445c36f37fc866fbac1f095e8bbba11beddd7 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 17 Nov 2006 09:03:15 +0000 Subject: outline reader: Support keywords. * src/guile/skribilo/reader/outline.scm (outline-reader)[keywords-rx]: New. [author-rx]: Support "Authors" (plural). [extract-keywords]: New. Use a `cond' instead of nested `if's when matching the title/author/keywords regexps. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-74 --- src/guile/skribilo/reader/outline.scm | 54 +++++++++++++++++++++++++---------- 1 file changed, 39 insertions(+), 15 deletions(-) diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm index 09792f5..7411892 100644 --- a/src/guile/skribilo/reader/outline.scm +++ b/src/guile/skribilo/reader/outline.scm @@ -22,7 +22,10 @@ :use-module (skribilo utils syntax) :use-module (skribilo reader) :use-module (ice-9 optargs) + :use-module (srfi srfi-11) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) :autoload (ice-9 rdelim) (read-line) :autoload (ice-9 regex) (make-regexp) @@ -380,12 +383,19 @@ to @var{node-type}." (define modeline-rx (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$")) (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended)) - (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended)) + (define author-rx (make-regexp "^[Aa]uthors?: (.+)$" regexp/extended)) + (define keywords-rx + (make-regexp "^[Kk]ey ?[wW]ords?: (.+)$" regexp/extended)) + + (define (extract-keywords str) + (map string-trim-both + (string-tokenize str (char-set-complement (char-set #\,))))) (let ((doc-proc (make-document-processor %node-processors %line-processor))) (let loop ((title #f) (author #f) + (keywords '()) (line (read-line port))) (if (eof-object? line) @@ -394,20 +404,34 @@ to @var{node-type}." line) (if (or (empty-line? line) (regexp-exec modeline-rx line)) - (loop title author (read-line port)) - (let ((title-match (regexp-exec title-rx line))) - (if title-match - (loop (match:substring title-match 1) - author (read-line port)) - (let ((author-match (regexp-exec author-rx line))) - (if author-match - (loop title (match:substring author-match 1) - (read-line port)) - - ;; Let's go. - `(document :title ,title - :author (author :name ,author) - ,@(doc-proc line port))))))))))) + (loop title author keywords (read-line port)) + (cond ((regexp-exec title-rx line) + => + (lambda (title-match) + (loop (match:substring title-match 1) + author keywords (read-line port)))) + + ((regexp-exec author-rx line) + => + (lambda (author-match) + (loop title (match:substring author-match 1) + keywords (read-line port)))) + + ((regexp-exec keywords-rx line) + => + (lambda (kw-match) + (loop title author + (append keywords + (extract-keywords + (match:substring kw-match 1))) + (read-line port)))) + + (else + ;; Let's go. + `(document :title ,title + :author (author :name ,author) + :keywords ',keywords + ,@(doc-proc line port))))))))) (define* (make-outline-reader :optional (version "0.1")) -- cgit v1.2.3 From 62443764135d6810a8e45d888b282344c5de42a5 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 17 Nov 2006 09:05:31 +0000 Subject: Lout engine: Better cover sheet for `doc' documents. * src/guile/skribilo/engine/lout.scm (lout-make-doc-cover-sheet): Improved spacing. Moved `date-line' after `author'. Provide a default value for `date-line' when it's `#t'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-15 --- src/guile/skribilo/engine/lout.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 92977e7..db93257 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -432,18 +432,22 @@ (output title engine) (display "The Lout Document")) (display " }\n") - (display "//1.7fx\n") - (if date-line - (begin - (display "@Center { ") - (output date-line engine) - (display " }\n//1.4fx\n"))) + (display "//2.0fx\n") (if author (begin (display "@Center { ") (output author engine) (display " }\n") - (display "//4fx\n"))) + (display "//4.6fx\n"))) + (if date-line + (begin + (display "@Center { ") + (output (if (eq? #t date-line) + (strftime "%e %B %Y" (localtime (current-time))) + date-line) + engine) + (display " }\n//1.7fx\n"))) + (display "//0.5fx\n") (if multi-column? (display "\n} # @FullWidth\n")))) -- cgit v1.2.3 From b2aec83973f1b7c2bf9e952ed8e713611cbdc7fb Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 17 Nov 2006 09:06:30 +0000 Subject: outline reader: Support keywords. * src/guile/skribilo/reader/outline.scm (outline-reader)[keywords-rx]: New. [author-rx]: Support "Authors" (plural). [extract-keywords]: New. Use a `cond' instead of nested `if's when matching the title/author/keywords regexps. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-16 --- src/guile/skribilo/reader/outline.scm | 54 +++++++++++++++++++++++++---------- 1 file changed, 39 insertions(+), 15 deletions(-) diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm index 09792f5..7411892 100644 --- a/src/guile/skribilo/reader/outline.scm +++ b/src/guile/skribilo/reader/outline.scm @@ -22,7 +22,10 @@ :use-module (skribilo utils syntax) :use-module (skribilo reader) :use-module (ice-9 optargs) + :use-module (srfi srfi-11) + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) :autoload (ice-9 rdelim) (read-line) :autoload (ice-9 regex) (make-regexp) @@ -380,12 +383,19 @@ to @var{node-type}." (define modeline-rx (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$")) (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended)) - (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended)) + (define author-rx (make-regexp "^[Aa]uthors?: (.+)$" regexp/extended)) + (define keywords-rx + (make-regexp "^[Kk]ey ?[wW]ords?: (.+)$" regexp/extended)) + + (define (extract-keywords str) + (map string-trim-both + (string-tokenize str (char-set-complement (char-set #\,))))) (let ((doc-proc (make-document-processor %node-processors %line-processor))) (let loop ((title #f) (author #f) + (keywords '()) (line (read-line port))) (if (eof-object? line) @@ -394,20 +404,34 @@ to @var{node-type}." line) (if (or (empty-line? line) (regexp-exec modeline-rx line)) - (loop title author (read-line port)) - (let ((title-match (regexp-exec title-rx line))) - (if title-match - (loop (match:substring title-match 1) - author (read-line port)) - (let ((author-match (regexp-exec author-rx line))) - (if author-match - (loop title (match:substring author-match 1) - (read-line port)) - - ;; Let's go. - `(document :title ,title - :author (author :name ,author) - ,@(doc-proc line port))))))))))) + (loop title author keywords (read-line port)) + (cond ((regexp-exec title-rx line) + => + (lambda (title-match) + (loop (match:substring title-match 1) + author keywords (read-line port)))) + + ((regexp-exec author-rx line) + => + (lambda (author-match) + (loop title (match:substring author-match 1) + keywords (read-line port)))) + + ((regexp-exec keywords-rx line) + => + (lambda (kw-match) + (loop title author + (append keywords + (extract-keywords + (match:substring kw-match 1))) + (read-line port)))) + + (else + ;; Let's go. + `(document :title ,title + :author (author :name ,author) + :keywords ',keywords + ,@(doc-proc line port))))))))) (define* (make-outline-reader :optional (version "0.1")) -- cgit v1.2.3 From c3242a5179081b651ab56701a717f9589532464c Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 24 Nov 2006 09:36:49 +0000 Subject: lout: bib-ref+: Gracefully handle `unref' objects. * src/guile/skribilo/engine/lout.scm (bib-ref+)[canonicalize-entry]: Handle `unref' objects. [help-proc]: Don't pass `unref' objects to PROC. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-75 --- src/guile/skribilo/engine/lout.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index db93257..272b131 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -2495,6 +2495,7 @@ ((is-markup? x 'bib-entry) x) ((is-markup? x 'bib-ref) (handle-ast (markup-body x))) + ((is-markup? x 'unref) #f) (else (skribe-error 'lout @@ -2502,9 +2503,14 @@ x))))) (help-proc (lambda (proc) (lambda (e1 e2) - (proc (canonicalize-entry e1) - (canonicalize-entry e2))))) + (let ((e1 (canonicalize-entry e1)) + (e2 (canonicalize-entry e2))) + ;; don't pass `unref's to PROC + (if (and e1 e2) + (proc e1 e2) + #f))))) (sort-proc (engine-custom e 'bib-refs-sort-proc))) + (let loop ((rs (if sort-proc (sort entries (help-proc sort-proc)) entries))) -- cgit v1.2.3 From 25deac661d70aa848fb2134dc769cc9ff55c5173 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 24 Nov 2006 10:48:04 +0000 Subject: Introduced `markup-number-string'. * src/guile/skribilo/ast.scm: Use `(ice-9 optargs)'. (markup-number-string): New (stolen from the Lout engine). * src/guile/skribilo/engine/lout.scm: Use it. (lout-structure-number-string): Redefined in terms of `markup-number-string'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-76 --- src/guile/skribilo/ast.scm | 22 ++++++++++++++++++++++ src/guile/skribilo/engine/lout.scm | 22 ++++++++-------------- 2 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm index 542f629..55f37bf 100644 --- a/src/guile/skribilo/ast.scm +++ b/src/guile/skribilo/ast.scm @@ -30,6 +30,9 @@ :autoload (skribilo location) (location?) :autoload (srfi srfi-1) (fold) + + :use-module (ice-9 optargs) + :export ( ast? ast-loc ast-loc-set! ast-parent ast->string ast->file-location ast-resolved? @@ -62,6 +65,9 @@ find-up find1-up ast-document ast-chapter ast-section + ;; numbering + markup-number-string + ;; error conditions &ast-error &ast-orphan-error &ast-cycle-error &markup-unknown-option-error &markup-already-bound-error @@ -596,6 +602,22 @@ (define (ast-section m) (find1-up (lambda (n) (is-markup? n 'section)) m)) + +;;; +;;; Section numbering. +;;; + +(define* (markup-number-string markup :optional (sep ".")) + ;; Return a structure number string such as "1.2". + (let loop ((markup markup)) + (if (document? markup) + "" + (let ((parent-num (loop (ast-parent markup))) + (num (markup-option markup :number))) + (string-append parent-num + (if (string=? "" parent-num) "" sep) + (if (number? num) (number->string num) "")))))) + ;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7 diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 272b131..6106f35 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -502,7 +502,7 @@ (if num (begin (if (is-markup? node 'chapter) (display "@B { ")) - (printf "~a. |2s " (lout-structure-number-string node)) + (printf "~a. |2s " (markup-number-string node)) (output title engine) (if (is-markup? node 'chapter) (display " }"))) (if (is-markup? node 'chapter) @@ -525,7 +525,7 @@ (define (lout-pdf-bookmark-title node engine) ;; Default implementation of the `pdf-bookmark-title-proc' custom that ;; returns a title (a string) for the PDF bookmark of `node'. - (let ((number (lout-structure-number-string node))) + (let ((number (markup-number-string node))) (string-append (if (string=? number "") "" (string-append number ". ")) (ast->string (markup-option node :title))))) @@ -1321,17 +1321,11 @@ doc-type))))) (define-public (lout-structure-number-string markup) - ;; Return a structure number string such as "1.2". - ;; FIXME: External code has started to rely on this. This should be - ;; generalized and moved elsewhere. - (let loop ((struct markup)) - (if (document? struct) - "" - (let ((parent-num (loop (ast-parent struct))) - (num (markup-option struct :number))) - (string-append parent-num - (if (string=? "" parent-num) "" ".") - (if (number? num) (number->string num) "")))))) + ;; FIXME: External code has started to rely on this before this was moved + ;; to the `ast' module as `markup-number-string'. Thus, we'll have to keep it + ;; here for some time. + (markup-number-string markup ".")) + ;*---------------------------------------------------------------------*/ ;* lout-block-before ... */ @@ -1360,7 +1354,7 @@ (if (number? number) (printf " @BypassNumber { ~a }\n" - (lout-structure-number-string n)) + (markup-number-string n)) (if (not number) ;; this trick hides the section number (printf " @BypassNumber { } # unnumbered\n"))) -- cgit v1.2.3 From 4c3a84d4fd923cefc663d314d5659253101b70f9 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 24 Nov 2006 12:53:47 +0000 Subject: `base' package: Added `numref'. * src/guile/skribilo/package/base.scm (numref): New. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-77 --- src/guile/skribilo/package/base.scm | 43 +++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index bbb2a62..4c9e84c 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -1187,6 +1187,49 @@ (line (line-ref line)) (else (skribe-error 'ref "illegal reference" opts))))) + +;*---------------------------------------------------------------------*/ +;* numref ... */ +;*---------------------------------------------------------------------*/ +(define-markup (numref #!rest opts + #!key (ident #f) (text "") (page #f) + (separator ".") (class #f)) + ;; Produce a numbered reference to `ident'. + (new unresolved + (proc (lambda (n e env) + (let* ((parent (ast-parent n)) + (doc (ast-document n)) + (target (document-lookup-node doc ident)) + (number (and target + (markup-option target :number)))) + (cond + ((not target) + (skribe-warning/ast 1 n 'numref + (format #f "can't find `ident': ") + ident) + (new markup + (markup 'unref) + (ident (symbol->string (gensym "unref"))) + (class class) + (required-options '(:text)) + (options `((kind numref) + ,@(the-options opts :ident :class))) + (body (list ident ": " (ast->file-location n))))) + ((unresolved? number) + ;; Loop until `number' is resolved. + n) + (else + (let ((xref + (ref :text + (list (if text text "") " " + (if (number? number) + (markup-number-string target + separator) + "")) + :page page + :handle (handle target)))) + (resolve! xref e env))))))))) + ;*---------------------------------------------------------------------*/ ;* resolve ... */ ;*---------------------------------------------------------------------*/ -- cgit v1.2.3 From 3e46caf3e034552854ff6829ca2bf4e0a46e0089 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 24 Nov 2006 12:56:27 +0000 Subject: doc: Documented `numref'. * doc/user/links.skb (Reference): Added identifier `refs'. [ref](page): Explain that this option is hardcopy-specific. [numref]: New. * doc/user/src/links1.skb: Show `numref' usage. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-78 --- doc/user/links.skb | 24 +++++++++++++++++++----- doc/user/src/links1.skb | 4 ++++ 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/doc/user/links.skb b/doc/user/links.skb index ae7301c..c6e37a0 100644 --- a/doc/user/links.skb +++ b/doc/user/links.skb @@ -71,9 +71,9 @@ automatically sets a mark whose value is the legend of the figure.])) ;*---------------------------------------------------------------------*/ ;* ref ... @label ref@ */ ;*---------------------------------------------------------------------*/ -(section :title "Reference" +(section :title "Reference" :ident "refs" -(p [Skribe proposes only one single function for all the references. +(p [Skribilo proposes a single function that can be used for most references. This same ,(code "ref") function is used for introducing references to section, to bibliographic entries, to source code line number, etc.]) @@ -92,7 +92,8 @@ section, to bibliographic entries, to source code line number, etc.]) (:section [The title of a ,(markup-ref "section").]) (:subsection [The title of a ,(markup-ref "subsection").]) (:subsubsection [The title of a ,(markup-ref "subsubsection").]) - (:page [A boolean enabling/disabling page reference.]) + (:page [A boolean enabling/disabling page reference (for + hard copies as produced by the Lout and LaTeX engines).]) (:bib ,[A name or a list of names of ,(ref :chapter "Bibliographies" :text "bibliographic") entry.]) (:bib-table ,[The @@ -108,8 +109,21 @@ section, to bibliographic entries, to source code line number, etc.]) a ,(tt "mark") located in the Skribe document described by the ,(var "file") ,(sc "sui").])) :force-args '(:url :bib :line :skribe) - :see-also '(index)) - + :see-also '(index numref)) + +(p [Sometimes, it is useful to produce phrases that refer a section by +its number, as in ``See Section 2.3''. This is especially useful on +printed documents, as produced by the Lout and LaTeX engines. The +,(code "numref") markup is provided to that end:]) + +(doc-markup 'numref + `((:text [Text preceding the reference number.]) + (:ident [The identifier of the node (a chapter, section, + subsection, etc.) being referenced.]) + (:page [A boolean enabling/disabling page reference (for + hard copies as produced by the Lout and LaTeX engines).]) + (:separator [The separator between numbers.])) + :see-also '(ref)) (example-produce (example :legend "Some references" (prgm :file "src/links1.skb")) diff --git a/doc/user/src/links1.skb b/doc/user/src/links1.skb index e0b393b..bfe6f86 100644 --- a/doc/user/src/links1.skb +++ b/doc/user/src/links1.skb @@ -10,6 +10,10 @@ 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) +And one can also refer to sections by number, as in ``see ,(numref :text +[Wonderful Section] :ident "refs")''. + ,(linebreak) With more complex tricks that are explained in Section ,(ref :section "Resolve"), it is also possible use, for the text of the -- cgit v1.2.3 From c23335b3c7ee9f48a7f68fc8828e5b6546649a1a Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 24 Nov 2006 14:46:30 +0000 Subject: Cleaned up `(skribilo biblio)' a bit. * doc/user/bib.skb: Replaced `default-bib-table' with `*bib-table*'. * src/guile/skribilo/biblio.scm: Clean up. (skribe-open-bib-file): Renamed to `open-bib-file'. * src/guile/skribilo/package/base.scm: Use `*bib-table*' instead of `default-bib-table'. * src/guile/skribilo/utils/compat.scm: Autoload `biblio'. (default-bib-table): New. (skribe-open-bib-file): New. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-79 --- doc/user/bib.skb | 20 ++++--- src/guile/skribilo/biblio.scm | 103 +++++++++++++----------------------- src/guile/skribilo/package/base.scm | 8 +-- src/guile/skribilo/utils/compat.scm | 13 +++++ 4 files changed, 67 insertions(+), 77 deletions(-) diff --git a/doc/user/bib.skb b/doc/user/bib.skb index 5b26417..e7b5b77 100644 --- a/doc/user/bib.skb +++ b/doc/user/bib.skb @@ -52,32 +52,36 @@ 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 +,(markup-ref "make-bib-table") or ,(markup-ref "*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) + :see-also '(make-bib-table *bib-table* bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f ;;"skribilo/biblio.scm" :def '(define-markup (bib-table? obj) ...)) - (p [The function ,(code "default-bib-table") returns a global, pre-existing + (p [The function ,(code "*bib-table*") returns a global, pre-existing bibliography-table:]) - (doc-markup 'default-bib-table + (doc-markup '*bib-table* '() :see-also '(bib-table? make-bib-table bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f - :def '(define-markup (default-bib-table) ...)) + :def '(define-markup (*bib-table*) ...)) + (p [Technically, ,(code "*bib-table*") is actually an ,(ref :text +[SRFI-39] :url "http://srfi.schemers.org/srfi-39/srfi-39.html") +parameter object, so it can be queried and modified like any other +parameter object.]) (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) + :see-also '(bib-table? *bib-table* bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f @@ -109,7 +113,7 @@ the ,(code "bibliography") Skribe function call before the call to the :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) + :see-also '(bib-table? make-bib-table *bib-table* the-bibliography) :force-engines *api-engines* :common-args '()) @@ -161,7 +165,7 @@ Here is an example of a simple Skribe database.]) 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) + :see-also '(bib-table? make-bib-table *bib-table* bibliography) :force-engines *api-engines* :common-args '()) diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index 1fb4b78..55f2ea9 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -1,5 +1,6 @@ ;;; biblio.scm -- Bibliography functions. ;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano ;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI ;;; Copyright 2005, 2006 Ludovic Courtès ;;; @@ -24,9 +25,10 @@ :use-module (skribilo utils strings) :use-module (skribilo utils syntax) ;; `when', `unless' + :use-module (srfi srfi-1) :autoload (srfi srfi-34) (raise) :use-module (srfi srfi-35) - :use-module (srfi srfi-1) + :use-module (srfi srfi-39) :autoload (skribilo condition) (&file-search-error) :autoload (skribilo reader) (%default-reader) @@ -36,9 +38,9 @@ :use-module (ice-9 optargs) :use-module (oop goops) - :export (bib-table? make-bib-table default-bib-table + :export (bib-table? make-bib-table *bib-table* bib-add! bib-duplicate bib-for-each bib-map - skribe-open-bib-file parse-bib + open-bib-file parse-bib bib-load! resolve-bib resolve-the-bib make-bib-entry @@ -52,27 +54,15 @@ ;;; Provides the bibliography data type and basic bibliography handling, ;;; including simple procedures to sort bibliography entries. ;;; -;;; FIXME: This module need cleanup! -;;; ;;; Code: (fluid-set! current-reader %skribilo-module-reader) - -;; FIXME: Should be a fluid? -(define *bib-table* #f) - -;; Forward declarations -(define skribe-open-bib-file #f) -(define parse-bib #f) - -;;; ====================================================================== ;;; -;;; Utilities +;;; Accessors. ;;; -;;; ====================================================================== (define (make-bib-table ident) (make-hash-table)) @@ -80,10 +70,9 @@ (define (bib-table? obj) (hash-table? obj)) -(define (default-bib-table) - (unless *bib-table* - (set! *bib-table* (make-bib-table "default-bib-table"))) - *bib-table*) +;; The current bib table. +(define *bib-table* + (make-parameter (make-bib-table "default-bib-table"))) (define (%bib-error who entry) (let ((msg "bibliography syntax error on entry")) @@ -91,22 +80,34 @@ (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) (skribe-error who msg entry)))) -(define* (bib-for-each proc :optional (table (default-bib-table))) +(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 #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate key #f old) + (hash-set! table key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + +(define* (bib-for-each proc :optional (table (*bib-table*))) (hash-for-each (lambda (ident entry) (proc ident entry)) table)) -(define* (bib-map proc :optional (table (default-bib-table))) +(define* (bib-map proc :optional (table (*bib-table*))) (hash-map->list (lambda (ident entry) (proc ident entry)) table)) - -;;; ====================================================================== -;;; -;;; BIB-DUPLICATE -;;; -;;; ====================================================================== (define (bib-duplicate ident from old) (let ((ofrom (markup-option old 'from))) (skribe-warning 2 @@ -120,11 +121,11 @@ " ignoring redefinition.")))) -;;; ====================================================================== + ;;; -;;; PARSE-BIB +;;; Parsing. ;;; -;;; ====================================================================== + (define (parse-bib table port) (let ((read %default-reader)) ;; FIXME: We should use a fluid (if (not (bib-table? table)) @@ -146,43 +147,15 @@ (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 #f "~A" (cadr entry))) - (fields (cddr entry)) - (old (hash-ref table key))) - (if old - (bib-duplicate key #f old) - (hash-set! 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) +(define* (open-bib-file file :optional (command #f)) (let ((path (search-path (*bib-path*) file))) (if (string? path) (begin (when (> (*verbose*) 0) - (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (format (current-error-port) + " [loading bibliography: ~S]\n" path)) + ;; FIXME: The following `open-input-file' won't work with actual + ;; commands. We need to use `(ice-9 popen)'. (open-input-file (if (string? command) (string-append "| " (format #f command path)) @@ -209,7 +182,7 @@ (if (not (bib-table? table)) (skribe-error 'bib-load "Illegal bibliography table" table) ;; read the file - (let ((p (skribe-open-bib-file filename command))) + (let ((p (open-bib-file filename command))) (if (not (input-port? p)) (skribe-error 'bib-load "Can't open data base" filename) (unwind-protect diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index 4c9e84c..01e8667 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -33,7 +33,7 @@ :autoload (skribilo engine) (engine?) ;; optional ``sub-packages'' - :autoload (skribilo biblio) (default-bib-table resolve-bib + :autoload (skribilo biblio) (*bib-table* resolve-bib bib-load! bib-add!) :autoload (skribilo color) (skribe-use-color!) :autoload (skribilo source) (language? source-read-lines source-fontify) @@ -1015,7 +1015,7 @@ (subsection #f) (subsubsection #f) (bib #f) - (bib-table (default-bib-table)) + (bib-table (*bib-table*)) (url #f) (figure #f) (mark #f) @@ -1245,7 +1245,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (bibliography #!rest files #!key - (command #f) (bib-table (default-bib-table))) + (command #f) (bib-table (*bib-table*))) (for-each (lambda (f) (cond ((string? f) @@ -1267,7 +1267,7 @@ (define-markup (the-bibliography #!rest opts #!key pred - (bib-table (default-bib-table)) + (bib-table (*bib-table*)) (sort bib-sort/authors) (count 'partial)) (if (not (memq count '(partial full))) diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm index 118f294..4905cef 100644 --- a/src/guile/skribilo/utils/compat.scm +++ b/src/guile/skribilo/utils/compat.scm @@ -35,6 +35,7 @@ :autoload (skribilo lib) (type-name) :autoload (skribilo resolve) (*document-being-resolved*) :autoload (skribilo output) (*document-being-output*) + :autoload (skribilo biblio) (*bib-table* open-bib-file) :use-module (skribilo debug) :re-export (file-size) ;; re-exported from `(skribilo utils files)' @@ -207,6 +208,18 @@ (or (find-markups ident) '())) + +;;; +;;; Bibliography. +;;; + +(define-public (default-bib-table) + (*bib-table*)) + +(define-public (skribe-open-bib-file file command) + (open-bib-file file command)) + + ;;; ;;; Debugging facilities. -- cgit v1.2.3 From a5b8c2cfaf31b5d81a900b1020eb45252d775dd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 25 Nov 2006 17:37:51 +0000 Subject: lout: bib-ref+: Gracefully handle `unref' objects. * src/guile/skribilo/engine/lout.scm (bib-ref+)[canonicalize-entry]: Handle `unref' objects. [help-proc]: Don't pass `unref' objects to PROC. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-17 --- src/guile/skribilo/engine/lout.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index db93257..272b131 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -2495,6 +2495,7 @@ ((is-markup? x 'bib-entry) x) ((is-markup? x 'bib-ref) (handle-ast (markup-body x))) + ((is-markup? x 'unref) #f) (else (skribe-error 'lout @@ -2502,9 +2503,14 @@ x))))) (help-proc (lambda (proc) (lambda (e1 e2) - (proc (canonicalize-entry e1) - (canonicalize-entry e2))))) + (let ((e1 (canonicalize-entry e1)) + (e2 (canonicalize-entry e2))) + ;; don't pass `unref's to PROC + (if (and e1 e2) + (proc e1 e2) + #f))))) (sort-proc (engine-custom e 'bib-refs-sort-proc))) + (let loop ((rs (if sort-proc (sort entries (help-proc sort-proc)) entries))) -- cgit v1.2.3 From 45b606578f7bae67ee92ca77b894d71a3ebab82a Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 25 Nov 2006 17:40:28 +0000 Subject: Introduced `markup-number-string'. * src/guile/skribilo/ast.scm: Use `(ice-9 optargs)'. (markup-number-string): New (stolen from the Lout engine). * src/guile/skribilo/engine/lout.scm: Use it. (lout-structure-number-string): Redefined in terms of `markup-number-string'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-18 --- src/guile/skribilo/ast.scm | 22 ++++++++++++++++++++++ src/guile/skribilo/engine/lout.scm | 22 ++++++++-------------- 2 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm index 542f629..55f37bf 100644 --- a/src/guile/skribilo/ast.scm +++ b/src/guile/skribilo/ast.scm @@ -30,6 +30,9 @@ :autoload (skribilo location) (location?) :autoload (srfi srfi-1) (fold) + + :use-module (ice-9 optargs) + :export ( ast? ast-loc ast-loc-set! ast-parent ast->string ast->file-location ast-resolved? @@ -62,6 +65,9 @@ find-up find1-up ast-document ast-chapter ast-section + ;; numbering + markup-number-string + ;; error conditions &ast-error &ast-orphan-error &ast-cycle-error &markup-unknown-option-error &markup-already-bound-error @@ -596,6 +602,22 @@ (define (ast-section m) (find1-up (lambda (n) (is-markup? n 'section)) m)) + +;;; +;;; Section numbering. +;;; + +(define* (markup-number-string markup :optional (sep ".")) + ;; Return a structure number string such as "1.2". + (let loop ((markup markup)) + (if (document? markup) + "" + (let ((parent-num (loop (ast-parent markup))) + (num (markup-option markup :number))) + (string-append parent-num + (if (string=? "" parent-num) "" sep) + (if (number? num) (number->string num) "")))))) + ;;; arch-tag: e2489bd6-1b6d-4b03-bdfb-83cffd2f7ce7 diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 272b131..6106f35 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -502,7 +502,7 @@ (if num (begin (if (is-markup? node 'chapter) (display "@B { ")) - (printf "~a. |2s " (lout-structure-number-string node)) + (printf "~a. |2s " (markup-number-string node)) (output title engine) (if (is-markup? node 'chapter) (display " }"))) (if (is-markup? node 'chapter) @@ -525,7 +525,7 @@ (define (lout-pdf-bookmark-title node engine) ;; Default implementation of the `pdf-bookmark-title-proc' custom that ;; returns a title (a string) for the PDF bookmark of `node'. - (let ((number (lout-structure-number-string node))) + (let ((number (markup-number-string node))) (string-append (if (string=? number "") "" (string-append number ". ")) (ast->string (markup-option node :title))))) @@ -1321,17 +1321,11 @@ doc-type))))) (define-public (lout-structure-number-string markup) - ;; Return a structure number string such as "1.2". - ;; FIXME: External code has started to rely on this. This should be - ;; generalized and moved elsewhere. - (let loop ((struct markup)) - (if (document? struct) - "" - (let ((parent-num (loop (ast-parent struct))) - (num (markup-option struct :number))) - (string-append parent-num - (if (string=? "" parent-num) "" ".") - (if (number? num) (number->string num) "")))))) + ;; FIXME: External code has started to rely on this before this was moved + ;; to the `ast' module as `markup-number-string'. Thus, we'll have to keep it + ;; here for some time. + (markup-number-string markup ".")) + ;*---------------------------------------------------------------------*/ ;* lout-block-before ... */ @@ -1360,7 +1354,7 @@ (if (number? number) (printf " @BypassNumber { ~a }\n" - (lout-structure-number-string n)) + (markup-number-string n)) (if (not number) ;; this trick hides the section number (printf " @BypassNumber { } # unnumbered\n"))) -- cgit v1.2.3 From 2415df2ae4716bec5ca0d9605116c43d0977ea30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 25 Nov 2006 17:41:04 +0000 Subject: `base' package: Added `numref'. * src/guile/skribilo/package/base.scm (numref): New. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-19 --- src/guile/skribilo/package/base.scm | 43 +++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index bbb2a62..4c9e84c 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -1187,6 +1187,49 @@ (line (line-ref line)) (else (skribe-error 'ref "illegal reference" opts))))) + +;*---------------------------------------------------------------------*/ +;* numref ... */ +;*---------------------------------------------------------------------*/ +(define-markup (numref #!rest opts + #!key (ident #f) (text "") (page #f) + (separator ".") (class #f)) + ;; Produce a numbered reference to `ident'. + (new unresolved + (proc (lambda (n e env) + (let* ((parent (ast-parent n)) + (doc (ast-document n)) + (target (document-lookup-node doc ident)) + (number (and target + (markup-option target :number)))) + (cond + ((not target) + (skribe-warning/ast 1 n 'numref + (format #f "can't find `ident': ") + ident) + (new markup + (markup 'unref) + (ident (symbol->string (gensym "unref"))) + (class class) + (required-options '(:text)) + (options `((kind numref) + ,@(the-options opts :ident :class))) + (body (list ident ": " (ast->file-location n))))) + ((unresolved? number) + ;; Loop until `number' is resolved. + n) + (else + (let ((xref + (ref :text + (list (if text text "") " " + (if (number? number) + (markup-number-string target + separator) + "")) + :page page + :handle (handle target)))) + (resolve! xref e env))))))))) + ;*---------------------------------------------------------------------*/ ;* resolve ... */ ;*---------------------------------------------------------------------*/ -- cgit v1.2.3 From b0e202992a38753888465fa8fb1331ac31f838ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 25 Nov 2006 17:41:44 +0000 Subject: doc: Documented `numref'. * doc/user/links.skb (Reference): Added identifier `refs'. [ref](page): Explain that this option is hardcopy-specific. [numref]: New. * doc/user/src/links1.skb: Show `numref' usage. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-20 --- doc/user/links.skb | 24 +++++++++++++++++++----- doc/user/src/links1.skb | 4 ++++ 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/doc/user/links.skb b/doc/user/links.skb index ae7301c..c6e37a0 100644 --- a/doc/user/links.skb +++ b/doc/user/links.skb @@ -71,9 +71,9 @@ automatically sets a mark whose value is the legend of the figure.])) ;*---------------------------------------------------------------------*/ ;* ref ... @label ref@ */ ;*---------------------------------------------------------------------*/ -(section :title "Reference" +(section :title "Reference" :ident "refs" -(p [Skribe proposes only one single function for all the references. +(p [Skribilo proposes a single function that can be used for most references. This same ,(code "ref") function is used for introducing references to section, to bibliographic entries, to source code line number, etc.]) @@ -92,7 +92,8 @@ section, to bibliographic entries, to source code line number, etc.]) (:section [The title of a ,(markup-ref "section").]) (:subsection [The title of a ,(markup-ref "subsection").]) (:subsubsection [The title of a ,(markup-ref "subsubsection").]) - (:page [A boolean enabling/disabling page reference.]) + (:page [A boolean enabling/disabling page reference (for + hard copies as produced by the Lout and LaTeX engines).]) (:bib ,[A name or a list of names of ,(ref :chapter "Bibliographies" :text "bibliographic") entry.]) (:bib-table ,[The @@ -108,8 +109,21 @@ section, to bibliographic entries, to source code line number, etc.]) a ,(tt "mark") located in the Skribe document described by the ,(var "file") ,(sc "sui").])) :force-args '(:url :bib :line :skribe) - :see-also '(index)) - + :see-also '(index numref)) + +(p [Sometimes, it is useful to produce phrases that refer a section by +its number, as in ``See Section 2.3''. This is especially useful on +printed documents, as produced by the Lout and LaTeX engines. The +,(code "numref") markup is provided to that end:]) + +(doc-markup 'numref + `((:text [Text preceding the reference number.]) + (:ident [The identifier of the node (a chapter, section, + subsection, etc.) being referenced.]) + (:page [A boolean enabling/disabling page reference (for + hard copies as produced by the Lout and LaTeX engines).]) + (:separator [The separator between numbers.])) + :see-also '(ref)) (example-produce (example :legend "Some references" (prgm :file "src/links1.skb")) diff --git a/doc/user/src/links1.skb b/doc/user/src/links1.skb index e0b393b..bfe6f86 100644 --- a/doc/user/src/links1.skb +++ b/doc/user/src/links1.skb @@ -10,6 +10,10 @@ 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) +And one can also refer to sections by number, as in ``see ,(numref :text +[Wonderful Section] :ident "refs")''. + ,(linebreak) With more complex tricks that are explained in Section ,(ref :section "Resolve"), it is also possible use, for the text of the -- cgit v1.2.3 From 80b757fc4bf93f59edde426b9fca4dcca15509c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 25 Nov 2006 17:42:18 +0000 Subject: Cleaned up `(skribilo biblio)' a bit. * doc/user/bib.skb: Replaced `default-bib-table' with `*bib-table*'. * src/guile/skribilo/biblio.scm: Clean up. (skribe-open-bib-file): Renamed to `open-bib-file'. * src/guile/skribilo/package/base.scm: Use `*bib-table*' instead of `default-bib-table'. * src/guile/skribilo/utils/compat.scm: Autoload `biblio'. (default-bib-table): New. (skribe-open-bib-file): New. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-21 --- doc/user/bib.skb | 20 ++++--- src/guile/skribilo/biblio.scm | 103 +++++++++++++----------------------- src/guile/skribilo/package/base.scm | 8 +-- src/guile/skribilo/utils/compat.scm | 13 +++++ 4 files changed, 67 insertions(+), 77 deletions(-) diff --git a/doc/user/bib.skb b/doc/user/bib.skb index 5b26417..e7b5b77 100644 --- a/doc/user/bib.skb +++ b/doc/user/bib.skb @@ -52,32 +52,36 @@ 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 +,(markup-ref "make-bib-table") or ,(markup-ref "*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) + :see-also '(make-bib-table *bib-table* bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f ;;"skribilo/biblio.scm" :def '(define-markup (bib-table? obj) ...)) - (p [The function ,(code "default-bib-table") returns a global, pre-existing + (p [The function ,(code "*bib-table*") returns a global, pre-existing bibliography-table:]) - (doc-markup 'default-bib-table + (doc-markup '*bib-table* '() :see-also '(bib-table? make-bib-table bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f - :def '(define-markup (default-bib-table) ...)) + :def '(define-markup (*bib-table*) ...)) + (p [Technically, ,(code "*bib-table*") is actually an ,(ref :text +[SRFI-39] :url "http://srfi.schemers.org/srfi-39/srfi-39.html") +parameter object, so it can be queried and modified like any other +parameter object.]) (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) + :see-also '(bib-table? *bib-table* bibliography the-bibliography) :force-engines *api-engines* :common-args '() :source #f @@ -109,7 +113,7 @@ the ,(code "bibliography") Skribe function call before the call to the :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) + :see-also '(bib-table? make-bib-table *bib-table* the-bibliography) :force-engines *api-engines* :common-args '()) @@ -161,7 +165,7 @@ Here is an example of a simple Skribe database.]) 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) + :see-also '(bib-table? make-bib-table *bib-table* bibliography) :force-engines *api-engines* :common-args '()) diff --git a/src/guile/skribilo/biblio.scm b/src/guile/skribilo/biblio.scm index 1fb4b78..55f2ea9 100644 --- a/src/guile/skribilo/biblio.scm +++ b/src/guile/skribilo/biblio.scm @@ -1,5 +1,6 @@ ;;; biblio.scm -- Bibliography functions. ;;; +;;; Copyright 2001, 2002, 2003, 2004 Manuel Serrano ;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI ;;; Copyright 2005, 2006 Ludovic Courtès ;;; @@ -24,9 +25,10 @@ :use-module (skribilo utils strings) :use-module (skribilo utils syntax) ;; `when', `unless' + :use-module (srfi srfi-1) :autoload (srfi srfi-34) (raise) :use-module (srfi srfi-35) - :use-module (srfi srfi-1) + :use-module (srfi srfi-39) :autoload (skribilo condition) (&file-search-error) :autoload (skribilo reader) (%default-reader) @@ -36,9 +38,9 @@ :use-module (ice-9 optargs) :use-module (oop goops) - :export (bib-table? make-bib-table default-bib-table + :export (bib-table? make-bib-table *bib-table* bib-add! bib-duplicate bib-for-each bib-map - skribe-open-bib-file parse-bib + open-bib-file parse-bib bib-load! resolve-bib resolve-the-bib make-bib-entry @@ -52,27 +54,15 @@ ;;; Provides the bibliography data type and basic bibliography handling, ;;; including simple procedures to sort bibliography entries. ;;; -;;; FIXME: This module need cleanup! -;;; ;;; Code: (fluid-set! current-reader %skribilo-module-reader) - -;; FIXME: Should be a fluid? -(define *bib-table* #f) - -;; Forward declarations -(define skribe-open-bib-file #f) -(define parse-bib #f) - -;;; ====================================================================== ;;; -;;; Utilities +;;; Accessors. ;;; -;;; ====================================================================== (define (make-bib-table ident) (make-hash-table)) @@ -80,10 +70,9 @@ (define (bib-table? obj) (hash-table? obj)) -(define (default-bib-table) - (unless *bib-table* - (set! *bib-table* (make-bib-table "default-bib-table"))) - *bib-table*) +;; The current bib table. +(define *bib-table* + (make-parameter (make-bib-table "default-bib-table"))) (define (%bib-error who entry) (let ((msg "bibliography syntax error on entry")) @@ -91,22 +80,34 @@ (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) (skribe-error who msg entry)))) -(define* (bib-for-each proc :optional (table (default-bib-table))) +(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 #f "~A" (cadr entry))) + (fields (cddr entry)) + (old (hash-ref table key))) + (if old + (bib-duplicate key #f old) + (hash-set! table key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + +(define* (bib-for-each proc :optional (table (*bib-table*))) (hash-for-each (lambda (ident entry) (proc ident entry)) table)) -(define* (bib-map proc :optional (table (default-bib-table))) +(define* (bib-map proc :optional (table (*bib-table*))) (hash-map->list (lambda (ident entry) (proc ident entry)) table)) - -;;; ====================================================================== -;;; -;;; BIB-DUPLICATE -;;; -;;; ====================================================================== (define (bib-duplicate ident from old) (let ((ofrom (markup-option old 'from))) (skribe-warning 2 @@ -120,11 +121,11 @@ " ignoring redefinition.")))) -;;; ====================================================================== + ;;; -;;; PARSE-BIB +;;; Parsing. ;;; -;;; ====================================================================== + (define (parse-bib table port) (let ((read %default-reader)) ;; FIXME: We should use a fluid (if (not (bib-table? table)) @@ -146,43 +147,15 @@ (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 #f "~A" (cadr entry))) - (fields (cddr entry)) - (old (hash-ref table key))) - (if old - (bib-duplicate key #f old) - (hash-set! 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) +(define* (open-bib-file file :optional (command #f)) (let ((path (search-path (*bib-path*) file))) (if (string? path) (begin (when (> (*verbose*) 0) - (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (format (current-error-port) + " [loading bibliography: ~S]\n" path)) + ;; FIXME: The following `open-input-file' won't work with actual + ;; commands. We need to use `(ice-9 popen)'. (open-input-file (if (string? command) (string-append "| " (format #f command path)) @@ -209,7 +182,7 @@ (if (not (bib-table? table)) (skribe-error 'bib-load "Illegal bibliography table" table) ;; read the file - (let ((p (skribe-open-bib-file filename command))) + (let ((p (open-bib-file filename command))) (if (not (input-port? p)) (skribe-error 'bib-load "Can't open data base" filename) (unwind-protect diff --git a/src/guile/skribilo/package/base.scm b/src/guile/skribilo/package/base.scm index 4c9e84c..01e8667 100644 --- a/src/guile/skribilo/package/base.scm +++ b/src/guile/skribilo/package/base.scm @@ -33,7 +33,7 @@ :autoload (skribilo engine) (engine?) ;; optional ``sub-packages'' - :autoload (skribilo biblio) (default-bib-table resolve-bib + :autoload (skribilo biblio) (*bib-table* resolve-bib bib-load! bib-add!) :autoload (skribilo color) (skribe-use-color!) :autoload (skribilo source) (language? source-read-lines source-fontify) @@ -1015,7 +1015,7 @@ (subsection #f) (subsubsection #f) (bib #f) - (bib-table (default-bib-table)) + (bib-table (*bib-table*)) (url #f) (figure #f) (mark #f) @@ -1245,7 +1245,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (bibliography #!rest files #!key - (command #f) (bib-table (default-bib-table))) + (command #f) (bib-table (*bib-table*))) (for-each (lambda (f) (cond ((string? f) @@ -1267,7 +1267,7 @@ (define-markup (the-bibliography #!rest opts #!key pred - (bib-table (default-bib-table)) + (bib-table (*bib-table*)) (sort bib-sort/authors) (count 'partial)) (if (not (memq count '(partial full))) diff --git a/src/guile/skribilo/utils/compat.scm b/src/guile/skribilo/utils/compat.scm index 118f294..4905cef 100644 --- a/src/guile/skribilo/utils/compat.scm +++ b/src/guile/skribilo/utils/compat.scm @@ -35,6 +35,7 @@ :autoload (skribilo lib) (type-name) :autoload (skribilo resolve) (*document-being-resolved*) :autoload (skribilo output) (*document-being-output*) + :autoload (skribilo biblio) (*bib-table* open-bib-file) :use-module (skribilo debug) :re-export (file-size) ;; re-exported from `(skribilo utils files)' @@ -207,6 +208,18 @@ (or (find-markups ident) '())) + +;;; +;;; Bibliography. +;;; + +(define-public (default-bib-table) + (*bib-table*)) + +(define-public (skribe-open-bib-file file command) + (open-bib-file file command)) + + ;;; ;;; Debugging facilities. -- cgit v1.2.3 From 56bd1e10d39a97f53f0c8ebefcdef909d99260bb Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 10:47:28 +0000 Subject: eq: Added the `:div-style' option. * src/guile/skribilo/package/eq.scm (eq): New `:div-style' option. Return a container rather than a markup. (eq:/): Added support for `:div-style'. * src/guile/skribilo/package/eq/lout.scm (eq): List `:div-style' as supported. (div-style->lout): New. (simple-lout-markup-writer): Handle LOUT-NAME as procedure. (eq:/): Use the `:div-style' option. (eq:script): Only use "on" when SUP is passed. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-80 --- src/guile/skribilo/package/eq.scm | 22 +++++++-- src/guile/skribilo/package/eq/lout.scm | 89 +++++++++++++++++++++------------- 2 files changed, 72 insertions(+), 39 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 4f5020e..58fb77c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -169,12 +169,15 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; Markup. ;;; -(define-markup (eq :rest opts :key (ident #f) (inline? #f) - (renderer #f) (class "eq")) - (new markup +(define-markup (eq :rest opts :key (ident #f) (class "eq") + (inline? #f) + (renderer #f) (div-style 'over)) + (new container (markup 'eq) (ident (or ident (symbol->string (gensym "eq")))) - (options (the-options opts)) + (class class) + (options `((:div-style ,div-style) + ,@(the-options opts :ident :class :div-style))) (body (let loop ((body (the-body opts)) (result '())) (if (null? body) @@ -187,7 +190,16 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;; passed )))))) -(define-simple-markup eq:/) +(define-markup (eq:/ :rest opts :key (ident #f) (div-style #f)) + ;; If no `:div-style' is specified here, obey the top-level one. + (new markup + (markup 'eq:/) + (ident (or ident (symbol->string (gensym "eq:/")))) + (class #f) + (options `((:div-style ,div-style) + ,@(the-options opts :ident :class :div-style))) + (body (the-body opts)))) + (define-simple-markup eq:*) (define-simple-markup eq:+) (define-simple-markup eq:-) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index c487b85..cce5124 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -53,7 +53,7 @@ (markup-writer 'eq (find-engine 'lout) - :options '(:inline?) + :options '(:inline? :div-style) :before "{ " :action (lambda (node engine) (display (if (markup-option node :inline?) @@ -65,6 +65,14 @@ :after " } }") +(define (div-style->lout style) + (case style + ((over) "over") + ((fraction) "frac") + ((div) "div") + ((slash) "slash") + (else + (error "unsupported div style" style)))) (define-macro (simple-lout-markup-writer sym . args) (let* ((lout-name (if (null? args) @@ -83,37 +91,41 @@ `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (let* ((op (car operands)) - (eq-op? (equation-markup? op)) - (need-paren? - (and eq-op? - (< (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) - (column (port-column - (current-output-port)))) - - ;; Work around Lout's limitations... - (if (> column 1000) (display "\n")) - - (display (string-append " { " - ,(if parentheses? - open-par - ""))) - (output op engine) - (display (string-append ,(if parentheses? - close-par - "") - " }")) - (if (pair? (cdr operands)) - (display ,(string-append " " - lout-name - " "))) - (loop (cdr operands))))))))) + (let ((lout-name ,(if (string? lout-name) + lout-name + `(,lout-name node + engine)))) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (< (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column + (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " + ,(if parentheses? + open-par + ""))) + (output op engine) + (display (string-append ,(if parentheses? + close-par + "") + " }")) + (if (pair? (cdr operands)) + (display (string-append " " + lout-name + " "))) + (loop (cdr operands)))))))))) ;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their @@ -124,7 +136,16 @@ (simple-lout-markup-writer +) (simple-lout-markup-writer * "times") (simple-lout-markup-writer - "-") -(simple-lout-markup-writer / "over" #f) +(simple-lout-markup-writer / + (lambda (n e) + ;; Obey either the per-node `:div-style' or the + ;; top-level one. + (or (markup-option n :div-style) + (let* ((eq (ast-parent n)) + (div-style + (markup-option eq :div-style))) + (div-style->lout div-style)))) + #f) (simple-lout-markup-writer =) (simple-lout-markup-writer <) (simple-lout-markup-writer >) @@ -208,7 +229,7 @@ (display " } "))) (if sub (begin - (display " on { ") + (display (if sup " on { " " sub { ")) (output sub engine) (display " } "))) (display " } ")))) -- cgit v1.2.3 From 9f08ec317436acb62fb0f47c1ea3f1a1460f88e1 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 12:40:13 +0000 Subject: doc: Documented `eq' and the `:div-style' option. * doc/user/char.skb (Symbols): Added an ident. * doc/user/eq.skb (Equation Formatting)[Summary]: New section. Use `doc-markup' as should have already been the case and document `:div-style'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-81 --- doc/user/char.skb | 1 + doc/user/eq.skb | 26 +++++++++++++++++++++++--- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/doc/user/char.skb b/doc/user/char.skb index 16c4625..b2f94e2 100644 --- a/doc/user/char.skb +++ b/doc/user/char.skb @@ -67,6 +67,7 @@ are replaced with the actual values of the arguments ,(param 'node).]) ;*--- Symbols ---------------------------------------------------------*/ (subsection :title "Symbols" + :ident "symbols" (p [The function ,(code "symbol") introduces special symbols in the produced file. Note that the rendering of symbols is unportable. It depends diff --git a/doc/user/eq.skb b/doc/user/eq.skb index a611f88..455832b 100644 --- a/doc/user/eq.skb +++ b/doc/user/eq.skb @@ -57,7 +57,7 @@ much like any other kind of markup. However, the resulting syntax is very verbose and hard to read.]) (p [Fortunately, the ,(tt [eq]) package allows for the use of a -much simple syntax. ] +much simpler syntax. ] (example-produce (example :legend "Example of a simple equation" @@ -69,10 +69,30 @@ may have already recognized its ,(emph [prefix notation]). Note that, unlike in the previous example, the equation itself if ,(emph [quoted]), that is, preceded by the ,(tt [']) sign. Additionally, when referring to a symbol (such as the Greek letter ,(symbol "phi")), you no longer -need to use the ,(tt [symbol]) markup (,(ref :text [see subsection] -:subsection "Symbols")).])) +need to use the ,(tt [symbol]) markup (,(numref :text [see Section] +:ident "symbols")).])) + ;; FIXME: Write this. (section :title [Rendering]) + + (section :title [Summary] + + (p [The options available for the top-level ,(code [eq]) markup +are summarized here:]) + + (doc-markup 'eq + `((:inline? [A boolean indicating whether the equation +is to appear "inline", i.e., within a paragraph. If the engine supports +it, it may adjust various parameters such as in-equation spacing +accordingly.]) + (:renderer [The engine that should be used to render +the equation. This allows, for instance, to use the Lout engine to +render equations in HTML.]) + (:div-style [A symbol denoting the default style for +divisions. This should be one of ,(code [over]), ,(code [fraction]), +,(code [div]) and ,(code [slash]). Per-,(code [eq:/]) ,(code +[:div-style]) options override this setting.])) + :source "skribilo/package/eq.scm")) ) -- cgit v1.2.3 From e0101950f601d38176410848840882d51ec90b9b Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 14:05:13 +0000 Subject: eq: Added `limit' and `combinations'. * src/guile/skribilo/package/eq.scm (%operators): Added `limit' and `combinations'. (eq:limit): New. (eq:combinations): New. (eq:limit): New text-based writer. (eq:combinations): Likewise. * src/guile/skribilo/package/eq/lout.scm (eq:limit): New. (eq:combinations): New. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-82 --- src/guile/skribilo/package/eq.scm | 40 +++++++++++++++++++++++++++++++++- src/guile/skribilo/package/eq/lout.scm | 24 ++++++++++++++++++++ 2 files changed, 63 insertions(+), 1 deletion(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 58fb77c..c45f698 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -54,7 +54,7 @@ (define %operators '(/ * + - = != ~= < > <= >= sqrt expt sum product script - in notin apply)) + in notin apply limit combinations)) (define %symbols ;; A set of symbols that are automatically recognized within an `eq' quoted @@ -264,6 +264,22 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (loop (cdr body) (cons first result))))))))) +(define-markup (eq:limit var lim :rest body :key (ident #f)) + (new markup + (markup 'eq:limit) + (ident (or ident (symbol->string (gensym "eq:limit")))) + (options `((:var ,var) (:limit ,lim) + ,@(the-options body :ident))) + (body (the-body body)))) + +(define-markup (eq:combinations x y :rest opts :key (ident #f)) + (new markup + (markup 'eq:combinations) + (ident (or ident (symbol->string (gensym "eq:combinations")))) + (options `((:of ,x) (:among ,y) + ,@(the-options opts :ident))) + (body (the-body opts)))) + ;;; ;;; Text-based rendering. @@ -434,6 +450,28 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (output (sup sup*) engine) (output (sub sub*) engine)))) +(markup-writer 'eq:limit (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node)) + (var (markup-option node :var)) + (limit (markup-option node :limit))) + (display "lim (") + (output var engine) + (output (symbol "->") engine) + (output limit engine) + (display ", ") + (output body engine) + (display ")")))) + +(markup-writer 'eq:combinations (find-engine 'base) + :action (lambda (node engine) + (let ((of (markup-option node :of)) + (among (markup-option node :among))) + (display "combinations(") + (output of engine) + (display ", ") + (output among engine) + (display ")")))) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index cce5124..563fdbf 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -191,6 +191,30 @@ (display ")")))) +(markup-writer 'eq:limit (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node)) + (var (markup-option node :var)) + (limit (markup-option node :limit))) + (display "{ lim on { ") + (output var engine) + (display " --> ") + (output limit engine) + (display " } } (") + (output body engine) + (display ") ")))) + +(markup-writer 'eq:combinations (find-engine 'lout) + :action (lambda (node engine) + (let ((of (markup-option node :of)) + (among (markup-option node :among))) + (display " { matrix atleft { blpar } atright { brpar } { ") + (display "row col { ") + (output among engine) + (display " } row col { ") + (output of engine) + (display " } } }\n")))) + ;;; ;;; Sums, products, integrals, etc. -- cgit v1.2.3 From dded89e4e810f13fdf521d6ec8a90ca06ea21675 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 14:40:32 +0000 Subject: eq: Properly handle operator precedence. * src/guile/skribilo/package/eq.scm (%operator-precedence): Fixed according to Wikipedia. (simple-markup-writer): Honor operator precedence. * src/guile/skribilo/package/eq/lout.scm (simple-lout-markup-writer): Likewise. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-83 --- src/guile/skribilo/package/eq.scm | 39 +++++++++++++++++++++------------- src/guile/skribilo/package/eq/lout.scm | 28 ++++++++++++------------ 2 files changed, 38 insertions(+), 29 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index c45f698..a3eb99c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -116,18 +116,27 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; (define %operator-precedence - ;; FIXME: This needs to be augmented. - '((+ . 1) - (- . 1) - (* . 2) - (/ . 2) - (sum . 3) + ;; Taken from http://en.wikipedia.org/wiki/Order_of_operations . + '((expt . 2) + (sqrt . 2) + + (* . 3) + (/ . 3) (product . 3) - (= . 0) - (< . 0) - (> . 0) - (<= . 0) - (>= . 0))) + + (+ . 4) + (- . 4) + (sum . 4) + + (< . 6) + (> . 6) + (<= . 6) + (>= . 6) + + (= . 7) + (!= . 7) + (~= . 7))) + (define-public (operator-precedence op) (let ((p (assq op %operator-precedence))) @@ -329,10 +338,10 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (nested-eq? (equation-markup? o)) (need-paren? (and nested-eq? -; (< (operator-precedence -; (equation-markup-name->operator -; (markup-markup o))) -; ,precedence) + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup o))) + ,precedence) ) )) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 563fdbf..9cd594b 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -85,8 +85,12 @@ ;; Note: We could use `pmatrix' here but it precludes line-breaking ;; within equations. - (open-par `(if need-paren? "{ @VScale ( }" "")) - (close-par `(if need-paren? "{ @VScale ) }" ""))) + (open-par (if parentheses? + `(if need-paren? "{ @VScale ( }" "") + "")) + (close-par (if parentheses? + `(if need-paren? "{ @VScale ) }" "") + ""))) `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) @@ -102,25 +106,21 @@ (eq-op? (equation-markup? op)) (need-paren? (and eq-op? - (< (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) (column (port-column (current-output-port)))) ;; Work around Lout's limitations... (if (> column 1000) (display "\n")) - (display (string-append " { " - ,(if parentheses? - open-par - ""))) + (display + (string-append " { " ,open-par)) (output op engine) - (display (string-append ,(if parentheses? - close-par - "") - " }")) + (display + (string-append ,close-par " }")) (if (pair? (cdr operands)) (display (string-append " " lout-name -- cgit v1.2.3 From 5b43497afce0e669d041e92d1df7ad22e110235d Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 17:46:31 +0000 Subject: eq: Added `eq-display' and the `:align-with' option for `eq'. * src/guile/skribilo/package/eq.scm: Use `srfi-39'. (*embedded-renderer*): New. (eq-display): New. (eq)[:align-with]: New option. (eq-display): New text-based writer. (eq): Parameterize `*embedded-renderer*'. * src/guile/skribilo/package/eq/lout.scm (eq-display): New writer. (eq): Support `:align-with'. (simple-lout-markup-writer): Honor `:align-with'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-84 --- src/guile/skribilo/package/eq.scm | 62 +++++++++++++++++------- src/guile/skribilo/package/eq/lout.scm | 86 ++++++++++++++++++++-------------- 2 files changed, 95 insertions(+), 53 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index a3eb99c..76bbf6c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -29,6 +29,8 @@ :use-module (skribilo utils keywords) ;; `the-options', etc. :autoload (skribilo package base) (it symbol sub sup) :autoload (skribilo engine lout) (lout-illustration) + + :use-module (srfi srfi-39) :use-module (ice-9 optargs)) ;;; Author: Ludovic Courtès @@ -52,6 +54,11 @@ ;;; Utilities. ;;; +(define-public *embedded-renderer* + ;; Tells whether an engine is invoked as an embedded renderer or as the + ;; native engine. + (make-parameter #f)) + (define %operators '(/ * + - = != ~= < > <= >= sqrt expt sum product script in notin apply limit combinations)) @@ -178,15 +185,25 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; Markup. ;;; +(define-markup (eq-display :rest opts :key (ident #f) (class "eq-display")) + (new container + (markup 'eq-display) + (ident (or ident (symbol->string (gensym "eq-display")))) + (class class) + (options (the-options opts :ident :class :div-style)) + (body (the-body opts)))) + (define-markup (eq :rest opts :key (ident #f) (class "eq") - (inline? #f) + (inline? #f) (align-with #f) (renderer #f) (div-style 'over)) (new container (markup 'eq) (ident (or ident (symbol->string (gensym "eq")))) (class class) - (options `((:div-style ,div-style) - ,@(the-options opts :ident :class :div-style))) + (options `((:div-style ,div-style) (:align-with ,align-with) + ,@(the-options opts + :ident :class + :div-style :align-with))) (body (let loop ((body (the-body opts)) (result '())) (if (null? body) @@ -199,6 +216,7 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;; passed )))))) + (define-markup (eq:/ :rest opts :key (ident #f) (div-style #f)) ;; If no `:div-style' is specified here, obey the top-level one. (new markup @@ -295,6 +313,15 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; +(markup-writer 'eq-display (find-engine 'base) + :action (lambda (node engine) + (for-each (lambda (node) + (let ((eq? (is-markup? node 'eq))) + (if eq? (output (linebreak) engine)) + (output node engine) + (if eq? (output (linebreak) engine)))) + (markup-body node)))) + (markup-writer 'eq (find-engine 'base) :action (lambda (node engine) ;; The `:renderer' option should be a symbol (naming an engine @@ -306,20 +333,21 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (cond ((not renderer) ;; default: use the current engine (output (it (markup-body node)) engine)) ((symbol? renderer) - (case renderer - ;; FIXME: We should have an `embed' slot for each - ;; engine class similar to `lout-illustration'. - ((lout) - (let ((lout-code - (with-output-to-string - (lambda () - (output node (find-engine 'lout)))))) - (output (lout-illustration - :ident (markup-ident node) - lout-code) - engine))) - (else - (skribe-error 'eq "invalid renderer" renderer)))) + (parameterize ((*embedded-renderer* #t)) + (case renderer + ;; FIXME: We should have an `embed' slot for each + ;; engine class similar to `lout-illustration'. + ((lout) + (let ((lout-code + (with-output-to-string + (lambda () + (output node (find-engine 'lout)))))) + (output (lout-illustration + :ident (markup-ident node) + lout-code) + engine))) + (else + (skribe-error 'eq "invalid renderer" renderer))))) ;; FIXME: `engine?' and `engine-class?' (else (skribe-error 'eq "`:renderer' -- wrong argument type" diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 9cd594b..b1ff7ae 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -51,10 +51,18 @@ ;;; Simple markup writers. ;;; +(markup-writer 'eq-display (find-engine 'lout) + :before "\n@BeginAlignedDisplays\n" + :after "\n@EndAlignedDisplays\n") (markup-writer 'eq (find-engine 'lout) - :options '(:inline? :div-style) - :before "{ " + :options '(:inline? :align-with :div-style) + :before (lambda (node engine) + (let* ((parent (ast-parent node)) + (displayed? (is-markup? parent 'eq-display))) + (format #t "~a{ " + (if (and displayed? (not (*embedded-renderer*))) + "\n@IAD " "")))) :action (lambda (node engine) (display (if (markup-option node :inline?) "@E { " @@ -92,40 +100,46 @@ `(if need-paren? "{ @VScale ) }" "") ""))) - `(markup-writer ',(symbol-append 'eq: sym) - (find-engine 'lout) - :action (lambda (node engine) - (let ((lout-name ,(if (string? lout-name) - lout-name - `(,lout-name node - engine)))) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (let* ((op (car operands)) - (eq-op? (equation-markup? op)) - (need-paren? - (and eq-op? - (>= (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) - (column (port-column - (current-output-port)))) - - ;; Work around Lout's limitations... - (if (> column 1000) (display "\n")) - - (display - (string-append " { " ,open-par)) - (output op engine) - (display - (string-append ,close-par " }")) - (if (pair? (cdr operands)) - (display (string-append " " - lout-name - " "))) - (loop (cdr operands)))))))))) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let* ((lout-name ,(if (string? lout-name) + lout-name + `(,lout-name node + engine))) + (eq (ast-parent node)) + (eq-parent (ast-parent eq))) + + (let loop ((operands (markup-body node)) + (first? #t)) + (if (null? operands) + #t + (let* ((align? + (and first? + (is-markup? eq-parent 'eq-display) + (eq? ',sym + (markup-option eq :align-with)))) + (op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " ,open-par)) + (output op engine) + (display (string-append ,close-par " }")) + (if (pair? (cdr operands)) + (display (string-append " " + (if align? "^" "") + lout-name + " "))) + (loop (cdr operands) #f))))))))) ;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their -- cgit v1.2.3 From 571d41ac337819d4a5bbdbdb1f0c8f13c542059c Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Tue, 28 Nov 2006 17:47:44 +0000 Subject: doc: Augmented the `eq' doc, documented `eq-display'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-85 --- doc/user/eq.skb | 25 +++++++++++++++++++++++-- doc/user/src/eq3.skb | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 61 insertions(+), 2 deletions(-) create mode 100644 doc/user/src/eq3.skb diff --git a/doc/user/eq.skb b/doc/user/eq.skb index 455832b..1ef0208 100644 --- a/doc/user/eq.skb +++ b/doc/user/eq.skb @@ -70,7 +70,16 @@ unlike in the previous example, the equation itself if ,(emph [quoted]), that is, preceded by the ,(tt [']) sign. Additionally, when referring to a symbol (such as the Greek letter ,(symbol "phi")), you no longer need to use the ,(tt [symbol]) markup (,(numref :text [see Section] -:ident "symbols")).])) +:ident "symbols")).]) + + (p [It is possible to create ,(emph [equation display blocks]), +where several equations are displayed and aligned according to a +particular operator. ] + + (example-produce + (example :legend "Inlined, displayed, and aligned equations" + (prgm :file "src/eq3.skb")) + (disp (include "src/eq3.skb"))))) ;; FIXME: Write this. (section :title [Rendering]) @@ -91,7 +100,19 @@ render equations in HTML.]) (:div-style [A symbol denoting the default style for divisions. This should be one of ,(code [over]), ,(code [fraction]), ,(code [div]) and ,(code [slash]). Per-,(code [eq:/]) ,(code -[:div-style]) options override this setting.])) +[:div-style]) options override this setting.]) + (:align-with [Within a ,(code [eq-display]) block, +this should be a symbol specifying according to which operator equations +are to be aligned with one another.])) + :source "skribilo/package/eq.scm") + + (p [Equation display blocks can be defined using ,(code +[eq-display]). Display blocks define the scope of the alignment among +equations as specified by the ,(code [:align-with]) options of ,(code +[eq]).]) + + (doc-markup 'eq-display + `() :source "skribilo/package/eq.scm")) ) diff --git a/doc/user/src/eq3.skb b/doc/user/src/eq3.skb new file mode 100644 index 0000000..e229b6c --- /dev/null +++ b/doc/user/src/eq3.skb @@ -0,0 +1,38 @@ +(p [This paragraph contains this equation: ,(eq :inline? #t '(/ alpha +beta)). This is actually an ,(emph [inline]) equation, meaning that it +occurs within a paragraph. Typesetting has to be adjusted +accordingly.]) + +(eq-display + + (p [This is an equation display block, within which equations can be +aligned with one another.]) + + (eq :ident "eq-limit-b-over-l" + :renderer 'lout + :align-with '= + '(= (limit (/ lambda beta) 0 + (apply IPL n k)) + + ;; non-simplified + (/ (expt (+ alpha beta) k) + (* beta + (sum :from (= x 0) + :to (- k 1) + (* (combinations k x) + (expt beta (- k 1 x)) + (expt alpha x))))))) + + [This equation can be simplified as follows:] + + (eq :ident "eq-limit-b-over-l-simplified" + :renderer 'lout + :align-with '= + '(= ;; simplified + (/ (expt (+ alpha beta) k) + (- (expt (+ alpha beta) k) + (expt alpha k))) + + (limit (/ lambda beta) 0 + (apply IPL n k))))) + -- cgit v1.2.3 From 81f9b6cae9be169cf0723434dc629d75a37595a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:40:47 +0000 Subject: eq: Added the `:div-style' option. * src/guile/skribilo/package/eq.scm (eq): New `:div-style' option. Return a container rather than a markup. (eq:/): Added support for `:div-style'. * src/guile/skribilo/package/eq/lout.scm (eq): List `:div-style' as supported. (div-style->lout): New. (simple-lout-markup-writer): Handle LOUT-NAME as procedure. (eq:/): Use the `:div-style' option. (eq:script): Only use "on" when SUP is passed. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-22 --- src/guile/skribilo/package/eq.scm | 22 +++++++-- src/guile/skribilo/package/eq/lout.scm | 89 +++++++++++++++++++++------------- 2 files changed, 72 insertions(+), 39 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 4f5020e..58fb77c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -169,12 +169,15 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; Markup. ;;; -(define-markup (eq :rest opts :key (ident #f) (inline? #f) - (renderer #f) (class "eq")) - (new markup +(define-markup (eq :rest opts :key (ident #f) (class "eq") + (inline? #f) + (renderer #f) (div-style 'over)) + (new container (markup 'eq) (ident (or ident (symbol->string (gensym "eq")))) - (options (the-options opts)) + (class class) + (options `((:div-style ,div-style) + ,@(the-options opts :ident :class :div-style))) (body (let loop ((body (the-body opts)) (result '())) (if (null? body) @@ -187,7 +190,16 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;; passed )))))) -(define-simple-markup eq:/) +(define-markup (eq:/ :rest opts :key (ident #f) (div-style #f)) + ;; If no `:div-style' is specified here, obey the top-level one. + (new markup + (markup 'eq:/) + (ident (or ident (symbol->string (gensym "eq:/")))) + (class #f) + (options `((:div-style ,div-style) + ,@(the-options opts :ident :class :div-style))) + (body (the-body opts)))) + (define-simple-markup eq:*) (define-simple-markup eq:+) (define-simple-markup eq:-) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index c487b85..cce5124 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -53,7 +53,7 @@ (markup-writer 'eq (find-engine 'lout) - :options '(:inline?) + :options '(:inline? :div-style) :before "{ " :action (lambda (node engine) (display (if (markup-option node :inline?) @@ -65,6 +65,14 @@ :after " } }") +(define (div-style->lout style) + (case style + ((over) "over") + ((fraction) "frac") + ((div) "div") + ((slash) "slash") + (else + (error "unsupported div style" style)))) (define-macro (simple-lout-markup-writer sym . args) (let* ((lout-name (if (null? args) @@ -83,37 +91,41 @@ `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) :action (lambda (node engine) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (let* ((op (car operands)) - (eq-op? (equation-markup? op)) - (need-paren? - (and eq-op? - (< (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) - (column (port-column - (current-output-port)))) - - ;; Work around Lout's limitations... - (if (> column 1000) (display "\n")) - - (display (string-append " { " - ,(if parentheses? - open-par - ""))) - (output op engine) - (display (string-append ,(if parentheses? - close-par - "") - " }")) - (if (pair? (cdr operands)) - (display ,(string-append " " - lout-name - " "))) - (loop (cdr operands))))))))) + (let ((lout-name ,(if (string? lout-name) + lout-name + `(,lout-name node + engine)))) + (let loop ((operands (markup-body node))) + (if (null? operands) + #t + (let* ((op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (< (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column + (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " + ,(if parentheses? + open-par + ""))) + (output op engine) + (display (string-append ,(if parentheses? + close-par + "") + " }")) + (if (pair? (cdr operands)) + (display (string-append " " + lout-name + " "))) + (loop (cdr operands)))))))))) ;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their @@ -124,7 +136,16 @@ (simple-lout-markup-writer +) (simple-lout-markup-writer * "times") (simple-lout-markup-writer - "-") -(simple-lout-markup-writer / "over" #f) +(simple-lout-markup-writer / + (lambda (n e) + ;; Obey either the per-node `:div-style' or the + ;; top-level one. + (or (markup-option n :div-style) + (let* ((eq (ast-parent n)) + (div-style + (markup-option eq :div-style))) + (div-style->lout div-style)))) + #f) (simple-lout-markup-writer =) (simple-lout-markup-writer <) (simple-lout-markup-writer >) @@ -208,7 +229,7 @@ (display " } "))) (if sub (begin - (display " on { ") + (display (if sup " on { " " sub { ")) (output sub engine) (display " } "))) (display " } ")))) -- cgit v1.2.3 From 9d5dfa5b32e1dcf98cb4878322d00150477a8225 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:41:59 +0000 Subject: doc: Documented `eq' and the `:div-style' option. * doc/user/char.skb (Symbols): Added an ident. * doc/user/eq.skb (Equation Formatting)[Summary]: New section. Use `doc-markup' as should have already been the case and document `:div-style'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-23 --- doc/user/char.skb | 1 + doc/user/eq.skb | 26 +++++++++++++++++++++++--- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/doc/user/char.skb b/doc/user/char.skb index 16c4625..b2f94e2 100644 --- a/doc/user/char.skb +++ b/doc/user/char.skb @@ -67,6 +67,7 @@ are replaced with the actual values of the arguments ,(param 'node).]) ;*--- Symbols ---------------------------------------------------------*/ (subsection :title "Symbols" + :ident "symbols" (p [The function ,(code "symbol") introduces special symbols in the produced file. Note that the rendering of symbols is unportable. It depends diff --git a/doc/user/eq.skb b/doc/user/eq.skb index a611f88..455832b 100644 --- a/doc/user/eq.skb +++ b/doc/user/eq.skb @@ -57,7 +57,7 @@ much like any other kind of markup. However, the resulting syntax is very verbose and hard to read.]) (p [Fortunately, the ,(tt [eq]) package allows for the use of a -much simple syntax. ] +much simpler syntax. ] (example-produce (example :legend "Example of a simple equation" @@ -69,10 +69,30 @@ may have already recognized its ,(emph [prefix notation]). Note that, unlike in the previous example, the equation itself if ,(emph [quoted]), that is, preceded by the ,(tt [']) sign. Additionally, when referring to a symbol (such as the Greek letter ,(symbol "phi")), you no longer -need to use the ,(tt [symbol]) markup (,(ref :text [see subsection] -:subsection "Symbols")).])) +need to use the ,(tt [symbol]) markup (,(numref :text [see Section] +:ident "symbols")).])) + ;; FIXME: Write this. (section :title [Rendering]) + + (section :title [Summary] + + (p [The options available for the top-level ,(code [eq]) markup +are summarized here:]) + + (doc-markup 'eq + `((:inline? [A boolean indicating whether the equation +is to appear "inline", i.e., within a paragraph. If the engine supports +it, it may adjust various parameters such as in-equation spacing +accordingly.]) + (:renderer [The engine that should be used to render +the equation. This allows, for instance, to use the Lout engine to +render equations in HTML.]) + (:div-style [A symbol denoting the default style for +divisions. This should be one of ,(code [over]), ,(code [fraction]), +,(code [div]) and ,(code [slash]). Per-,(code [eq:/]) ,(code +[:div-style]) options override this setting.])) + :source "skribilo/package/eq.scm")) ) -- cgit v1.2.3 From 32136d000be5c570133c48c3650d5d7b51efa2fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:42:56 +0000 Subject: eq: Added `limit' and `combinations'. * src/guile/skribilo/package/eq.scm (%operators): Added `limit' and `combinations'. (eq:limit): New. (eq:combinations): New. (eq:limit): New text-based writer. (eq:combinations): Likewise. * src/guile/skribilo/package/eq/lout.scm (eq:limit): New. (eq:combinations): New. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-24 --- src/guile/skribilo/package/eq.scm | 40 +++++++++++++++++++++++++++++++++- src/guile/skribilo/package/eq/lout.scm | 24 ++++++++++++++++++++ 2 files changed, 63 insertions(+), 1 deletion(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 58fb77c..c45f698 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -54,7 +54,7 @@ (define %operators '(/ * + - = != ~= < > <= >= sqrt expt sum product script - in notin apply)) + in notin apply limit combinations)) (define %symbols ;; A set of symbols that are automatically recognized within an `eq' quoted @@ -264,6 +264,22 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (loop (cdr body) (cons first result))))))))) +(define-markup (eq:limit var lim :rest body :key (ident #f)) + (new markup + (markup 'eq:limit) + (ident (or ident (symbol->string (gensym "eq:limit")))) + (options `((:var ,var) (:limit ,lim) + ,@(the-options body :ident))) + (body (the-body body)))) + +(define-markup (eq:combinations x y :rest opts :key (ident #f)) + (new markup + (markup 'eq:combinations) + (ident (or ident (symbol->string (gensym "eq:combinations")))) + (options `((:of ,x) (:among ,y) + ,@(the-options opts :ident))) + (body (the-body opts)))) + ;;; ;;; Text-based rendering. @@ -434,6 +450,28 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (output (sup sup*) engine) (output (sub sub*) engine)))) +(markup-writer 'eq:limit (find-engine 'base) + :action (lambda (node engine) + (let ((body (markup-body node)) + (var (markup-option node :var)) + (limit (markup-option node :limit))) + (display "lim (") + (output var engine) + (output (symbol "->") engine) + (output limit engine) + (display ", ") + (output body engine) + (display ")")))) + +(markup-writer 'eq:combinations (find-engine 'base) + :action (lambda (node engine) + (let ((of (markup-option node :of)) + (among (markup-option node :among))) + (display "combinations(") + (output of engine) + (display ", ") + (output among engine) + (display ")")))) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index cce5124..563fdbf 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -191,6 +191,30 @@ (display ")")))) +(markup-writer 'eq:limit (find-engine 'lout) + :action (lambda (node engine) + (let ((body (markup-body node)) + (var (markup-option node :var)) + (limit (markup-option node :limit))) + (display "{ lim on { ") + (output var engine) + (display " --> ") + (output limit engine) + (display " } } (") + (output body engine) + (display ") ")))) + +(markup-writer 'eq:combinations (find-engine 'lout) + :action (lambda (node engine) + (let ((of (markup-option node :of)) + (among (markup-option node :among))) + (display " { matrix atleft { blpar } atright { brpar } { ") + (display "row col { ") + (output among engine) + (display " } row col { ") + (output of engine) + (display " } } }\n")))) + ;;; ;;; Sums, products, integrals, etc. -- cgit v1.2.3 From a7a4342d6efd74f7231994b4cc5b4255b36e13f4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:43:59 +0000 Subject: eq: Properly handle operator precedence. * src/guile/skribilo/package/eq.scm (%operator-precedence): Fixed according to Wikipedia. (simple-markup-writer): Honor operator precedence. * src/guile/skribilo/package/eq/lout.scm (simple-lout-markup-writer): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-25 --- src/guile/skribilo/package/eq.scm | 39 +++++++++++++++++++++------------- src/guile/skribilo/package/eq/lout.scm | 28 ++++++++++++------------ 2 files changed, 38 insertions(+), 29 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index c45f698..a3eb99c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -116,18 +116,27 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; (define %operator-precedence - ;; FIXME: This needs to be augmented. - '((+ . 1) - (- . 1) - (* . 2) - (/ . 2) - (sum . 3) + ;; Taken from http://en.wikipedia.org/wiki/Order_of_operations . + '((expt . 2) + (sqrt . 2) + + (* . 3) + (/ . 3) (product . 3) - (= . 0) - (< . 0) - (> . 0) - (<= . 0) - (>= . 0))) + + (+ . 4) + (- . 4) + (sum . 4) + + (< . 6) + (> . 6) + (<= . 6) + (>= . 6) + + (= . 7) + (!= . 7) + (~= . 7))) + (define-public (operator-precedence op) (let ((p (assq op %operator-precedence))) @@ -329,10 +338,10 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (nested-eq? (equation-markup? o)) (need-paren? (and nested-eq? -; (< (operator-precedence -; (equation-markup-name->operator -; (markup-markup o))) -; ,precedence) + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup o))) + ,precedence) ) )) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 563fdbf..9cd594b 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -85,8 +85,12 @@ ;; Note: We could use `pmatrix' here but it precludes line-breaking ;; within equations. - (open-par `(if need-paren? "{ @VScale ( }" "")) - (close-par `(if need-paren? "{ @VScale ) }" ""))) + (open-par (if parentheses? + `(if need-paren? "{ @VScale ( }" "") + "")) + (close-par (if parentheses? + `(if need-paren? "{ @VScale ) }" "") + ""))) `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) @@ -102,25 +106,21 @@ (eq-op? (equation-markup? op)) (need-paren? (and eq-op? - (< (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) (column (port-column (current-output-port)))) ;; Work around Lout's limitations... (if (> column 1000) (display "\n")) - (display (string-append " { " - ,(if parentheses? - open-par - ""))) + (display + (string-append " { " ,open-par)) (output op engine) - (display (string-append ,(if parentheses? - close-par - "") - " }")) + (display + (string-append ,close-par " }")) (if (pair? (cdr operands)) (display (string-append " " lout-name -- cgit v1.2.3 From 362047ce067c665d7f7e63de362a9e9f5dd50dbf Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:44:57 +0000 Subject: eq: Added `eq-display' and the `:align-with' option for `eq'. * src/guile/skribilo/package/eq.scm: Use `srfi-39'. (*embedded-renderer*): New. (eq-display): New. (eq)[:align-with]: New option. (eq-display): New text-based writer. (eq): Parameterize `*embedded-renderer*'. * src/guile/skribilo/package/eq/lout.scm (eq-display): New writer. (eq): Support `:align-with'. (simple-lout-markup-writer): Honor `:align-with'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-26 --- src/guile/skribilo/package/eq.scm | 62 +++++++++++++++++------- src/guile/skribilo/package/eq/lout.scm | 86 ++++++++++++++++++++-------------- 2 files changed, 95 insertions(+), 53 deletions(-) diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index a3eb99c..76bbf6c 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -29,6 +29,8 @@ :use-module (skribilo utils keywords) ;; `the-options', etc. :autoload (skribilo package base) (it symbol sub sup) :autoload (skribilo engine lout) (lout-illustration) + + :use-module (srfi srfi-39) :use-module (ice-9 optargs)) ;;; Author: Ludovic Courtès @@ -52,6 +54,11 @@ ;;; Utilities. ;;; +(define-public *embedded-renderer* + ;; Tells whether an engine is invoked as an embedded renderer or as the + ;; native engine. + (make-parameter #f)) + (define %operators '(/ * + - = != ~= < > <= >= sqrt expt sum product script in notin apply limit combinations)) @@ -178,15 +185,25 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; Markup. ;;; +(define-markup (eq-display :rest opts :key (ident #f) (class "eq-display")) + (new container + (markup 'eq-display) + (ident (or ident (symbol->string (gensym "eq-display")))) + (class class) + (options (the-options opts :ident :class :div-style)) + (body (the-body opts)))) + (define-markup (eq :rest opts :key (ident #f) (class "eq") - (inline? #f) + (inline? #f) (align-with #f) (renderer #f) (div-style 'over)) (new container (markup 'eq) (ident (or ident (symbol->string (gensym "eq")))) (class class) - (options `((:div-style ,div-style) - ,@(the-options opts :ident :class :div-style))) + (options `((:div-style ,div-style) (:align-with ,align-with) + ,@(the-options opts + :ident :class + :div-style :align-with))) (body (let loop ((body (the-body opts)) (result '())) (if (null? body) @@ -199,6 +216,7 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;; passed )))))) + (define-markup (eq:/ :rest opts :key (ident #f) (div-style #f)) ;; If no `:div-style' is specified here, obey the top-level one. (new markup @@ -295,6 +313,15 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., ;;; +(markup-writer 'eq-display (find-engine 'base) + :action (lambda (node engine) + (for-each (lambda (node) + (let ((eq? (is-markup? node 'eq))) + (if eq? (output (linebreak) engine)) + (output node engine) + (if eq? (output (linebreak) engine)))) + (markup-body node)))) + (markup-writer 'eq (find-engine 'base) :action (lambda (node engine) ;; The `:renderer' option should be a symbol (naming an engine @@ -306,20 +333,21 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (cond ((not renderer) ;; default: use the current engine (output (it (markup-body node)) engine)) ((symbol? renderer) - (case renderer - ;; FIXME: We should have an `embed' slot for each - ;; engine class similar to `lout-illustration'. - ((lout) - (let ((lout-code - (with-output-to-string - (lambda () - (output node (find-engine 'lout)))))) - (output (lout-illustration - :ident (markup-ident node) - lout-code) - engine))) - (else - (skribe-error 'eq "invalid renderer" renderer)))) + (parameterize ((*embedded-renderer* #t)) + (case renderer + ;; FIXME: We should have an `embed' slot for each + ;; engine class similar to `lout-illustration'. + ((lout) + (let ((lout-code + (with-output-to-string + (lambda () + (output node (find-engine 'lout)))))) + (output (lout-illustration + :ident (markup-ident node) + lout-code) + engine))) + (else + (skribe-error 'eq "invalid renderer" renderer))))) ;; FIXME: `engine?' and `engine-class?' (else (skribe-error 'eq "`:renderer' -- wrong argument type" diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 9cd594b..b1ff7ae 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -51,10 +51,18 @@ ;;; Simple markup writers. ;;; +(markup-writer 'eq-display (find-engine 'lout) + :before "\n@BeginAlignedDisplays\n" + :after "\n@EndAlignedDisplays\n") (markup-writer 'eq (find-engine 'lout) - :options '(:inline? :div-style) - :before "{ " + :options '(:inline? :align-with :div-style) + :before (lambda (node engine) + (let* ((parent (ast-parent node)) + (displayed? (is-markup? parent 'eq-display))) + (format #t "~a{ " + (if (and displayed? (not (*embedded-renderer*))) + "\n@IAD " "")))) :action (lambda (node engine) (display (if (markup-option node :inline?) "@E { " @@ -92,40 +100,46 @@ `(if need-paren? "{ @VScale ) }" "") ""))) - `(markup-writer ',(symbol-append 'eq: sym) - (find-engine 'lout) - :action (lambda (node engine) - (let ((lout-name ,(if (string? lout-name) - lout-name - `(,lout-name node - engine)))) - (let loop ((operands (markup-body node))) - (if (null? operands) - #t - (let* ((op (car operands)) - (eq-op? (equation-markup? op)) - (need-paren? - (and eq-op? - (>= (operator-precedence - (equation-markup-name->operator - (markup-markup op))) - ,precedence))) - (column (port-column - (current-output-port)))) - - ;; Work around Lout's limitations... - (if (> column 1000) (display "\n")) - - (display - (string-append " { " ,open-par)) - (output op engine) - (display - (string-append ,close-par " }")) - (if (pair? (cdr operands)) - (display (string-append " " - lout-name - " "))) - (loop (cdr operands)))))))))) + `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) + :action (lambda (node engine) + (let* ((lout-name ,(if (string? lout-name) + lout-name + `(,lout-name node + engine))) + (eq (ast-parent node)) + (eq-parent (ast-parent eq))) + + (let loop ((operands (markup-body node)) + (first? #t)) + (if (null? operands) + #t + (let* ((align? + (and first? + (is-markup? eq-parent 'eq-display) + (eq? ',sym + (markup-option eq :align-with)))) + (op (car operands)) + (eq-op? (equation-markup? op)) + (need-paren? + (and eq-op? + (>= (operator-precedence + (equation-markup-name->operator + (markup-markup op))) + ,precedence))) + (column (port-column (current-output-port)))) + + ;; Work around Lout's limitations... + (if (> column 1000) (display "\n")) + + (display (string-append " { " ,open-par)) + (output op engine) + (display (string-append ,close-par " }")) + (if (pair? (cdr operands)) + (display (string-append " " + (if align? "^" "") + lout-name + " "))) + (loop (cdr operands) #f))))))))) ;; `+' and `*' have higher precedence than `-', `/', `=', etc., so their -- cgit v1.2.3 From 67142b1e7b350765ce68cb0b89668d5b3abc034b Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sat, 2 Dec 2006 10:45:56 +0000 Subject: doc: Augmented the `eq' doc, documented `eq-display'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-27 --- doc/user/eq.skb | 25 +++++++++++++++++++++++-- doc/user/src/eq3.skb | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 61 insertions(+), 2 deletions(-) create mode 100644 doc/user/src/eq3.skb diff --git a/doc/user/eq.skb b/doc/user/eq.skb index 455832b..1ef0208 100644 --- a/doc/user/eq.skb +++ b/doc/user/eq.skb @@ -70,7 +70,16 @@ unlike in the previous example, the equation itself if ,(emph [quoted]), that is, preceded by the ,(tt [']) sign. Additionally, when referring to a symbol (such as the Greek letter ,(symbol "phi")), you no longer need to use the ,(tt [symbol]) markup (,(numref :text [see Section] -:ident "symbols")).])) +:ident "symbols")).]) + + (p [It is possible to create ,(emph [equation display blocks]), +where several equations are displayed and aligned according to a +particular operator. ] + + (example-produce + (example :legend "Inlined, displayed, and aligned equations" + (prgm :file "src/eq3.skb")) + (disp (include "src/eq3.skb"))))) ;; FIXME: Write this. (section :title [Rendering]) @@ -91,7 +100,19 @@ render equations in HTML.]) (:div-style [A symbol denoting the default style for divisions. This should be one of ,(code [over]), ,(code [fraction]), ,(code [div]) and ,(code [slash]). Per-,(code [eq:/]) ,(code -[:div-style]) options override this setting.])) +[:div-style]) options override this setting.]) + (:align-with [Within a ,(code [eq-display]) block, +this should be a symbol specifying according to which operator equations +are to be aligned with one another.])) + :source "skribilo/package/eq.scm") + + (p [Equation display blocks can be defined using ,(code +[eq-display]). Display blocks define the scope of the alignment among +equations as specified by the ,(code [:align-with]) options of ,(code +[eq]).]) + + (doc-markup 'eq-display + `() :source "skribilo/package/eq.scm")) ) diff --git a/doc/user/src/eq3.skb b/doc/user/src/eq3.skb new file mode 100644 index 0000000..e229b6c --- /dev/null +++ b/doc/user/src/eq3.skb @@ -0,0 +1,38 @@ +(p [This paragraph contains this equation: ,(eq :inline? #t '(/ alpha +beta)). This is actually an ,(emph [inline]) equation, meaning that it +occurs within a paragraph. Typesetting has to be adjusted +accordingly.]) + +(eq-display + + (p [This is an equation display block, within which equations can be +aligned with one another.]) + + (eq :ident "eq-limit-b-over-l" + :renderer 'lout + :align-with '= + '(= (limit (/ lambda beta) 0 + (apply IPL n k)) + + ;; non-simplified + (/ (expt (+ alpha beta) k) + (* beta + (sum :from (= x 0) + :to (- k 1) + (* (combinations k x) + (expt beta (- k 1 x)) + (expt alpha x))))))) + + [This equation can be simplified as follows:] + + (eq :ident "eq-limit-b-over-l-simplified" + :renderer 'lout + :align-with '= + '(= ;; simplified + (/ (expt (+ alpha beta) k) + (- (expt (+ alpha beta) k) + (expt alpha k))) + + (limit (/ lambda beta) 0 + (apply IPL n k))))) + -- cgit v1.2.3 From fd94a38600be0fa9103f598edabde9307aeea4b2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:50:20 +0000 Subject: eq/lout: Fixed `limit'. * src/guile/skribilo/package/eq/lout.scm (eq:limit): Use `from' instead of `on'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-28 --- ChangeLog | 117 +++++++++++++++++++++++++++++++++ src/guile/skribilo/package/eq/lout.scm | 2 +- 2 files changed, 118 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index f0cafb4..07f35bd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,123 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 17:35:08 GMT Ludovic Courtes patch-86 + + Summary: + eq/lout: Fixed `limit'. + Revision: + skribilo--devel--1.2--patch-86 + + * src/guile/skribilo/package/eq/lout.scm (eq:limit): Use `from' instead + of `on'. + + modified files: + ChangeLog src/guile/skribilo/package/eq/lout.scm + + +2006-12-02 10:56:17 GMT Ludovic Courtes patch-85 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-85 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 80-85) + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 22-27) + + - eq: Added the `:div-style' option. + - doc: Documented `eq' and the `:div-style' option. + - eq: Added `limit' and `combinations'. + - eq: Properly handle operator precedence. + - eq: Added `eq-display' and the `:align-with' option for `eq'. + - doc: Augmented the `eq' doc, documented `eq-display'. + + new files: + doc/user/src/.arch-ids/eq3.skb.id doc/user/src/eq3.skb + + modified files: + ChangeLog doc/user/char.skb doc/user/eq.skb + src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-80 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-81 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-82 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-83 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-84 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-85 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-22 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-23 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-24 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-25 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-26 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-27 + + +2006-11-25 17:47:29 GMT Ludovic Courtes patch-84 + + Summary: + Merge from skribilo@sv.gnu.org--2006/skribilo--devo--1.2 + Revision: + skribilo--devel--1.2--patch-84 + + Patches applied: + + * lcourtes@laas.fr--2005-libre/skribilo--devo--1.2 (patch 72-79) + + - Merge from skribilo@sv.gnu.org--2006 + - Lout engine: Better cover sheet for `doc' documents. + - outline reader: Support keywords. + - lout: bib-ref+: Gracefully handle `unref' objects. + - Introduced `markup-number-string'. + - `base' package: Added `numref'. + - doc: Documented `numref'. + - Cleaned up `(skribilo biblio)' a bit. + + * skribilo@sv.gnu.org--2006/skribilo--devo--1.2 (patch 13-21) + + - Added the `(skribilo biblio template)' module. + - Lout engine: Make URLs breakable; make bibliography defaults sane. + - Lout engine: Better cover sheet for `doc' documents. + - outline reader: Support keywords. + - lout: bib-ref+: Gracefully handle `unref' objects. + - Introduced `markup-number-string'. + - `base' package: Added `numref'. + - doc: Documented `numref'. + - Cleaned up `(skribilo biblio)' a bit. + + modified files: + ChangeLog doc/user/bib.skb doc/user/links.skb + doc/user/src/links1.skb src/guile/skribilo/ast.scm + src/guile/skribilo/biblio.scm + src/guile/skribilo/engine/lout.scm + src/guile/skribilo/package/base.scm + src/guile/skribilo/reader/outline.scm + src/guile/skribilo/utils/compat.scm + + new patches: + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-72 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-73 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-74 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-75 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-76 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-77 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-78 + lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-79 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-13 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-14 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-15 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-16 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-17 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-18 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-19 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-20 + skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-21 + + 2006-11-11 23:02:57 GMT Ludovic Courtes patch-83 Summary: diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index b1ff7ae..16d4513 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -210,7 +210,7 @@ (let ((body (markup-body node)) (var (markup-option node :var)) (limit (markup-option node :limit))) - (display "{ lim on { ") + (display "{ lim from { ") (output var engine) (display " --> ") (output limit engine) -- cgit v1.2.3 From a165a2604af8b9d222488a29eb5165c791fa2c73 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:51:27 +0000 Subject: eq/lout: Improved typesetting of parentheses. * src/guile/skribilo/package/eq/lout.scm (%left-paren): New. (%right-paren): New. (simple-lout-markup-writer): Use them. (binary-lout-markup-writer): Likewise. (eq:apply): Likewise. (eq:limit): Likewise. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-29 --- ChangeLog | 18 ++++++++++++++++++ src/guile/skribilo/package/eq/lout.scm | 27 +++++++++++++++------------ 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/ChangeLog b/ChangeLog index 07f35bd..c8e34a6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,24 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 19:00:42 GMT Ludovic Courtes patch-87 + + Summary: + eq/lout: Improved typesetting of parentheses. + Revision: + skribilo--devel--1.2--patch-87 + + * src/guile/skribilo/package/eq/lout.scm (%left-paren): New. + (%right-paren): New. + (simple-lout-markup-writer): Use them. + (binary-lout-markup-writer): Likewise. + (eq:apply): Likewise. + (eq:limit): Likewise. + + modified files: + ChangeLog src/guile/skribilo/package/eq/lout.scm + + 2006-12-03 17:35:08 GMT Ludovic Courtes patch-86 Summary: diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 16d4513..cc4b3bf 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -73,6 +73,11 @@ :after " } }") +;; Scaled parenthesis. We could use `pmatrix' here but it precludes +;; line-breaking within equations. +(define %left-paren "{ Base @Font @VScale \"(\" }") +(define %right-paren "{ Base @Font @VScale \")\" }") + (define (div-style->lout style) (case style ((over) "over") @@ -91,13 +96,11 @@ (cadr args))) (precedence (operator-precedence sym)) - ;; Note: We could use `pmatrix' here but it precludes line-breaking - ;; within equations. (open-par (if parentheses? - `(if need-paren? "{ @VScale ( }" "") + `(if need-paren? %left-paren "") "")) (close-par (if parentheses? - `(if need-paren? "{ @VScale ) }" "") + `(if need-paren? %right-paren "") ""))) `(markup-writer ',(symbol-append 'eq: sym) (find-engine 'lout) @@ -175,9 +178,9 @@ (second (cadr body)) (parentheses? (equation-markup? first))) (display " { { ") - (if parentheses? (display "(")) + (if parentheses? (display %left-paren)) (output first engine) - (if parentheses? (display ")")) + (if parentheses? (display %right-paren)) (display ,(string-append " } " lout-name " { ")) (output second engine) (display " } } ")) @@ -185,15 +188,15 @@ "wrong number of arguments" body)))))) -(binary-lout-markup-writer expt "sup") -(binary-lout-markup-writer in "element") +(binary-lout-markup-writer expt "sup") +(binary-lout-markup-writer in "element") (binary-lout-markup-writer notin "notelement") (markup-writer 'eq:apply (find-engine 'lout) :action (lambda (node engine) (let ((func (car (markup-body node)))) (output func engine) - (display "(") + (display %left-paren) (let loop ((operands (cdr (markup-body node)))) (if (null? operands) #t @@ -202,7 +205,7 @@ (if (not (null? (cdr operands))) (display ", ")) (loop (cdr operands))))) - (display ")")))) + (display %right-paren)))) (markup-writer 'eq:limit (find-engine 'lout) @@ -214,9 +217,9 @@ (output var engine) (display " --> ") (output limit engine) - (display " } } (") + (display (string-append " } } @VContract { " %left-paren)) (output body engine) - (display ") ")))) + (display (string-append %right-paren " } "))))) (markup-writer 'eq:combinations (find-engine 'lout) :action (lambda (node engine) -- cgit v1.2.3 From 80a7bbc7174962aaeca389b1b1592dc74297d50f Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:52:02 +0000 Subject: eq: Added support for `:mul-style'. * src/guile/skribilo/package/eq.scm (eq)[:mul-style]: New option. (eq*)[mul-style]: New option. * src/guile/skribilo/package/eq/lout.scm (eq)[options]: Added `:mul-style'. (mul-style->lout): New. (eq:*): Support `:mul-style'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-30 --- ChangeLog | 20 ++++++++++++++++++++ src/guile/skribilo/package/eq.scm | 21 ++++++++++++++++----- src/guile/skribilo/package/eq/lout.scm | 24 ++++++++++++++++++++++-- 3 files changed, 58 insertions(+), 7 deletions(-) diff --git a/ChangeLog b/ChangeLog index c8e34a6..6198716 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,26 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 19:21:19 GMT Ludovic Courtes patch-88 + + Summary: + eq: Added support for `:mul-style'. + Revision: + skribilo--devel--1.2--patch-88 + + * src/guile/skribilo/package/eq.scm (eq)[:mul-style]: New option. + (eq*)[mul-style]: New option. + + * src/guile/skribilo/package/eq/lout.scm (eq)[options]: Added + `:mul-style'. + (mul-style->lout): New. + (eq:*): Support `:mul-style'. + + modified files: + ChangeLog src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + + 2006-12-03 19:00:42 GMT Ludovic Courtes patch-87 Summary: diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index 76bbf6c..e783c89 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -190,20 +190,22 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (markup 'eq-display) (ident (or ident (symbol->string (gensym "eq-display")))) (class class) - (options (the-options opts :ident :class :div-style)) + (options (the-options opts :ident :class)) (body (the-body opts)))) (define-markup (eq :rest opts :key (ident #f) (class "eq") (inline? #f) (align-with #f) - (renderer #f) (div-style 'over)) + (renderer #f) (div-style 'over) + (mul-style 'space)) (new container (markup 'eq) (ident (or ident (symbol->string (gensym "eq")))) (class class) (options `((:div-style ,div-style) (:align-with ,align-with) + (:mul-style ,mul-style) ,@(the-options opts :ident :class - :div-style :align-with))) + :div-style :mul-style :align-with))) (body (let loop ((body (the-body opts)) (result '())) (if (null? body) @@ -224,10 +226,19 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (ident (or ident (symbol->string (gensym "eq:/")))) (class #f) (options `((:div-style ,div-style) - ,@(the-options opts :ident :class :div-style))) + ,@(the-options opts :ident :div-style))) + (body (the-body opts)))) + +(define-markup (eq:* :rest opts :key (ident #f) (mul-style #f)) + ;; If no `:mul-style' is specified here, obey the top-level one. + (new markup + (markup 'eq:*) + (ident (or ident (symbol->string (gensym "eq:*")))) + (class #f) + (options `((:mul-style ,mul-style) + ,@(the-options opts :ident :mul-style))) (body (the-body opts)))) -(define-simple-markup eq:*) (define-simple-markup eq:+) (define-simple-markup eq:-) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index cc4b3bf..c8ea50a 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -56,7 +56,7 @@ :after "\n@EndAlignedDisplays\n") (markup-writer 'eq (find-engine 'lout) - :options '(:inline? :align-with :div-style) + :options '(:inline? :align-with :div-style :mul-style) :before (lambda (node engine) (let* ((parent (ast-parent node)) (displayed? (is-markup? parent 'eq-display))) @@ -87,6 +87,16 @@ (else (error "unsupported div style" style)))) +(define (mul-style->lout style) + (case style + ((space) "") + ((cross) "times") + ((asterisk) "*") + ((dot) "cdot") + (else + (error "unsupported mul style" style)))) + + (define-macro (simple-lout-markup-writer sym . args) (let* ((lout-name (if (null? args) (symbol->string sym) @@ -151,8 +161,18 @@ (simple-lout-markup-writer +) -(simple-lout-markup-writer * "times") (simple-lout-markup-writer - "-") + +(simple-lout-markup-writer * + (lambda (n e) + ;; Obey either the per-node `:mul-style' or the + ;; top-level one. + (or (markup-option n :mul-style) + (let* ((eq (ast-parent n)) + (mul-style + (markup-option eq :mul-style))) + (mul-style->lout mul-style))))) + (simple-lout-markup-writer / (lambda (n e) ;; Obey either the per-node `:div-style' or the -- cgit v1.2.3 From 1eecf11d36df1ec53f22f9882199abf481bd7494 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:52:40 +0000 Subject: eq/lout: Fixed binomial coefficient. * src/guile/skribilo/package/eq/lout.scm (eq:combinations): Fixed spacing, use `lpar' instead of `blpar' (according to "The TeXbook"), changed order of OF and AMONG. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-31 --- ChangeLog | 15 +++++++++++++++ src/guile/skribilo/package/eq/lout.scm | 8 ++++---- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6198716..c95106b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,21 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 19:31:45 GMT Ludovic Courtes patch-89 + + Summary: + eq/lout: Fixed binomial coefficient. + Revision: + skribilo--devel--1.2--patch-89 + + * src/guile/skribilo/package/eq/lout.scm (eq:combinations): Fixed + spacing, use `lpar' instead of `blpar' (according to "The TeXbook"), + changed order of OF and AMONG. + + modified files: + ChangeLog src/guile/skribilo/package/eq/lout.scm + + 2006-12-03 19:21:19 GMT Ludovic Courtes patch-88 Summary: diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index c8ea50a..2c7b1bb 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -245,12 +245,12 @@ :action (lambda (node engine) (let ((of (markup-option node :of)) (among (markup-option node :among))) - (display " { matrix atleft { blpar } atright { brpar } { ") + (display " ` { matrix atleft { lpar } atright { rpar } { ") (display "row col { ") - (output among engine) - (display " } row col { ") (output of engine) - (display " } } }\n")))) + (display " } row col { ") + (output among engine) + (display " } } } `\n")))) ;;; -- cgit v1.2.3 From 7996e5b2dddf1321d03b52635367a90cefa85c8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:53:41 +0000 Subject: eq: Support automatic detection of inlining. * src/guile/skribilo/package/eq.scm (inline-equation?): New. (eq)[inline?]: Default to `auto'. * src/guile/skribilo/package/eq/lout.scm (eq): Use `inline-equation?'. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-32 --- ChangeLog | 17 +++++++++++++++++ src/guile/skribilo/package/eq.scm | 16 ++++++++++++++-- src/guile/skribilo/package/eq/lout.scm | 2 +- 3 files changed, 32 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index c95106b..4a740d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,23 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 19:59:46 GMT Ludovic Courtes patch-90 + + Summary: + eq: Support automatic detection of inlining. + Revision: + skribilo--devel--1.2--patch-90 + + * src/guile/skribilo/package/eq.scm (inline-equation?): New. + (eq)[inline?]: Default to `auto'. + + * src/guile/skribilo/package/eq/lout.scm (eq): Use `inline-equation?'. + + modified files: + ChangeLog src/guile/skribilo/package/eq.scm + src/guile/skribilo/package/eq/lout.scm + + 2006-12-03 19:31:45 GMT Ludovic Courtes patch-89 Summary: diff --git a/src/guile/skribilo/package/eq.scm b/src/guile/skribilo/package/eq.scm index e783c89..cadc1ba 100644 --- a/src/guile/skribilo/package/eq.scm +++ b/src/guile/skribilo/package/eq.scm @@ -19,7 +19,7 @@ ;;; USA. (define-module (skribilo package eq) - :autoload (skribilo ast) (markup?) + :autoload (skribilo ast) (markup? find-up) :autoload (skribilo output) (output) :use-module (skribilo writer) :use-module (skribilo engine) @@ -117,6 +117,18 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (string-length str)))) #f)) +(define-public (inline-equation? m) + "Return @code{#t} if @var{m} is an equation that is to be displayed inline." + (and (is-markup? m 'eq) + (let ((i (markup-option m :inline?))) + (case i + ((auto) + (not (find-up (lambda (n) + (is-markup? n 'eq-display)) + m))) + ((#t) #t) + (else #f))))) + ;;; ;;; Operator precedence. @@ -194,7 +206,7 @@ a symbol representing the mathematical operator denoted by @var{m} (e.g., (body (the-body opts)))) (define-markup (eq :rest opts :key (ident #f) (class "eq") - (inline? #f) (align-with #f) + (inline? 'auto) (align-with #f) (renderer #f) (div-style 'over) (mul-style 'space)) (new container diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index 2c7b1bb..e08e6d1 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -64,7 +64,7 @@ (if (and displayed? (not (*embedded-renderer*))) "\n@IAD " "")))) :action (lambda (node engine) - (display (if (markup-option node :inline?) + (display (if (inline-equation? node) "@E { " "@Eq { ")) (let ((eq (markup-body node))) -- cgit v1.2.3 From fedce06edf8768b927ca91fb22ade620ac77ec2a Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Sun, 3 Dec 2006 21:54:14 +0000 Subject: doc: Updated the `eq' markup documentation. * doc/user/eq.skb: Updated documentation of `eq': the `inline?' parameter and the `:mul-style' parameter. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-33 --- ChangeLog | 14 ++++++++++++++ doc/user/eq.skb | 11 ++++++++--- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4a740d7..52f6d53 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,20 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-12-03 20:02:17 GMT Ludovic Courtes patch-91 + + Summary: + doc: Updated the `eq' markup documentation. + Revision: + skribilo--devel--1.2--patch-91 + + * doc/user/eq.skb: Updated documentation of `eq': the `inline?' + parameter and the `:mul-style' parameter. + + modified files: + ChangeLog doc/user/eq.skb + + 2006-12-03 19:59:46 GMT Ludovic Courtes patch-90 Summary: diff --git a/doc/user/eq.skb b/doc/user/eq.skb index 1ef0208..fb8c3ef 100644 --- a/doc/user/eq.skb +++ b/doc/user/eq.skb @@ -90,13 +90,18 @@ particular operator. ] are summarized here:]) (doc-markup 'eq - `((:inline? [A boolean indicating whether the equation -is to appear "inline", i.e., within a paragraph. If the engine supports -it, it may adjust various parameters such as in-equation spacing + `((:inline? [If ,(code [auto]), Skribilo will +automatically determine whether the equation is to be "in-line". +Otherwise, it should be a boolean indicating whether the equation is to +appear "in-line", i.e., within a paragraph. If the engine supports it, +it may adjust various parameters such as in-equation spacing accordingly.]) (:renderer [The engine that should be used to render the equation. This allows, for instance, to use the Lout engine to render equations in HTML.]) + (:mul-style [A symbol denoting the default style for +multiplications. This should be one of ,(code [space]), ,(code +[cross]), ,(code [asterisk]) or ,(code [dot]).]) (:div-style [A symbol denoting the default style for divisions. This should be one of ,(code [over]), ,(code [fraction]), ,(code [div]) and ,(code [slash]). Per-,(code [eq:/]) ,(code -- cgit v1.2.3 From a24b5dbd2dc91b6fc3088c77a946fd8931e7e7dd Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 8 Dec 2006 08:19:12 +0000 Subject: lout & latex engines: Fixed the output of `&prog-line'. * src/guile/skribilo/engine/latex.scm: Use `(srfi srfi-13)'. (&prog-line): Use markup option `:number' instead of `markup-ident' as the line number. * src/guile/skribilo/engine/lout.scm: Likewise. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-87 --- src/guile/skribilo/engine/latex.scm | 11 ++++++++--- src/guile/skribilo/engine/lout.scm | 9 +++++++-- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm index 8d5b88f..21ff6c5 100644 --- a/src/guile/skribilo/engine/latex.scm +++ b/src/guile/skribilo/engine/latex.scm @@ -18,7 +18,8 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, ;;; USA. -(define-skribe-module (skribilo engine latex)) +(define-skribe-module (skribilo engine latex) + :use-module (srfi srfi-13)) ;*---------------------------------------------------------------------*/ ;* latex-verbatim-encoding ... */ @@ -997,8 +998,12 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&prog-line :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) + (let ((num (markup-option n :number))) + (if (number? num) + (skribe-eval + (it (string-append (string-pad (number->string num) 3) + ": ")) + e)))) :after "\\\\\n") ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index 6106f35..b10c4a2 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -24,6 +24,7 @@ (define-skribe-module (skribilo engine lout) + :use-module (srfi srfi-13) :autoload (ice-9 popen) (open-output-pipe) :autoload (ice-9 rdelim) (read-line)) @@ -1673,8 +1674,12 @@ ;; Program lines appear within a `lines @Break' block. (markup-writer '&prog-line :before (lambda (n e) - (let ((n (markup-ident n))) - (if n (skribe-eval (it (list n) ": ") e)))) + (let ((num (markup-option n :number))) + (if (number? num) + (skribe-eval + (it (string-append (string-pad (number->string num) 3) + ": ")) + e)))) :after "\n") ;*---------------------------------------------------------------------*/ -- cgit v1.2.3 From 4e4849ca546074d9475229cc7508bc81b9b6c06c Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 8 Dec 2006 17:33:45 +0000 Subject: eq/lout: Properly handle `div-style' and `mul-style'. * src/guile/skribilo/package/eq/lout.scm (eq:*): Always pass the result through `mul-style->lout'. (eq:/): Likewise. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-88 --- src/guile/skribilo/package/eq/lout.scm | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/guile/skribilo/package/eq/lout.scm b/src/guile/skribilo/package/eq/lout.scm index e08e6d1..21e8f92 100644 --- a/src/guile/skribilo/package/eq/lout.scm +++ b/src/guile/skribilo/package/eq/lout.scm @@ -167,21 +167,19 @@ (lambda (n e) ;; Obey either the per-node `:mul-style' or the ;; top-level one. - (or (markup-option n :mul-style) - (let* ((eq (ast-parent n)) - (mul-style - (markup-option eq :mul-style))) - (mul-style->lout mul-style))))) + (mul-style->lout + (or (markup-option n :mul-style) + (let ((eq (ast-parent n))) + (markup-option eq :mul-style)))))) (simple-lout-markup-writer / (lambda (n e) ;; Obey either the per-node `:div-style' or the ;; top-level one. - (or (markup-option n :div-style) - (let* ((eq (ast-parent n)) - (div-style - (markup-option eq :div-style))) - (div-style->lout div-style)))) + (div-style->lout + (or (markup-option n :div-style) + (let ((eq (ast-parent n))) + (markup-option eq :div-style))))) #f) (simple-lout-markup-writer =) (simple-lout-markup-writer <) -- cgit v1.2.3 From 86ce503639151de4235f322691571b9f2347c9aa Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Fri, 8 Dec 2006 17:47:59 +0000 Subject: Fixed `publisher' in default biblio entry style. * src/guile/skribilo/biblio/template.scm (make-bib-entry-template/default): Issue `publisher' for `inproceedings' entries. * src/guile/skribilo/engine/base.scm (&bib-entry-publisher): No italics. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-89 --- src/guile/skribilo/biblio/template.scm | 3 ++- src/guile/skribilo/engine/base.scm | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/guile/skribilo/biblio/template.scm b/src/guile/skribilo/biblio/template.scm index da0c948..5a82e26 100644 --- a/src/guile/skribilo/biblio/template.scm +++ b/src/guile/skribilo/biblio/template.scm @@ -130,7 +130,8 @@ (series ", ") ("(" number ")") ("pp. " pages ", ") - ;; FIXME: Addr., month., pub. + ("" publisher ", ") + ;; FIXME: Addr., month. year ".")) ((book) ;; FIXME: Title should be in italics '(author ". " (or title url documenturl) ". " diff --git a/src/guile/skribilo/engine/base.scm b/src/guile/skribilo/engine/base.scm index 3b70f66..711c179 100644 --- a/src/guile/skribilo/engine/base.scm +++ b/src/guile/skribilo/engine/base.scm @@ -280,7 +280,7 @@ ;*---------------------------------------------------------------------*/ (markup-writer '&bib-entry-publisher :action (lambda (n e) - (skribe-eval (it (markup-body n)) e))) + (skribe-eval (markup-body n) e))) ;*---------------------------------------------------------------------*/ ;* &the-index ... @label the-index@ */ -- cgit v1.2.3 From 37bc0ccc3cfcabbe042fe310943d2518e4bfff94 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 11 Dec 2006 16:02:55 +0000 Subject: lout engine: Fixed automatic `url-ref' breaking wrt. spacing. * src/guile/skribilo/engine/lout.scm: Use `(srfi srfi-14)'. (lout-split-external-link): Use `char-set-contains?' when looking for whitespace. (lout-make-url-breakable): Do not remove newlines. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-90 --- src/guile/skribilo/engine/lout.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b10c4a2..43aa356 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -25,6 +25,7 @@ (define-skribe-module (skribilo engine lout) :use-module (srfi srfi-13) + :use-module (srfi srfi-14) :autoload (ice-9 popen) (open-output-pipe) :autoload (ice-9 rdelim) (read-line)) @@ -471,9 +472,9 @@ (let ((split (let loop ((where 10)) (if (= 0 where) 10 - (if (char=? (string-ref text - (- where 1)) - #\space) + (if (char-set-contains? + char-set:whitespace + (string-ref text (- where 1))) (loop (- where 1)) where))))) `(,(ref :url url :text (substring text 0 split)) @@ -2539,7 +2540,7 @@ (#\_ "_&0ik{}") (#\@ "\"@\"&0ik{}") ,@lout-verbatim-encoding - (#\newline "")))) + (#\newline " ")))) ;*---------------------------------------------------------------------*/ ;* url-ref ... */ -- cgit v1.2.3 -- cgit v1.2.3