diff options
Diffstat (limited to 'src/guile')
35 files changed, 3117 insertions, 379 deletions
diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..afe4667 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,4 @@ +SUBDIRS = skribilo + +bin_SCRIPTS = skribilo.scm +EXTRA_DIST = README diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am new file mode 100644 index 0000000..c86f2f3 --- /dev/null +++ b/src/guile/skribilo/Makefile.am @@ -0,0 +1,9 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm + +SUBDIRS = reader engine package skribe coloring diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in index 80a26de..add7d0e 100644 --- a/src/guile/skribilo/Makefile.in +++ b/src/guile/skribilo/Makefile.in @@ -1,110 +1,463 @@ -# -# Makefile.in -- Skribe Src Makefile -# -# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -# -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# +# Makefile.in generated by automake 1.9.6 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + # This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 10-Aug-2003 20:26 (eg) -# Last file update: 6-Mar-2004 16:00 (eg) -# -include ../../etc/stklos/Makefile.skb +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. -prefix=@PREFIX@ +@SET_MAKE@ -SKR = $(wildcard ../../skr/*.skr) +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +top_builddir = ../../.. +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +INSTALL = @INSTALL@ +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +subdir = src/guile/skribilo +DIST_COMMON = $(dist_guilemodule_DATA) $(srcdir)/Makefile.am \ + $(srcdir)/Makefile.in $(srcdir)/config.scm.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_CLEAN_FILES = config.scm +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \ + html-recursive info-recursive install-data-recursive \ + install-exec-recursive install-info-recursive \ + install-recursive installcheck-recursive installdirs-recursive \ + pdf-recursive ps-recursive uninstall-info-recursive \ + uninstall-recursive +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; +am__installdirs = "$(DESTDIR)$(guilemoduledir)" +dist_guilemoduleDATA_INSTALL = $(INSTALL_DATA) +DATA = $(dist_guilemodule_DATA) +ETAGS = etags +CTAGS = ctags +DIST_SUBDIRS = $(SUBDIRS) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +GUILE = @GUILE@ +GUILE_CONFIG = @GUILE_CONFIG@ +GUILE_SITE = @GUILE_SITE@ +GUILE_TOOLS = @GUILE_TOOLS@ +HAVE_LOUT_FALSE = @HAVE_LOUT_FALSE@ +HAVE_LOUT_TRUE = @HAVE_LOUT_TRUE@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LOUT = @LOUT@ +LTLIBOBJS = @LTLIBOBJS@ +MAKEINFO = @MAKEINFO@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +SKRIBILO_DOC_DIR = @SKRIBILO_DOC_DIR@ +SKRIBILO_EXT_DIR = @SKRIBILO_EXT_DIR@ +SKRIBILO_SKR_PATH = @SKRIBILO_SKR_PATH@ +STRIP = @STRIP@ +VERSION = @VERSION@ +ac_ct_STRIP = @ac_ct_STRIP@ +am__leading_dot = @am__leading_dot@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build_alias = @build_alias@ +datadir = @datadir@ +exec_prefix = @exec_prefix@ +host_alias = @host_alias@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm -DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ - ../common/index.scm ../common/bib.scm ../common/lib.scm +SUBDIRS = reader engine package skribe coloring +all: all-recursive -SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ - eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ - resolve.stk runtime.stk source.stk types.stk vars.stk \ - verify.stk writer.stk xml.stk +.SUFFIXES: +$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/guile/skribilo/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --gnu src/guile/skribilo/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; -LEXFILES = c-lex.l lisp-lex.l xml-lex.l +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk +$(top_srcdir)/configure: $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +config.scm: $(top_builddir)/config.status $(srcdir)/config.scm.in + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ +uninstall-info-am: +install-dist_guilemoduleDATA: $(dist_guilemodule_DATA) + @$(NORMAL_INSTALL) + test -z "$(guilemoduledir)" || $(mkdir_p) "$(DESTDIR)$(guilemoduledir)" + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(dist_guilemoduleDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + $(dist_guilemoduleDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -BINDIR=../../bin +uninstall-dist_guilemoduleDATA: + @$(NORMAL_UNINSTALL) + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + rm -f "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -EXE= $(BINDIR)/skribe.stklos +# This directory's subdirectories are mostly independent; you can cd +# into them and run `make' without going through this Makefile. +# To change the values of `make' variables: instead of editing Makefiles, +# (1) if the variable is set in `config.status', edit `config.status' +# (which will cause the Makefiles to be regenerated when you run `make'); +# (2) otherwise, pass the desired values on the `make' command line. +$(RECURSIVE_TARGETS): + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" -PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) +mostlyclean-recursive clean-recursive distclean-recursive \ +maintainer-clean-recursive: + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + rev=''; for subdir in $$list; do \ + if test "$$subdir" = "."; then :; else \ + rev="$$subdir $$rev"; \ + fi; \ + done; \ + rev="$$rev ."; \ + target=`echo $@ | sed s/-recursive//`; \ + for subdir in $$rev; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done && test -z "$$fail" +tags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \ + done +ctags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \ + done -SFLAGS= +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + mkid -fID $$unique +tags: TAGS -all: $(EXE) +TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + tags="$$tags $$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$tags $$unique; \ + fi +ctags: CTAGS +CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + test -z "$(CTAGS_ARGS)$$tags$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$tags $$unique -Makefile: Makefile.in - (cd ../../etc/stklos; autoconf; configure) +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && cd $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) $$here -$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) - stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ - chmod $(BMASK) $(EXE) +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -# -# Lex files -# -lisp-lex.stk: lisp-lex.l - stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ + list='$(DISTFILES)'; for file in $$list; do \ + case $$file in \ + $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ + $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \ + esac; \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test "$$dir" != "$$file" && test "$$dir" != "."; then \ + dir="/$$dir"; \ + $(mkdir_p) "$(distdir)$$dir"; \ + else \ + dir=''; \ + fi; \ + if test -d $$d/$$file; then \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done + list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test -d "$(distdir)/$$subdir" \ + || $(mkdir_p) "$(distdir)/$$subdir" \ + || exit 1; \ + distdir=`$(am__cd) $(distdir) && pwd`; \ + top_distdir=`$(am__cd) $(top_distdir) && pwd`; \ + (cd $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$top_distdir" \ + distdir="$$distdir/$$subdir" \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +all-am: Makefile $(DATA) +installdirs: installdirs-recursive +installdirs-am: + for dir in "$(DESTDIR)$(guilemoduledir)"; do \ + test -z "$$dir" || $(mkdir_p) "$$dir"; \ + done +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive -xml-lex.stk: xml-lex.l - stklos-genlex xml-lex.l xml-lex.stk xml-lex +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am -c-lex.stk: c-lex.l - stklos-genlex c-lex.l c-lex.stk c-lex +installcheck: installcheck-recursive +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: +clean-generic: -install: $(INSTALL_BINDIR) - cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ - && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos - rm -f $(INSTALL_BINDIR)/skribe - ln -s skribe.stklos $(INSTALL_BINDIR)/skribe +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -uninstall: - rm $(INSTALL_BINDIR)/skribe - rm $(INSTALL_BINDIR)/skribe.stklos +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive -$(BINDIR): - mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) +clean-am: clean-generic mostlyclean-am -$(INSTALL_BINDIR): - mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags -## -## Services -## -tags: TAGS +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +info: info-recursive + +info-am: + +install-data-am: install-dist_guilemoduleDATA + +install-exec-am: + +install-info: install-info-recursive + +install-man: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive -TAGS: $(SRCS) - etags -l scheme $(SRCS) +ps-am: -pop: - @echo $(PRCS_FILES:%=src/stklos/%) +uninstall-am: uninstall-dist_guilemoduleDATA uninstall-info-am -links: - ln -s $(DEPS) . - ln -s $(SKR) . +uninstall-info: uninstall-info-recursive -clean: - /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr +.PHONY: $(RECURSIVE_TARGETS) CTAGS GTAGS all all-am check check-am \ + clean clean-generic clean-recursive ctags ctags-recursive \ + distclean distclean-generic distclean-recursive distclean-tags \ + distdir dvi dvi-am html html-am info info-am install \ + install-am install-data install-data-am \ + install-dist_guilemoduleDATA install-exec install-exec-am \ + install-info install-info-am install-man install-strip \ + installcheck installcheck-am installdirs installdirs-am \ + maintainer-clean maintainer-clean-generic \ + maintainer-clean-recursive mostlyclean mostlyclean-generic \ + mostlyclean-recursive pdf pdf-am ps ps-am tags tags-recursive \ + uninstall uninstall-am uninstall-dist_guilemoduleDATA \ + uninstall-info-am -distclean: clean - /bin/rm -f Makefile - /bin/rm -f ../common/configure.scm +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am new file mode 100644 index 0000000..d518553 --- /dev/null +++ b/src/guile/skribilo/coloring/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = c.scm lisp.scm xml.scm diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm index 53cf670..ad02431 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,46 +1,46 @@ ;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; +;;;; lisp.scm -- Lisp Family Fontification +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 16-Oct-2003 22:17 (eg) ;;;; Last file update: 28-Oct-2004 21:14 (eg) ;;;; -(require "lex-rt") ;; to avoid module problems +(define-module (skribilo coloring lisp) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo runtime) + :export (skribe scheme stklos bigloo lisp)) -(define-module (skribilo lisp) - :export (skribe scheme stklos bigloo lisp) - :import (skribe source)) -(include "lisp-lex.stk") ;; SILex generated - -(define *bracket-highlight* #f) -(define *class-highlight* #f) -(define *the-keys* #f) +(define *bracket-highlight* (make-fluid)) +(define *class-highlight* (make-fluid)) +(define *the-keys* (make-fluid)) -(define *lisp-keys* #f) -(define *scheme-keys* #f) -(define *skribe-keys* #f) -(define *stklos-keys* #f) -(define *lisp-keys* #f) +(define *lisp-keys* (make-fluid)) +(define *scheme-keys* (make-fluid)) +(define *skribe-keys* (make-fluid)) +(define *stklos-keys* (make-fluid)) +(define *lisp-keys* (make-fluid)) ;;; @@ -57,17 +57,17 @@ (define (lisp-family-fontifier s) - (let ((lex (lisp-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) + (let ((lisp-input (open-input-string s))) + (let loop ((token (read lisp-input)) (res '())) - (if (eq? token 'eof) + (if (eof-object? token) (reverse! res) - (Loop (lexer-next-token lex) + (loop (read lisp-input) (cons token res)))))) ;;;; ====================================================================== ;;;; -;;;; LISP +;;;; LISP ;;;; ;;;; ====================================================================== (define (lisp-extractor iport def tab) @@ -77,17 +77,17 @@ (lambda (exp) (match-case exp (((or defun defmacro) ?fun ?- . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) ((defvar ?var . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-lisp-keys) (unless *lisp-keys* (set! *lisp-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(setq if let let* letrec cond case else progn lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -95,9 +95,9 @@ *lisp-keys*) (define (lisp-fontifier s) - (fluid-let ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) @@ -109,7 +109,7 @@ ;;;; ====================================================================== ;;;; -;;;; SCHEME +;;;; SCHEME ;;;; ;;;; ====================================================================== (define (scheme-extractor iport def tab) @@ -130,7 +130,7 @@ (unless *scheme-keys* (set! *scheme-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(set! if let let* letrec quote cond case else begin do lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -139,11 +139,11 @@ (define (scheme-fontifier s) - (fluid-let ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) - + (define scheme (new language @@ -153,7 +153,7 @@ ;;;; ====================================================================== ;;;; -;;;; STKLOS +;;;; STKLOS ;;;; ;;;; ====================================================================== (define (stklos-extractor iport def tab) @@ -164,11 +164,11 @@ (match-case exp (((or define define-generic define-method define-macro) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-module) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-stklos-keys) @@ -192,9 +192,9 @@ (define (stklos-fontifier s) - (fluid-let ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -206,7 +206,7 @@ ;;;; ====================================================================== ;;;; -;;;; SKRIBE +;;;; SKRIBE ;;;; ;;;; ====================================================================== (define (skribe-extractor iport def tab) @@ -250,12 +250,12 @@ (map (lambda (x) (cons x '&source-define)) '(define-markup))))) *skribe-keys*) - + (define (skribe-fontifier s) - (fluid-let ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -267,7 +267,7 @@ ;;;; ====================================================================== ;;;; -;;;; BIGLOO +;;;; BIGLOO ;;;; ;;;; ====================================================================== (define (bigloo-extractor iport def tab) @@ -279,15 +279,14 @@ (((or define define-inline define-generic define-method define-macro define-expander) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define bigloo (new language (name "bigloo") (fontifier scheme-fontifier) (extractor bigloo-extractor))) - diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm index d71e98c..e3db36f 100644 --- a/src/guile/skribilo/coloring/xml.scm +++ b/src/guile/skribilo/coloring/xml.scm @@ -1,53 +1,82 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:33 (eg) -;;;; Last file update: 28-Dec-2003 17:33 (eg) -;;;; - - -;(require "lex-rt") ;; to avoid module problems - - -(define-module (skribilo xml) - :export (xml)) - -(use-modules (skribilo source)) - -(include "xml-lex.stk") ;; SILex generated - -(define (xml-fontifier s) - (let ((lex (xml-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (Loop (lexer-next-token lex) - (cons token res)))))) +;;; xml.scm -- XML syntax highlighting. +;;; +;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 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 "<!--(.|\\n)*-->" 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/config.scm.in b/src/guile/skribilo/config.scm.in index a5e3b7c..51e7a93 100644 --- a/src/guile/skribilo/config.scm.in +++ b/src/guile/skribilo/config.scm.in @@ -3,7 +3,7 @@ (define-module (skribilo config)) -(define-public (skribilo-release) "1.3") +(define-public (skribilo-release) "1.2") (define-public (skribilo-url) "http://www.laas.fr/~lcourtes/") (define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") (define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am new file mode 100644 index 0000000..7b6ec2c --- /dev/null +++ b/src/guile/skribilo/engine/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/engine +dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \ + latex-simple.scm latex.scm \ + lout.scm \ + xml.scm diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index 3ad7da6..6e0dc85 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -82,7 +82,7 @@ ;*---------------------------------------------------------------------*/ ;* html-engine ... */ ;*---------------------------------------------------------------------*/ -(define html-engine +(define-public html-engine ;; setup the html engine (default-engine-set! (make-engine 'html diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm index 8bd0ae3..2a59b4f 100644 --- a/src/guile/skribilo/engine/latex.scm +++ b/src/guile/skribilo/engine/latex.scm @@ -16,6 +16,8 @@ ;* @ref ../../doc/user/latexe.skb:ref@ */ ;*=====================================================================*/ +(define-skribe-module (skribilo engine latex)) + ;*---------------------------------------------------------------------*/ ;* latex-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b675e8a..36df9f9 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -384,10 +384,10 @@ " @PageMark @Tag\n" "}\n\n" - "# @SkribeLeaders is used in `toc'\n" + "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" - "def @SkribeLeaders { " - ,leader " |" ,leader-space " @SkribeLeaders }\n\n")))) + "def @SkribiloLeaders { " + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -397,7 +397,8 @@ (author (markup-option doc :author)) (date-line (engine-custom engine 'date-line)) (cover-sheet? (engine-custom engine 'cover-sheet?)) - (multi-column? (> 1 (engine-custom engine 'column-number)))) + (multi-column? (> (engine-custom engine 'column-number) 1))) + (if multi-column? ;; In single-column document, `@FullWidth' yields a blank page. (display "\n@FullWidth {")) @@ -1205,7 +1206,7 @@ (entry-proc node engine) (display " &1rt @OneCol { ") - (printf " @SkribeLeaders & @PageOf { ~a }" + (printf " @SkribiloLeaders & @PageOf { ~a }" (lout-tagify (markup-ident node))) (display " &0io } }") @@ -2876,93 +2877,93 @@ ;*---------------------------------------------------------------------*/ ;* Slides */ ;* */ -;* At some point, this should move to `slide.skr'. */ -;*---------------------------------------------------------------------*/ -; (skribe-load "slide.skr") - -; (markup-writer 'slide -; ;; FIXME: In `slide.skr', `:ident' is systematically generated. -; :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) - -; :validate (lambda (n e) -; (eq? (engine-custom e 'document-type) 'slides)) - -; :before (lambda (n e) -; (display "\n@Overhead\n") -; (display " @Title { ") -; (output (markup-option n :title) e) -; (display " }\n") -; (if (markup-ident n) -; (begin -; (display " @Tag { ") -; (display (lout-tagify (markup-ident n))) -; (display " }\n"))) -; (if (markup-option n :number) -; (begin -; (display " @BypassNumber { ") -; (output (markup-option n :number) e) -; (display " }\n"))) -; (display "@Begin\n") - -; ;; `doc' documents produce their PDF outline right after -; ;; `@Text @Begin'; other types of documents must produce it -; ;; as part of their first chapter. -; (lout-output-pdf-meta-info (ast-document n) e)) - -; :after "@End @Overhead\n") - -; (markup-writer 'slide-vspace -; :options '(:unit) -; :validate (lambda (n e) -; (and (pair? (markup-body n)) -; (number? (car (markup-body n))))) -; :action (lambda (n e) -; (printf "\n//~a~a # slide-vspace\n" -; (car (markup-body n)) -; (case (markup-option n :unit) -; ((cm) "c") -; ((point points pt) "p") -; ((inch inches) "i") -; (else -; (skribe-error 'lout -; "Unknown vspace unit" -; (markup-option n :unit))))))) - -; (markup-writer 'slide-pause -; ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. -; ;; << /Type /Action -; ;; << /S /Trans -; ;; entry in the trans dict -; ;; << /Type /Trans /S /Dissolve >> -; :action (lambda (n e) -; (let ((filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark " -; [ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) -; (display (lout-embedded-postscript-code -; (filter pdfmark)))))) - -; ;; For movies, see -; ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . -; (markup-writer 'slide-embed -; :options '(:alt :geometry :rgeometry :geometry-opt :command) -; ;; FIXME: `pdfmark'. -; ;; << /Type /Action /S /Launch -; :action (lambda (n e) -; (let ((command (markup-option n :command)) -; (filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark "[ /Rect [ 0 ysize xsize 0 ] -; /Name /Comment -; /Contents (This is an embedded application) -; /ANN pdfmark - -; [ /Type /Action -; /S /Launch -; /F (~a) -; /OBJ pdfmark")) -; (display (string-append -; "4c @Wide 3c @High " -; (lout-embedded-postscript-code -; (filter (format #f pdfmark command)))))))) +;* At some point, we might want to move this to `slide.scm'. */ +;*---------------------------------------------------------------------*/ + +(use-modules (skribilo packages slide)) + +(markup-writer 'slide + :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) + + :validate (lambda (n e) + (eq? (engine-custom e 'document-type) 'slides)) + + :before (lambda (n e) + (display "\n@Overhead\n") + (display " @Title { ") + (output (markup-option n :title) e) + (display " }\n") + (if (markup-ident n) + (begin + (display " @Tag { ") + (display (lout-tagify (markup-ident n))) + (display " }\n"))) + (if (markup-option n :number) + (begin + (display " @BypassNumber { ") + (output (markup-option n :number) e) + (display " }\n"))) + (display "@Begin\n") + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after "@End @Overhead\n") + +(markup-writer 'slide-vspace + :options '(:unit) + :validate (lambda (n e) + (and (pair? (markup-body n)) + (number? (car (markup-body n))))) + :action (lambda (n e) + (printf "\n//~a~a # slide-vspace\n" + (car (markup-body n)) + (case (markup-option n :unit) + ((cm) "c") + ((point points pt) "p") + ((inch inches) "i") + (else + (skribe-error 'lout + "Unknown vspace unit" + (markup-option n :unit))))))) + +(markup-writer 'slide-pause + ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. + ;; << /Type /Action + ;; << /S /Trans + ;; entry in the trans dict + ;; << /Type /Trans /S /Dissolve >> + :action (lambda (n e) + (let ((filter (make-string-replace lout-verbatim-encoding)) + (pdfmark " +[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) + (display (lout-embedded-postscript-code + (filter pdfmark)))))) + +For movies, see +http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . +(markup-writer 'slide-embed + :options '(:alt :geometry :rgeometry :geometry-opt :command) + ;; FIXME: `pdfmark'. + ;; << /Type /Action /S /Launch + :action (lambda (n e) + (let ((command (markup-option n :command)) + (filter (make-string-replace lout-verbatim-encoding)) + (pdfmark "[ /Rect [ 0 ysize xsize 0 ] + /Name /Comment + /Contents (This is an embedded application) + /ANN pdfmark + +[ /Type /Action + /S /Launch + /F (~a) + /OBJ pdfmark")) + (display (string-append + "4c @Wide 3c @High " + (lout-embedded-postscript-code + (filter (format #f pdfmark command)))))))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 703186c..def3280 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -39,8 +39,11 @@ (skribilo types) (skribilo lib) (skribilo vars) + (ice-9 optargs) - (oop goops)) + (oop goops) + (srfi srfi-13) + (srfi srfi-1)) @@ -49,8 +52,21 @@ (define *skribe-loaded* '()) ;; List of already loaded files (define *skribe-load-options* '()) +;;; +;;; %EVALUATE +;;; (define (%evaluate expr) - (eval expr (current-module))) + (let ((result (eval expr (current-module)))) + (if (or (ast? result) (markup? result)) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (format #t "~%~%*** source props for `~a': ~a~%~%" + result (source-properties expr)) + (slot-set! result 'loc + (make <location> + :file file :line line :pos column)))) + result)) @@ -74,6 +90,8 @@ (reader %default-reader)) (with-debug 2 'skribe-eval-port (debug-item "engine=" engine) + (debug-item "reader=" reader) + (let ((e (if (symbol? engine) (find-engine engine) engine))) (debug-item "e=" e) (if (not (is-a? e <engine>)) @@ -104,22 +122,31 @@ ((engine? engine) engine) ((not (symbol? engine)) (skribe-error 'skribe-load - "Illegal engine" engine)) + "illegal engine" engine)) (else engine))) - (path (cond - ((not path) (skribe-path)) - ((string? path) (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else path))) - (filep (search-path path file))) + (path (append (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "illegal path" path)) + (else path)) + %load-path)) + (filep (or (search-path path file) + (search-path (append path %load-path) file) + (search-path (append path %load-path) + (let ((dot (string-rindex file #\.))) + (if dot + (string-append + (string-take file dot) + ".scm") + file)))))) (set! *skribe-load-options* opt) (unless (and (string? filep) (file-exists? filep)) (skribe-error 'skribe-load (string-append "cannot find `" file "' in path") - (skribe-path))) + path)) ;; Load this file if not already done (unless (member filep *skribe-loaded*) @@ -139,22 +166,23 @@ ;;; (define* (skribe-include file #:optional (path (skribe-path))) (unless (every string? path) - (skribe-error 'skribe-include "Illegal path" path)) + (skribe-error 'skribe-include "illegal path" path)) (let ((path (search-path path file))) (unless (and (string? path) (file-exists? path)) (skribe-error 'skribe-load - (format "Cannot find ~S in path" file) + (format #t "cannot find ~S in path" file) path)) (when (> *skribe-verbose* 0) (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path (lambda () - (let Loop ((exp (read (current-input-port))) + (let Loop ((exp (%default-reader (current-input-port))) (res '())) (if (eof-object? exp) (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (Loop (read (current-input-port)) + (car res) + (reverse! res)) + (Loop (%default-reader (current-input-port)) (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index 8667f7e..2961fc6 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -1,5 +1,5 @@ ;;; -;;; lib.stk -- Utilities +;;; lib.scm -- Utilities ;;; ;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;; @@ -18,11 +18,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -;;; -;;; Author: Erick Gallesio [eg@essi.fr] -;;; Creation date: 11-Aug-2003 20:29 (eg) -;;; Last file update: 27-Oct-2004 12:41 (eg) -;;; (read-set! keywords 'prefix) @@ -59,7 +54,9 @@ hashtable->list skribe-read - find-runtime-type) + find-runtime-type + + date) :export-syntax (new define-markup define-simple-markup define-simple-container define-processor-markup @@ -73,6 +70,8 @@ :use-module (skribilo vars) :use-module (srfi srfi-1) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) ;; date + :use-module (oop goops) :use-module (ice-9 optargs)) @@ -81,11 +80,20 @@ ;;; ;;; NEW ;;; + +(define %types-module (resolve-module '(skribilo types))) + (define-macro (new class . parameters) - `(make ,(string->symbol (format #f "<~a>" class)) - ,@(apply append (map (lambda (x) - `(,(symbol->keyword (car x)) ,(cadr x))) - parameters)))) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo types)' in order to make use of `new'. + (let* ((class-name (symbol-append '< class '>)) + (actual-class (module-ref %types-module class-name))) + `(let ((make ,make) + (,class-name ,actual-class)) + (make ,class-name + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))))) ;;; ;;; DEFINE-MARKUP @@ -99,12 +107,23 @@ (let loop ((args args) (result '()) (rest-arg #f)) - (if (null? args) - (if rest-arg (append (reverse result) rest-arg) (reverse result)) - (let ((is-rest-arg? (eq? (car args) #:rest))) - (loop (if is-rest-arg? (cddr args) (cdr args)) - (if is-rest-arg? result (cons (car args) result)) - (if is-rest-arg? (list (car args) (cadr args)) rest-arg)))))) + (cond ((null? args) + (if rest-arg + (append (reverse result) rest-arg) + (reverse result))) + + ((list? args) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? + (list (car args) (cadr args)) + rest-arg)))) + + ((pair? args) + (loop '() + (cons (car args) result) + (list #:rest (cdr args))))))) (let ((name (car bindings)) (opts (cdr bindings))) @@ -376,3 +395,9 @@ (define-macro (when condition . exprs) `(if ,condition (begin ,@exprs))) + +(define (date) + (s19:date->string (s19:current-date) "~c")) + + +;;; lib.scm ends here diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 1a8f622..bb0c5ad 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -42,7 +42,6 @@ '((srfi srfi-1) ;; lists (srfi srfi-13) ;; strings ;(srfi srfi-19) ;; date and time - (oop goops) ;; `make' (ice-9 optargs) ;; `define*' (ice-9 and-let-star) ;; `and-let*' (ice-9 receive) ;; `receive' @@ -60,9 +59,13 @@ (skribilo output) (skribilo evaluator) (skribilo color) - (skribilo debug))) + (skribilo debug) + (skribilo source) ;; `source-read-lines', `source-fontify', etc. + (skribilo coloring lisp) ;; `skribe', `scheme', `lisp' + (skribilo coloring xml) ;; `xml' + )) -(define *skribe-core-modules* +(define %skribe-core-modules '("utils" "api" "bib" "index" "param" "sui")) (define-macro (define-skribe-module name . options) @@ -81,7 +84,7 @@ ,(string->symbol mod)))) (and (not (equal? m name)) m))) - *skribe-core-modules*))))) + %skribe-core-modules))))) ;; Make it available to the top-level module. @@ -106,7 +109,7 @@ execution of Skribilo/Skribe code." (map (lambda (mod) `(skribilo skribe ,(string->symbol mod))) - *skribe-core-modules*))) + %skribe-core-modules))) (set-module-name! the-module '(skribilo-user)) the-module)) @@ -152,7 +155,7 @@ hierarchy and in @code{(run-time-module)}." (module-use! (run-time-module) (resolve-module `(skribilo skribe ,(string->symbol mod))))) - *skribe-core-modules*)) + %skribe-core-modules)) ;;; module.scm ends here diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am new file mode 100644 index 0000000..6e047d3 --- /dev/null +++ b/src/guile/skribilo/package/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package +dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ + lncs.scm scribe.scm sigplan.scm skribe.scm \ + slide.scm web-article.scm web-book.scm diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/src/guile/skribilo/package/acmproc.scm @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/acmproc.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[letterpaper]{acmproc}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\numberofauthors{~a}\n\\author{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "\\alignauthor\n") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\CopyrightYear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\crdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key (class "abstract") postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :class class :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/french.scm b/src/guile/skribilo/package/french.scm new file mode 100644 index 0000000..bd095db --- /dev/null +++ b/src/guile/skribilo/package/french.scm @@ -0,0 +1,21 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* French Skribe style */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package french)) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/src/guile/skribilo/package/jfp.scm b/src/guile/skribilo/package/jfp.scm new file mode 100644 index 0000000..108b938 --- /dev/null +++ b/src/guile/skribilo/package/jfp.scm @@ -0,0 +1,319 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/jfp.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for JFP articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package jfp)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/src/guile/skribilo/package/letter.scm b/src/guile/skribilo/package/letter.scm new file mode 100644 index 0000000..1c39301 --- /dev/null +++ b/src/guile/skribilo/package/letter.scm @@ -0,0 +1,148 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for letters */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package letter)) + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "<table width=\"100%\">\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 "<tr><td align='left'>") + (output n e) + (when hd + (display "</td><td align='right'>") + (output hd e) + (set! hd #f)) + (display "</td></tr>\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 "</table>\n<hr>\n\n")) + + diff --git a/src/guile/skribilo/package/lncs.scm b/src/guile/skribilo/package/lncs.scm new file mode 100644 index 0000000..2f027d0 --- /dev/null +++ b/src/guile/skribilo/package/lncs.scm @@ -0,0 +1,149 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/lncs.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for LNCS articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package lncs)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm new file mode 100644 index 0000000..8e99c76 --- /dev/null +++ b/src/guile/skribilo/package/scribe.scm @@ -0,0 +1,231 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/scribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 29 10:07:21 2003 */ +;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Scribe Compatibility kit */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package scribe)) + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/package/sigplan.scm b/src/guile/skribilo/package/sigplan.scm new file mode 100644 index 0000000..b5269dc --- /dev/null +++ b/src/guile/skribilo/package/sigplan.scm @@ -0,0 +1,157 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/sigplan.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Wed May 18 16:00:38 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package sigplan)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/skribe.scm b/src/guile/skribilo/package/skribe.scm new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/src/guile/skribilo/package/skribe.scm @@ -0,0 +1,76 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/skribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 11 11:23:12 2002 */ +;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The standard Skribe style (always loaded). */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm new file mode 100644 index 0000000..37ee054 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,667 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package slide)) + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (output title e) + (display "</big></big></big></strong</div>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\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 "<a name=\"~a\">" (markup-ident n)) + (display "<br>\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 "<br>") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "<br>")))) + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm new file mode 100644 index 0000000..6a480be --- /dev/null +++ b/src/guile/skribilo/package/web-article.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-article.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jan 10 09:09:43 2004 */ +;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* A Skribe style for producing web articles */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-article)) + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><b>" tfont) + (output title e) + (display "</b></font>")) + (begin + (printf "<h1>") + (output title e) + (display "</h1>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\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 "<div id=\"~a\" class=\"document-title-title\">\n" + (string-canonicalize id)) + (output title e) + (display "</div>\n") + ;; the authors + (printf "<div id=\"~a\" class=\"document-title-authors\">\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "</div>\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 "<span class=\"document-author-name\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output name e) + (display "</span>\n")) + (when title + (printf "<span class=\"document-author-title\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output title e) + (display "</span>\n")) + (when affiliation + (printf "<span class=\"document-author-affiliation\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "</span>\n")) + (when (pair? address) + (printf "<span class=\"document-author-address\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "</span>\n")) + (when phone + (printf "<span class=\"document-author-phone\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "</span>\n")) + (when email + (printf "<span class=\"document-author-email\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output email e) + (display "</span>\n")) + (when url + (printf "<span class=\"document-author-url\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output url e) + (display "</span>\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 "<br>" + :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 "<br>" + :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 "<div id=\"~a\" class=\"document-title\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "</div>\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "<span id=\"~a\" class=\"document-author\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "</span\n") + ;; section + (markup-writer 'section he + :options 'all + :before (lambda (n e) + (printf "<div class=\"section\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "</div>\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "<div class=\"footnotes\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "</div>\n"))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &web-article-load-options) + (p (memq :style opt)) + (css (memq :css opt)) + (he (find-engine 'html))) + (cond + ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) + (web-article-css-setup he)) + ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) + (engine-custom-set! he 'css (cadr css)) + (web-article-css-setup he)) + (else + (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm new file mode 100644 index 0000000..a954c7a --- /dev/null +++ b/src/guile/skribilo/package/web-book.scm @@ -0,0 +1,109 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-book.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:54:32 2003 */ +;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe web book style. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-book)) + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold "main page")))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (markup-option n :title))))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (if chap "Chapters" "Sections"))))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..a1c58fb --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index 673a166..714f19e 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -22,7 +22,7 @@ :use-module (skribilo reader) :use-module (ice-9 optargs) - ;; the Scheme reader composition framework + ;; the Scheme reader composition framework :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) :export (reader-specification @@ -54,19 +54,39 @@ the Skribe syntax." (sharp-reader (r:make-reader (cons dsssl-keyword-reader (map r:standard-token-reader '(character srfi-4 + vector number+radix - boolean)))))) - (r:make-reader (cons (r:make-token-reader #\# sharp-reader) - (map r:standard-token-reader - `(whitespace - sexp string number - symbol-lower-case - symbol-upper-case - symbol-misc-chars - quote-quasiquote-unquote - semicolon-comment - keyword ;; keywords à la `:key' - skribe-exp)))))) + boolean))) + #f ;; use default fault handler + 'reader/record-positions)) + (colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (square-bracket-free-symbol-misc-chars + (let* ((tr (r:standard-token-reader 'guile-symbol-misc-chars)) + (tr-spec (r:token-reader-specification tr)) + (tr-proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (or (eq? chr #\[) + (eq? chr #\])))) + tr-spec) + tr-proc)))) + + (r:make-reader (cons* (r:make-token-reader #\# sharp-reader) + colon-keywords + square-bracket-free-symbol-misc-chars + (map r:standard-token-reader + `(whitespace + sexp string guile-number + guile-symbol-lower-case + guile-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)) diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index 14f36b2..a39bb77 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -178,7 +178,7 @@ (cadr c) n))) ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) + (skribe-error 'resolve-parent "orphan node" n)) (else (slot-ref n 'parent))))) @@ -211,7 +211,7 @@ (let ((c (assq (symbol-append cnt '-counter) e))) (if (not (pair? c)) (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "Orphan node" n) + (skribe-error cnt "orphan node" n) (begin (set-cdr! (last-pair e) (list (list (symbol-append cnt '-counter) 0) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am new file mode 100644 index 0000000..2850c4d --- /dev/null +++ b/src/guile/skribilo/skribe/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = api.scm bib.scm index.scm param.scm sui.scm utils.scm diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm index d66b3b4..34528ac 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/skribe/api.scm @@ -274,8 +274,8 @@ (new unresolved (proc (lambda (n e env) (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) + 'footnote #t)))))) + ,@(the-options opts :ident :class)))) (body (the-body opts)))) ;*---------------------------------------------------------------------*/ @@ -466,9 +466,9 @@ "start line > stop line" (format #f "~a/~a" start stop))) ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) + (skribe-error 'source "illegal language" language)) ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) + (skribe-error 'source "illegal tab" tab)) (file (let ((s (if (not definition) (source-read-lines file start stop tab) @@ -489,7 +489,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (language #!key name (fontifier #f) (extractor #f)) (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") + (skribe-type-error 'language "illegal name" name "string") (new language (name name) (fontifier fontifier) diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm index 840a179..415cadf 100644 --- a/src/guile/skribilo/skribe/index.scm +++ b/src/guile/skribilo/skribe/index.scm @@ -36,24 +36,24 @@ ;*---------------------------------------------------------------------*/ ;* index? ... */ ;*---------------------------------------------------------------------*/ -(define (index? obj) +(define-public (index? obj) (hashtable? obj)) ;*---------------------------------------------------------------------*/ ;* *index-table* ... */ ;*---------------------------------------------------------------------*/ -(define *index-table* #f) +(define-public *index-table* #f) ;*---------------------------------------------------------------------*/ ;* make-index-table ... */ ;*---------------------------------------------------------------------*/ -(define (make-index-table ident) +(define-public (make-index-table ident) (make-hashtable)) ;*---------------------------------------------------------------------*/ ;* default-index ... */ ;*---------------------------------------------------------------------*/ -(define (default-index) +(define-public (default-index) (if (not *index-table*) (set! *index-table* (make-index-table "default-index"))) *index-table*) @@ -61,7 +61,7 @@ ;*---------------------------------------------------------------------*/ ;* resolve-the-index ... */ ;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) +(define-public (resolve-the-index loc i c indexes split char-offset header-limit col) ;; fetch the descriminating index name letter (define (index-ref n) (let ((name (markup-option n 'name))) @@ -70,7 +70,7 @@ (string-ref name char-offset)))) ;; sort a bucket of entries (the entries in a bucket share there name) (define (sort-entries-bucket ie) - (sort ie + (sort ie (lambda (i1 i2) (or (not (markup-option i1 :note)) (markup-option i2 :note))))) diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm index 8daca62..6aebd0a 100644 --- a/src/guile/skribilo/skribe/param.scm +++ b/src/guile/skribilo/skribe/param.scm @@ -44,15 +44,16 @@ ;* *skribe-auto-mode-alist* ... */ ;*---------------------------------------------------------------------*/ (define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) + ;; Note: In Skribilo, this list is completely useless. + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) ;*---------------------------------------------------------------------*/ ;* *skribe-auto-load-alist* ... */ diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index c682687..e03deae 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,7 +1,8 @@ ;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; source.scm -- Highlighting source files. ;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -19,24 +20,16 @@ ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. ;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 3-Sep-2003 12:22 (eg) -;;;; Last file update: 27-Oct-2004 20:09 (eg) -;;;; (define-module (skribilo source) :export (source-read-lines source-read-definition source-fontify) - :use-module (skribilo vars)) - - -;; Temporary solution -(define (language-extractor lang) - (slot-ref lang 'extractor)) + :use-module (skribilo types) + :use-module (skribilo vars) + :use-module (skribilo lib) + :use-module (ice-9 rdelim)) -(define (language-fontifier lang) - (slot-ref lang 'fontifier)) ;*---------------------------------------------------------------------*/ @@ -172,7 +165,7 @@ (if (= i j) (reverse! r) (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) + ((char=? (string-ref str i) #\newline) (loop (+ i 1) (+ i 1) (if (= i j) @@ -180,7 +173,7 @@ (cons* 'eol (substring str j i) r)))) ((and (char=? (string-ref str i) #\cr) (< (+ i 1) l) - (char=? (string-ref str (+ i 1)) #\Newline)) + (char=? (string-ref str (+ i 1)) #\newline)) (loop (+ i 2) (+ i 2) (if (= i j) diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index 4b3729c..ac1edc4 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -43,7 +43,7 @@ container-ident container-body <document> document? document-ident document-body document-options document-end - <language> language? + <language> language? language-extractor language-fontifier <location> location? ast-location location-file location-line location-pos @@ -66,14 +66,6 @@ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) (loc :init-value #f)) -(define-method (initialize (ast <ast>) . args) - (next-method) - (let ((file (port-filename (current-input-port))) - (line (port-line (current-input-port))) - (column (port-column (current-input-port)))) - (slot-set! ast 'loc - (make <location> - :file file :line line :pos (* line column))))) (define (ast? obj) (is-a? obj <ast>)) (define (ast-loc obj) (slot-ref obj 'loc)) @@ -291,8 +283,8 @@ ;;; ====================================================================== (define-class <language> () (name :init-keyword :name :init-value #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-value #f :getter langage-extractor)) + (fontifier :init-keyword :fontifier :init-value #f :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f :getter language-extractor)) (define (language? obj) (is-a? obj <language>)) |