diff options
| author | Ludovic Court`es | 2005-06-15 13:00:39 +0000 |
|---|---|---|
| committer | Ludovic Court`es | 2005-06-15 13:00:39 +0000 |
| commit | fc42fe56a57eace2dbdb31574c2e161f0eacf839 (patch) | |
| tree | 18111570156cb0e3df0d81c8d104517a2263fd2c /skribe | |
| download | skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.gz skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.tar.lz skribilo-fc42fe56a57eace2dbdb31574c2e161f0eacf839.zip | |
Initial import of Skribe 1.2d.
Initial import of Skribe 1.2d.
git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--base-0
Diffstat (limited to 'skribe')
209 files changed, 33287 insertions, 0 deletions
diff --git a/skribe/INSTALL b/skribe/INSTALL new file mode 100644 index 0000000..30507e7 --- /dev/null +++ b/skribe/INSTALL @@ -0,0 +1,110 @@ +Here is the procedure for compiling and installing SKRIBE on a Unix system. + + +Requirements +************ + + - GNU-MAKE is required. + - BIGLOO 2.6b (or later) *or* SKTLOS 0.56 is required. + +Summary of a SKRIBE compilation, test and installation +****************************************************** + + $ ./configure --with-bigloo|--with-stklos + $ make + $ make install + + This procedure will self test SKRIBE because it will compile the various + Skribe documents that implement the Skribe documentation. + + +Configuring SKRIBE +****************** + + Configuring SKRIBE/BIGLOO + ************************* + + 1.a Edit the `./etc/bigloo/configure' file and set the variables defined in the Use + section (e.g. `bindir', `libdir', `mandir' and `docdir'). Note that + if you leave these variable definitions blank the installation procedure + will install Skribe at the same location as Bigloo. + + 1.b Configure Skribe for your machine by invoking: + `./configure --with-bigloo' + or + `./configure --with-bigloo --prefix <your-prefix>' + or + `./configure --with-bigloo --bigloo=<your-bigloo-compiler>' + When the system is ready to be compiled, `configure' prints + the message `configuration done.'. + + The following command: + `./configure --with-bigloo --help' + displays the available options. + + The default configuration uses the C back-end. To produce a JVM version of + SKRIBE, uses: + + `./configure --with-bigloo --jvm' + + Configuring SKRIBE/STKLOS + ************************* + + 1. Configure Skribe for your machine by invoking: + `./configure --with-stklos' + or + `./configure --with-stklos --prefix <your-prefix>' + +Compiling SKRIBE +**************** + + 2. Type: + `make' + + This will compile: + - the Skribe compiler: skribe + - the Texinfo to Skribe translator: skribeinfo (*) + - the BibTex to Skribe translator: skribebibtex (*) + - the Skribe documentation (in manuals/man, manuals/user and + manuals/expert). + + (*) this tools is compiled only when SKRIBE is compiled with BIGLOO. + + +Installing SKRIBE +***************** + + 3. Type: + `make install' + + This install, the Skribe compiler, the Skribeinfo compiler, the + various Skribe back-ends, the variable Skribe style files and + the Skribe documentation. + + This does not install the skribe.el emacs package. + + +Cleaning SKRIBE +*************** + + 4. Once, installed, you can type: + `make clean' + to remove all the useless files. + + +Uninstalling SKRIBE +******************* + + 5. To uninstall Skribe: + `make uninstall' + + +Unconfiguring SKRIBE +******************** + + 6. If you plan to re-install Skribe on a new platform. Before performing + the all installation process (step 1 to 5) you must first remove the + current configuration. For this type: + `make distclean' + + diff --git a/skribe/LICENSE b/skribe/LICENSE new file mode 100644 index 0000000..dbf912f --- /dev/null +++ b/skribe/LICENSE @@ -0,0 +1,25 @@ +--------------------------------------------------------------------- + Skribe + + Copyright (c) 2003, 2004 -- Erick Gallesio, Manuel Serrano + + Bug descriptions, use reports, comments or suggestions are + welcome. Send them to + skribe@sophia.inria.fr + http://www.inria.fr/mimosa/fp/Skribe + + This program is free software; you can redistribute it + and/or modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with this program; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, + MA 02111-1307, USA. +--------------------------------------------------------------------- diff --git a/skribe/Makefile b/skribe/Makefile new file mode 100644 index 0000000..918e91a --- /dev/null +++ b/skribe/Makefile @@ -0,0 +1,131 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Wed Jul 30 16:23:07 2003 */ +#* Last change : Fri May 21 16:37:53 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The general Skribe makefile */ +#*=====================================================================*/ +include etc/Makefile.config + +#*---------------------------------------------------------------------*/ +#* DIRECTORIES */ +#*---------------------------------------------------------------------*/ +DIRECTORIES = skr \ + doc \ + examples \ + src \ + emacs \ + etc \ + tools + +POPULATIONDIRS = $(DIRECTORIES) \ + contribs + +#*---------------------------------------------------------------------*/ +#* all */ +#*---------------------------------------------------------------------*/ +.PHONY: all + +all: + (cd src/$(SYSTEM) && $(MAKE)) + (cd tools && $(MAKE)) + (cd doc && $(MAKE)) + +#*---------------------------------------------------------------------*/ +#* install */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: + for d in $(DIRECTORIES); do \ + (cd $$d && $(MAKE) install) || exit -1; \ + done + +uninstall: + for d in $(DIRECTORIES); do \ + (cd $$d && $(MAKE) uninstall) || exit -1; \ + done + +#*---------------------------------------------------------------------*/ +#* revision */ +#*---------------------------------------------------------------------*/ +.PHONY: revision populate skribe.prj + +revision: populate checkin + +populate: skribe.prj + prcs populate skribe `$(MAKE) pop` + +checkin: + prcs checkin -r$(SKRIBERELEASE).@ skribe + +checkout: + @ prcs checkout -r$(SKRIBERELEASE).@ skribe + +skribe.prj: + @ cat skribe.prj | sed -e s,"(Populate-Ignore ())","(Populate-Ignore (\"\\\\\\\\\\.o\\$$\" \"\\\\\\\\\\~$$\" \"\\\\\\\\\\.log\\$$\" \"\\\\\\\\\\.ps\\$$\" \"\\\\\\\\\\.aux\\$$\" \"\\\\\\\\\\.date_of_backup\\$$\" \"\\\\\\\\\\.so\\$$\" \"\\\\\\\\\\.a\\$$\" \"if_not_there\\$$\" \"if_mach\\$$\" \"threadlibs\\$$\"))", > skribe.dprj; $(RM) -f skribe.prj; mv skribe.dprj skribe.prj + +#*---------------------------------------------------------------------*/ +#* population */ +#* ------------------------------------------------------------- */ +#* The list of all files that have to be placed inside the */ +#* repository for revision. */ +#*---------------------------------------------------------------------*/ +.PHONY: subpop popfilelist + +subpop: + @ for d in $(POPULATIONDIRS); do \ + (cd $$d && $(MAKE) -s pop); \ + done + +pop: + @ echo Makefile INSTALL LICENSE README README.java + @ echo configure + @ (for p in `$(MAKE) -s subpop`; do \ + echo $$p; \ + done) | sort + +#*---------------------------------------------------------------------*/ +#* distrib */ +#*---------------------------------------------------------------------*/ +.PHONY: distrib distrib-jvm distrib-src + +distrib: + $(MAKE) distrib -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) + (cd www && $(MAKE)) + +distrib-jvm: + $(MAKE) distrib-jvm -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) + +distrib-src: + $(MAKE) distrib-src -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) + +#*---------------------------------------------------------------------*/ +#* clean/distclean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean distclean + $(RM) -f etc/Makefile.config + +clean: + (cd src && $(MAKE) clean) + (cd doc && $(MAKE) clean) + (cd tools && $(MAKE) clean) + (cd etc && $(MAKE) clean) + +distclean: clean + (cd emacs && $(MAKE) distclean) + (cd etc && $(MAKE) distclean) + +#*---------------------------------------------------------------------*/ +#* devclean/devdistclean */ +#*---------------------------------------------------------------------*/ +.PHONY: devclean devdistclean + +devclean: clean + (cd www && $(MAKE) clean) + +devdistclean: devclean distclean + diff --git a/skribe/README b/skribe/README new file mode 100644 index 0000000..db68b22 --- /dev/null +++ b/skribe/README @@ -0,0 +1,69 @@ +What is Skribe +************** + +Skribe is programming language design for the production of electronic +documents. With Skribe one can: + + - Produce HTML web pages. + - Produce PS files. + - ... + +One may also: + + - Translate Texinfo files into HTML. + + - re-use BibTex bibliography databases. + + +Obtaining Skribe +**************** + +New versions of Skribe may downloaded from: + + ftp://ftp-sop.inria.fr/mimosa/fp/Skribe + + +Skribe distrubtion +****************** + +The Skribe distribution consists of several directories: + + INSTALL installation instructions. + + Makefile the Makefile to compile Skribe. + + README this document. + + README.java specific information regarding the JVM port of Skribe. + + etc private directory. + + bin the directory where binary files are compiled to. + + lib the directory where Skribe libraries are compiled to. + + configure configuration driver script. + + emacs Skribe emacs mode. + + examples Various example of Skribe texts. + + doc the Skribe sources for Skribe manuals. + + src the Scheme source code for Skribe. + + skr the Skribe source code for the Skribe engines and styles. + + tools the Bigloo source code for the Texi->Skribe and BibTex->Skribe + compilers. + + +Acknowledgements +**************** + +We thank all the people who helped me while writing Skribe. My first +though goes to Frederic Boussinot who's the first pre-alpha-tester of +Skribe always volunteering for new testing new features ;-) I then +thanks all the people that send me fixes, suggestions and +improvements, that is, all the people that appear in the ChangeLog +file. Many thanks to all of you. diff --git a/skribe/README.java b/skribe/README.java new file mode 100644 index 0000000..dcb0457 --- /dev/null +++ b/skribe/README.java @@ -0,0 +1,36 @@ +This README explains how to use the pre-compiled JVM +version of Skribe. This requires JDK 1.3 or higher. + +Installing SKRIBE +***************** + +The pre-compiled version of SKRIBE does not need installation procedure. +It is pre-installed. The documentation is pre-compiled. It is located +in the directory doc/html. + + +Running SKRIBE +************** + +Lets assume that SKRIBEDIR is the shell variable containing +the name of the directory where Skribe has been unzipped: + +1. To compile a Skribe program "prog.skr" uses: + + java -classpath $SKRIBEDIR/bin/skribe.zip:$SKRIBEDIR/lib/bigloo_s.zip -Dbigloo.SKRIBEPATH=$SKRIBEDIR/skr bigloo.skribe.main prog.skr + +2. To convert a Texi file "prog.texi" into Skribe: + + java -classpath $SKRIBEDIR/bin/skribeinfo.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribeinfo.main prog.texi + +3. To convert a BibTex database "db.bib" into Skribe: + + java -classpath $SKRIBEDIR/bin/skribebibtex.zip:$SKRIBEDIR/lib/bigloo_s.zip bigloo.skribe.skribebibtex.main db.bib + + +Compiling the examples +********************** + +On a Unix platform: + + cd examples; make diff --git a/skribe/configure b/skribe/configure new file mode 100755 index 0000000..798d9d2 --- /dev/null +++ b/skribe/configure @@ -0,0 +1,124 @@ +#!/bin/sh +# +# This file is a simple trampoline to the real configure script which +# depends of the Scheme system used +# +# Known systems so far: +# - Bigloo (use --with-bigloo) +# - STklos (use --with-stklos) +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 29-Jul-2003 13:59 (eg) +# Last file update: 23-Sep-2004 17:14 (eg) + + +use_bigloo=0 +use_stklos=0 + +new_args="" +export new_args +prefix=/usr/local +export prefix + +for i in "$@"; do + case $i in + --with-bigloo) scheme=bigloo; use_bigloo=1;; + --with-stklos) scheme=stklos; use_stklos=1;; + --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; + new_args="$new_args $i";; + *) new_args="$new_args \"$i\"";; + esac +done + +#* for i in $* ;do */ +#* case $i in */ +#* --with-bigloo) scheme=bigloo; use_bigloo=1;; */ +#* --with-stklos) scheme=stklos; use_stklos=1;; */ +#* --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; */ +#* new_args="$new_args $i";; */ +#* *) new_args="$new_args $i";; */ +#* esac */ +#* done */ + + +case `expr $use_bigloo + $use_stklos` in + 0) echo "You must at least specify a Scheme system: "; + echo " --with-bigloo to use Bigloo" + echo " --with-stklos to use STklos" + exit 1;; + 1) ;; + *) echo "You must specify ONLY ONE Scheme system"; exit 1;; +esac + +if test $use_bigloo = 1 ;then + scheme=bigloo +fi + +if test $use_stklos = 1 ;then + scheme=stklos +fi + + + +# Common configuration +release="1.2d" +skribeurl="http://www.inria.fr/mimosa/fp/Skribe" +skribeextdir="$prefix/share/skribe/extensions" +skribedocdir=$prefix/doc/skribe-$release +skribeskrdir="'(\".\" \"$skribeextdir\" \"$prefix/share/skribe/$release/skr\" )" + +# etc/config +rm -f etc/config 2> /dev/null +echo "# Automatically generated file (don't edit)" > etc/config +echo "release=$release" >> etc/config +echo "skribeurl=$skribeurl" >> etc/config +echo "prefix=$prefix" >> etc/config + +# etc/skribe-config +cat etc/skribe-config.in \ + | sed "s|@SKRIBE_RELEASE@|$release|" \ + | sed "s|@PREFIX@|$prefix|" \ + | sed "s|@SKRIBE_SKR_DIR@|$prefix/share/skribe/$release/skr|" \ + | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ + | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ + | sed "s|@SYSTEM@|$scheme|" \ + > etc/skribe-config +chmod a+x etc/skribe-config + +# emacs/skribe.el +cat emacs/skribe.el.in \ + | sed "s|@SKRIBE_RELEASE@|$release|" \ + | sed "s|@PREFIX@|$prefix|" \ + | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ + | sed "s|@SYSTEM@|$scheme|" \ + | sed "s|@SKRIBE_DOCDIR@|$skribedocdir|" \ + > emacs/skribe.el + +# src/common/configure.scm +rm -f src/common/configure.scm 2> /dev/null +echo ";; Automatically generated file (don't edit)" > src/common/configure.scm +cat src/common/configure.scm.in \ + | sed "s|@SKRIBE_RELEASE@|$release|" \ + | sed "s|@SKRIBE_URL@|$skribeurl|" \ + | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ + | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ + | sed "s|@SKRIBE_SKR_PATH@|$skribeskrdir|" \ + | sed "s|@SKRIBE_SCHEME@|$scheme|" \ + >> src/common/configure.scm +echo "" >> src/common/configure.scm + +if test $use_bigloo = 1 ;then + # pass all the arguments to the Bigloo autoconf without the --with-bigloo + echo "Using Bigloo system" + eval "cd etc/bigloo; SKRIBERELEASE=$release ./configure --docdir=$skribedocdir $new_args" + exit 0 +fi + +# If we are here, it means that we use the STklos system +if test $use_stklos = 1 ;then + # pass all the arguments to the STklos autoconf without the --with-stklos + echo "Using STklos system" + eval "cd etc/stklos; ./configure $new_args" + exit 0 +fi + diff --git a/skribe/doc/Makefile b/skribe/doc/Makefile new file mode 100644 index 0000000..934389e --- /dev/null +++ b/skribe/doc/Makefile @@ -0,0 +1,233 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/doc/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Mon Sep 1 10:29:28 2003 */ +#* Last change : Wed Mar 10 11:16:48 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Skribe documentation. */ +#*=====================================================================*/ +include ../etc/Makefile.config +include ../etc/$(SYSTEM)/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Compiler and tools */ +#*---------------------------------------------------------------------*/ +BINDIR = ../bin +LIBDIR = ../lib +LATEX = latex +DVIPS = dvips + +SKRIBEVERBOSE = -v1 +SKRIBEWARNING = -w1 +SFLAGS = $(SKRIBEVERBOSE) $(SKRIBEWARNING) \ + -I ../skr \ + -I skr \ + -P img \ + -S .. \ + --custom emit-sui=yes \ + --eval '(define *skribe-bin* "$(SKRIBE)")' \ + --eval '(define *skribebibtex-bin* "$(SKRIBEBIBTEX)")' + +#*---------------------------------------------------------------------*/ +#* Doc skr */ +#*---------------------------------------------------------------------*/ +_SKR = manual.skr env.skr api.skr extension.skr +SKR = $(_SKR:%=skr/%) + +#*---------------------------------------------------------------------*/ +#* Images */ +#*---------------------------------------------------------------------*/ +_IMG = bsd.gif lambda.gif linux.gif +IMG = $(_IMG:%=img/%) + +#*---------------------------------------------------------------------*/ +#* User document */ +#*---------------------------------------------------------------------*/ +_USERMAIN = user.skb +_USEROTHERS = start.skb syntax.skb \ + markup.skb document.skb \ + sectioning.skb toc.skb ornament.skb line.skb font.skb \ + justify.skb enumeration.skb \ + examples.skb colframe.skb figure.skb image.skb table.skb \ + footnote.skb char.skb \ + links.skb index.skb bib.skb prgm.skb \ + engine.skb htmle.skb latexe.skb xmle.skb \ + emacs.skb skribec.skb skribe-config.skb \ + lib.skb slide.skb package.skb +_USERSRC = start1.skb start2.skb start3.skb start4.skb start5.skb \ + api1.skb api2.skb api3.skb api4.skb api5.skb \ + api6.skb api7.skb api8.skb api9.skb api10.skb \ + api11.skb api12.skb api13.skb api14.skb api15.skb \ + api16.skb api17.skb api18.skb api19.skb api20.skb \ + links1.skb links2.skb \ + index1.skb index2.skb index3.skb \ + bib1.sbib bib2.skb bib3.skb bib4.skb bib5.skb bib6.skb \ + prgm1.skb prgm2.skb prgm3.skb slides.skb + +USERMAIN = $(_USERMAIN:%=user/%) +USEROTHERS = $(_USEROTHERS:%=user/%) +USERSRC = $(_USERSRC:%=user/src/%) +USERSKB = $(USERMAIN) $(USEROTHERS) $(USERSRC) + +#*---------------------------------------------------------------------*/ +#* User document */ +#*---------------------------------------------------------------------*/ +_DIRMAIN = dir.skb +_DIROTHERS = +_DIRSRC = + +DIRMAIN = $(_DIRMAIN:%=dir/%) +DIROTHERS = $(_DIROTHERS:%=dir/%) +DIRSRC = $(_DIRSRC:%=dir/src/%) +DIRSKB = $(DIRMAIN) $(DIROTHERS) $(DIRSRC) + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .skb .man .html .sui + +#*---------------------------------------------------------------------*/ +#* All */ +#*---------------------------------------------------------------------*/ +.PHONY: user dir + +all: user dir +re: re.html re.dir + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo doc/Makefile doc/Makefile.dir + @ echo $(USERSKB:%=doc/%) + @ echo $(DIRSKB:%=doc/%) + @ echo $(SKR:%=doc/%) + @ echo $(IMG:%=doc/%) + +#*---------------------------------------------------------------------*/ +#* user */ +#*---------------------------------------------------------------------*/ +.PHONY: user re.html user.html + +user: user.html user.sui +user.html: html/user.html html/img/lambda.gif html/img/bsd.gif html/img/linux.gif +user.sui: html/user.sui + +user.ps: tex/user.dvi + (cd tex; $(DVIPS) user.dvi -o user.ps) + +user.dvi: tex/user.dvi +tex/user.dvi: tex/user.tex + (cd tex; $(LATEX) user.tex) + +html/user.html html/user.sui: html $(USERSKB) $(SKR) + $(MAKE) re.html + +tex/user.tex: tex $(USERSKB) $(SKR) tex/img/lambda.eps tex/img/bsd.eps tex/img/linux.eps + $(MAKE) re.tex + +# gif +html/img/lambda.gif: html/img img/lambda.gif + cp img/lambda.gif html/img/lambda.gif + +html/img/linux.gif: html/img img/linux.gif + cp img/linux.gif html/img/linux.gif + +html/img/bsd.gif: html/img img/bsd.gif + cp img/bsd.gif html/img/bsd.gif + +# eps image +tex/img/lambda.eps: tex/img img/lambda.gif + convert img/lambda.gif tex/img/lambda.eps + +tex/img/linux.eps: tex/img img/linux.gif + convert img/linux.gif tex/img/linux.eps + +tex/img/bsd.eps: tex/img img/bsd.gif + convert img/bsd.gif tex/img/bsd.eps + +re.html: + $(SKRIBE) $(SFLAGS) $(USERMAIN) \ + --base html -I user -S user \ + -o html/user.html + +re.tex: + $(SKRIBE) $(SFLAGS) $(USERMAIN) \ + --base tex -I user -S user \ + -o tex/user.tex + +#*---------------------------------------------------------------------*/ +#* dir */ +#*---------------------------------------------------------------------*/ +.PHONY: dir re.dir dir.html + +dir: dir.html +dir.html: html/dir.html + +html/dir.html: html $(DIRSKB) $(SKR) + $(MAKE) re.dir + +re.dir: + $(MAKE) -f Makefile.dir SKRIBE="$(SKRIBE)" BASE=html + +#*---------------------------------------------------------------------*/ +#* Misc */ +#*---------------------------------------------------------------------*/ +html: + mkdir -p html + +html/img: + mkdir -p html/img + +tex: + mkdir -p tex + +tex/img: + mkdir -p tex/img + +gethtml: + @ echo "html/user.html" + +#*---------------------------------------------------------------------*/ +#* install/uinstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: $(DESTDIR)$(INSTALL_DOCDIR) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr + cp -r html/* $(DESTDIR)$(INSTALL_DOCDIR) \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/* \ + && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR)/img + cp -r skr/* $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ + && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc \ + && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr/* + cp Makefile.dir $(DESTDIR)$(INSTALL_DOCDIR) \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/Makefile.dir + cp dir/dir.skb $(DESTDIR)$(INSTALL_DOCDIR) \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_DOCDIR)/dir.skb + +uninstall: + $(RM) -rf $(DESTDIR)$(INSTALL_DOCDIR) + +$(DESTDIR)$(INSTALL_DOCDIR): + mkdir -p $(DESTDIR)$(INSTALL_DOCDIR) && chmod a+rx $(DESTDIR)$(INSTALL_DOCDIR) + + +$(DESTDIR)$(INSTALL_SKRDIR)/doc/skr: + mkdir -p $(DESTDIR)$(INSTALL_SKRDIR)/doc/skr \ + && chmod -R a+rx $(DESTDIR)$(INSTALL_SKRDIR)/doc + +#*---------------------------------------------------------------------*/ +#* Clean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean + +clean: + $(RM) -rf html + $(RM) -rf tex + $(RM) -f img/bsd.eps img/linux.eps diff --git a/skribe/doc/Makefile.dir b/skribe/doc/Makefile.dir new file mode 100644 index 0000000..e35cf0b --- /dev/null +++ b/skribe/doc/Makefile.dir @@ -0,0 +1,22 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/doc/Makefile.dir */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Thu Jan 1 15:30:39 2004 */ +#* Last change : Wed Feb 4 09:19:03 2004 (serrano) */ +#* Copyright : 2004 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Skribe directory. */ +#*=====================================================================*/ + +SKRIBE = skribe +SFLAGS = -I ../skr -I skr -P img -S .. -w0 +BASE = . +SPATH = + +.PHONY: re.dir + +re.dir: + $(SKRIBE) $(SFLAGS) $(SPATH) dir.skb \ + --base $(BASE) -I dir -S dir \ + -o $(BASE)/dir.html diff --git a/skribe/doc/dir/dir.skb b/skribe/doc/dir/dir.skb new file mode 100644 index 0000000..8c6d377 --- /dev/null +++ b/skribe/doc/dir/dir.skb @@ -0,0 +1,113 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/dir/dir.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Nov 28 10:37:39 2001 */ +;* Last change : Thu Jan 1 17:12:43 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe directory */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The Skribe documentation style */ +;*---------------------------------------------------------------------*/ +(skribe-load "web-book.skr") +(skribe-load "skr/env.skr") +(skribe-load "skr/manual.skr") +(skribe-load "skr/api.skr") + +;*---------------------------------------------------------------------*/ +;* Html configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (engine-custom-set! he 'web-book-main-browsing-extra + (lambda (n e) + (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 + (tr (td :align 'left :valign 'top (bold "Skribe: ")) + (td :align 'right :valign 'top + (ref :url *skribe-user-doc-url* + :text "User Manual"))))))) + +;*---------------------------------------------------------------------*/ +;* The global index */ +;*---------------------------------------------------------------------*/ +(define *sui-index* (make-index "sui")) + +;*---------------------------------------------------------------------*/ +;* index-sui ... */ +;*---------------------------------------------------------------------*/ +(define (index-sui sui dir) + (sui-filter sui + (lambda (s) + (and (pair? s) (eq? (car s) 'marks))) + (lambda (e) + (let ((f (memq :file e)) + (k (memq :mark e)) + (c (memq :class e))) + (when (and (pair? f) + (pair? k) + (pair? c) + (string=? (cadr c) "public-definition")) + (index :index *sui-index* + :url (format "~a/~a#~a" dir (cadr f) (cadr k)) + (cadr k))) + #f)))) + +;*---------------------------------------------------------------------*/ +;* Intern all the sui files */ +;*---------------------------------------------------------------------*/ +(define extensions '()) + +(let loop ((files (directory->list "html"))) + (when (pair? files) + (if (string=? (suffix (car files)) "sui") + (let* ((f (string-append "html/" (car files))) + (sui (load-sui f))) + (if (not (string=? (car files) "user.sui")) + (set! extensions (cons sui extensions))) + (index-sui sui (dirname (car files))))) + (loop (cdr files)))) +(let loop ((files (directory->list "."))) + (when (pair? files) + (if (string=? (suffix (car files)) "sui") + (let* ((f (car files)) + (sui (load-sui f))) + (if (not (string=? (car files) "user.sui")) + (set! extensions (cons sui extensions))) + (index-sui sui (dirname f)))) + (loop (cdr files)))) + +;*---------------------------------------------------------------------*/ +;* The document */ +;*---------------------------------------------------------------------*/ +(document :title "Skribe directory" + :author (list (author :name "Erick Gallesio" + :affiliation "Université de Nice - Sophia Antipolis" + :address '("930 route des Colles, BP 145" + "F-06903 Sophia Antipolis, Cedex" + "France") + :email (mailto "eg@essi.fr")) + (author :name "Manuel Serrano" + :affiliation "Inria Sophia-Antipolis" + :address `("2004 route des Lucioles - BP 93" + "F-06902 Sophia Antipolis, Cedex" + "France") + :url (ref :url *serrano-url*) + :email (mailto *serrano-mail*))) + + (linebreak 1) + +;;; extensions +(if (pair? extensions) + (section :title "Installed extensions" :number #f + (itemize (map (lambda (e) + (item :key (ref :url (sui-file e) :text (sui-title e)) + (let ((d (sui-key e :description))) + (if d (list ": " d) #f)))) + extensions)))) + +;;; global Index +(section :title "Global Markup Index" :number #f + (mark "global index") + (the-index :column 3 *sui-index*))) diff --git a/skribe/doc/img/bsd.gif b/skribe/doc/img/bsd.gif Binary files differnew file mode 100644 index 0000000..e406ba6 --- /dev/null +++ b/skribe/doc/img/bsd.gif diff --git a/skribe/doc/img/lambda.gif b/skribe/doc/img/lambda.gif Binary files differnew file mode 100644 index 0000000..9c46b7d --- /dev/null +++ b/skribe/doc/img/lambda.gif diff --git a/skribe/doc/img/linux.gif b/skribe/doc/img/linux.gif Binary files differnew file mode 100644 index 0000000..fa764bd --- /dev/null +++ b/skribe/doc/img/linux.gif diff --git a/skribe/doc/skr/api.skr b/skribe/doc/skr/api.skr new file mode 100644 index 0000000..a27c3a4 --- /dev/null +++ b/skribe/doc/skr/api.skr @@ -0,0 +1,575 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/skr/api.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 07:45:33 2003 */ +;* Last change : Tue Apr 6 06:51:34 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for documenting Lisp APIs. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Html configuration */ +;*---------------------------------------------------------------------*/ +(let* ((he (find-engine 'html)) + (tro (markup-writer-get 'tr he))) + (markup-writer 'tr he + :class 'api-table-header + :options '(:width :bg) + :action (lambda (n e) + (let ((c (engine-custom e 'section-title-background))) + (markup-option-add! n :bg c) + (output n e tro)))) + (markup-writer 'tr he + :class 'api-table-prototype + :options '(:width :bg) + :action (lambda (n e) + (let ((c (engine-custom e 'title-background))) + (markup-option-add! n :bg c) + (output n e tro)))) + (markup-writer 'tr he + :class 'api-symbol-prototype + :options '(:width :bg) + :action (lambda (n e) + (let ((c (engine-custom e 'title-background))) + (markup-option-add! n :bg c) + (output n e tro))))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let* ((le (find-engine 'latex)) + (tro (markup-writer-get 'tr le))) + (markup-writer 'tr le + :class 'api-table-prototype + :options '(:width :bg) + :action #f) + (markup-writer 'tr le + :class 'api-table-header + :options '(:width :bg) + :action (lambda (n e) + (let ((c (engine-custom e 'section-title-background))) + (markup-option-add! n :bg c) + (output n e tro))))) + +;*---------------------------------------------------------------------*/ +;* api-search-definition ... */ +;* ------------------------------------------------------------- */ +;* Find a definition inside a source file. */ +;*---------------------------------------------------------------------*/ +(define (api-search-definition id file pred) + (let ((f (find-file/path file *skribe-source-path*))) + (if (not (string? f)) + (skribe-error 'api-search-definition + (format "Can't find source file `~a' in path" file) + *skribe-source-path*) + (with-input-from-file f + (lambda () + (let loop ((exp (read))) + (if (eof-object? exp) + (skribe-error 'api-search-definition + (format "Can't find `~a' definition" id) + file) + (or (pred id exp) (loop (read)))))))))) + +;*---------------------------------------------------------------------*/ +;* api-compare-set ... */ +;* ------------------------------------------------------------- */ +;* This function compares two sets. It returns either #t */ +;* is they are equal, or two subsets which contain elements */ +;* not present in the arguments. For instance: */ +;* (api-compare-set '(foo bar) '(bar foo)) ==> #t */ +;* (api-compare-set '(foo gee) '(gee bar)) ==> '((foo) (bar)) */ +;*---------------------------------------------------------------------*/ +(define (api-compare-set s1 s2) + (let ((d1 (filter (lambda (x) (not (memq x s2))) s1)) + (d2 (filter (lambda (x) (not (memq x s1))) s2))) + (or (and (null? d1) (null? d2)) + (list d1 d2)))) + +;*---------------------------------------------------------------------*/ +;* keyword->symbol ... */ +;*---------------------------------------------------------------------*/ +(define (keyword->symbol kwd) + (let ((s (keyword->string kwd))) + (if (char=? #\: (string-ref s 0)) + ;; Bigloo + (string->symbol (substring s 1 (string-length s))) + ;; STklos + (string->symbol s)))) + +;*---------------------------------------------------------------------*/ +;* define-markup? ... */ +;*---------------------------------------------------------------------*/ +(define (define-markup? id o) + (match-case o + (((or define-markup define define-inline) + ((? (lambda (x) (eq? x id))) . (? (lambda (x) (or (pair? x) (null? x))))) . ?-) + o) + ((define-simple-markup (? (lambda (x) (eq? x id)))) + o) + ((define-simple-container (? (lambda (x) (eq? x id)))) + o) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* make-engine? ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine? id o) + (match-case o + (((or make-engine copy-engine) (quote (? (lambda (x) (eq? x id)))) . ?-) + o) + ((quasiquote . ?-) + #f) + ((quote . ?-) + #f) + ((?a . ?d) + (or (make-engine? id a) (make-engine? id d))) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* make-engine-custom ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine-custom def) + (match-case (memq :custom def) + ((:custom (quote ?custom) . ?-) + custom) + ((:custom ?custom . ?-) + (eval custom)) + (else + '()))) + +;*---------------------------------------------------------------------*/ +;* define-markup-formals ... */ +;* ------------------------------------------------------------- */ +;* Returns the formal parameters of a define-markup (not the */ +;* options). */ +;*---------------------------------------------------------------------*/ +(define (define-markup-formals def) + (match-case def + ((?- (?- . ?args) . ?-) + (if (symbol? args) + (list args) + (let loop ((args args) + (res '())) + (cond + ((null? args) + (reverse! res)) + ((symbol? args) + (reverse! (cons args res))) + ((not (symbol? (car args))) + (reverse! res)) + (else + (loop (cdr args) (cons (car args) res))))))) + ((define-simple-markup ?-) + '()) + ((define-simple-container ?-) + '()) + (else + (skribe-error 'define-markup-formals + "Illegal `define-markup' form" + def)))) + +;*---------------------------------------------------------------------*/ +;* define-markup-options ... */ +;* ------------------------------------------------------------- */ +;* Returns the options parameters of a define-markup. */ +;*---------------------------------------------------------------------*/ +(define (define-markup-options def) + (match-case def + ((?- (?- . ?args) . ?-) + (if (not (list? args)) + '() + (let ((keys (memq #!key args))) + (if (pair? keys) + (cdr keys) + '())))) + ((define-simple-markup ?-) + '((ident #f) (class #f))) + ((define-simple-container ?-) + '((ident #f) (class #f))) + (else + (skribe-error 'define-markup-formals + "Illegal `define-markup' form" + def)))) + +;*---------------------------------------------------------------------*/ +;* define-markup-rest ... */ +;* ------------------------------------------------------------- */ +;* Returns the rest parameter of a define-markup. */ +;*---------------------------------------------------------------------*/ +(define (define-markup-rest def) + (match-case def + ((?- (?- . ?args) . ?-) + (if (not (pair? args)) + args + (let ((l (last-pair args))) + (if (symbol? (cdr l)) + (cdr l) + (let ((rest (memq #!rest args))) + (if (pair? rest) + (if (or (not (pair? (cdr rest))) + (not (symbol? (cadr rest)))) + (skribe-error 'define-markup-rest + "Illegal `define-markup' form" + def) + (cadr rest)) + #f)))))) + ((define-simple-markup ?-) + 'node) + ((define-simple-container ?-) + 'node) + (else + (skribe-error 'define-markup-formals + "Illegal `define-markup' form" + def)))) + +;*---------------------------------------------------------------------*/ +;* doc-check-arguments ... */ +;*---------------------------------------------------------------------*/ +(define (doc-check-arguments id args dargs) + (if (not args) + (skribe-error 'doc-check-arguments id args)) + (if (not dargs) + (skribe-error 'doc-check-arguments id dargs)) + (let* ((s1 (map (lambda (x) (if (pair? x) (car x) x)) args)) + (s2 (map (lambda (x) + (let ((i (car x))) + (if (keyword? i) + (keyword->symbol i) + i))) + dargs)) + (d (api-compare-set s1 s2))) + (if (pair? d) + (let ((d1 (car d)) + (d2 (cadr d))) + (if (pair? d1) + (skribe-error 'doc-markup + (format "~a: missing descriptions" id) + d1) + (skribe-error 'doc-markup + (format "~a: extra descriptions" id) + d2)))))) + +;*---------------------------------------------------------------------*/ +;* exp->skribe ... */ +;*---------------------------------------------------------------------*/ +(define (exp->skribe exp) + (cond + ((number? exp) exp) + ((string? exp) (string-append "\"" exp "\"")) + ((eq? exp #f) "#f") + ((eq? exp #t) "#t") + ((symbol? exp) (symbol->string exp)) + ((equal? exp '(quote ())) "'()") + ((ast? exp) + (table :cellpadding 0 :cellspacing 0 + (tr (td :align 'left exp)))) + (else + (match-case exp + ((quote (and ?sym (? symbol?))) + (string-append "'" (symbol->string sym))) + (else + (with-output-to-string (lambda () (write exp)))))))) + +;*---------------------------------------------------------------------*/ +;* doc-markup-proto ... */ +;*---------------------------------------------------------------------*/ +(define (doc-markup-proto id options formals rest) + (define (option opt) + (if (pair? opt) + (if (eq? (cadr opt) #f) + (list " [" (keyword (car opt)) "]") + (list " [" (keyword (car opt)) " " + (code (exp->skribe (cadr opt))) "]")) + (list " " (keyword opt)))) + (define (formal f) + (list " " (param f))) + (code (list (bold "(") (bold :class 'api-proto-ident (format "~a" id))) + (map option (sort options + (lambda (s1 s2) + (cond + ((and (pair? s1) (not (pair? s2))) + #f) + ((and (pair? s2) (not (pair? s1))) + #t) + (else + #t))))) + (if (pair? formals) + (map formal formals)) + (if rest (list " " (param rest))) + (bold ")"))) + +;*---------------------------------------------------------------------*/ +;* doc-markup ... */ +;*---------------------------------------------------------------------*/ +(define-markup (doc-markup id args + #!rest + opts + #!key + (writer-id #f) + (common-args '((:ident "The node identifier.") + (:class "The node class."))) + (ignore-args '(&skribe-eval-location)) + (force-args '()) + (idx *markup-index*) + (idx-note "definition") + (idx-suffix #f) + (source "src/common/api.scm") + (def #f) + (see-also '()) + (others '()) + (force-engines '()) + (engines *api-engines*) + (sui #f) + &skribe-eval-location) + (define (opt-engine-support opt) + ;; find the engines providing a writer for id + (map (lambda (e) + (let* ((id (engine-ident e)) + (s (symbol->string id))) + (if (engine-format? "latex") + (list s " ") + (list (if sui + (ref :skribe sui + :mark (string-append s "-engine") + :text s) + (ref :mark (string-append s "-engine") + :text s)) + " ")))) + (if (pair? force-engines) + force-engines + (filter (lambda (e) + (or (memq opt '(:ident :class)) + (memq opt force-args) + (let ((w (markup-writer-get (or writer-id id) + e))) + (cond + ((not (writer? w)) + #f) + (else + (let ((o (writer-options w))) + (cond + ((eq? o 'all) + #t) + ((not (pair? o)) + #f) + (else + (memq opt o))))))))) + engines)))) + (cond + ((and def source) + (skribe-error 'doc-markup "source and def both specified" id)) + ((and (not def) (not source)) + (skribe-error 'doc-markup "source or def must be specified" id)) + (else + (let* ((d (or def (api-search-definition id source define-markup?))) + (od (map (lambda (o) + (api-search-definition o source define-markup?)) + others)) + (args (append common-args args)) + (formals (define-markup-formals d)) + (fformals (filter (lambda (s) + (let ((c (assq s args))) + (not + (and (pair? c) + (eq? (cadr c) 'ignore))))) + formals)) + (options (filter (lambda (s) + (not (memq s ignore-args))) + (define-markup-options d))) + (dformals (filter (lambda (x) + (symbol? (car x))) + args)) + (doptions (filter (lambda (x) + (and (keyword? (car x)) + ;; useful for STklos only + (not (eq? (car x) #!rest)))) + args)) + (drest (filter (lambda (x) + (eq? #!rest (car x))) + args)) + (dargs (and (pair? drest) (cadr (car drest)))) + (p+ (cons (doc-markup-proto id options fformals dargs) + (map (lambda (id def) + (doc-markup-proto + id + (define-markup-options def) + (define-markup-formals def) + dargs)) + others od)))) + ;; doc table + (define (doc-markup.html) + (let ((df (map (lambda (f) + (tr :bg *prgm-skribe-color* + (td :colspan 2 :width 20. :align 'left + (param (car f)) ) + (td :align 'left :width 80. (cadr f)))) + dformals)) + (dr (and (pair? drest) + (tr :bg *prgm-skribe-color* + (td :align 'left + :valign 'top + :colspan 2 + :width 20. + (param (cadr (car drest)))) + (td :align 'left :width 80. + (caddr (car drest)))))) + (do (map (lambda (f) + (tr :bg *prgm-skribe-color* + (td :align 'left + :valign 'top + :width 10. + (param (car f))) + (td :align 'left + :valign 'top + :width 20. + (opt-engine-support (car f))) + (td :align 'left :width 70. (cadr f)))) + doptions)) + (so (map (lambda (x) + (let ((s (symbol->string x))) + (list + (ref :mark s :text (code s)) + " "))) + see-also))) + (table :border (if (engine-format? "latex") 1 0) + :width (if (engine-format? "latex") #f *prgm-width*) + `(,(tr :class 'api-table-prototype + (th :colspan 3 :align 'left :width *prgm-width* + "prototype")) + ,@(map (lambda (p) + (tr :bg *prgm-skribe-color* + (td :colspan 3 :width *prgm-width* + :align 'left p))) + p+) + ,@(if (pair? do) + `(,(tr :class 'api-table-header + (th :align 'left "option" + :width 10.) + (th :align 'center "engines" + :width 20.) + (th "description")) + ,@do) + '()) + ,@(if (or (pair? df) dr) + `(,(tr :class 'api-table-header + (th :colspan 2 + :align 'left + :width 30. + "argument") + (th "description")) + ,@(if (pair? df) df '()) + ,@(if dr (list dr) '())) + '()) + ,@(if (pair? so) + `(,(tr :class 'api-table-header + (th :colspan 3 :align 'left + (it "See also"))) + ,(tr :bg *prgm-skribe-color* + (td :colspan 3 :align 'left so))) + '()))))) + ;; doc enumerate + (define (doc-markup.latex) + (let ((df (map (lambda (f) + (item :key (param (car f)) (cadr f))) + dformals)) + (dr (if (pair? drest) + (list (item :key (param (cadr (car drest))) + (caddr (car drest)))) + '())) + (do (map (lambda (f) + (item :key (param (car f)) + (list (opt-engine-support (car f)) + (cadr f)))) + doptions)) + (so (map (lambda (x) + (let ((s (symbol->string x))) + (list + (ref :mark s :page #t + :text [,(code s), p.]) + " "))) + see-also))) + (list (center + (frame :margin 5 :border 0 :width *prgm-width* + (color :class 'api-table-prototype + :margin 5 :width 100. :bg "#ccccff" + p+))) + (when (pair? do) + (subsubsection :title "Options" :number #f :toc #f + (description do))) + (when (or (pair? df) (pair? dr)) + (subsubsection :title "Parameters" :number #f :toc #f + (description (append df dr)))) + (when (pair? so) + (subsubsection :title "See also" :number #f :toc #f + (p so) + (! "\\noindent")))))) + ;; check all the descriptions + (doc-check-arguments id formals dformals) + (doc-check-arguments id options doptions) + (if (and (pair? drest) (not (define-markup-rest d))) + (skribe-error 'doc-markup "No rest argument for" id) + options) + (list (mark :class "public-definition" (symbol->string id)) + (map (lambda (i) (mark (symbol->string i))) others) + (map (lambda (i) + (let ((is (symbol->string i))) + (index (if (string? idx-suffix) + (string-append is idx-suffix) + is) + :index idx + :note idx-note))) + (cons id others)) + (cond + ((engine-format? "latex") + (doc-markup.latex)) + (else + (center (doc-markup.html))))))))) + +;*---------------------------------------------------------------------*/ +;* doc-engine ... */ +;*---------------------------------------------------------------------*/ +(define-markup (doc-engine id args + #!rest + opts + #!key + (idx *custom-index*) + source + (def #f)) + (cond + ((and def source) + (skribe-error 'doc-engine "source and def both specified" id)) + ((and (not def) (not source)) + (skribe-error 'doc-engine "source or def must be specified" id)) + (else + (let* ((d (or def (api-search-definition id source make-engine?))) + (c (make-engine-custom d))) + (doc-check-arguments id c args) + (cond + ((engine-format? "latex") + #f) + (else + (center + (apply table + :width *prgm-width* + (tr :class 'api-table-header + (th :align 'left :width 20. "custom") + (th :width 10. "default") + (th "description")) + (map (lambda (r) + (tr :bg *prgm-skribe-color* + (td :align 'left :valign 'top + (list (index (symbol->string (car r)) + :index idx + :note (format "~a custom" id)) + (symbol->string (car r)))) + (let ((def (assq (car r) c))) + (td :valign 'top + (code (exp->skribe (cadr def))))) + (td :align 'left :valign 'top (cadr r)))) + (filter cadr args)))))))))) + diff --git a/skribe/doc/skr/env.skr b/skribe/doc/skr/env.skr new file mode 100644 index 0000000..09d5146 --- /dev/null +++ b/skribe/doc/skr/env.skr @@ -0,0 +1,32 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/skr/env.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:22:42 2003 */ +;* Last change : Thu Jan 29 06:48:54 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The environment variables for the documentation. */ +;*=====================================================================*/ + +(define *serrano-url* "http://www.inria.fr/mimosa/Manuel.Serrano") +(define *serrano-mail* "Manuel.Serrano@sophia.inria.fr") +(define *html-url* "http://www.w3.org/TR/html4") +(define *html-form* "interact/forms.html") +(define *emacs-url* "http://www.gnu.org/software/emacs") +(define *xemacs-url* "http://www.xemacs.org") +(define *texinfo-url* "http://www.texinfo.org") +(define *r5rs-url* "http://www.inria.fr/mimosa/fp/Bigloo/doc/r5rs.html") +(define *bigloo-url* "http://www.inria.fr/mimosa/fp/Bigloo") +(define *skribe-user-doc-url* (string-append (skribe-doc-dir) "/user.html")) +(define *skribe-dir-doc-url* (string-append (skribe-doc-dir) "/dir.html")) + +(define *prgm-width* 97.) +(define *prgm-skribe-color* "#ffffcc") +(define *prgm-default-color* "#ffffcc") +(define *prgm-xml-color* "#ffcccc") +(define *prgm-example-color* "#ccccff") +(define *disp-color* "#ccffcc") +(define *header-color* "#cccccc") + +(define *api-engines* (map find-engine '(html latex xml))) diff --git a/skribe/doc/skr/extension.skr b/skribe/doc/skr/extension.skr new file mode 100644 index 0000000..ce10ce7 --- /dev/null +++ b/skribe/doc/skr/extension.skr @@ -0,0 +1,95 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/skr/extension.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Dec 23 07:18:36 2003 */ +;* Last change : Fri Jan 2 21:25:49 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe package for documenting extensions */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* extension */ +;*---------------------------------------------------------------------*/ +(define-markup (extension #!rest opt + #!key (ident (symbol->string (gensym 'extension))) + (class "extension") + title html-title ending author description + (env '())) + (new document + (markup 'extension) + (ident ident) + (class class) + (options (the-options opt)) + (body (the-body opt)) + (env (append env + (list (list 'example-counter 0) (list 'example-env '()) + (list 'chapter-counter 0) (list 'chapter-env '()) + (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()) + (list 'figure-counter 0) (list 'figure-env '())))))) + +;*---------------------------------------------------------------------*/ +;* html engine */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (engine-custom-set! he 'web-book-main-browsing-extra + (lambda (n e) + (let ((i (let ((m (find-markup-ident "Index"))) + (and (pair? m) (car m))))) + (if (not i) + (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 + (tr (td :align 'left :valign 'top (bold "Skribe: ")) + (td :align 'right :valign 'top + (ref :url *skribe-dir-doc-url* + :text "Directory"))) + (tr (td) + (td :align 'right :valign 'top + (ref :url *skribe-user-doc-url* + :text "User Manual")))) + (table :width 100. :border 0 :cellspacing 0 :cellpadding 0 + (tr (td :align 'left :valign 'top (bold "index:")) + (td :align 'right (ref :handle (handle i)))) + (tr (td :align 'left :valign 'top (bold "Skribe: ")) + (td :align 'right :valign 'top + (ref :url *skribe-dir-doc-url* + :text "Directory"))) + (tr (td) + (td :align 'right :valign 'top + (ref :url *skribe-user-doc-url* + :text "User Manual")))))))) + (default-engine-set! he)) + +;*---------------------------------------------------------------------*/ +;* extension-sui ... */ +;*---------------------------------------------------------------------*/ +(define (extension-sui n e) + (define (sui) + (display "(sui \"") + (skribe-eval (markup-option n :title) html-title-engine) + (display "\"\n") + (printf " :file ~s\n" (sui-referenced-file n e)) + (printf " :description ~s\n" (markup-option n :description)) + (sui-marks n e) + (display " )\n")) + (if (string? *skribe-dest*) + (let ((f (format "~a.sui" (prefix *skribe-dest*)))) + (with-output-to-file f sui)) + (sui))) + +;*---------------------------------------------------------------------*/ +;* project ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'extension + :options '(:title :html-title :ending :author :description) + :action (lambda (n e) + (output n e (markup-writer-get 'document he))) + :after (lambda (n e) + (if (engine-custom e 'emit-sui) + (extension-sui n e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/skribe/doc/skr/manual.skr b/skribe/doc/skr/manual.skr new file mode 100644 index 0000000..1982237 --- /dev/null +++ b/skribe/doc/skr/manual.skr @@ -0,0 +1,281 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/skr/manual.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 11:24:19 2003 */ +;* Last change : Mon Sep 13 19:18:48 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe manuals and documentation pages style */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Base configuration */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (markup-writer 'example be + :options '(:legend :number) + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (skribe-eval (mark ident) e) + (skribe-eval (center + (markup-body n) + (if number (bold (format "Ex. ~a: " number))) + legend) + e))))) + +;*---------------------------------------------------------------------*/ +;* html-browsing-extra ... */ +;*---------------------------------------------------------------------*/ +(define (html-browsing-extra n e) + (let ((i1 (let ((m (find-markup-ident "Index"))) + (and (pair? m) (car m)))) + (i2 (let ((m (find-markup-ident "markups-index"))) + (and (pair? m) (car m))))) + (cond + ((not i1) + (skribe-error 'left-margin "Can't find section" "Index")) + ((not i2) + (skribe-error 'left-margin "Can't find chapter" "Standard Markups")) + (else + (table :width 100. + :border 0 + :cellspacing 0 :cellpadding 0 + (tr (td :align 'left :valign 'top (bold "index:")) + (td :align 'right (ref :handle (handle i1) :text "Global"))) + (tr (td :align 'left :valign 'top (bold "markups:")) + (td :align 'right (ref :handle (handle i2) :text "Index"))) + (tr (td :align 'left :valign 'top (bold "extensions:")) + (td :align 'right (ref :url *skribe-dir-doc-url* + :text "Directory")))))))) + +;*---------------------------------------------------------------------*/ +;* Html configuration */ +;*---------------------------------------------------------------------*/ +(let* ((he (find-engine 'html)) + (bd (markup-writer-get 'bold he))) + (markup-writer 'bold he + :class 'api-proto-ident + :before "<font color=\"red\">" + :action (lambda (n e) (output n e bd)) + :after "</font>") + (engine-custom-set! he 'web-book-main-browsing-extra html-browsing-extra) + (engine-custom-set! he 'favicon "lambda.gif")) + +;*---------------------------------------------------------------------*/ +;* LaTeX */ +;*---------------------------------------------------------------------*/ +(let* ((le (find-engine 'latex)) + (opckg (engine-custom le 'usepackage)) + (lpckg "\\usepackage{fullpage}\n\\usepackage{eurosym}\n") + (npckg (if (string? opckg) + (string-append lpckg opckg) + lpckg))) + (engine-custom-set! le 'documentclass "\\documentclass{book}") + (engine-custom-set! le 'usepackage npckg)) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts #!key (language skribe) (line #f) (file #f) (definition #f)) + (let* ((c (cond + ((eq? language skribe) *prgm-skribe-color*) + ((eq? language xml) *prgm-xml-color*) + (else *prgm-default-color*))) + (sc (cond + ((and file definition) + (source :language language :file file :definition definition)) + (file + (source :language language :file file)) + (else + (source :language language (the-body opts))))) + (pr (cond + (line + (prog :line line sc)) + (else + (pre sc))))) + (center + (frame :margin 5 :border 0 :width *prgm-width* + (color :margin 5 :width 100. :bg c pr))))) + +;*---------------------------------------------------------------------*/ +;* disp ... */ +;*---------------------------------------------------------------------*/ +(define-markup (disp #!rest opts #!key (verb #f) (line #f) (bg *disp-color*)) + (if (engine-format? "latex") + (if verb + (pre (the-body opts)) + (the-body opts)) + (center + (frame :margin 5 :border 0 :width *prgm-width* + (color :margin 5 :width 100. :bg bg + (if verb + (pre (the-body opts)) + (the-body opts))))))) + +;*---------------------------------------------------------------------*/ +;* keyword ... */ +;*---------------------------------------------------------------------*/ +(define-markup (keyword arg) + (new markup + (markup '&source-key) + (body (cond + ((keyword? arg) + (keyword->string arg)) + ((symbol? arg) + (string-append ":" (symbol->string arg))) + (else + arg))))) + +;*---------------------------------------------------------------------*/ +;* param ... */ +;*---------------------------------------------------------------------*/ +(define-markup (param arg) + (cond + ((keyword? arg) + (keyword arg)) + ((symbol? arg) + (code (symbol->string arg))) + (else + arg))) + +;*---------------------------------------------------------------------*/ +;* example ... */ +;*---------------------------------------------------------------------*/ +(define-markup (example #!rest opts #!key legend class) + (new container + (markup 'example) + (ident (symbol->string (gensym 'example))) + (class class) + (required-options '(:legend :number)) + (options `((:number + ,(new unresolved + (proc (lambda (n e env) + (resolve-counter n env 'example #t))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* example-produce ... */ +;*---------------------------------------------------------------------*/ +(define-markup (example-produce example . produce) + (list (it "Example:") + example + (if (pair? produce) + (list (paragraph "Produces:") (car produce))))) + +;*---------------------------------------------------------------------*/ +;* markup-ref ... */ +;*---------------------------------------------------------------------*/ +(define-markup (markup-ref mk) + (ref :mark mk :text (code mk))) + +;*---------------------------------------------------------------------*/ +;* &the-index ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index + :class 'markup-index + :options '(:column) + :before (lambda (n e) + (output (markup-option n 'header) e)) + :action (lambda (n e) + (define (make-mark-entry n fst) + (let ((l (tr :class 'index-mark-entry + (td :colspan 2 :align 'left + (bold (it (sf n))))))) + (if fst + (list l) + (list (tr (td :colspan 2)) l)))) + (define (make-primary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n))) + (when p + (markup-option-add! b :text + (list (markup-option b :text) + ", p.")) + (markup-option-add! b :page #t)) + (tr :class 'index-primary-entry + (td :colspan 2 :valign 'top :align 'left b)))) + (define (make-column ie p) + (let loop ((ie ie) + (f #t)) + (cond + ((null? ie) + '()) + ((not (pair? (car ie))) + (append (make-mark-entry (car ie) f) + (loop (cdr ie) #f))) + (else + (cons (make-primary-entry (caar ie) p) + (loop (cdr ie) #f)))))) + (define (make-sub-tables ie nc p) + (define (split-list l num) + (let loop ((l l) + (i 0) + (acc '()) + (res '())) + (cond + ((null? l) + (reverse! (cons (reverse! acc) res))) + ((= i num) + (loop l + 0 + '() + (cons (reverse! acc) res))) + (else + (loop (cdr l) + (+ i 1) + (cons (car l) acc) + res))))) + (let* ((l (length ie)) + (w (/ 100. nc)) + (iepc (let ((d (/ l nc))) + (if (integer? d) + (inexact->exact d) + (+ 1 (inexact->exact (truncate d)))))) + (split (split-list ie iepc))) + (tr (map (lambda (ies) + (td :valign 'top :width w + (if (pair? ies) + (table :width 100. (make-column ies p)) + ""))) + split)))) + (let* ((ie (markup-body n)) + (nc (markup-option n :column)) + (pref (eq? (engine-custom e 'index-page-ref) #t)) + (loc (ast-loc n)) + (t (cond + ((null? ie) + "") + ((or (not (integer? nc)) (= nc 1)) + (table :width 100. :&skribe-eval-location loc + (make-column ie pref))) + (else + (table :width 100. :&skribe-eval-location loc + (make-sub-tables ie nc pref)))))) + (output (skribe-eval t e) e)))) + +;*---------------------------------------------------------------------*/ +;* compiler-command ... */ +;*---------------------------------------------------------------------*/ +(define-markup (compiler-command bin . opts) + (disp :verb #t + (color :fg "red" (bold bin)) + (map (lambda (o) + (list " [" (it o) "]")) + opts) + "...")) + +;*---------------------------------------------------------------------*/ +;* compiler-options ... */ +;*---------------------------------------------------------------------*/ +(define-markup (compiler-options bin) + (skribe-message " [executing: ~a --options]\n" bin) + (let ((port (open-input-file (format "| ~a --options" bin)))) + (let ((opts (read port))) + (close-input-port port) + (apply description (map (lambda (opt) (item :key (bold (car opt)) + (cadr opt) ".")) + opts))))) diff --git a/skribe/doc/user/bib.skb b/skribe/doc/user/bib.skb new file mode 100644 index 0000000..a006a9b --- /dev/null +++ b/skribe/doc/user/bib.skb @@ -0,0 +1,252 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/bib.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Dec 2 10:02:56 2001 */ +;* Last change : Tue Oct 26 21:41:19 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe index */ +;*=====================================================================*/ + +(bibliography "user/src/bib1.sbib") + +;*---------------------------------------------------------------------*/ +;* Index */ +;*---------------------------------------------------------------------*/ +(chapter :title "Bibliographies" + + (p [ +Skribe supports bibliographies. In order to use bibliography +,(markup-ref "ref") it is needed to:]) + (itemize + (item [ +Use the default pre-existing ,(emph "bibliography table") or create a +custom one.]) + (item [ +Provide a ,(emph "bibliography database").]) + (item [ +Load the database by the mean of the ,(markup-ref "bibliography") +Skribe function call.]) + (item [ +Reference to a bibliography entry, with a ,(markup-ref "ref") Skribe +function call.])) + +;*---------------------------------------------------------------------*/ +;* Bibliography tables */ +;*---------------------------------------------------------------------*/ +(section :title "Bibliography tables" + + (p [ +This section describes the function of using and creating bibliography +tables.]) + + (p [The predicate ,(code "bib-table?") returns ,(code "#t") if and only +if its argument is a bibliography table as returned by +,(markup-ref "make-bib-table") or ,(markup-ref "default-bib-table"). Otherwise +,(code "bib-table?") returns ,(code "#f").]) + + (doc-markup 'bib-table? + '((obj [The value to be tested])) + :see-also '(make-bib-table default-bib-table bibliography the-bibliography) + :force-engines *api-engines* + :common-args '() + :source "../src/bigloo/bib.bgl") + + (p [The function ,(code "default-bib-table") returns a global, pre-existing +bibliography-table:]) + (doc-markup 'default-bib-table + '() + :see-also '(bib-table? make-bib-table bibliography the-bibliography) + :force-engines *api-engines* + :common-args '() + :source "../src/bigloo/bib.bgl") + + (p [The function ,(code "make-bib-table") constructs a new +bibliography-table:]) + (doc-markup 'make-bib-table + '((ident [The name of the bibliography table.])) + :see-also '(bib-table? default-bib-table bibliography the-bibliography) + :force-engines *api-engines* + :common-args '() + :source "../src/bigloo/bib.bgl")) + +;*---------------------------------------------------------------------*/ +;* bibliography ... @label bibliography@ */ +;*---------------------------------------------------------------------*/ +(section :title "Bibliography" + +(p [The function ,(code "bibliography") loads bibliography ,(param 'entries) +into the Skribe memory. An ,(emph "entry") is either a list +representing one entry (such as an article or book reference) or a +string which denotes a file name that contains several +entries. All the entries loaded in memory are available for the function +,(ref :ident "ref" :node "references"). A bibliography database must be loaded +,(emph "before") any reference is introduced. It is advised to place +the ,(code "bibliography") Skribe function call before the call to the +,(markup-ref "document") function call.]) + +(doc-markup 'bibliography + `((:command ,[An external command to be applied when loading + the bibliography entries. The sequence ,(code "~a") is replaced + with the name of the file when the command is invoked.]) + (:bib-table ,[The ,(ref :mark "make-bib-table" :text "table") + where entry is searched.]) + (#!rest entry... ,[If ,(param 'entry) is a string, it denotes + a file containing the entry (see ,(ref :mark "skribe-bib-path" + :text "bibliograph path")). Otherwise, it is a list described + by the ,(ref :subsection "Bibliography syntax" :text "syntax") + below.])) + :see-also '(bib-table? make-bib-table default-bib-table the-bibliography) + :force-engines *api-engines* + :common-args '()) + +(p [The ,(param :command) option can be used to import foreign bibliography. +The following example, shows how to directly use a Bibtex bibliography +using the ,(ref :section "Skribebibtex") translator.]) + +(example-produce + (example :legend "Printing a bibliography" (prgm :file "src/bib6.skb"))) + + +;; bibliography syntax +(subsection :title "Bibliography syntax" + +(p [The Skribe bibliography database uses a format very close to +the Bibtex one. It is a parenthetic version of Bibtex. Here is the +syntax of an entry:]) + +(disp :verb #t :bg *prgm-skribe-color* [ +<entry> --> ,(bold "(")<kind> <key> <field>+,(bold ")") +<kind> --> techreport | article | inproceedings | book +<key> --> <symbol> | <string> +<field> --> ,(bold "(")<symbol> <string>,(bold ")")]) + +(p [Bibtex files cannot be directly loaded in Skribe but the tool +,(ref :section "Skribebibtex" :text (tt "skribebibtex")) can be use to +automatically convert Bibtex format to Skribe bibliography format. +Here is an example of a simple Skribe database.]) + +(prgm :file "src/bib1.sbib"))) + +;*---------------------------------------------------------------------*/ +;* the-bibliography ... @label the-bibliography@ */ +;*---------------------------------------------------------------------*/ +(section :title "Printing a bibliography" + +(p [The function ,(code "the-bibliography") displays the bibliography. ]) + +(doc-markup 'the-bibliography + `((:bib-table [The bibliography + ,(ref :mark "make-bib-table" :text "table") to be displayed.]) + (:pred [A predicate filtering the bibliography entries. It takes + two parameters: the bibliography entry and the + ,(code "the-bibliography") node.]) + (:sort [A function sorting a list of entries.]) + (:count ,[The symbol ,(code "partial") or ,(code "full") + specifies the numbering to be applied. The value + ,(code "partial") tells Skribe to count only the entries + filtered in by ,(param :pred). The value ,(code "full") + tells Skribe to count all entries, event those filtered out + by ,(param :pred).])) + :see-also '(bib-table? make-bib-table default-bib-table bibliography) + :force-engines *api-engines* + :common-args '()) + +(example-produce + (example :legend "Printing a bibliography" (prgm :file "src/bib2.skb")) + (disp (include "src/bib2.skb"))) + +;; filtering bibliography +(subsection :title "Filtering bibliography entries" +(index "the-bibliography" :note "filtering") + +(p [The ,(param :pred) option is bound to a function of one argument +that filters bibliography entries. It is used to control which entries +must appears on a bibliography. The default behavior is to display +only the entries referenced to in the text. For instance, in order to +display ,(emph "all") the entries of a bibliography, is it needed to +print the bibliography with a predicate returning always ,(code "#t").]) + +(example-produce + (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib3.skb")) + (disp (include "src/bib3.skb"))) + +(p [The second example, filters out the entries that are not ,(emph "book") +or that are not referenced to from the document.]) + +(example-produce + (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib4.skb")) + (disp (include "src/bib4.skb"))) + +(p [The last example, illustrates how to change the rendering of a +bibliography. It uses the ,(markup-ref "processor") construction +and it defines two ,(ref :ident "writer" :text "writers") for +displaying ,(code "&bib-entry-ident") and ,(code "&bib-entry-title") +markups. These two markups are introduced by Skribe when it loads a +bibliography. All fields of bibliography entries are represented by +markups whose prefix are ,(code "&bib-entry-"). The parent of all these +markups is the bibliography entry itself. The ,(code "&bib-entry-") markups +are options of there parent.]) + +(example-produce + (example :legend "Unfiltering bibliography entries" (prgm :file "src/bib5.skb")) + (disp (include "src/bib5.skb")))) + +;; sorting bibliography +(subsection :title "Sorting bibliography entries" +(index "the-bibliography" :note "sorting") + +(p [The ,(param :sort) option of the ,(markup-ref "the-bibliography") +markup is used for sorting the bibliography entries. There are three +pre-existing functions for sorting entries:]) + +(doc-markup 'bib-sort/authors + '((l [The list of entries.])) + :force-engines *api-engines* + :source "../src/common/bib.scm" + :others '(bib-sort/idents bib-sort/dates) + :common-args '()) + +(p [The first function sorts the entries according to an alphabetic ordering +on authors. The second sorts according to an alphabetic ordering on +entries identifier. The last one sorts according to entries date.]) + +(example-produce + (example :legend "Sorting bibliography entries" + (prgm :file "src/common/bib.scm" :definition 'bib-sort/idents))))) + +;*---------------------------------------------------------------------*/ +;* skribebibtex */ +;*---------------------------------------------------------------------*/ +(section :title "Skribebibtex" +(index "skribebibtex" :note "manual page") +(index "bibtex") +(p [ +In this section we present the Skribebibtex translator that compiles Bibtex +source files into a Skribe bibliography.]) + +;; Synopsis +(subsection :title "SYNOPSIS" :number #f + (compiler-command *skribebibtex-bin* "options" "input")) + +;; Description +(subsection :title "DESCRIPTION" :number #f [ +This manual page is not meant to be exhaustive. It +documents the ,(tt "skribebibtex"), a tool that translates +,(bold "Bibtex") files into ,(it "Skribe"), bibliography format. These +files can be used by the ,(bold "skribe") compiler to produce +bibliography entries.]) + +;; Suffixes +(subsection :title "SUFFIXES" :number #f [ +The ,(ref :chapter "Skribe compiler" :text "skribe") compiler uses file +suffixes in order to select amongst its possible targets which to choose. +These suffixes are: + +,(description (item :key (it ".bib") [a ,(bold "Bibtex") source file.]))]) + +;; Options +(subsection :title "OPTIONS" :number #f +(compiler-options *skribebibtex-bin*)))) + diff --git a/skribe/doc/user/char.skb b/skribe/doc/user/char.skb new file mode 100644 index 0000000..85409f0 --- /dev/null +++ b/skribe/doc/user/char.skb @@ -0,0 +1,86 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/char.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Sep 6 16:07:08 2003 */ +;* Last change : Mon Feb 2 11:16:57 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Characters, strings and symbols */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Footnote ... */ +;*---------------------------------------------------------------------*/ +(section :title "Characters, Strings and Symbols" :file #t + +;*--- characters ------------------------------------------------------*/ +(subsection :title "Characters" + +(p [The function ,(code "char") introduces a ,(emph "character") in +the produced document. The purpose of this function is to introduce +escape characters or to introduce characters that cannot be typesetted +in the document (for instance because the editors does not support +them). The escapes characters are ,(code (char 91)), ,(code (char 93)) +and ,(code (char 59)).]) + +(doc-markup 'char + '((char [The character to be introduced. Specified value can be +a character, a string or an integer])) + :common-args '()) + +(example-produce + (example :legend "Some characters" (prgm :file "src/api19.skb")) + (disp (include "src/api19.skb")))) + + +;*--- Strings ---------------------------------------------------------*/ +(subsection :title "Strings" + +(p [the function ,(code "!") introduces raw strings in the target. +That is, the strings introduced by ,(code "!") are written ,(emph "as is"), +without any transformation from the engine.]) + +(doc-markup '! + '((format [The format of the command.]) + (#!rest node... "The arguments.")) + :common-args '()) + +(p [The sequences ,(code "$1"), ,(code "$2"), ... in the ,(param 'format) +are replaced with the actual values of the arguments ,(param 'node).]) + +(example-produce + (example :legend "Some characters" (prgm :file "src/api20.skb")) + (disp (include "src/api20.skb")))) + +;*--- Symbols ---------------------------------------------------------*/ +(subsection :title "Symbols" + +(p [The function ,(code "symbol") introduces special symbols in the +produced file. Note that the rendering of symbols is unportable. It depends +of the capacity of the targeted format.]) + +(doc-markup 'symbol + '((symbol [The symbol to introduce.])) + :common-args '()) + +(p [Here is the list of recognized symbols:]) + +(center + (apply table + :width *prgm-width* + (tr :class 'api-symbol-prototype (th "Symbol name") (th "Rendering")) + (map (lambda (s) + (tr :bg *prgm-skribe-color* + (td :align 'left s) + (td :align 'left (symbol s)))) + (sort (let ((t (make-hashtable))) + (for-each (lambda (e) + (for-each (lambda (s) + (hashtable-put! t (car s) (car s))) + (engine-symbol-table e))) + *api-engines*) + (hashtable->list t)) + string<?)))))) + + diff --git a/skribe/doc/user/colframe.skb b/skribe/doc/user/colframe.skb new file mode 100644 index 0000000..79b32f9 --- /dev/null +++ b/skribe/doc/user/colframe.skb @@ -0,0 +1,57 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/colframe.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Mon Apr 5 11:51:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe color and frame */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Frame and color */ +;*---------------------------------------------------------------------*/ +(section :title "Frame and color" :file #t + +(p [The function ,(code "frame") embeds a text inside a frame. +The function ,(code "color") may also use the same purpose when it is +specified a ,(code "bg") option. This is why both functions are included +in the same Skribe manual section.]) + +;*--- Frame -----------------------------------------------------------*/ +(subsection :title "Frame" + +(doc-markup 'frame + `((:width ,[The ,(ref :mark "width") of the frame.]) + (:margin [The margin pixel size of the frame.]) + (:border [The border pixel of the frame.]) + (#!rest node... "The items of the enumeration.")) + :see-also '(color table)) + +(example-produce + (example :legend "The frame markup" (prgm :file "src/api12.skb")) + (disp (include "src/api12.skb")))) + +;*--- color -----------------------------------------------------------*/ +(subsection :title "Color" + +(p [The ,(code "color") markup enables changing ,(emph "locally") the +text of the document. If the ,(code "bg") color is used, then, ,(code "color") +acts as a container. Otherwise, it acts as an ,(ref :section "Ornaments").]) + +(doc-markup 'color + `((:width ,[The ,(ref :mark "width") of the frame.]) + (:margin [The margin pixel size of the frame.]) + (:bg [The background color]) + (:fg [The foreground color]) + (#!rest node... "The items of the enumeration.")) + :see-also '(frame table)) +(example-produce + (example :legend "The color markup" (prgm :file "src/api13.skb")) + (disp (include "src/api13.skb"))))) + + + + + diff --git a/skribe/doc/user/document.skb b/skribe/doc/user/document.skb new file mode 100644 index 0000000..09f8cb3 --- /dev/null +++ b/skribe/doc/user/document.skb @@ -0,0 +1,80 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/document.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 11:39:07 2003 */ +;* Last change : Wed Feb 4 14:51:12 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Document and author */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* dummy-document-output ... */ +;*---------------------------------------------------------------------*/ +(define dummy-document-output + (lambda (n e) + (let* ((a (markup-option n :author)) + (t (markup-option n :title)) + (b (markup-body n)) + (ta (table (tr (map (lambda (n) + (td :valign 'top :align 'center n)) + a))))) + (skribe-eval (center (bold t)) e) + (skribe-eval (center ta) e) + (output b e)))) + +;*---------------------------------------------------------------------*/ +;* Document */ +;*---------------------------------------------------------------------*/ +(section :title "Building documents" :file #t + +;*--- document --------------------------------------------------------*/ +(subsection :title "Document" + +(p [The ,(tt "document") function defines a Skribe document.]) + +(doc-markup 'document + '((:title "The title of the document.") + (:html-title "The title of window of the HTML browser.") + (:author "The authors of the document.") + (:ending "An ending text.") + (:env "A counter environment.") + (#!rest node... "The document nodes.")) + :see-also '(author chapter toc)) + +(example-produce + (example :legend "The document markup" (prgm :file "src/api2.skb")) + (disp + (processor :combinator + (lambda (e1 e2) + (let ((e (copy-engine 'document-engine e2))) + (markup-writer 'document e + :options '(:title :author :ending) + :action dummy-document-output) + e)) + (include "src/api2.skb"))))) + +;*---------------------------------------------------------------------*/ +;* Author ... */ +;*---------------------------------------------------------------------*/ +(subsection :title "Author" + +(p [The ,(tt "author") function is used to specify the authors of a Skribe +document.]) + +(doc-markup 'author + '((:name "The name of the author.") + (:title "His title.") + (:affiliation "His affiliation.") + (:email "His email.") + (:url "His web page.") + (:address "His address.") + (:phone "His phone number.") + (:photo "His photograph.") + (:align "The author item alignment.")) + :see-also '(mailto ref)) + +(example-produce + (example :legend "The author markup" (prgm :file "src/api3.skb")) + (disp (include "src/api3.skb"))))) diff --git a/skribe/doc/user/emacs.skb b/skribe/doc/user/emacs.skb new file mode 100644 index 0000000..742fa87 --- /dev/null +++ b/skribe/doc/user/emacs.skb @@ -0,0 +1,58 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/emacs.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Nov 30 13:36:44 2001 */ +;* Last change : Sun Feb 29 16:12:32 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Editing Skribe programs */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Editing Skribe programs */ +;*---------------------------------------------------------------------*/ +(chapter :title "Editing Skribe Programs" (p [ +Skribe sources can be automatically generated from +,(ref :url *texinfo-url* :text "Texinfo") by the ,(tt "skribeinfo") compiler. +They can also be typed in. For this task, it is highly recommended to +use ,(ref :url *emacs-url* :text "GNU Emacs") or +,(ref :url *xemacs-url* :text "Xemacs"). +These editors provide parentheses matching and Skribe expressions +handling.]) + +;*---------------------------------------------------------------------*/ +;* Skribe emacs mode */ +;*---------------------------------------------------------------------*/ +(section :title "Skribe Emacs mode" [ +,(index "emacs" :note "skribe mode") + +The Skribe distribution contains a minor mode dedicated to +Skribe edition. This mode provides ,(emph "fontification") and +indentation of Skribe programs. In this manual, we present +the two most important key bindings specific to this mode. + +,(itemize (item [,(color :fg "#007700" (kbd "tab")) Indents the current line.]) + (item [,(color :fg "#007700" (kbd "M-C-q")) Indents a whole Skribe +expression.])) + +,(p [In order to install the Skribe emacs mode, you need to specify that +when the emacs Lisp ,(tt "skribe-mode") function is needed +it has to be loaded from the ,(tt "skribe.el") file:]) + + +,(disp :verb #t (source :language lisp [ +(autoload 'skribe-mode "skribe.el" "Skribe mode." t)])) + +,(p [The ,(tt "skribe.el") file must in the path described by the Emacs Lisp +,(tt "load-path") variable.]) + +,(p [ +The ,(code "skribe") mode is a minor mode. It is intended to be used with +a Lisp or Scheme mode. Hence, to use the ,(code "skribe") mode you will +have to use the following Emacs commands:]) + +,(disp :vert #t (source :language lisp [ +ESC-x: scheme-mode +ESC-x: skribe-mode +]))])) diff --git a/skribe/doc/user/engine.skb b/skribe/doc/user/engine.skb new file mode 100644 index 0000000..06be3c4 --- /dev/null +++ b/skribe/doc/user/engine.skb @@ -0,0 +1,135 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/engine.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 11:19:21 2003 */ +;* Last change : Mon Nov 8 15:07:35 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The description of the Skribe engines */ +;*=====================================================================*/ +;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@ + +(cond-expand + (bigloo + (define *engine-src* "../src/bigloo/engine.scm") + (define *types-src* "../src/bigloo/types.scm")) + (stklos + (define *engine-src* "../src/stklos/engine.stk") + (define *types-src* "../src/stklos/types.stk"))) + +;*---------------------------------------------------------------------*/ +;* Engine */ +;*---------------------------------------------------------------------*/ +(chapter :title "Engines" + + (p [When Skribe produces a document in a given format, it uses a +specialize engine. For instance, when a Web page is made from a Skribe +document, the HTML engine is used. The engines provided by Skribe are +given below:]) + + (resolve (lambda (n e env) + (let* ((current-chapter (ast-chapter n)) + (body (map (lambda (x) (if (pair? x) (car x) x)) + (markup-body current-chapter))) + (sects (filter (lambda (x) (is-markup? x 'section)) + body))) + (itemize + (map (lambda (x) + (let ((title (markup-option x :title))) + (item (ref :text title :section title)))) + sects))))) + + (section :title "Functions dealing with engines" + + (subsection :title "Creating engines" + (p [The function ,(code "make-engine") creates a brand new engine.]) + + (doc-markup 'make-engine + '((ident [The name (a symbol) of the new engine.]) + (:version [The version number.]) + (:format [The output format (a string) of this engine.]) + (:filter [A string filter (a function).]) + (:delegate [A delegate engine.]) + (:symbol-table [The engine symbol table.]) + (:custom [The engine custom list.]) + (:info [Miscellaneous.])) + :common-args '() + :source *engine-src* + :idx *function-index*) + + (p [The function ,(code "copy-engine") duplicates an existing engine.]) + (doc-markup 'copy-engine + '((ident [The name (a symbol) of the new engine.]) + (e [The old engine to be duplicated.]) + (:version [The version number.]) + (:filter [A string filter (a function).]) + (:delegate [A delegate engine.]) + (:symbol-table [The engine symbol table.]) + (:custom [The engine custom list.])) + :common-args '() + :source *engine-src* + :idx *function-index*)) + + (subsection :title "Retrieving engines" + + (p [The ,(code "find-engine") function searches in the list of defined +engines. It returns an ,(code "engine") object on success and ,(code "#f") +on failure.]) + (doc-markup 'find-engine + '((id [The name (a symbol) of the engine to be searched.]) + (:version [An optional version number for the searched engine.])) + :common-args '() + :source *engine-src* + :idx *function-index*)) + + (subsection :title "Engine accessors" + (p [The predicate ,(code "engine?") returns ,(code "#t") if its +argument is an engine. Otherwise, it returns ,(code "#f"). In other words, +,(code "engine?") returns ,(code "#t") for objects created by +,(code "make-engine"), ,(code "copy-engine"), and ,(code "find-engine").]) + (doc-markup 'engine? + '((obj [The checked object.])) + :common-args '() + :source *types-src* + :idx *function-index*) + + (p [The following functions return information about engines.]) + + (doc-markup 'engine-ident + '((obj [The engine.])) + :common-args '() + :others '(engine-format engine-customs engine-filter engine-symbol-table) + :source *types-src* + :idx *function-index*)) + + (subsection :title "Engine customs" + + (p [Engine customs are locations where dynamic informations relative +to engines can be stored. Engine custom can be seen a global variables that +are specific to engines. The function ,(code "engine-custom") returns the +value of a custom or ,(code "#f") if that custom is not defined. The +function ,(code "engine-custom-set!") defines or sets a new value for +a custom.]) + + (doc-markup 'engine-custom + `((e ,[The engine (as returned by +,(ref :mark "find-engine" :text (code "find-engine"))).]) + (id [The name of the custom.])) + :common-args '() + :source *engine-src* + :idx *function-index*) + + (doc-markup 'engine-custom-set! + `((e ,[The engine (as returned by +,(ref :mark "find-engine" :text (code "find-engine"))).]) + (id [The name of the custom.]) + (val [The new value of the custom.])) + :common-args '() + :source *engine-src* + :idx *function-index*))) + + ;; existing engines + (include "htmle.skb") + (include "latexe.skb") + (include "xmle.skb")) diff --git a/skribe/doc/user/enumeration.skb b/skribe/doc/user/enumeration.skb new file mode 100644 index 0000000..01155e2 --- /dev/null +++ b/skribe/doc/user/enumeration.skb @@ -0,0 +1,33 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/enumeration.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Fri Sep 12 15:31:37 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe enumerations */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Justification */ +;*---------------------------------------------------------------------*/ +(section :title "Enumeration" :file #t + +(p [These functions implements three various style of enumerations.]) + +(doc-markup 'itemize + '((:symbol [The symbol that prefixes the items.]) + (#!rest item... "The items of the enumeration.")) + :others '(enumerate description)) + +(p [Items are introduce by the means of the ,(code "item") markup:]) + +(doc-markup 'item + '((:key [The item key.]))) + +;; FIXME: Rien n'est fait en html sur le type de bullet. Mais peut on faire? +(example-produce + (example :legend "The enumeration markups" (prgm :file "src/api11.skb")) + (disp (include "src/api11.skb")))) + diff --git a/skribe/doc/user/examples.skb b/skribe/doc/user/examples.skb new file mode 100644 index 0000000..a37ece4 --- /dev/null +++ b/skribe/doc/user/examples.skb @@ -0,0 +1,34 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/examples.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 13:35:34 2003 */ +;* Last change : Tue Feb 3 14:52:33 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The list of examples */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Examples */ +;*---------------------------------------------------------------------*/ +(chapter :title "List of examples" + +(resolve (lambda (n e env) + (let* ((d (ast-document n)) + (ex (container-env-get d 'example-env))) + (table (map (lambda (e) + (tr (td :align 'left + (markup-option e :number) + ". " + (ref :handle (handle e) + :text (markup-option e :legend)) + " (chapter " + (let ((c (ast-chapter e))) + (ref :handle (handle c) + :text (markup-option c :title))) + ")"))) + (sort ex + (lambda (e1 e2) + (< (markup-option e1 :number) + (markup-option e2 :number)))))))))) diff --git a/skribe/doc/user/figure.skb b/skribe/doc/user/figure.skb new file mode 100644 index 0000000..08fbdd5 --- /dev/null +++ b/skribe/doc/user/figure.skb @@ -0,0 +1,58 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/figure.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Fri Sep 12 15:31:48 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe figures */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(section :title "Figure" :file #t + +(doc-markup 'figure + `((:legend ,[The legend of the figure. If no ,(param :ident) is + provided to the figure, it uses the legend value as an + identifier. In consequence, it is possible to use the + ,(param :legend) value in + ,(ref :mark "ref" :text "references").]) + (:number ,[If the optional argument ,(param :number) is a number, + that number is used as the new Scribe compiler figure + counter. If it is ,(tt "#t") the compiler automatically + sets a number for that figure. If it is ,(tt "#f") the + figure is numberless.]) + (:multicolumns ,[A boolean that indicates, for back-ends + supporting multi-columns rendering (e.g., "TeX"), if the figure + spans over all the columns.]) + (#!rest body [The body of the figure.])) + + :see-also '(ref document)) + +(example-produce + (example :legend "The figure markup" (prgm :file "src/api14.skb")) + (disp (include "src/api14.skb"))) + +;*--- List of figures -------------------------------------------------*/ +(subsection :title "List of figures" +(index "figure" :note "list of figures") + +(p [Skribe has no builtin facility for displaying the list of figures. +Instead, it provides a general machinery for displaying any kind of lists +contained in the document. This is described in the section ,(ref +:section "Resolve") and ,(ref :section "Introspection") but for the +sake of the coherence, this section also contains an example that +shows how to display the list of figures of a document.]) + +(example-produce + (example :legend "The figure markup" (prgm :file "src/api15.skb")) + (disp (include "src/api15.skb"))))) + + + + + + diff --git a/skribe/doc/user/font.skb b/skribe/doc/user/font.skb new file mode 100644 index 0000000..df0bfed --- /dev/null +++ b/skribe/doc/user/font.skb @@ -0,0 +1,30 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/font.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Fri Sep 12 15:31:25 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe font */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Font */ +;*---------------------------------------------------------------------*/ +(section :title "Font" :file #t + +(p [The function ,(code "font") enables font selection.]) + +(doc-markup 'font + '((:size [The size of the font. The size may be ,(emph "relative") +(with respect to the current font size) or absolute. A relative +font is either specified with a floating point value or a negative +integer value. A positive integer value specifies an absolute font size.]) + (:face [The name of the font to be used.]) + (#!rest node... "The nodes of the font."))) + +(example-produce + (example :legend "The font markup" (prgm :file "src/api9.skb")) + (disp (include "src/api9.skb")))) + diff --git a/skribe/doc/user/footnote.skb b/skribe/doc/user/footnote.skb new file mode 100644 index 0000000..96101f3 --- /dev/null +++ b/skribe/doc/user/footnote.skb @@ -0,0 +1,28 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/footnote.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Sep 6 15:43:24 2003 */ +;* Last change : Fri Sep 12 15:32:13 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe footnotes. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Footnote ... */ +;*---------------------------------------------------------------------*/ +(section :title "Footnote" :file #t + +(p [By default, footnotes appear at the bottom of the page that contains +the reference to the footnote.]) + +(doc-markup 'footnote + `((:number [The number of the footnote.]) + (#!rest text... [The text of the footnote.])) + :see-also '(document chapter section)) + +(example-produce + (example :legend "A footnote" (prgm :file "src/api18.skb")) + (disp (include "src/api18.skb")))) + diff --git a/skribe/doc/user/htmle.skb b/skribe/doc/user/htmle.skb new file mode 100644 index 0000000..b5d0b0e --- /dev/null +++ b/skribe/doc/user/htmle.skb @@ -0,0 +1,111 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/htmle.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 11:20:49 2003 */ +;* Last change : Wed Oct 27 12:05:53 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The documentation of the html engine */ +;*=====================================================================*/ +;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ + +;*---------------------------------------------------------------------*/ +;* Document */ +;*---------------------------------------------------------------------*/ +(section :title "Html engine" :file #t + (mark "html-engine") + (index "Html" :note "Engine") + (p [The html engine...]) + + (subsection :title "The HTML customization" + + (doc-engine 'html + `((favicon ,[The name of an image file of the URL image. The +,(code "favicon") custom can be either bound to a string +which is the name of the image, or to a procedure of +two arguments, a node and an engine that returns the file name +of the icon. This can be used to use different icons per +chapter or section.]) + (charset [The character set used for the document.]) + (javascript [Enable/disable Javascript support.]) + (head [A string included in the HTML header.]) + (css ,[The URL or a list of URLs of +,(ref :url "http://www.w3.org/TR/REC-CSS2/" :text "CSS") +used by the document.]) + (inline-css ,[The file or a list of files inlined +inside the header's style section. The custom ,(code "inline-css") should be +used in replacement of the ,(code "css") custom in order to produce +stand alone HTML documents.]) + (js ,[A URL or a list of URLs of JavaScript programs used by +the document.]) + (emit-sui [Emit a SUI file for this document.]) + (background "The background color of the document.") + (foreground "The foreground color of the document.") + ;; the margins + (margin-padding "Margins padding.") + (left-margin "A procedure of two arguments producing the left margin of the document.") + (chapter-left-margin "A procedure of two arguments producing the left margin of the document.") + (section-left-margin "A procedure of two arguments producing the left margin of the document.") + (left-margin-font "The font of the left margin.") + (left-margin-size ,[The ,(ref :mark "width" :text "width") of the left margin.]) + (left-margin-background "The background color of the left margin.") + (left-margin-foreground "The foreground color of the left margin.") + (right-margin "A procedure of two arguments producing the right margin of the document.") + (chapter-right-margin "A procedure of two arguments producing the right margin of the document.") + (section-right-margin "A procedure of two arguments producing the right margin of the document.") + (right-margin-font "The font of the right margin.") + (right-margin-size ,[The ,(ref :mark "width" :text "width") of the right margin.]) + (right-margin-background "The background color of the right margin.") + (right-margin-foreground "The foreground color of the right margin.") + ;; author configuration + (author-font "The author font.") + ;; title configuration + (title-font "The title font.") + (title-background "The title background color.") + (title-foreground "The title foreground color.") + (file-title-separator "A text to be inserted in between the document title and the chapter or section title when the chapter or section is rendered in a separate file.") + ;; index configuration + (index-header-font-size "The index header font size.") + ;; chapter configuration + (chapter-number->string "A procedure of one argument for rendering chapter numbers.") + (chapter-file ,[A boolean specifying if chapters are rendered in speparate html file (see ,(markup-ref "chapter") markup).]) + ;; section configuration + (section-title-start "The HTML sequence for starting section title.") + (section-title-stop "The HTML sequence for stopping section title.") + (section-title-background "The background color of section title.") + (section-title-foreground "The foreground color of section title.") + (section-title-number-separator "The section title number separator.") + (section-number->string "A procedure of one argument for rendering section numbers.") + (section-file ,[A boolean specifying if sections are rendered in speparate html file (see ,(markup-ref "section") markup).]) + ;; subsection configuration + (subsection-title-start "The HTML sequence for starting subsection title.") + (subsection-title-stop "The HTML sequence for stopping subsection title.") + (subsection-title-background "The background color of subsection title.") + (subsection-title-foreground "The foreground color of subsection title.") + (subsection-title-number-separator "The subsection title number separator.") + (subsection-number->string "A procedure of one argument for rendering subsection numbers.") + (subsection-file ,[A boolean specifying if subsections are rendered in speparate html file (see ,(markup-ref "subsection") markup).]) + ;; subsubsection configuration + (subsubsection-title-start "The HTML sequence for starting subsubsection title.") + (subsubsection-title-stop "The HTML sequence for stopping subsubsection title.") + (subsubsection-title-background "The background color of subsubsection title.") + (subsubsection-title-foreground "The foreground color of subsubsection title.") + (subsubsection-title-number-separator "The subsubsection title number separator.") + (subsubsection-number->string "A procedure of one argument for rendering subsubsection numbers.") + (subsubsection-file ,[A boolean specifying if subsubsections are rendered in speparate html file (see ,(markup-ref "subsubsection") markup).]) + ;; source fontification + (source-color ,[A boolean enabling/disabling color of source code (see ,(markup-ref "source") markup).]) + (source-comment-color "The source comment color.") + (source-error-color "The source error color.") + (source-define-color "The source define color.") + (source-module-color "The source module color.") + (source-markup-color "The source markup color.") + (source-thread-color "The source thread color.") + (source-string-color "The source string color.") + (source-bracket-color "The source bracket color.") + (source-type-color "The source type color.") + (image-format "The image formats for this engine.")) + :source "skr/html.skr"))) + + diff --git a/skribe/doc/user/image.skb b/skribe/doc/user/image.skb new file mode 100644 index 0000000..d08ad18 --- /dev/null +++ b/skribe/doc/user/image.skb @@ -0,0 +1,79 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/image.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Sat Jan 17 18:08:15 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe images */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(section :title "Image" :file #t + +(p [Images are defined by the means of the ,(code "image") function]) + +(doc-markup 'image + `((:file ,[The file where the image is stored on the disk + (see ,(ref :mark "skribe-image-path" + :text "image path")). + The image is converted + (see ,(markup-ref "convert-image")) into a format + supported by the engine. This option is exclusive + with the ,(param :url) option.]) + (:url [The URL of the file. This option is exclusive with the + ,(param :file) option.]) + (:width [The width of the image. It may be an integer for a pixel + size or a floating point number for a percentage.]) + (:height [The height of the image. It may be an integer for a + pixel size or a floating point number for a + percentage.]) + (:zoom [A zoom factor.]) + (#!rest comment [A text describing the image.])) + :see-also '(skribe-image-path convert-image)) + +(example-produce + (example :legend "The image markup" (prgm :file "src/api16.skb")) + (disp (include "src/api16.skb"))) + +;*--- Image format ----------------------------------------------------*/ +(subsection :title "Image formats" + (index "image" :note "conversion") + + (p [ +Images are unfortunately ,(emph "unportable"). The various Skribe output +formats support different image formats. For instance, HTML supports +,(code "gif") and ,(code "jpeg") while the LaTeX back-end only supports +,(code "ps"). Skribe tries, only when needed, to automatically +,(emph "convert") images to a format supported by the target +to be produced. For this, it uses external tools. The default Skribe +translation scheme is:]) +(itemize (item [Do not translate an image that needs no conversion.]) + (item [Uses the ,(code "fig2dev") external tool to translate + ,(code "Xfig") images.]) + (item [Uses the ,(code "convert") external tools to translate all + other formats.])) + + (p [,(ref :chapter "Engines" :text "Engines") support different image +formats. Each engine may specify a converter to be applied to an image. +The engine custom ,(code "image-format") specifies the list of supported +image formats. This list is composed of a suffix such as ,(code "jpeg") or +,(code "gif").]) + + (p [The function ,(code "convert-image") tries to convert an +image according to a list of formats. All the specified formats are +successively tried. On the first success, the function ,(code "convert-image") +returns the name of the new converted image. On failure, it returns +,(code "#f").]) + (doc-markup 'convert-image + `((file [The image file to be converted. The file is +searched in the ,(ref :mark "skribe-image-path" :text "image path").]) + (formats [A list of formats into which images are converted to.])) + :common-args '() + :source "../src/bigloo/lib.bgl" + :see-also '(skribe-image-path) + :idx *function-index*))) + diff --git a/skribe/doc/user/index.skb b/skribe/doc/user/index.skb new file mode 100644 index 0000000..dd5e8fa --- /dev/null +++ b/skribe/doc/user/index.skb @@ -0,0 +1,118 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/index.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Dec 2 10:02:56 2001 */ +;* Last change : Mon Feb 23 18:59:00 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe indexes */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Index */ +;*---------------------------------------------------------------------*/ +(chapter :title "Indexes" (p [ +Skribe support indexes. One may accumulate all entries inside one +unique index or dispatch them amongst user declared indexes. Indexes +may be ,(emph "monolithic") or ,(emph "split"). They only differ in +the way they are rendered by the back-ends. For a split index a sectioning +based on the specific (e.g., "the first one") character of +index entries is deployed.]) + +;*---------------------------------------------------------------------*/ +;* make-index ... @label make-index@ */ +;*---------------------------------------------------------------------*/ +(section :title "Making indexes" + +(p [The function ,(code "make-index") declares a new index.]) + +(doc-markup 'make-index + '((ident "A string, the name the index (currently unused).")) + :common-args '() + :see-also '(default-index index the-index ref mark)) + +(p [For instance, the following Skribe expression declares an index named +,(tt "*index1*"):]) + +(example-produce + (example :legend "Creation of a new index" (prgm :file "src/index1.skb"))) + +(include "src/index1.skb") + +(p [This example produces no output but enables entries to be added to that +index. In general it is convenient to declare indexes ,(emph "before") +the call to the ,(markup-ref "document") function.]) + +(p [The function ,(code "default-index") returns the default index +that pre-exists to all execution.]) + +(doc-markup 'default-index + '() + :common-args '() + :source "src/common/index.scm")) + +;*---------------------------------------------------------------------*/ +;* Index ... @label index@ */ +;*---------------------------------------------------------------------*/ +(section :title "Adding entries to an index" + +(p [The function ,(code "index") adds a new entry into one existing +index and sets a mark in the text where the index will point to. It is +an error to add an entry into an index that is not already declared.]) + +(doc-markup 'index + '((:index [The name of the index whose index entry belongs to. + A value of ,(tt "#f") means that the + ,(markup-ref :mark "default-index") owns this entry.]) + (:note [An optional note added to the index entry. This note + will be displayed in the index printing.]) + (:shape [An optional shape to be used for rendering the entry.]) + (:url [An optional URL that is referenced in the index table + instead of the location of the ,(code "index").]) + (#!rest name [The name of the entry. This must be a string.])) + :see-also '(make-index default-index the-index)) + +(p [The following expressions add entries to the index ,(code "*index1*"):]) + +(example-produce + (example :legend "Adding entries to an index" (prgm :file "src/index2.skb"))) + +(include "src/index2.skb") + +(p [There is no output associated with these expressions.])) + +;*---------------------------------------------------------------------*/ +;* Print-index ... @label the-index@ */ +;*---------------------------------------------------------------------*/ +(section :title "Printing indexes" + + (p [The function ,(code "the-index") displays indexes in the produced +document.]) + + (doc-markup 'the-index + '((:split [If ,(tt "#t"), character based sectioning is deployed. + Otherwise all the index entries are displayed one next to + the other.]) + (:char-offset [The character number to use when split is + required. This option may be useful when printing index whose + items share a common prefix. The ,(param :char-offset) + argument can be used to skip this prefix.]) + (:header-limit [The number of entries from which an index header + is introduced.]) + (:column [The number of columns of the index.]) + (#!rest index... [The indexes to be displayed. If index + is provided, the global index ,(markup-ref "default-index") + is printed.]))) + + (p [If the engine custom +,(ref :chapter "Engines" :text (code "index-page-ref")) is true when a +index is rendered then, page reference framework is used instead of +a direct reference framework.]) + +(example-produce + (example :legend "Printing indexes" (prgm :file "src/index3.skb")) + (disp (include "src/index3.skb"))) + +(p [See the Skribe ,(ref :mark "global index" :text "global index") for +a real life index example.]))) diff --git a/skribe/doc/user/justify.skb b/skribe/doc/user/justify.skb new file mode 100644 index 0000000..94db7d5 --- /dev/null +++ b/skribe/doc/user/justify.skb @@ -0,0 +1,30 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/justify.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 11:53:32 2003 */ +;* Last change : Fri Sep 12 15:31:31 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe justification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Justification */ +;*---------------------------------------------------------------------*/ +(section :title "Justification" :file #t + +(p [These functions control the text layout. The default layout is text +justification.]) + +(doc-markup 'flush + '((:side [The possible values for the side justification + are ,(tt "left"), ,(tt "center") or ,(tt "right").]) + (#!rest node... "The nodes of the font.")) + :others '(center pre) + :see-also '(linebreak table prog)) + +(example-produce + (example :legend "The justification markups" (prgm :file "src/api10.skb")) + (disp (include "src/api10.skb")))) + diff --git a/skribe/doc/user/latexe.skb b/skribe/doc/user/latexe.skb new file mode 100644 index 0000000..f53737b --- /dev/null +++ b/skribe/doc/user/latexe.skb @@ -0,0 +1,60 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/latexe.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 11:20:49 2003 */ +;* Last change : Tue Apr 6 06:28:59 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The documentation of the html engine */ +;*=====================================================================*/ +;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ + +;*---------------------------------------------------------------------*/ +;* Document */ +;*---------------------------------------------------------------------*/ +(section :title "LaTeX engine" :file #t + (mark "latex-engine") + (index "LaTeX" :note "Engine") + (p [The LaTeX engine...]) + + + (subsection :title "The LaTeX customization" + + (doc-engine 'latex + `((documentclass ,[A string declaring The LaTeX document class.]) + (usepackage ,[The boolean ,(code "#f") if no package is used or a string declaring The LaTeX packages.]) + (predocument ,[The boolean ,(code "#f") or a string to be written before the \\begin{document} statement.]) + (postdocument ,[The boolean ,(code "#f") or a string to be written after the \\begin{document} statement.]) + (maketitle ,[The boolean ,(code "#f") or a string to be written after the \\begin{document} statement for emitting the document title.]) + (color [Enable/disable colors.]) + (%font-size #f) + ;; source fontification + (source-color ,[A boolean enabling/disabling color of source code (see ,(markup-ref "source") markup).]) + (source-comment-color "The source comment color.") + (source-error-color "The source error color.") + (source-define-color "The source define color.") + (source-module-color "The source module color.") + (source-markup-color "The source markup color.") + (source-thread-color "The source thread color.") + (source-string-color "The source string color.") + (source-bracket-color "The source bracket color.") + (source-type-color "The source type color.") + (color-usepackage "The LaTeX package for coloring.") + (hyperref "Enables/disables hypererrf.") + (hyperref-usepackage "The LaTeX package for hyperref.") + (image-format "The image formats for this engine.") + (index-page-ref "Indexes use page references.")) + :source "skr/latex.skr")) + + (subsection :title "LaTeX documentclass" + + (p [The default setting of the Skribe LaTeX engine is to produce +a document using the ,(code "article") document class. In order to +generate a document using ,(code "chapter") this must be changed because +this LaTeX style does not define any ,(code "\\chapter") function. For +instance, one may use the LaTeX ,(code "book") document class. Changing +this setting can be done with expressions such as: +,(prgm :language skribe [ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\\\documentclass{book}"))])]))) diff --git a/skribe/doc/user/lib.skb b/skribe/doc/user/lib.skb new file mode 100644 index 0000000..499ca61 --- /dev/null +++ b/skribe/doc/user/lib.skb @@ -0,0 +1,156 @@ +;;;; +;;;; Standard Library +;;;; +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Nov-2003 07:20 (eg) +;;;; Last file update: 21-Nov-2003 10:17 (eg) + + +(chapter :title "Standard Library" + + (p [This section describes the Skribe standard library]) + +;;; +(section :title "File functions" + + (p [The function ,(code "include") is particularily useful to spread a +long document amongst several files.]) + + (doc-markup 'include + '((file [The file containing the nodes to be included. +These nodes are included in the document in place of the ,(code "include") +call.])) + :common-args '() + :see-also '(skribe-load skribe-path skribe-path-set!) + :idx *function-index*) + + (p [The given file is searched in the current +,(ref :mark "skribe-path" :text "Skribe path")]) + + (p [The function ,(code "skribe-load") is generally used to load in the +Skribe memory, a package or an extension. In general the prelude of a +Skribe document (the expressions placed before the ,(markup-ref "document") +call) contains several ,(code "skribe-load"). The file is search +in the ,(ref :mark "skribe-path" :text "Skribe path").]) + + (doc-markup 'skribe-load + `((file [The file containing the expressions to be loaded.]) + (:engine [The engine used to evaluate the expressions.]) + (:path ,[The optional path where to find the file. The default + path is ,(markup-ref "skribe-path").]) + (#!rest opt... [Additional user options.])) + :source "../src/bigloo/eval.scm" + :common-args '() + :see-also '(skribe-load-options skribe-path skribe-path-set!) + :idx *function-index*) + + (p [Returns the user of options of the last call to +,(markup-ref "skribe-load")]) + (doc-markup 'skribe-load-options + '() + :source "../src/bigloo/eval.scm" + :common-args '() + :see-also '(skribe-load) + :idx *function-index*) + + (p [Skribe provides functions for dealing with paths. These functions +are related to the path that can be specified on the command line, +when the Skribe compiler is invoked (see Chapter +,(ref :chapter "Skribe compiler").)]) + + (doc-markup 'skribe-path + '() + :source "../src/bigloo/eval.scm" + :common-args '() + :others '(skribe-image-path skribe-bib-path skribe-source-path) + :see-also '(include skribe-load image source bibliography skribe-path-set! skribe-image-path-set! skribe-bib-path-set! skribe-source-path-set!) + :idx *function-index*) + + (p [The function ,(code "skribe-path-set!") sets a new path.]) + (doc-markup 'skribe-path-set! + '((path [A list of strings which is the new Skribe search path.])) + :source "../src/bigloo/eval.scm" + :common-args '() + :others '(skribe-image-path-set! skribe-bib-path-set! skribe-source-path-set!) + :see-also '(skribe-path skribe-image-path skribe-bib-path skribe-source-path) + :idx *function-index*)) + +;;; Misc +(section :title "Misc. Functions" + + (p [The function ,(code "skribe-release") returns the Skribe version +as a string]) + (doc-markup 'skribe-release + '() + :common-args '() + :source #f + :def '(define (skribe-release) ...) + :idx *function-index*) + + (p [For instance, the following piece of code:]) + (prgm :language skribe + "[This manual documents the ,(bold (skribe-release)) Skribe release]") + (p [produces the following output]) + (disp [This manual documents the ,(bold (skribe-release)) Skribe release])) + + (p [The function ,(code "skribe-configure") accesses the whole +Skribe configuration. It can be used to ,(emph "get") or ,(emph "check") +the configuration.]) + + (doc-markup 'skribe-configure + '((opt... [Optional arguments.])) + :common-args '() + :source #f + :def '(define (skribe-configure . opt...) ...) + :idx *function-index*) + + (p [The function ,(code "skribe-configure") can be used in three distinct +ways depending on the number of provided arguments:]) + + (enumerate + (item [If no argument is provided, ,(code "skribe-configure") returns +a fresh list of Skribe configuration.]) + (item [If one keyword argument is provided, ,(code "skribe-configure") +returns the value associated with this keyword in the configuration list. +If this value does not exist, it returns the symbol ,(code "void").]) + (item [(code "skribe-configure") is invoked with a list composed +of ,(emph "keyword") ,(emph "value"). The actual configuration is checked +against the provided values. Values are compared with ,(code "equal") except +if the value to check has to be compared with a procedure. In that particular +case the value of the check is the value produces by ,(emph "applying") the +function to the actual value. The result of ,(code "skribe-configure") is a +boolean.])) + + (p [Here are some examples.]) + (prgm :language skribe [ +;; fetch the whole configuration list +(skribe-configure) + +;; fetch the release number +(skribe-configure :release) + +;; test if the release number is 1.0b +(skribe-configure :release "1.0b") + +;; test if the release number is greater or equal than "1.0b" +(skribe-configure :release (lambda (v) (string>=? v "1.0b"))) + +;; test if the release number is greater or equal than "1.0b" +;; and the implementation is bigloo +(skribe-configure :release (lambda (v) (string>=? v "1.0b")) :scheme "bigloo")]) + + (p [The function ,(code "skribe-enforce-configure") checks for the Skribe +configuration. In case of mismatch, it raises an error. The syntax of the +arguments if the same as that of ,(code "skribe-configure") when invoked +with several arguments.]) + + (doc-markup 'skribe-enforce-configure + '((opt... [Optional arguments.])) + :common-args '() + :source #f + :def '(define (skribe-enforce-configure . opt...) ...) + :idx *function-index*)) + + + diff --git a/skribe/doc/user/line.skb b/skribe/doc/user/line.skb new file mode 100644 index 0000000..85f84dd --- /dev/null +++ b/skribe/doc/user/line.skb @@ -0,0 +1,39 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/line.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 4 10:08:08 2003 */ +;* Last change : Thu Sep 4 13:29:49 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Line breaks */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Line breaks */ +;*---------------------------------------------------------------------*/ +(section :title "Line breaks" :file #t + +(p [Line breaks and horizontal rules enable text cutting.]) + +;*--- linebreak -------------------------------------------------------*/ +(subsection :title "Linebreak" + +(p [The Skribe function ,(code "linebreak") is unportable. Even if +most engines handle it for their code production, using ,(code "linebreak") +generally produces expected result. For instance, using ,(code "linebreak") +with an engine producing LaTeX code is bound to fail. In consequence, +as much as possible, one should prefer other ways for splitting a text]) + +(doc-markup 'linebreak + '((#!rest num "The number of line breaks.")) + :see-also '(paragraph table))) + +;*--- Horizontal rule -------------------------------------------------*/ +(subsection :title "Horizontal rule" + +(doc-markup 'hrule + `((:width ,[The ,(ref :mark "width") of the horizontal rule.]) + (:height [The thickness of the rule. A positive integer + value stands for a number of pixels.]))))) + diff --git a/skribe/doc/user/links.skb b/skribe/doc/user/links.skb new file mode 100644 index 0000000..b454f28 --- /dev/null +++ b/skribe/doc/user/links.skb @@ -0,0 +1,152 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/links.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu Sep 11 06:10:44 2003 */ +;* Last change : Thu Feb 26 20:56:48 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe links */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Links and references */ +;*---------------------------------------------------------------------*/ +(chapter :title "References and Hyperlinks" [ +Skribe supports traditional ,(emph "references") (that is, references to some +part of documents) and ,(emph "hyperlinks") (that is visual marks enriching +texts that enable interactive browsing). Hyperlinks may point to + +,(itemize (item [Inner parts of a document, such as a section or a figure.]) + (item [Other documents, such as Web documents.]) + (item [Other Skribe documents.]) + (item [Specific part of other Skribe documents, such as a chapter + of another Skribe document.])) + +,(paragraph [In order to use hyperlinks, Skribe documents must:]) + +,(itemize (item [,(emph "Refer to") marks. This is the role of the ,(tt "ref") + Skribe function.]) + (item [,(emph "Set") marks. This is the role of the ,(tt "mark") + function. However, most Skribe functions that introduce text + structures (e.g., chapters, sections, figures, ...) + automatically introduce marks as well. So, it is + useless to ,(emph "explicitly") introduce a mark at the + beginning of these constructions in order to refer to them + with an hyperlink.]))] + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(section :title "Mark" + +(p [The ,(code "mark") function sets a mark in the produced document +that can be referenced to with the ,(markup-ref "ref") +function. Unless a ,(param :text) option is specified, no visible text +in associated with the mark in the generated document.]) + +(doc-markup 'mark + '((:text "A text associated with the markup.") + (#!rest mark [A string that will be used in a + ,(markup-ref "ref") function call to point to that mark.]))) + +(p [The Skribe functions + ,(map (lambda (x y) + (list (markup-ref x) y)) + '("chapter" "section" "subsection" "subsubsection") + '(", " ", " ", " " ")) +Skribe automatically set a mark whose value is the title of the section. +The Skribe function ,(markup-ref "figure") +automatically sets a mark whose value is the legend of the figure.])) + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(section :title "Reference" + +(p [Skribe proposes only one single function for all the references. +This same ,(code "ref") function is used for introducing references to +section, to bibliographic entries, to source code line number, etc.]) + +(doc-markup 'ref + `((:text [The text that is the visual part the links for + engines that support hyperlinks.]) + (:url [An URL, that is, a location of another file, + such as an HTML file.]) + (:mark [A string that is the name of a mark. That mark has + been introduced by a ,(markup-ref "mark") markup.]) + (:handle [A Skribe node ,(markup-ref "handle").]) + (:ident [A reference to a node who has been specified + an ,(param :ident) value.]) + (:figure [The name of a ,(markup-ref "figure").]) + (:chapter [The name of a ,(markup-ref "chapter").]) + (:section [The name of a ,(markup-ref "section").]) + (:subsection [The name of a ,(markup-ref "subsection").]) + (:subsubsection [The name of a ,(markup-ref "subsubsection").]) + (:page [A boolean enabling/disabling page reference.]) + (:bib ,[A name or a list of names of + ,(ref :chapter "Bibliographies" :text "bibliographic") entry.]) + (:bib-table ,[The + ,(ref :chapter "Bibliographies" :text "bibliography") where + searching the entry.]) + (:line [A reference to a ,(ref :mark "prog" :text "program") + line number.]) + (:skribe [The name of a + ,(ref :section "Skribe Url Index" :text "Skribe Url Index") + ,(var "file") that contains the reference. The + reference can be a ,(tt "chapter"), ,(tt "section"), + ,(tt "subsection"), ,(tt "subsubsection") or even + a ,(tt "mark") located in the Skribe document + described by the ,(var "file") ,(sc "sui").])) + :force-args '(:url :bib :line :skribe) + :see-also '(index)) + + +(example-produce + (example :legend "Some references" (prgm :file "src/links1.skb")) + (disp (include "src/links1.skb")))) + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(section :title "Electronic mails" + +(p [The ,(code "mailto") function is mainly useful for electronic +output formats that are able to run a mailing agent. The function ,(tt "mailto") +introduces mail annotation in a Skribe document.]) + +(doc-markup 'mailto + '((:text [The text that is the visual part the links.]) + (#!rest email [The electronic address.]))) + +(example-produce + (example :legend "Mail address reference" (prgm :file "src/links2.skb")) + (disp (include "src/links2.skb")))) + +;*---------------------------------------------------------------------*/ +;* Skribe Url Index ... */ +;*---------------------------------------------------------------------*/ +(section :title "Skribe Url Index" [ +,(p [A ,(emph "Skribe Url Index") (henceforth ,(sc "Sui")) describes the +marks that are available in a Skribe document. It is to be used to +make Skribe marks available to other Skribe documents. The syntax +of a ,(sc "Sui") file is:]) + +,(disp :verb #t :bg *prgm-skribe-color* [ +<sui> --> (skribe-url-index <title> + :file <file-name> + (marks <sui-ref>*) + (chapters <sui-ref>*) + (section <sui-ref>*) + (subsection <sui-ref>*) + (subsubsection <sui-ref>*)) +<sui-ref> --> (<string> :file <file-name> :mark <string>)]) + +,(p [,(sc "Sui") files can be automatically produced by the Skribe compiler. +For instance, in order to produce the ,(sc "Sui") file of this user +manual, one should write:]) + +,(disp :verb #t [ +$ skribe user.skb -o user.sui])])) + +;; LocalWords: Hyperlinks HTML URL url diff --git a/skribe/doc/user/markup.skb b/skribe/doc/user/markup.skb new file mode 100644 index 0000000..272bfbe --- /dev/null +++ b/skribe/doc/user/markup.skb @@ -0,0 +1,83 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/markup.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 06:09:18 2003 */ +;* Last change : Wed Feb 4 06:11:45 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe standard markups */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* API */ +;*---------------------------------------------------------------------*/ +(chapter :title "Standard Markups" [ + +This chapter describes the forms composing Skribe texts. In XML/HTML +these forms are called ,(emph "markups"). In LaTeX they are called +,(emph "macros"). In Skribe these forms are called ,(emph +"functions"). In this manual, we will say that we ,(emph "call a +function") when a function is used in a form. The values used in a +function call are named the ,(emph "actual parameters") of the +function or ,(emph "parameters") in short. When calling a function +with parameters we say that we are ,(emph "passing") arguments to the +function. + +,(p [ In this documentation function names are typesetted in bold +face. We call a ,(emph "keyword argument"), an argument whose +identifier starts with the ,(tt ":") character. Arguments whose +identifier does not start with this character are called ,(emph "plain +arguments") or ,(emph "arguments") in short. An ,(emph "optional +argument") is represented by a list, starting with the character ,(q +(char 91)) and ending with the character ,(q (char 93)), whose first +element is a keyword argument and the optional second (,(code "#f") +when not specified) element is the default value used if the optional +argument value is not provided on a function call. Arguments that are +not optional are said ,(emph "mandatory"). If a plain argument is +preceeded with a ,(tt ".") character, this argument may be used to +accumulate several values. There are two ways to pass actual arguments +to a function.]) + +,(itemize (item [for keyword arguments: the value of the parameter +must be preceeded by the name of the argument.]) + (item [for plain arguments: a value is provided.])) + +Example: Let us consider the function ,(tt "section") defined as follows: +,(prgm "(section :title [:number #t] [:toc #t] . body)") + +,(p [ +The argument ,(param :title) is a mandatory keyword argument. +The keyword arguments ,(param :number) and ,(param :toc) are +optional. The plain argument ,(param 'body) is preceeded with a +,(tt ".") character so it may receive several values. All the following +calls are legal ,(tt "section") calls:]) + +,(prgm (source :file "src/api1.skb"))] + +;*---------------------------------------------------------------------*/ +;* Markup index ... */ +;*---------------------------------------------------------------------*/ +(section :title "Markup index" :ident "markups-index" :file #f :number #f :toc #t + (the-index :class 'markup-index + :column (if (engine-format? "latex") 2 4) + :split #f + *markup-index*)) + +;*---------------------------------------------------------------------*/ +;* Markups */ +;*---------------------------------------------------------------------*/ +(include "document.skb") +(include "sectioning.skb") +(include "toc.skb") +(include "ornament.skb") +(include "line.skb") +(include "font.skb") +(include "justify.skb") +(include "enumeration.skb") +(include "colframe.skb") +(include "figure.skb") +(include "image.skb") +(include "table.skb") +(include "footnote.skb") +(include "char.skb")) diff --git a/skribe/doc/user/ornament.skb b/skribe/doc/user/ornament.skb new file mode 100644 index 0000000..e65b9d1 --- /dev/null +++ b/skribe/doc/user/ornament.skb @@ -0,0 +1,25 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/ornament.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 14:00:52 2003 */ +;* Last change : Fri Sep 12 15:31:19 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The skribe ornaments */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Ornaments */ +;*---------------------------------------------------------------------*/ +(section :title "Ornaments" :file #t + +(p [Skribe supports the standard text ornaments.]) + +(doc-markup 'bold + '((#!rest node... "The nodes of the ornament.")) + :others '(code emph it kbd roman sc sf sub sup tt underline var)) + +(example-produce + (example :legend "The ornament markups" (prgm :file "src/api8.skb")) + (disp (include "src/api8.skb")))) diff --git a/skribe/doc/user/package.skb b/skribe/doc/user/package.skb new file mode 100644 index 0000000..ad989d0 --- /dev/null +++ b/skribe/doc/user/package.skb @@ -0,0 +1,139 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/package.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Feb 21 08:26:44 2004 */ +;* Last change : Fri Jun 3 16:51:30 2005 (serrano) */ +;* Copyright : 2004-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Packages */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Standard packages */ +;*---------------------------------------------------------------------*/ +(chapter :title "Standard Packages" + + (p [ +This chapter describes the standard Skribe packages. Additional +packages can be found from the +,(ref :url (skribe-url) :text "Skribe web page"). +This chapter only describes the packages that are contained in the standard +Skribe distribution.]) + + (p [ +In order to use the facilities described in the following sections, the +Skribe source file must contains expressions such as:]) + +(prgm [(skribe-load ,(it "package.skr") ...)]) + +[where ,(it (tt "package.skr")) is the described package.] + +;*---------------------------------------------------------------------*/ +;* jfp */ +;*---------------------------------------------------------------------*/ +(section :title "Articles" + + (subsection :title (tt "acmproc.skr") :ident "acmproc" + (index :index *package-index* "acmproc.skr" :note "package") + (p [ +This package enables producing LaTeX documents conforming to the +,(emph "ACM proceeding") (ACMPROC) style. It introduces the +markup ,(code "abstract"):]) + (doc-markup 'abstract + `((:class "The node class.") + (:postscript [The URL of the PostScript version of the paper.])) + :common-args '() + :idx-note "acmproc" + :idx-suffix " (acmproc)" + :force-engines *api-engines* + :source "../skr/acmproc.skr")) + + (subsection :title (tt "jfp.skr") :ident "jfp" + (index :index *package-index* "jfp.skr" :note "package") + (p [ +This package enables producing LaTeX documents conforming to the +,(emph "Journal of Functional Programming") (JFP) style. It introduces the +markup ,(code "abstract"):]) + (doc-markup 'abstract + `((:postscript [The URL of the PostScript version of the paper.])) + :common-args '() + :idx-note "jfp" + :idx-suffix " (jfp)" + :force-engines *api-engines* + :source "../skr/jfp.skr")) + + (subsection :title (tt "lncs.skr") :ident "lncs" + (index :index *package-index* "lncs.skr" :note "package") + (p [ +This package enables producing LaTeX documents conforming to the +,(emph "Lecture Notes on Computer Science") (LNCS) style. It introduces the +markup ,(code "abstract"):]) + (doc-markup 'abstract + `((:postscript [The URL of the PostScript version of the paper.])) + :common-args '() + :idx-note "lncs" + :idx-suffix " (lncs)" + :force-engines *api-engines* + :source "../skr/lncs.skr"))) + +;*---------------------------------------------------------------------*/ +;* french */ +;*---------------------------------------------------------------------*/ +(section :title "Languages" + (subsection :title (tt "french.skr") + (index :index *package-index* "french.skr" :note "package") + (p [ +Enables French typesetting and typographical rules.]))) + +;*---------------------------------------------------------------------*/ +;* letter */ +;*---------------------------------------------------------------------*/ +(section :title (tt "letter.skr") + (index :index *package-index* "letter.skr" :note "package") + (p [ +This package is to be used to authoring simple letters. It redefines the +,(markup-ref "document") markup.]) + + (doc-markup 'document + `((:where [The location where the letter is posted.]) + (:date [The date of the letter.]) + (:author [The author of the letter.])) + :idx-note "letter" + :idx-suffix " (letter)" + :force-engines *api-engines* + :source "../skr/letter.skr")) + +;*---------------------------------------------------------------------*/ +;* Web */ +;*---------------------------------------------------------------------*/ +(section :title "Web" + + (subsection :title (tt "web-article.skr") + (index :index *package-index* "web-article.skr" :note "package") + (p [ +A convenient mode for rendering articles (i.e., documents made of +sections) in HTML. The Slide package supports two ,(markup-ref "skribe-load") +user options: +,(param :style) and ,(param :css). The ,(param :style) option can either +be ,(code "'traditional") which forces traditional HTML code +emission or ,(code "'css") which forces HTML code emission using CSS +annotations. The CSS style used is specified in the (code "css") +HTML engine ,(ref :subsection "The HTML customization" :text "custom"). +The ,(param :css) is a shorthand for ,(param :style). For instance:]) +(prgm [(skribe-load "web-article.skr" :css "style.css")]) +[is equivalent to:] +(prgm [(skribe-load "web-article.skr" :style 'css) +(engine-custom-set! (find-engine 'html) :css "style.css")])) + + (subsection :title (tt "web-book.skr") + (index :index *package-index* "web-book.skr" :note "package") + (p [ +A convenient mode for rendering books (i.e., documents made of +chapters and sections) in HTML.])))) + +;*---------------------------------------------------------------------*/ +;* Emacs indentation */ +;*---------------------------------------------------------------------*/ +;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@* + diff --git a/skribe/doc/user/prgm.skb b/skribe/doc/user/prgm.skb new file mode 100644 index 0000000..c894614 --- /dev/null +++ b/skribe/doc/user/prgm.skb @@ -0,0 +1,121 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/prgm.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Nov 30 09:21:11 2001 */ +;* Last change : Wed Sep 22 02:11:49 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Computer programs */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* fib ... */ +;*---------------------------------------------------------------------*/ +(define (fib x) ;!fib + (if (< x 2) + 1 + (+ (fib (- x 1)) (fib (- x 2))))) + +;*---------------------------------------------------------------------*/ +;* Computer programs */ +;*---------------------------------------------------------------------*/ +(chapter :title "Computer programs" + +(p [It is common that some parts of a Skribe text represent other +texts. For instance, for a document describing a computer programming +language, it is frequent to include excerpt of programs. These +embedded texts are frequently displayed in a specific font and with no +justification but with a precise ,(emph "indentation"). This indentation is +important because it helps in understanding the text,(begin ";") +it is thus desirable to preserve it in the Skribe text. The +,(markup-ref "pre") text layout already enables such a +text formating. This chapter presents two new Skribe functions: +,(markup-ref "prog") and ,(markup-ref "source") that is specially +designed to represent computer programs in Skribe text.]) + +;*---------------------------------------------------------------------*/ +;* Programs ... @label prog@ */ +;*---------------------------------------------------------------------*/ +(section :title "Program" + +(p [A ,(code "prog") function call preserves the indentation of the +program. It may automatically introduce line numbers.]) + +(doc-markup 'prog + `((:line ,[Enables/disables automatic line numbering. An integer + value enables the line number and specifies the number of + the first line of the program. A value of ,(code "#f") disables + the line numbering.]) + (:linedigit ,[The number of digit for representing line + numbers.]) + (:mark ,[A string or the boolean ,(code "#f"). If this option + is a string, that string is the prefix + of line marks. These marks can be used in the + ,(markup-ref "ref") reference. A mark + identifier is defined by the regular expression: + ,(code [,(char "[")_a-zA-Z,(char "]"),(char "[")_a-zA-Z0-9,(char "]")*]). The prefix and the mark are removed from the output program.])) + :force-engines *api-engines* + :see-also '(source pre ref)) + +(example-produce + (example :legend "A program" (prgm :file "src/prgm1.skb")) + (disp (include "src/prgm1.skb")))) + +;*---------------------------------------------------------------------*/ +;* Source code ... @label source@ */ +;*---------------------------------------------------------------------*/ +(section :title "Source code" + +(p [The ,(code "source") function extracts part of the source code and +enables ,(emph "fontification"). That is, some words of the program +can be rendered using different colors or faces.]) + +;!source-start +(doc-markup 'source + `((:language ,[The ,(markup-ref "language") of the source code.]) + (:file ,[The file containing the actual source code. The file + is searched in the ,(markup-ref "skribe-source-path") path.]) + (:start [A start line number or a start marker.]) + (:stop [A stop line number or a stop marker.]) + (:definition [The identifier of the definition to extract.]) + (:tab [The tabulation width.])) + :common-args '() + :force-engines *api-engines* + :see-also '(prog language ref skribe-source-path)) +;!source-stop + +(example-produce + (example :legend "The source markup" (prgm :file "src/prgm2.skb")) + (disp (include "src/prgm2.skb")))) + +;*---------------------------------------------------------------------*/ +;* Language ... @label language@ */ +;*---------------------------------------------------------------------*/ +(section :title "Language" +(index "source" :note "fontification") +(index "fontification") + +(p [The ,(code "language") function builds a language that can be used +in ,(markup-ref "source") function call.]) + +(doc-markup 'language + `((:name [A string which denotes the name of the language.]) + (:fontifier [A function of one argument (a string), that + colorizes a line source code.]) + (:extractor [A function of three arguments: an input port, + an identifier, a tabulation size. This function ,(emph "scans") + in the input port the definition is looks for.])) + :common-args '() + :force-engines *api-engines* + :see-also '(prog source ref)) + +; **** FIXME: +(cond-expand + (bigloo + (example-produce + (example :legend "An ad-hoc fontification" + (prgm :file "src/prgm3.skb")) + (disp (include "src/prgm3.skb")))) + (else + '())))) diff --git a/skribe/doc/user/sectioning.skb b/skribe/doc/user/sectioning.skb new file mode 100644 index 0000000..48bbc45 --- /dev/null +++ b/skribe/doc/user/sectioning.skb @@ -0,0 +1,117 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/sectioning.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 12:27:03 2003 */ +;* Last change : Tue Apr 6 06:45:28 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Sectioning markups */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* dummy-section-output ... */ +;*---------------------------------------------------------------------*/ +(define dummy-section-output + (lambda (n e) + (let* ((t (markup-option n :title)) + (b (markup-body n))) + (skribe-eval (center (bold t)) e) + (output b e)))) + +;*---------------------------------------------------------------------*/ +;* Sectioning */ +;*---------------------------------------------------------------------*/ +(section :title "Sectioning" :file #t + +;*--- chapter ---------------------------------------------------------*/ +(subsection :title "Chapter" + +(p [The function ,(code "chapter") creates new chapters.]) + +(doc-markup 'chapter + `((:title [The title of the chapter.]) + (:html-title "The title of window of the HTML browser.") + (:number [This argument controls the chapter number. +A value of ,(tt "#t") means that the Skribe compiler computes the chapter +number. A value of ,(tt "#f") means that the chapter has no number.]) + (:toc ,[This argument controls if the chapter must +be referenced in the ,(ref :mark "toc" :text "table of contents").]) + (:file [The argument must be a boolean. A value of +,(tt "#t") tells the Skribe compiler to compile that chapter in a separate +file. A value of ,(tt "#f") tells the Skribe compiler to embed the chapter +in the main target file.]) + (#!rest node... [The nodes of the chapter.])) + :see-also '(document section toc)) + +(example-produce + (example :legend "The chapter markup" (prgm :file "src/api4.skb")) + (disp + (processor :combinator + (lambda (e1 e2) + (let ((e (copy-engine 'document-engine e2))) + (markup-writer 'chapter e + :options '(:title :file :number :toc) + :action dummy-section-output) + e)) + (include "src/api4.skb"))))) + +;*--- section ---------------------------------------------------------*/ +(subsection :title "Sections" + +(p [These functions create new sections.]) + +(doc-markup 'section + `((:title [The title of the chapter.]) + (:number [This argument controls the chapter number. +A value of ,(tt "#t") means that the Skribe compiler computes the chapter +number. A value of ,(tt "#f") means that the chapter has no number.]) + (:toc ,[This argument controls if the chapter must +be referenced in the ,(ref :mark "toc" :text "table of contents").]) + (:file [The argument must be a boolean. A value of +,(tt "#t") tells the Skribe compiler to compile that section in a separate +file. A value of ,(tt "#f") tells the Skribe compiler to embed the chapter +in the main target file.]) + (#!rest node... [The nodes of the section.])) + :others '(subsection subsubsection) + :see-also '(document chapter paragraph toc)) + +(example-produce + (example :legend "The chapter markup" (prgm :file "src/api5.skb")) + (disp + (processor :combinator + (lambda (e1 e2) + (let ((e (copy-engine 'document-engine e2))) + (markup-writer 'chapter e + :options '(:title :file :number :toc) + :action dummy-section-output) + e)) + (include "src/api5.skb"))))) + +;*--- paragraph -------------------------------------------------------*/ +(subsection :title "Paragraph" + +(p [The function ,(code "paragraph") (also aliased ,(code "p")) creates +paragraphs.]) + +(doc-markup 'paragraph + '((#!rest node... "The nodes of the paragraph.")) + :see-also '(document chapter section p)) + +(p [The function ,(code "p") is an alias for ,(code "paragraph").]) +(doc-markup 'p + '((#!rest node... "The nodes of the paragraph.")) + :source "../skr/skribe.skr" + :see-also '(document chapter section paragraph))) + +;*--- blockquote -----------------------------------------------------*/ +(subsection :title "Blockquote" + +(p [The function ,(code "blockquote") can be used for text +quotations. A text quotation is generally renderd as an indented block +of text.]) +(doc-markup 'blockquote + '((#!rest node... "The nodes of the quoted text."))))) + + + diff --git a/skribe/doc/user/skribe-config.skb b/skribe/doc/user/skribe-config.skb new file mode 100644 index 0000000..956af63 --- /dev/null +++ b/skribe/doc/user/skribe-config.skb @@ -0,0 +1,44 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/skribe-config.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 2 21:12:24 2004 */ +;* Last change : Thu Sep 23 17:11:53 2004 (eg) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The skribe-config tool */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The skribe-config tool */ +;*---------------------------------------------------------------------*/ +(chapter :title "Getting Skribe configuration information" +(index "skribe-config") + +(p [ +In this chapter we present ,(code "skribe-config") that gives +information about the current Skribe configuration.]) + +;; Synopsis +(section :title "SYNOPSIS" :number #f +(compiler-command "skribe-config" "options")) + +;; Description +(section :title "DESCRIPTION" :number #f [ +The ,(code "skribe-config") gives information about the Skribe configuration. +This information can be the directories used to install Skribe, the Scheme +implementation used for compiling Skribe, etc.]) + +;; Options +(section :title "OPTIONS" :number #f [ +,(pre (let* ((proc (run-process "../etc/skribe-config" "--help" error: pipe:)) + (port (process-error-port proc))) + (let loop ((line (read-line port)) + (lines '())) + (if (eof-object? line) + (reverse! lines) + (begin + (loop (read-line port) (cons* line "\n" lines)))))))])) + + + diff --git a/skribe/doc/user/skribec.skb b/skribe/doc/user/skribec.skb new file mode 100644 index 0000000..0f00632 --- /dev/null +++ b/skribe/doc/user/skribec.skb @@ -0,0 +1,56 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/skribec.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Nov 30 13:43:50 2001 */ +;* Last change : Thu Feb 26 20:58:26 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe compiler */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The Skribe compiler */ +;*---------------------------------------------------------------------*/ +(chapter :title "Skribe compiler" +(index "skribe" :note "manual page") +(p [ +In this chapter we present the Skribe compiler that compiles Skribe +source text into various output formats.]) + +;; Synopsis +(section :title "SYNOPSIS" :number #f +(linebreak 1) +(compiler-command "skribe" "options" "input")) + +;; Description +(section :title "DESCRIPTION" :number #f +(p [ +This manual page is not meant to be exhaustive. The complete documentation +for the programming language ,(bold "Skribe") can be found at the following +,(ref :url (skribe-url) :text "URL"). This manual page only documents +the ,(tt "skribe") +compiler that compiles ,(bold "Skribe") programs into ,(it "HTML"), +,(it "TeX"), ,(it "Info") or ,(it "Nroff") formats.])) + +;; Suffixes +(section :title "SUFFIXES" :number #f [ +The ,(tt "skribe") compiler uses file suffixes in order to select amongst +its possible targets which one to choose. These suffixes are: + +,(description (item :key (it ".skb") [a ,(bold "Skribe") source file.]) + (item :key (it ".html") [an ,(it "HTML") target file.]) + (item :key (it ".tex") [a ,(it "TeX") target file.]) + (item :key (it ".sui") [a ,(it "Skribe url index") file.]))]) + +;; Options +(section :title "OPTIONS" :number #f [ +,(mark "skribe compiler option") +,(compiler-options *skribe-bin*)]) + +;; Environment variables +(section :title "ENVIRONMENT VARIABLES" :number #f [ +Some shell variables control the Skribe search path: +,(description (item :key (it "SKRIBEPATH") + "Search path for source and style files."))])) + diff --git a/skribe/doc/user/skribeinfo.skb b/skribe/doc/user/skribeinfo.skb new file mode 100644 index 0000000..502cc73 --- /dev/null +++ b/skribe/doc/user/skribeinfo.skb @@ -0,0 +1,50 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/skribeinfo.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Nov 30 13:43:50 2001 */ +;* Last change : Mon Dec 15 13:22:08 2003 (serrano) */ +;* Copyright : 2001-03 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribeinfo compiler */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The Skribeinfo compiler */ +;*---------------------------------------------------------------------*/ +(chapter :title "Compiling Texi documents" +(index "skribeinfo" :note "compiler") +(index "texinfo") + +(p [ +In this chapter we present the Skribeinfo compiler that compiles Texinfo +(texi) source files into Skribe source file.]) + +;; Synopsis +(section :title "SYNOPSIS" :number #f +(compiler-command "skribeinfo" "options" "input")) + +;; Description +(section :title "DESCRIPTION" :number #f [ +This manual page is not meant to be exhaustive. The complete documentation +for the programming language ,(bold "Skribe") can be found at the +following ,(ref :url (skribe-url) :text "url"). This manual page only +document the ,(tt "skribeinfo") +compiler that compiles ,(bold "Texinfo") source files into ,(it "Skribe"), +source files. These Skribe files can be compiled by the ,(bold "skribe") +compiler in order to produce ,(it "HTML"), ,(it "TeX"), ,(it "Info") +or ,(it "Nroff") target files.]) + +;; Suffixes +(section :title "SUFFIXES" :number #f [ +The ,(tt "skribe") compiler uses file suffixes in order to select amongst +its possible targets which to choose. These suffixes are: + +,(description (item :key (it ".texi") [a ,(bold "Texinfo") source file.]) + (item :key (it ".skb") [a ,(bold "Skribe") source file.]) + (item :key (it ".sui") [a ,(it "Skribe url index") file.]))]) + +;; Options +(section :title "OPTIONS" :number #f [ +,(compiler-options *skribeinfo-bin*)])) + diff --git a/skribe/doc/user/slide.skb b/skribe/doc/user/slide.skb new file mode 100644 index 0000000..c1111ee --- /dev/null +++ b/skribe/doc/user/slide.skb @@ -0,0 +1,114 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/slide.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 9 06:37:47 2004 */ +;* Last change : Thu Feb 26 21:00:04 2004 (eg) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Slides */ +;*=====================================================================*/ +(skribe-load "slide.skr") + +;*---------------------------------------------------------------------*/ +;* Computer programs */ +;*---------------------------------------------------------------------*/ +(chapter :title "Slide Package" + + (p [ +This chapter describes the facilities Skribe offers authoring slides. +In order to access the functionalities described in this chapter, it +is require to introduce a ,(code [(skribe-load "slides.skr")]) expression +at the beginning of the document. The Slide package supports two +,(markup-ref "skribe-load") user options: ,(param :advi) and ,(param :prosper). +The first one tells Skribe to generate slides for the Advi presenter. The +second one tells Skribe to generate slides for the LaTeX prosper package.]) + +;*---------------------------------------------------------------------*/ +;* slide ... @label slide@ */ +;*---------------------------------------------------------------------*/ +(section :title "Slide" + + (p [A ,(code "slide") function call creates a slide.]) + + (doc-markup 'slide + `((:title [The title of the slide.]) + (:number [The number of the slide (a boolean or an integer).]) + (:toc [This argument controls if the slide must +be referenced in the ,(mark :mark "toc" "table of contents").]) + (:vspace [The boolean ,(code "#f") or an integer representing +the vertical space size between the title and the body of the slide.]) + (:vfill [A boolean that is used to control whether a LaTeX +,(code "\\vfill") is issued at the end of the slide.]) + (:transition [The boolean ,(code "#f") or a symbol in the +list ,(code "(split blinds box wipe dissolve glitter)").]) + (:bg [The background color of the slide.]) + (:image [The background image of the slide.])) + :source "../skr/slide.skr")) + +;*---------------------------------------------------------------------*/ +;* slide-pause */ +;*---------------------------------------------------------------------*/ +(section :title "Pause" + + (p [A ,(code "slide-pause") function call introduces a pause in the slide +projection.]) + + (doc-markup 'slide-pause + '() + :common-args '() + :source "../skr/slide.skr")) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(section :title "Slide Vertical Space" + + (p [The ,(code "slide-vspace") introduces a vertical space in the slide.]) + + (doc-markup 'slide-vspace + '((:unit [The unit of the space.]) + (#!rest val [The size of the vertical space.])) + :common-args '() + :source "../skr/slide.skr")) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(section :title "Slide Embed Applications" + + (p [Embed an application inside a slide.]) + + (doc-markup 'slide-embed + `((:command [The binary file for running the embedded +application.]) + (:geometry-opt [The name of the geometry option to be sent +to the embedded application.]) + (:geometry [The geometry value to be sent.]) + (:rgeometry [A relative geometry to be sent.]) + (:transient-opt [The name of the transient option to be sent +to the embedded application.]) + (:transient [The transient value to be sent.]) + (:alt [An alternative Skribe expression to be used if the +output format does not support embedded application.])) + :common-args '() + :source "../skr/slide.skr")) + +;*---------------------------------------------------------------------*/ +;* Example */ +;*---------------------------------------------------------------------*/ +(section :title "Example" + (p [Here is a complete example of Skribe slides:]) + + (if (and (engine-format? "html") + (not (equal? (engine-custom html-engine 'html-variant) "html4"))) + ;; Show the example and its result + (example-produce + (example :legend "Example of Skribe slides" + (prgm :file "src/slides.skb")) + (disp (include "src/slides.skb"))) + ;; Show only the example (i.e. don't produce a document in a document) + (example :legend "Example of Skribe slides" + (prgm :file "src/slides.skb"))))) + + diff --git a/skribe/doc/user/src/api1.skb b/skribe/doc/user/src/api1.skb new file mode 100644 index 0000000..80c4389 --- /dev/null +++ b/skribe/doc/user/src/api1.skb @@ -0,0 +1,5 @@ +(section :title "A title" "This is the body of the section") +(section :title "A title" "This" " is" " the body of the section") +(section :title "A title" :number 3 "This" " is" " the body of the section") +(section :title "A title" :toc #f :number 3 "This" " is" " the body of the section") +(section :title "A title" :number 3 :toc #f "This" " is" " the body of the section") diff --git a/skribe/doc/user/src/api10.skb b/skribe/doc/user/src/api10.skb new file mode 100644 index 0000000..207d8a7 --- /dev/null +++ b/skribe/doc/user/src/api10.skb @@ -0,0 +1,12 @@ +(center [A ,(linebreak) multilines ,(linebreak) text]) +(hrule) +(flush :side 'left [A ,(linebreak) multilines ,(linebreak) text]) +(hrule) +(flush :side 'right [A ,(linebreak) multilines ,(linebreak) text]) +(hrule) +(pre [A text layout that + + preserves + linebreaks and spaces ,(it "(into which it is still legal") +,(it "to use Skribe markups)"). +]) diff --git a/skribe/doc/user/src/api11.skb b/skribe/doc/user/src/api11.skb new file mode 100644 index 0000000..5014e30 --- /dev/null +++ b/skribe/doc/user/src/api11.skb @@ -0,0 +1,22 @@ +(itemize (item [A first item.]) + (item [A ,(bold "second") one: + ,(itemize (item "One.") + (item "Two.") + (item "Three."))]) + (item [Lists can be nested. For instance that item contains a + ,(tt "description"): + ,(description (item :key (bold "foo") + [is a usual Lisp dummy identifier.]) + (item :key (bold "bar") + [is another one.]) + (item :key (list (bold "foo") (bold "bar")) + [A description entry may contain more than + one keyword.]))]) + (item [The last ,(tt "itemize") entry contains an ,(tt "enumerate"): + ,(enumerate (item "One.") (item "Two.") (item "Three."))])) + +(itemize :symbol "-" + (item "One.") + (item "Two.") + (item "Three.") + (item "Four.")) diff --git a/skribe/doc/user/src/api12.skb b/skribe/doc/user/src/api12.skb new file mode 100644 index 0000000..b0c68da --- /dev/null +++ b/skribe/doc/user/src/api12.skb @@ -0,0 +1 @@ +(center (frame :width 10. :margin 10 (p [This is a frame.]))) diff --git a/skribe/doc/user/src/api13.skb b/skribe/doc/user/src/api13.skb new file mode 100644 index 0000000..a9acb04 --- /dev/null +++ b/skribe/doc/user/src/api13.skb @@ -0,0 +1,10 @@ +(center + (color :bg "#aaaaaa" + :margin 10 + :width 30. + (center + (color :bg "#eeeeee" :fg "blue" :width 100. :margin 10 [This is an +example of color box that uses a color for the +background ,(emph "and") the ,(color :fg "red" "foreground"). It also specifies +a width, that is, an horizontal space, the text should +span to.])))) diff --git a/skribe/doc/user/src/api14.skb b/skribe/doc/user/src/api14.skb new file mode 100644 index 0000000..a3ede40 --- /dev/null +++ b/skribe/doc/user/src/api14.skb @@ -0,0 +1,9 @@ +(center + (figure :legend "This is a unnumbered figure" + :ident "fig1" + :number #f + (frame [Skribe is a functional programming language.]))) + +(center + (figure :legend "The great Penguin" + (image :file "linux.gif"))) diff --git a/skribe/doc/user/src/api15.skb b/skribe/doc/user/src/api15.skb new file mode 100644 index 0000000..f8f4958 --- /dev/null +++ b/skribe/doc/user/src/api15.skb @@ -0,0 +1,25 @@ +(resolve (lambda (n e env) + (let* ((d (ast-document n)) + (ex (container-env-get d 'figure-env))) + (table (map (lambda (e) + (tr (td :align 'left + (markup-option e ':number) + " " + (ref :handle (handle e) + :text (markup-option e :legend)) + " (section " + (let ((c (ast-section e))) + (ref :handle (handle c) + :text (markup-option c :title))) + ")"))) + (sort ex + (lambda (e1 e2) + (let ((n1 (markup-option e1 :number)) + (n2 (markup-option e2 :number))) + (cond + ((not (number? n1)) + #t) + ((not (number? n2)) + #f) + (else + (< n1 n2))))))))))) diff --git a/skribe/doc/user/src/api16.skb b/skribe/doc/user/src/api16.skb new file mode 100644 index 0000000..a9d5705 --- /dev/null +++ b/skribe/doc/user/src/api16.skb @@ -0,0 +1,5 @@ +(image :file "linux.gif" "A first image") +(image :height 50 :file "linux.gif" "A smaller one") +(image :file "bsd.gif" "A second image") +(image :width 50 :file "bsd.gif") +(image :width 200 :height 40 :file "bsd.gif") diff --git a/skribe/doc/user/src/api17.skb b/skribe/doc/user/src/api17.skb new file mode 100644 index 0000000..42fa54f --- /dev/null +++ b/skribe/doc/user/src/api17.skb @@ -0,0 +1,9 @@ +(center + (table :border 1 :width 50. :frame 'hsides :cellstyle 'collapse + (tr :bg "#cccccc" (th :align 'center :colspan 3 "A table")) + (tr (th "Col 1") (th "Col 2") (th "Col 3")) + (tr (td :align 'center "10") (td "-20") (td "30")) + (tr (td :align 'right :rowspan 2 :valign 'center "12") (td "21")) + (tr (td :align 'center :colspan 2 "1234")) + (tr (td :align 'center :colspan 2 "1234") (td :align 'right "5")) + (tr (td :align 'center :colspan 1 "1") (td :colspan 2 "2345")))) diff --git a/skribe/doc/user/src/api18.skb b/skribe/doc/user/src/api18.skb new file mode 100644 index 0000000..2112dc4 --- /dev/null +++ b/skribe/doc/user/src/api18.skb @@ -0,0 +1,2 @@ +[Scheme,(footnote [To be pronounced ,(char "[")Skim,(char "]")]) +is a programming language,(footnote [And a great one!]).] diff --git a/skribe/doc/user/src/api19.skb b/skribe/doc/user/src/api19.skb new file mode 100644 index 0000000..cfc11f6 --- /dev/null +++ b/skribe/doc/user/src/api19.skb @@ -0,0 +1,3 @@ +(itemize (item [The character ,(code "#\\a"): ,(char #\a).]) + (item [The character ,(code "\"a\""): ,(char "a").]) + (item [The character ,(code "97"): ,(char 97).])) diff --git a/skribe/doc/user/src/api2.skb b/skribe/doc/user/src/api2.skb new file mode 100644 index 0000000..2c20965 --- /dev/null +++ b/skribe/doc/user/src/api2.skb @@ -0,0 +1,5 @@ +(document :title "This is a Scribe document" + :author (list (author :name "Foo" :email (mailto "foo@nowhere.org")) + (author :name "Bar" :email (mailto "bar@anywhere.org")) + (author :name "Gee" :email (mailto "gee@nowhere.org"))) + "A body...") diff --git a/skribe/doc/user/src/api20.skb b/skribe/doc/user/src/api20.skb new file mode 100644 index 0000000..686efcb --- /dev/null +++ b/skribe/doc/user/src/api20.skb @@ -0,0 +1,2 @@ +[A simple ,(! "string"). A more annoying one ,(! "<strong>string</strong>"). +A last one with arguments ,(! "<u>$1 $2</u>" (bold 1) (it 2)).] diff --git a/skribe/doc/user/src/api3.skb b/skribe/doc/user/src/api3.skb new file mode 100644 index 0000000..ed46eea --- /dev/null +++ b/skribe/doc/user/src/api3.skb @@ -0,0 +1,8 @@ +(author :name "Manuel Serrano" + :affiliation "Inria Sophia-Antipolis" + :url (ref :url "http://www.inria.fr/mimosa/Manuel.Serrano") + :email (mailto "Manuel.Serrano@inria.fr") + :address `("2004 route des Lucioles - BP 93" + "F-06902 Sophia Antipolis, Cedex" + "France") + :phone "phone: (+33) 4 92 38 76 41") diff --git a/skribe/doc/user/src/api4.skb b/skribe/doc/user/src/api4.skb new file mode 100644 index 0000000..cfe13f7 --- /dev/null +++ b/skribe/doc/user/src/api4.skb @@ -0,0 +1,2 @@ +(chapter :title "This is a simple chapter" :number #f :toc #f [ +Its body is just one sentence.]) diff --git a/skribe/doc/user/src/api5.skb b/skribe/doc/user/src/api5.skb new file mode 100644 index 0000000..01188c1 --- /dev/null +++ b/skribe/doc/user/src/api5.skb @@ -0,0 +1,2 @@ +(section :title "This is a simple section" :number #f :toc #f [ +Its body is just one sentence.]) diff --git a/skribe/doc/user/src/api6.skb b/skribe/doc/user/src/api6.skb new file mode 100644 index 0000000..22a1c77 --- /dev/null +++ b/skribe/doc/user/src/api6.skb @@ -0,0 +1 @@ +(toc :chapter #t :section #f :subsection #f) diff --git a/skribe/doc/user/src/api7.skb b/skribe/doc/user/src/api7.skb new file mode 100644 index 0000000..c6aec8b --- /dev/null +++ b/skribe/doc/user/src/api7.skb @@ -0,0 +1,3 @@ +(resolve (lambda (n e env) + (toc :chapter #t :section #t :subsection #t + (handle (ast-chapter n))))) diff --git a/skribe/doc/user/src/api8.skb b/skribe/doc/user/src/api8.skb new file mode 100644 index 0000000..a4403ff --- /dev/null +++ b/skribe/doc/user/src/api8.skb @@ -0,0 +1,15 @@ +(itemize (item (roman "a roman text.")) + (item (bold "a bold text.")) + (item (it "an italic text.")) + (item (emph "an emphasized text.")) + (item (underline "an underline text.")) + (item (kbd "a keyboard description.")) + (item (tt "a typewritter text.")) + (item (code "a text representing computer code.")) + (item (var "a computer program variable description.")) + (item (samp "a sample.")) + (item (sc "a smallcaps text.")) + (item (sf "a sans-serif text.")) + (item (sup "a superscripts text.")) + (item (sub "a subscripts text.")) + (item (underline (bold (it "an underline, bold, italic text."))))) diff --git a/skribe/doc/user/src/api9.skb b/skribe/doc/user/src/api9.skb new file mode 100644 index 0000000..1f6890e --- /dev/null +++ b/skribe/doc/user/src/api9.skb @@ -0,0 +1,5 @@ +(itemize + (item (font :size -2 [A smaller font.])) + (item (font :size 6 [An absolute font size.])) + (item (font :size 4. [A larger font.])) + (item (font :face "Helvetica" [An helvetica example.]))) diff --git a/skribe/doc/user/src/bib1.sbib b/skribe/doc/user/src/bib1.sbib new file mode 100644 index 0000000..3f1c04f --- /dev/null +++ b/skribe/doc/user/src/bib1.sbib @@ -0,0 +1,39 @@ +(book queinnec:lisp + (author "Queinnec, C.") + (title "Lisp In Small Pieces") + (publisher "Cambridge University Press") + (year "1996")) + +(book scheme:ieee + (title "IEEE Standard for the Scheme Programming Language") + (author "IEEE Std 1178-1990") + (publisher "Institute of Electrical and Electronic Engineers, Inc.") + (address "New York, NY") + (year "1991")) + +(misc bigloo + (url "http://www.inria.fr/mimosa/fp/Bigloo")) + +(misc scheme:r4rs + (title "The Revised4 Report on the Algorithmic Language Scheme") + (author "Clinger, W. and Rees, J.") + (month "Nov") + (year "1991") + (url "http://www.cs.indiana.edu/scheme-repository/R4RS/r4rs_toc.html")) + +(article scheme:r5rs + (title "The Revised5 Report on the Algorithmic Language Scheme") + (author "Kelsey, R. and Clinger, W. and Rees, J.") + (journal "Higher-Order and Symbolic Computation") + (volume "11") + (number "1") + (month "Sep") + (year "1998") + (url "http://kaolin.unice.fr/Bigloo/doc/r5rs.html")) + +(book as:sicp + (author "Abelson, H. and Sussman, G.") + (title "Structure and Interpretation of Computer Programs") + (year "1985") + (publisher "MIT Press") + (address "Cambridge, Mass., USA")) diff --git a/skribe/doc/user/src/bib2.skb b/skribe/doc/user/src/bib2.skb new file mode 100644 index 0000000..25417b5 --- /dev/null +++ b/skribe/doc/user/src/bib2.skb @@ -0,0 +1,7 @@ +[Scheme ,(ref :bib 'scheme:r5rs) is functional programming language. It exists +several books about this language ,(ref :bib '(as:sicp queinnec:lisp)). + +,(linebreak 2) +,(center (bold [-- Bibliography --])) + +,(center (frame :border 1 :margin 2 :width 90. (the-bibliography)))] diff --git a/skribe/doc/user/src/bib3.skb b/skribe/doc/user/src/bib3.skb new file mode 100644 index 0000000..9cb838e --- /dev/null +++ b/skribe/doc/user/src/bib3.skb @@ -0,0 +1,3 @@ +(center + (frame :border 1 :margin 2 :width 90. + (the-bibliography :pred (lambda (m n) #t)))) diff --git a/skribe/doc/user/src/bib4.skb b/skribe/doc/user/src/bib4.skb new file mode 100644 index 0000000..81ba5df --- /dev/null +++ b/skribe/doc/user/src/bib4.skb @@ -0,0 +1,5 @@ +(center + (frame :border 1 :margin 2 :width 90. + (the-bibliography :pred (lambda (m n) + (and (eq? (markup-option m 'kind) 'book) + (pair? (markup-option m 'used))))))) diff --git a/skribe/doc/user/src/bib5.skb b/skribe/doc/user/src/bib5.skb new file mode 100644 index 0000000..a0ee361 --- /dev/null +++ b/skribe/doc/user/src/bib5.skb @@ -0,0 +1,24 @@ +(center + (frame :border 1 :margin 2 :width 90. + (processor :engine + (make-engine '_ :filter string-upcase) + :combinator + (lambda (e1 e2) + (let ((e (copy-engine '_ e2))) + (markup-writer '&bib-entry-ident e + :action + (lambda (n e) + (let* ((be (ast-parent n)) + (o (markup-option be 'author)) + (y (markup-option be 'year))) + (output (markup-body o) e1) + (display ":") + (output (markup-body y) e)))) + (markup-writer '&bib-entry-title e + :action + (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + e)) + (the-bibliography :pred + (lambda (m n) + (eq? (markup-option m 'kind) 'book)))))) diff --git a/skribe/doc/user/src/bib6.skb b/skribe/doc/user/src/bib6.skb new file mode 100644 index 0000000..013ca97 --- /dev/null +++ b/skribe/doc/user/src/bib6.skb @@ -0,0 +1 @@ +(bibliography :command "gzip -d --to-stdout ~a | skribebibtex" "scheme.bib.gz") diff --git a/skribe/doc/user/src/index1.skb b/skribe/doc/user/src/index1.skb new file mode 100644 index 0000000..199428c --- /dev/null +++ b/skribe/doc/user/src/index1.skb @@ -0,0 +1 @@ +(define *index1* (make-index "a new index")) diff --git a/skribe/doc/user/src/index2.skb b/skribe/doc/user/src/index2.skb new file mode 100644 index 0000000..f49cf33 --- /dev/null +++ b/skribe/doc/user/src/index2.skb @@ -0,0 +1,11 @@ +[The identifier ,(code "Foo"),(index :index *index1* "Foo") is a usually +used as an example. When two identifiers have to used, frequently the +second choice is ,(code "Bar"),(index :index *index1* "Bar" :shape (it "Bar")). +When three are needed, some use ,(code "Baz") +,(index :index *index1* "Baz" :shape (it "Baz")). + +This illustrates how to use identifier +,(index :index *index1* "Foo" :note "How to use Foo") +,(index :index *index1* "Foo" :note "How not to use Foo") +,(index :index *index1* "Fooz") +...] diff --git a/skribe/doc/user/src/index3.skb b/skribe/doc/user/src/index3.skb new file mode 100644 index 0000000..3d76a90 --- /dev/null +++ b/skribe/doc/user/src/index3.skb @@ -0,0 +1 @@ +(the-index *index1*) diff --git a/skribe/doc/user/src/links1.skb b/skribe/doc/user/src/links1.skb new file mode 100644 index 0000000..e0ce61c --- /dev/null +++ b/skribe/doc/user/src/links1.skb @@ -0,0 +1,23 @@ +[This hyperlink points to the ,(ref :figure "The great Penguin" :text "figure") +of the chapter ,(ref :chapter "Standard Markups") (or also, the +,(ref :ident "Standard Markups" :text "chapter") about markups). +In the second example of reference, no ,(code ":text") option is specified: +,(ref :figure "The great Penguin"). One may use the ,(param ":ident") +field when specified such as: ,(ref :ident "fig1") or ,(ref :figure "fig1"). + +,(linebreak) +That other one points to a well known +,(ref :url "http://slashdot.org/" :text "url"). The same without +,(code ":text"): ,(ref :url "http://slashdot.org/"). + +,(linebreak) +With more complex tricks that are explained in Section +,(ref :section "Resolve"), it is also possible use, for the text of the +reference, a container number such as chapter: +,(resolve (lambda (n e env) + (let ((s (find1-down (lambda (x) + (and (is-markup? x 'chapter) + (string=? (markup-option x :title) + "Standard Markups"))) + (ast-document n)))) + (ref :handle (handle s) :text (markup-option s :number))))).] diff --git a/skribe/doc/user/src/links2.skb b/skribe/doc/user/src/links2.skb new file mode 100644 index 0000000..7cdee07 --- /dev/null +++ b/skribe/doc/user/src/links2.skb @@ -0,0 +1,4 @@ +[It is possible to send a mail by +,(mailto "foo@nowhere.com" :text "clicking") that link. That same +reference without ,(code ":text") options: ,(mailto "foo@nowhere.com"). +] diff --git a/skribe/doc/user/src/prgm1.skb b/skribe/doc/user/src/prgm1.skb new file mode 100644 index 0000000..dcdeb88 --- /dev/null +++ b/skribe/doc/user/src/prgm1.skb @@ -0,0 +1,15 @@ +(frame :width 100. + (prog :line 10 :mark "##" [ +SKRIBE=skribe + +all: demo.html demo.man ##main-goal + +demo.html: demo.skb + $(SKRIBE) demo.skb -o demo.html + +demo.man: demo.skb + $(SKRIBE) demo.skb -o demo.man +])) + +(p [The main goal is specified line ,(ref :line "main-goal").]) + diff --git a/skribe/doc/user/src/prgm2.skb b/skribe/doc/user/src/prgm2.skb new file mode 100644 index 0000000..5b5644b --- /dev/null +++ b/skribe/doc/user/src/prgm2.skb @@ -0,0 +1,18 @@ +(frame :width 100. + (prog (source :language bigloo :file "prgm.skb" :definition 'fib))) + +(p [The Fibonacci function is defined line ,(ref :line "fib").]) + +;!start +(frame :width 100. + (prog :line 11 :mark #f + (source :language skribe :file "prgm.skb" :start 11 :stop 24))) +;!stop + +(p [Here is the source of the frame above:]) + +(frame :width 100. + (prog :line 30 :mark #f + (source :language skribe :file "src/prgm2.skb" + :start ";!start" + :stop ";!stop"))) diff --git a/skribe/doc/user/src/prgm3.skb b/skribe/doc/user/src/prgm3.skb new file mode 100644 index 0000000..51cb564 --- /dev/null +++ b/skribe/doc/user/src/prgm3.skb @@ -0,0 +1,55 @@ +(define (makefile-fontifier string) + (with-input-from-string string + (lambda () + (read/rp (regular-grammar () + ((: #\# (+ all)) + ;; makefile comment + (let ((cmt (the-string))) + (cons (it cmt) (ignore)))) + ((bol (: (+ (out " \t\n:")) #\:)) + ;; target + (let ((prompt (the-string))) + (cons (bold prompt) (ignore)))) + ((bol (: (+ alpha) #\=)) + ;; variable definitions + (let* ((len (- (the-length) 1)) + (var (the-substring 0 len))) + (cons (list (color :fg "#bb0000" (bold var)) "=") + (ignore)))) + ((+ (out " \t\n:=$")) + ;; plain strings + (let ((str (the-string))) + (cons str (ignore)))) + ((: #\$ #\( (+ (out " )\n")) #\)) + ;; variable references + (let ((str (the-string)) + (var (the-substring 2 (- (the-length) 1)))) + (cons (underline str) (ignore)))) + ((+ (in " \t\n:")) + ;; separators + (let ((nl (the-string))) + (cons nl (ignore)))) + (else + ;; default + (let ((c (the-failure))) + (if (eof-object? c) + '() + (skribe-error 'makefile "Unexpected char" c))))) + (current-input-port))))) + +(define makefile + (language :name "Makefile" + :fontifier makefile-fontifier)) + +(frame :width 100. + (prog (source :language makefile [ +SKRIBE=skribe + +all: demo.html demo.man + +demo.html: demo.skb + $(SKRIBE) demo.skb -o demo.html + +demo.man: demo.skb + $(SKRIBE) demo.skb -o demo.man +]))) diff --git a/skribe/doc/user/src/slides.skb b/skribe/doc/user/src/slides.skb new file mode 100644 index 0000000..ac584d1 --- /dev/null +++ b/skribe/doc/user/src/slides.skb @@ -0,0 +1,27 @@ +(skribe-load "slide.skr" :advi #t) + +(document :title (color :fg "red" (sf (font :size +2. "Skribe Slides"))) + :author (author :name (it "Manuel Serrano") + :affiliation [Inria Sophia Antipolis] + :address (ref :url "http://www.inria.fr/mimosa/Manuel.Serrano")) + + (if (engine-format? "html") + (slide :title "Table of contents" :number #f :toc #f + (toc :chapter #f :section #f :subsection #f :subsubsection #f + :slide #t))) + + (slide :title "X11 client" :toc #t :vspace 0.3 + + (itemize + (item "xlock") + (item "xeyes") + (item "xterm"))) + + (slide :title "Xclock" :toc #t :vspace 0.3 + + (center (sf (underline "The Unix xclock client"))) + (slide-vspace 0.3) + + (slide-pause) + (slide-embed :command "xlock" + :alt (frame "Can't run embedded application")))) diff --git a/skribe/doc/user/src/start1.skb b/skribe/doc/user/src/start1.skb new file mode 100644 index 0000000..4e37dda --- /dev/null +++ b/skribe/doc/user/src/start1.skb @@ -0,0 +1,2 @@ +(document :title [Hello World!] [ +This is a very simple text.]) diff --git a/skribe/doc/user/src/start2.skb b/skribe/doc/user/src/start2.skb new file mode 100644 index 0000000..9fcfdbf --- /dev/null +++ b/skribe/doc/user/src/start2.skb @@ -0,0 +1,2 @@ +(document :title [Hello World!] [ +This is a ,(bold [very]) ,(it [simple]) ,(color :fg [red] [text]).]) diff --git a/skribe/doc/user/src/start3.skb b/skribe/doc/user/src/start3.skb new file mode 100644 index 0000000..0705966 --- /dev/null +++ b/skribe/doc/user/src/start3.skb @@ -0,0 +1,10 @@ +(document :title [Hello World!] + +(section :title [A first Section] [ + This is a ,(bold [very]) ,(it [simple]) ,(color :fg [red] [text]).]) + +(section :title [A second Section] [ + That section contains an ,(bold itemize) construction: + ,(itemize (item [first item]) + (item [second item]) + (item [third item]))])) diff --git a/skribe/doc/user/src/start4.skb b/skribe/doc/user/src/start4.skb new file mode 100644 index 0000000..3311925 --- /dev/null +++ b/skribe/doc/user/src/start4.skb @@ -0,0 +1,13 @@ +(document :title [Various links] [ + +(section :title "A Section" [ +The first link points to an external web page. Here we point to a +,(ref :url [http://slashdot.org/] [Slashdot]) +web page. The second one points to the second +,(ref :section [A second Section] [Section]) +of that document.]) + +(section :title [A second Section] [ +The last links points to the first +,(ref :scribe [user.scr] :figure [A simple web page] [Figure]) +of the Scribe User Manual.])]) diff --git a/skribe/doc/user/src/start5.skb b/skribe/doc/user/src/start5.skb new file mode 100644 index 0000000..9e6b877 --- /dev/null +++ b/skribe/doc/user/src/start5.skb @@ -0,0 +1,9 @@ +(resolve (lambda (n e env) + (let* ((current-chapter (ast-chapter n)) + (body (markup-body current-chapter)) + (sects (filter (lambda (x) (is-markup? x 'section)) + body))) + (itemize + (map (lambda (x) + (item (it (markup-option x :title)))) + sects)))))
\ No newline at end of file diff --git a/skribe/doc/user/start.skb b/skribe/doc/user/start.skb new file mode 100644 index 0000000..f3c1e28 --- /dev/null +++ b/skribe/doc/user/start.skb @@ -0,0 +1,197 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/start.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 11:22:25 2003 */ +;* Last change : Sun Feb 29 16:14:21 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Getting started with Skribe */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Getting started */ +;*---------------------------------------------------------------------*/ +(chapter :title "Getting Started" + +(p [ +In this chapter, the syntax of a Skribe text is presented ,(emph "informally"). +In particular, the Skribe syntax is compared to the HTML syntax. Then, +it is presented how one can use Skribe to make dynamic text +(i.e texts which are generated by the system rather than entered-in by hand. +Finally, It is also +presented how Skribe source files can be processed.]) + +;*--- Hello world -----------------------------------------------------*/ +(section :title "Hello World!" [ +In this section we show how to produce very simple electronic documents +with Skribe. Suppose that we want to produce the following Web document: + +,(disp [,(font :size 2. (bold "Hello World!")) +,(linebreak 2) +This is a very simple text.]) + +The HTML source file for such a page should look like: + +,(prgm :language xml [ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> +<HTML> +<HEAD> +<TITLE>Hello world Example</TITLE> +</HEAD> +<BODY> +<H1>Hello World!</H1> + +This is a very simple text. +</BODY> +</HTML>]) + +In Skribe, the very same document must be written: + +,(prgm :language skribe :file "src/start1.skb")]) + +;*--- Adding colors and fonts -----------------------------------------*/ +(section :title "Adding colors and fonts" [ +Let us suppose that we want now to colorize and change the face of some +words such as: + +,(disp [,(font :size 2. (bold "Hello World!")) +,(linebreak 2) +This is a ,(bold "very") ,(it "simple") ,(color :fg "red" "text").]) + +The HTML source file for such a document should look like: + +,(prgm :language xml [ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> +<HTML> +<HEAD> +<TITLE>Hello world Example</TITLE> +</HEAD> +<BODY> +<H1>Hello World!</H1> + +This is a <B>very</B> <I>simple</I> <FONT color="red">text</FONT>. +</BODY> +</HTML>]) + +In Skribe, the very same document must be written: + +,(prgm :language skribe (source :file "src/start2.skb")) + +As one may notice the Skribe version is much more compact than the HTML one.]) + +;*--- Structured documents --------------------------------------------*/ +(section :title "Structured documents" [ +,(p [For large documents there is an obvious need of structure. Skribe +documents may contain ,(bold "chapters"), ,(bold "sections"), +,(bold "subsections"), ,(bold "itemize"), ... For instance, if we want to +extend our previous example to:]) + +,(disp :verb #t [,(bold (font :size 2. "Hello World!")) + +,(font :size 1. (bold "1. A first Section")) +This is a ,(bold "very") ,(it "simple") ,(color :fg "red" "text"). + +,(font :size 1. (bold "2. A second Section")) +That contains an ,(bold "itemize") construction: + . first item + . second item + . third item]) + +The Skribe source for that text is: + +,(prgm :language skribe (source :file "src/start3.skb"))]) + +;*--- Hyperlinks ------------------------------------------------------*/ +(section :title "Hyperlinks" [ +A Skribe document may contain links to chapters, to sections, to other +Skribe documents or Web pages. The following Skribe source +code illustrates these various kinds of links: + +,(prgm :language skribe (source :file "src/start4.skb"))]) + +;*--- Dynamic documents -----------------------------------------------*/ +(section :title "Dynamic documents" [ +Since Skribe is a programming language, rather than just a markup language, +it is easy to use it to generate some parts of a document. This section +presents here the kind of documents that can be created with Skribe. + +,(subsection :title "Simple computations" [ +In this section we present how to introduce a simple computation into a +document. For instance, the following sentence +,(disp [ +Document creation date: ,(date)]) +is generated with the following piece of code + +,(prgm :language skribe [ +\[Document creation date: \,(date)\] +]) + +Here, we use the Skribe function ,(code "date") to compute the date to +be inserted in the document. In general, any valid Scheme expression +is authorized inside a ,(code ",(...)") construct.,(footnote +[Skribe can be built either with Bigloo or STklos Scheme systems. The Scheme +expressions which are valid inside a ,(code ",(...)") depends of the Scheme system +used at Skribe construction.]). +Another example of +such a computation is given below. +,(prgm :language skribe [ +\[The value of \,(symbol "pi") is \,(* 4 (atan 1))\] +]) +When evaluated, this form produces the following output: +,(disp [ +The value of ,(symbol "pi") is ,(* 4 (atan 1)).]) +]) + +,(subsection :title "Text generation" [ When building a document, one +often need to generate some repetitive text. Skribe programming skills +can be used to ease the construction of such documents as illustrated below. +,(disp +(itemize + (map (lambda (x) (item [The square of ,(bold x) is ,(bold (* x x))])) + '(1 2 3 4 5 6 7 8 9)))) +This text has been generated with the following piece of code +,(prgm :language skribe [ +(itemize + (map (lambda (x) (item \[The square of \,(bold x) is \,(bold (* x x))\])) + '(1 2 3 4 5 6 7 8 9))) +])]) + +,(subsection :title "Introspection" [ +In Skribe, a document is represented by a tree which is available to +the user. So, it is easy to perform introspective tasks on the current +document. For instance the following code displays as an +enumeration the sections titles of the current chapter: + +,(prgm :language skribe :file "src/start5.skb") + +Without entering too much into the details here, the resolve function +is called at the end of the document processing. This function +searches the node representing the chapter to which belongs the +current node and from it finds all its sections. The titles +of these sections are put in italics in an itemize. + +,(p [The execution of this code yield the following text]) + +,(disp (include "src/start5.skb"))]) +]) + + +;*--- Compiling skribe documents --------------------------------------*/ +(section :title "Compiling Skribe documents" [ + +There are several ways to render a Skribe document. It can be statically +compiled by the ,(tt "skribe") compiler to various formats such as HTML, +LaTeX, man and so on. It can be compiled on-demand by the ,(tt "mod_skribe") +,(ref :url "http://www.apache.org/" :text "Apache") Skribe module. In this +section we only present static compilation. + +,(p [Let us suppose a Skribe text located in a file ,(tt "file.skb"). +In order to compile to various formats one must type in:]) + +,(disp :verb #t [ +$ skribe file.skb -o file.html ,(char 35) ,(it "This produces an HTML file.") +$ skribe file.skb -o file.tex ,(char 35) ,(it "This produces a TeX file.") +$ skribe file.skb -o file.man ,(char 35) ,(it "This produces a man page.") +$ skribe file.skb -o file.info ,(char 35) ,(it "This produces an info page.") +$ skribe file.skb -o file.mgp ,(char 35) ,(it "This produces a MagicPoint document")])])) diff --git a/skribe/doc/user/syntax.skb b/skribe/doc/user/syntax.skb new file mode 100644 index 0000000..de60bd9 --- /dev/null +++ b/skribe/doc/user/syntax.skb @@ -0,0 +1,105 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/syntax.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Nov 30 11:55:24 2001 */ +;* Last change : Sun Feb 29 16:14:53 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The syntax of Skribe */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The Skribe syntax */ +;*---------------------------------------------------------------------*/ +(chapter :title "Syntax & Values" [ +A Skribe document is composed of Skribe expressions. A Skribe expression +can be: + +,(itemize (item [An atomic expression, such as a string of characters, a number.]) + (item [A list.]) + (item [A text.])) + +Here are several examples of correct Skribe expressions: + +,(center (frame :margin 5 :border 0 :width *prgm-width* + (color :margin 5 :bg *disp-color* :width 100. +(itemize (item [,(color :fg "#009900" (tt "\"foo\"")), a string of characters composed of the +characters `,(color :fg "#009900" "f")', `,(color :fg "#009900" "o")' +and `,(color :fg "#009900" "o")'.]) + (item [,(color :fg "#009900" (tt "123") " " (tt "3.14")), two numbers.]) + (item [,(color :fg "#009900" (tt "#t") " " (tt "#f")), the ,(emph "true") and ,(emph "false") +Skribe value.]) + (item [,(color :fg "#009900" (tt "(bold \"foo bar\")")), a list.]) + (item [,(color :fg "#009900" (tt (char 91)"A text sample"(char 93))), a simple text containing +three words and no escape sequence.]) + (item [,(color :fg "#009900" (tt (char 91)"Another text sample (that is still) simple"(char 93))), +another simple text.]) + (item [,(color :fg "#009900" (tt (char 91)"Another ,(bold \"text\") sample"(char 93))), +a more complex text that contains two words (,(color :fg "#009900" (tt "Another")) and ,(color :fg "#009900" (tt "sample"))) +and an expression ,(color :fg "#009900" (tt "(bold \"text\")")). The escape sequence is introduced +with the `,(color :fg "#009900" (tt ",("))' characters.]))))) + +,(p [ +Expressions are evaluated, thus ,(color :fg "#009900" (tt "(bold \"foo\")")) +has the effect of typesetting the word ,(color :fg "#009900" (tt "foo")) in +bold face to produce ,(color :fg "#009999" (bold "foo")). Escape sequences +enable evaluation of expressions inside the text. Thus the text +,(color :fg "#009900" (tt (char 91)"Another ,(bold \"text\") sample"(char 93))) +produces `,(color :fg "#009999" (tt [Another ,(bold "text") sample]))'. +On the other hand +,(color :fg "#009900" (tt (char 91)"Another (bold \"text\") sample"(char 93))) +produces +`,(color :fg "#009999" (tt [Another (bold "text") sample]))' because it does not contain +the escape sequence `,(color :fg "#009900" (char #\,)(char #\())'.]) +] + +;*---------------------------------------------------------------------*/ +;* Formal syntax */ +;*---------------------------------------------------------------------*/ +(section :title "Skribe syntax" + +(disp :verb #t :bg *prgm-skribe-color* [ +<expr> --> <atom> + | <text> + | <list> +<list> --> (<expr>+) +<text> --> ,(bold (color :fg "red" (char 91))),(it "any sequence but `,(' or a `,")<list>,(it "'"),(bold (color :fg "red" (char 93))) +<atom> --> <boolean> + | <integer> + | <float> + | <string> + | <color> +<integer> --> ,(tt (char 91))0-9,(tt (char 93))+ +<float> --> ,(tt (char 91))0-9,(tt (char 93))+.,(tt (char 91))0-9,(tt (char 93))* + | ,(tt (char 91))0-9,(tt (char 93))*.,(tt (char 91))0-9,(tt (char 93))+ +<string> --> ,(tt #\")...,(tt #\") +<color> --> <string> + | ,(tt #\")#,(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt (char 91))0-9a-f,(tt (char 93)),(tt #\")])) + +;*---------------------------------------------------------------------*/ +;* Values */ +;*---------------------------------------------------------------------*/ +(section :title "Values" :file #f :toc #t + +;*--- width -----------------------------------------------------------*/ +(subsection :title "Width" (p [ +,(mark "width") +A Skribe ,(emph "width") refers to the horizontal size a construction +occupies on an output document. There are three different ways for +specifying a width:]) + +(description (item :key "An absolute pixel size" + [This is represented by an ,(emph "exact") integer value + (such as ,(code "350")).]) + (item :key "A relative size" + [This is represented by an ,(emph "inexact") integer value + (such as ,(code "50.0")) which ranges in the interval + ,(char 91)-100.0 .. 100.0,(char 93)]) + (item :key "An engine dependent representation" + [This is represented by a string that is directly emitted + in the output document (such as HTML column ,(code "\"0*\"") + specification). Note that this way of specifying width + is strictly unportable.]))))) + + diff --git a/skribe/doc/user/table.skb b/skribe/doc/user/table.skb new file mode 100644 index 0000000..c726d44 --- /dev/null +++ b/skribe/doc/user/table.skb @@ -0,0 +1,81 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/table.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Sep 5 13:45:18 2003 */ +;* Last change : Wed Oct 27 12:09:01 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe tables */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Table ... */ +;*---------------------------------------------------------------------*/ +(section :title "Table" :file #t + + (p [Tables are defined by the means of the ,(code "table") function.]) + + (doc-markup 'table + `((:border [The table border thickness.]) + (:width ,[The ,(ref :mark "width") of the table.]) + (:frame ,[Which parts of frame to render. Must be one of + ,(code "none"), ,(code "above"), ,(code "below"), + ,(code "hsides"), ,(code "vsides"), ,(code "lhs"), + ,(code "rhs"), ,(code "box"), ,(code "border").]) + (:rules ,[Rulings between rows and cols, Must be one of + ,(code [none]), ,(code "rows"), ,(code "cols"), ,(code "header"), + ,(code "all").]) + (:cellstyle ,[The style of cells border. Must be either + ,(code "collapse"), ,(code "separate"), or a length representing + the horizontal and vertical space separating the cells.]) + (:cellpadding [A number of pixels around each cell.]) + (:cellspacing [An optional number of pixels used to separate each + cell of the table. A negative uses the target default.]) + (#!rest row... [The rows of the table. Each row must be + constructed by the ,(ref :mark "tr" :text (code "tr")) function.]))) + + (p [,(bold (emph (color :fg "red" "Note:"))) Tables rendering may be only +partially supported by graphical agents. For instance, the ,(code "cellstyle") +attribute is only supported by HTML engines supporting +,(ref :url "http://www.w3.org/TR/REC-CSS2/" :text "CSS2").]) + + +;*--- table rows ------------------------------------------------------*/ +(subsection :title "Table row" + +(p [Table rows are defined by the ,(code "tr") function.]) + +(doc-markup 'tr + '((:bg [The background color of the row.]) + (#!rest cell... [The row cells.])))) + +;*--- Table cell ------------------------------------------------------*/ +(subsection :title "Table cell" + +(p [Two functions define table cells: ,(code "th") for header cells and +,(code "td") for plain cells.]) + +(doc-markup 'th + '((:bg [The background color of the cell.]) + (:width ,[The ,(ref :mark "width") of the table.]) + (:align [The horizontal alignment of the table cell + (,(tt "left"), ,(tt "right"), or ,(tt "center"). Some + engines, such as the HTML engine, also supports a + character for the alignment.)]) + (:valign [The vertical alignment of the cell. The value can + be ,(code "top"), ,(code "center"), ,(code "bottom").]) + (:colspan [The number of columns that the cell expands to.]) + (#!rest node [The value of the cell.])) + :writer-id 'tc + :ignore-args '(m) + :others '(td))) + +;*--- Example ---------------------------------------------------------*/ +(subsection :title "Example" + +(example-produce + (example :legend "A table" (prgm :file "src/api17.skb")) + (disp (include "src/api17.skb"))))) + +;; @indent: (put 'doc-markup 'skribe-indent 'skribe-indent-function)@* diff --git a/skribe/doc/user/toc.skb b/skribe/doc/user/toc.skb new file mode 100644 index 0000000..aa6c0dc --- /dev/null +++ b/skribe/doc/user/toc.skb @@ -0,0 +1,37 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/toc.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 13:01:03 2003 */ +;* Last change : Fri Sep 12 15:31:14 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Table of contents */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Sectioning */ +;*---------------------------------------------------------------------*/ +(section :title "Table of contents" :file #t + +(p [The production of table of contains.]) + +(doc-markup 'toc + '((:chapter [A boolean. The value ,(code "#t") forces the + inclusion of chapters in the table of contents.]) + (:section [A boolean controlling sections.]) + (:subsection [A boolean controlling subsections.]) + (#!rest handle [An optional handle pointing to the node from + which the table of contents if computed.])) + :see-also '(document chapter section resolve handle)) + +(example-produce + (example :legend "The toc markup" (prgm :file "src/api6.skb")) + (disp (include "src/api6.skb"))) + +(p [The second example only displays the table of contents of the current +chapter.]) + +(example-produce + (example :legend "A restricted table of contents" (prgm :file "src/api7.skb")) + (disp (include "src/api7.skb")))) diff --git a/skribe/doc/user/user.skb b/skribe/doc/user/user.skb new file mode 100644 index 0000000..07a6e03 --- /dev/null +++ b/skribe/doc/user/user.skb @@ -0,0 +1,163 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/user.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Nov 28 10:37:39 2001 */ +;* Last change : Thu Feb 26 21:02:00 2004 (eg) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe user manual */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The Skribe documentation style */ +;*---------------------------------------------------------------------*/ +(skribe-load "web-book.skr") +(skribe-load "skr/env.skr") +(skribe-load "skr/manual.skr") +(skribe-load "skr/api.skr") + +;*---------------------------------------------------------------------*/ +;* HTML custom */ +;*---------------------------------------------------------------------*/ +;; since we load slides (for documenting it), we have to use a +;; correct title width +(let ((he (find-engine 'html))) + (engine-custom-set! he 'body-width 100.)) + +;*---------------------------------------------------------------------*/ +;* The various indexes */ +;*---------------------------------------------------------------------*/ +(define *markup-index* (make-index "markup")) +(define *custom-index* (make-index "custom")) +(define *function-index* (make-index "function")) +(define *package-index* (make-index "package")) + +;*---------------------------------------------------------------------*/ +;* The document */ +;*---------------------------------------------------------------------*/ +(document :title "Skribe User Manual" + :env '((example-counter 0) (example-env ())) + :author (list (author :name "Erick Gallesio" + :affiliation "Université de Nice - Sophia Antipolis" + :address '("930 route des Colles, BP 145" + "F-06903 Sophia Antipolis, Cedex" + "France") + :email (mailto "eg@essi.fr")) + (author :name "Manuel Serrano" + :affiliation "Inria Sophia-Antipolis" + :address `("2004 route des Lucioles - BP 93" + "F-06902 Sophia Antipolis, Cedex" + "France") + :url (ref :url *serrano-url*) + :email (mailto *serrano-mail*))) + + (linebreak 1) + (center (frame (bold (font :size 1. [ +This is the documentation for Skribe version +,(color :fg "red" (skribe-release)).])))) + (linebreak 1) + +;;; Introduction +(section :title "Introduction" :number #f :toc #f [ +Skribe is a programming language designed for implementing electronic +documents. It is mainly designed for the writing of technical documents +such as the documentation of computer programs. With Skribe these +documents can be rendered using various tools and technologies. For +instance, a Skribe document can be ,(emph "compiled") to an HTML file +that suits Web browser, it can be compiled to a TeX file in order to +produce a high-quality printed document, and so on.] + + (subsection :title "Who may use Skribe?" :number #f [ +Everyone needing to design web pages, info documents, man pages or +Postscript files can use Skribe. In particular, there is ,(bold "no need") +for programming skills in order to use Skribe. Skribe can be used as +any text description languages such as TeX, LaTeX or HTML.]) + + (subsection :title "Why using Skribe?" :number #f [ +There are three main reasons for using Skribe:] + + (itemize + (item [ +It is easier to type in Skribe texts than other text description formats. +The need for ,(emph "meta keyword"), that is, words used to describe +the structure of the text and not the text itself, is very limited.]) + (item [ +Skribe is highly skilled for computing texts. It is very common that +one needs to automatically produce parts of the text. This can +be very simple such as, for instance, the need to include inside a text, +the date of the last update or the number of the last revision. +Sometimes it may be more complex. For instance, one may be willing to +embed inside a text the result of a complex arithmetic computation. Or +even, you may want to include some statistics about that +text, such as, the number of words, paragraphs, sections, and so on. +Skribe makes these sort of text manipulation easy whereas other +systems rely on the use of text preprocessors.]) + (item [ +The same source file can be compiled to various output formats such +as HTML, Info pages, man pages, Postscript, etc.])))) + +;;; toc +(if (engine-format? "latex") + (toc :chapter #t :section #t :subsection #t)) + +;;; Getting started +(include "start.skb") + +;;; Syntax +(include "syntax.skb") + +;;; Skribe Markup Library +(include "markup.skb") + +;;; Hyperlinks and references +(include "links.skb") + +;;; Indexes +(include "index.skb") + +;;; Bibliography +(include "bib.skb") + +;;; Computer programs +(include "prgm.skb") + +;;; Standard Library +(include "lib.skb") + +;;; Engines +(include "engine.skb") + +;;; Emacs +(include "emacs.skb") + +;;; Skribe +(include "skribec.skb") + +;;; Slides +(include "slide.skb") + +;;; Packages +(include "package.skb") + +;;; skribe-config +(include "skribe-config.skb") + +;;; List of examples +(include "examples.skb") + +;;; table of contents +(if (not (engine-format? "latex")) + (begin + (chapter :title "Table of contents" + (toc :chapter #t :section #t :subsection #t)) + (section :title "Index" :number #f + (mark "global index") + (the-index :column (if (engine-format? "latex") 2 3) + *markup-index* *custom-index* *function-index* *package-index* + (default-index)))) + (chapter :title "Index" + (mark "global index") + (the-index :column (if (engine-format? "latex") 2 3) + *markup-index* *custom-index* *function-index* *package-index* + (default-index))))) diff --git a/skribe/doc/user/xmle.skb b/skribe/doc/user/xmle.skb new file mode 100644 index 0000000..4a1ee78 --- /dev/null +++ b/skribe/doc/user/xmle.skb @@ -0,0 +1,25 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/doc/user/xmle.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 3 11:20:49 2003 */ +;* Last change : Tue Apr 6 06:27:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The documentation of the XML engine */ +;*=====================================================================*/ +;; @indent: (put 'doc-engine 'skribe-indent 'skribe-indent-function)@ + +;*---------------------------------------------------------------------*/ +;* Document */ +;*---------------------------------------------------------------------*/ +(section :title "Xml engine" :file #t + (mark "xml-engine") + (index "Xml" :note "Engine") + (p [The Xml engine...]) + + (subsection :title "The Xml customization" + + (doc-engine 'xml + `() + :source "skr/xml.skr"))) diff --git a/skribe/emacs/Makefile b/skribe/emacs/Makefile new file mode 100644 index 0000000..52074cb --- /dev/null +++ b/skribe/emacs/Makefile @@ -0,0 +1,55 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/emacs/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Sat Oct 25 08:20:06 2003 */ +#* Last change : Thu Jan 1 16:46:32 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* Skribe emacs Makefile */ +#*=====================================================================*/ +include ../etc/Makefile.config +include ../etc/$(SYSTEM)/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo emacs/skribe.el.in emacs/Makefile + +#*---------------------------------------------------------------------*/ +#* install/uninstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: + $(MAKE) install-$(SYSTEM) +uninstall: + $(MAKE) uninstall-$(SYSTEM) + +install-bigloo: + if [ "$(EMACSDIR) " != " " ]; then \ + if [ -d $(EMACSDIR) ]; then \ + cp skribe.el $(EMACSDIR) && chmod $(BMASK) $(EMACSDIR)/skribe.el; \ + fi \ + fi +uninstall-bigloo: + if [ "$(EMACSDIR) " != " " ]; then \ + if [ -d $(EMACSDIR) ]; then \ + $(RM) -f $(EMACSDIR)/skribe.el; \ + fi \ + fi + +install-stklos: +uninstall-stklos: + +#*---------------------------------------------------------------------*/ +#* clean/distclean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean distclean + +clean: +distclean: clean + $(RM) -f skribe.el diff --git a/skribe/emacs/skribe.el.in b/skribe/emacs/skribe.el.in new file mode 100644 index 0000000..1b1ae4f --- /dev/null +++ b/skribe/emacs/skribe.el.in @@ -0,0 +1,841 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/emacs/skribe.el.in */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Nov 23 13:16:30 2003 */ +;* Last change : Sun Jul 11 10:38:17 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe minor mode (major mode is supposed to be a */ +;* Scheme-like mode). */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* module */ +;*---------------------------------------------------------------------*/ +(provide 'skribe) +(require 'ude-custom) +(require 'ude-config) +(require 'ude-icon) +(require 'ude-autoload) +(require 'bmacs-config) +(require (if (featurep 'xemacs) 'bmacs-xemacs 'bmacs-gnu-emacs)) + +;*---------------------------------------------------------------------*/ +;* custom */ +;*---------------------------------------------------------------------*/ +;; skribe version +(defconst skribe-version "@SKRIBE_RELEASE@" + "*The Skribe version.") + +;; skribe group +(defgroup skribe nil + "Skribe Emacs Environment." + :tag "Skribe" + :prefix "skribe-" + :group 'processes) + +;; emacs directory +(defcustom skribe-emacs-dir '"@SKRIBE_EMACSDIR@" + "*Directory for Skribe Emacs installation." + :group 'skribe + :type '(string)) + +;; additional directories for online documentation +(defcustom skribe-docdirs '("@SKRIBE_DOCDIR@") + "*Directories for online documentation." + :group 'skribe + :type '(repeat (string))) + +;; Host scheme documentation +(defcustom skribe-host-scheme-docdirs '("@SKRIBE_HOSTSCHEMEDOCDIR@") + "*URL for hosting Scheme system." + :group 'skribe + :type '(string)) + +;; html browser +(defcustom skribe-html-browser "mozilla" + "*The binary file to run for browing HTML files or nil for Emacs mode." + :group 'skribe + :type '(choice string (const nil))) + +;; electric parenthesis +(defcustom skribe-electric-parenthesis t + "*Set his to nil if you don't want electric closing parenthesis." + :type 'boolean) + +;;;###autoload +(defcustom skribe-mode-line-string " Skr" + "*String displayed on the modeline when skribe is active. +Set this to nil if you don't want a modeline indicator." + :group 'skribe + :type '(choice string (const :tag "None" nil))) + +;; fixed indentation +(defcustom skribe-forced-indent-regexp ";;;\\|;[*]" + "*The regexp that marks a forced indentation" + :group 'skribe + :type 'string) + +;; normal indentation +(defcustom skribe-body-indent 3 + "*The Skribe indentation width" + :group 'skribe + :type 'integer) + +;; font lock +(defcustom skribe-font-lock-keywords + (list + (list (concat "\(\\(let\\|let[*]\\|letrec\\|define" + "\\|define-markup\\|set[!]" + "\\|lambda\\|labels" + "\\|let-syntax\\|letrec-syntax" + "\\|regular-grammar\\|lalr-grammar" + "\\|if\\|when\\|unless\\|begin\\|case\\|cond\\|else" + "\\|multiple-value-bind\\|values\\)[ :\n\t]") + 1 + 'font-lock-keyword-face) + + (list "(\\(document\\|chapter\\|section\\|subsection\\|subsubsection\\|paragraph\\|p\\|skribe-load\\|include\\|slide\\)[) \n]" + 1 + 'font-lock-function-name-face) + (list "(\\(toc\\|itemize\\|enumerate\\|description\\|item\\|the-bibliography\\|the-index\\|default-index\\|frame\\|center\\|table\\|tr\\|th\\|td\\|linebreak\\|footnote\\|color\\|author\\|prog\\|source\\|figure\\|image\\)[) \n]" + 1 + 'ude-font-lock-face-2) + (list "(\\(bold\\|code\\|emph\\|it\\|kbd\\|tt\\|roman\\|underline\\|var\\|samp\\|sc\\|sf\\|sup\\|sub\\)[ )]" + 1 + 'ude-font-lock-face-8) + (list "(\\(ref\\|mailto\\|mark\\|new\\)[) \n]" + 1 + 'ude-font-lock-face-3) + (cons "\\(:[^] \n)]+\\|#![a-zA-Z]+\\)" + 'ude-font-lock-face-7) + (cons "[[]\\|]" + 'ude-font-lock-face-3) + (list "(\\(markup-writer\\|make-engine\\|copy-engine\\|default-engine-set!\\|engine-custom\\|engine-custom-set!\\|engine-custom-add!\\|markup-option\\|markup-option-add!\\|markup-body\\)[ \n]" + 1 + 'font-lock-function-name-face) + (list ",(\\([^ \n()]+\\)" + 1 + 'ude-font-lock-face-6)) + "*The Skribe font-lock specification." + :group 'skribe) + +;; tool-bar +(defcustom skribe-toolbar + `(;; the spell button + ("spell.xpm" flyspell-buffer "Buffer spell check") + -- + ;; the compile button + (,ude-compile-icon ude-mode-compile-from-menu "Compile") + ;; the root button + (,ude-root-icon ude-user-set-root-directory "Set new root directory") + -- + ;; the repl button + (,ude-repl-icon ude-repl-other-frame "Start a read-eval-print loop") + -- + --> + -- + ;; online documentation + (,ude-help-icon skribe-doc-ident "Describe markup at point") + (,ude-info-icon skribe-manuals "Skribe online documentations")) + "*The Skribe toolbar" + :group 'skribe) + +;; paragraphs +(defcustom skribe-paragraph-start + "^\\(?:[ \t\n\f]\\|;;\\|[(]\\(?:section\\|sub\\|p\\|slide\\|document\\)\\)" + "*The regexp that marks a paragraph start" + :group 'skribe + :type 'string) + +(defcustom skribe-paragraph-separate + "^[ \t\f%]*$" + "*The regexp that marks a paragraph separation" + :group 'skribe + :type 'string) + +;*---------------------------------------------------------------------*/ +;* Which emacs are we currently running */ +;*---------------------------------------------------------------------*/ +(defvar skribe-emacs + (cond + ((string-match "XEmacs" emacs-version) + 'xemacs) + (t + 'emacs)) + "The type of Emacs we are currently running.") + +;*---------------------------------------------------------------------*/ +;* Autoloading */ +;*---------------------------------------------------------------------*/ +;;;###autoload +(defvar skribe-mode-map (make-sparse-keymap)) + +;;;###autoload +(if (fboundp 'add-minor-mode) + (add-minor-mode 'skribe-mode + 'skribe-mode-line-string + nil + nil + 'skribe-mode) + + (or (assoc 'skribe-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(skribe-mode skribe-mode-line-string) + minor-mode-alist))) + + (or (assoc 'skribe-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons (cons 'skribe-mode skribe-mode-map) + minor-mode-map-alist)))) + +;*---------------------------------------------------------------------*/ +;* skribe-manuals-menu-entry ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-manuals-menu-entry (s) + (let ((sym (gensym))) + (fset sym `(lambda () + (interactive) + (ude-system skribe-html-browser + (format "file:%s" (expand-file-name ,s))))) + (vector (file-name-nondirectory s) sym t))) + +;*---------------------------------------------------------------------*/ +;* skribe-directory-html-files */ +;*---------------------------------------------------------------------*/ +(defun skribe-directory-html-files (dirs) + (let ((dirs dirs) + (res '())) + (while (consp dirs) + (let ((dir (car dirs))) + (when (file-directory-p dir) + (setq res (append (directory-files dir t "^.+[^0-9][.]html$") res)) + (setq dirs (cdr dirs))))) + res)) + +;*---------------------------------------------------------------------*/ +;* skribe-manuals ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-manuals () + (interactive) + (when (stringp skribe-html-browser) + (let ((res (skribe-directory-html-files skribe-docdirs)) + (host (sort (skribe-directory-html-files skribe-host-scheme-docdirs) + 'string<))) + (if (= (length res) 1) + (ude-system skribe-html-browser + (format "file:%s" (expand-file-name (car res)))) + (let (user dir) + (let ((old res) + (new '())) + (while (consp old) + (let* ((f (car old)) + (b (file-name-nondirectory f))) + (setq old (cdr old)) + (cond + ((string-equal b "user.html") + (setq user f)) + ((string-equal b "dir.html") + (setq dir f)) + (t (setq new (cons f new)))))) + (let* ((rest (mapcar 'skribe-manuals-menu-entry + (sort new + '(lambda (s u) + (string< + (file-name-nondirectory s) + (file-name-nondirectory u)))))) + (smenu (cond + ((and user dir) + (append (list (skribe-manuals-menu-entry user) + (skribe-manuals-menu-entry dir) + "--:shadowEtchedInDash") + rest)) + ((dir) + (cons (skribe-manuals-menu-entry dir) rest)) + ((user) + (cons (skribe-manuals-menu-entry user) rest)) + (t + rest))) + (menu (if (consp host) + (append smenu + (cons "--:shadowEtchedInDash" + (mapcar 'skribe-manuals-menu-entry + host))) + smenu))) + (popup-menu + (cons "Doc" menu))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-scheme-indent-line ... */ +;*---------------------------------------------------------------------*/ +(defvar skribe-scheme-indent-line nil) +(make-variable-buffer-local 'skribe-scheme-indent-line) + +;*---------------------------------------------------------------------*/ +;* skribe-insert-parenthesis ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-insert-parenthesis (char) + ;; find the open parenthesis + (if skribe-electric-parenthesis + (let ((clo nil) + (tag nil)) + (save-excursion + (save-restriction + ;; Scan across one sexp within that range. + ;; Errors or nil mean there is a mismatch. + (insert ?\)) + (condition-case () + (let ((pos (scan-sexps (point) -1))) + (if pos + (progn + (save-excursion + (goto-char pos) + (forward-word 1) + (setq tag (buffer-substring (1+ pos) (point)))) + (setq clo (matching-paren (char-after pos)))) )) + (error nil)))) + (if clo + (progn + (delete-char 1) + (insert clo)) + (forward-char 1))) + (insert char))) + +;*---------------------------------------------------------------------*/ +;* skribe-parenthesis ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-parenthesis (&optional dummy) + "Automatic parenthesis closing of )." + (interactive) + ;; find the open parenthesis + (skribe-insert-parenthesis ?\))) + +;*---------------------------------------------------------------------*/ +;* skribe-bracket ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-bracket (&optional dummy) + "Automatic parenthesis closing of ]." + (interactive) + (skribe-insert-parenthesis ?\])) + +;*---------------------------------------------------------------------*/ +;* skribe-doc-ident ... */ +;* ------------------------------------------------------------- */ +;* On-line document for identifier IDENT. This spawns an */ +;* HTML browser for serving the documentation. */ +;*---------------------------------------------------------------------*/ +(defun skribe-doc-ident (ident) + (interactive (ude-interactive-ident (point) "Identifier: ")) + (and (stringp skribe-html-browser) + (let ((dirs skribe-docdirs)) + (while (consp dirs) + (let* ((dir (car dirs)) + (html-ref (ude-sui-find-ref ident dir))) + (if (stringp html-ref) + (progn + (ude-system skribe-html-browser + (format "file:%s/%s" + (expand-file-name dir) + html-ref)) + (setq dirs '())) + (setq dirs (cdr dirs)))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-mode ... */ +;*---------------------------------------------------------------------*/ +;;;###autoload +(defvar skribe-mode nil) +(make-variable-buffer-local 'skribe-mode) + +;*---------------------------------------------------------------------*/ +;* skribe-major-mode ... */ +;*---------------------------------------------------------------------*/ +;;;###autoload +(defun skribe-major-mode () + "Major mode for editing Skribe code." + (interactive) + (bee-mode) + (skribe-mode t)) + +;*---------------------------------------------------------------------*/ +;* skribe-mode ... */ +;*---------------------------------------------------------------------*/ +;;;###autoload +(defun skribe-mode (&optional arg) + "Minor mode for editing Skribe sources. + +Bindings: +\\[skribe-doc-ident]: on-line document. + +Hooks: +This runs `skribe-mode-hook' after skribe is enterend." + (interactive "P") + (let ((old-skribe-mode skribe-mode)) + ;; Mark the mode as on or off. + (setq skribe-mode (not (or (and (null arg) skribe-mode) + (<= (prefix-numeric-value arg) 0)))) + ;; Do the real work. + (unless (eq skribe-mode old-skribe-mode) + (if skribe-mode (skribe-activate-mode) nil)) + ;; Force modeline redisplay. + (set-buffer-modified-p (buffer-modified-p)))) + +;*---------------------------------------------------------------------*/ +;* skribe-return ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-return (&optional dummy) + "Automatic indentation on RET." + (interactive) + (newline) + (if (>= (point) (point-min)) + (skribe-indent-line))) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-line-toggle ... */ +;*---------------------------------------------------------------------*/ +(defvar skribe-indent-line-toggle nil) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-line ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-line () + (interactive) + (if (eq last-command 'skribe-indent-line) + (if skribe-indent-line-toggle + (skribe-do-indent-line) + (progn + (setq skribe-indent-line-toggle t) + (if skribe-scheme-indent-line + (funcall skribe-scheme-indent-line)))) + (skribe-do-indent-line))) + +;*---------------------------------------------------------------------*/ +;* skribe-do-indent-line ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-do-indent-line () + (setq skribe-indent-line-toggle nil) + (let ((start (point)) beg) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward " \t") + (let* ((pos (- (point-max) start)) + (indent (skribe-calculate-indent start))) + (when indent + (if (listp indent) (setq indent (car indent))) + (let ((shift-amt (- indent (current-column)))) + (if (zerop shift-amt) + nil + (delete-region beg (point)) + (indent-to indent)))) + ;; If initial point was within line's indentation, + ;; position after the indentation. + ;; Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))))) + +;*---------------------------------------------------------------------*/ +;* skribe-calculate-indent ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-calculate-indent (start &optional parse-start) + "Return appropriate indentation for current line as Skribe code. +In usual case returns an integer: the column to indent to. +Can instead return a list, whose car is the column to indent to. +This means that following lines at the same level of indentation +should not necessarily be indented the same way. +The second element of the list is the buffer position +of the start of the containing expression." + (or (skribe-calculate-forced-indent) + (skribe-calculate-free-indent start parse-start))) + +;*---------------------------------------------------------------------*/ +;* skribe-calculate-forced-indent ... */ +;* ------------------------------------------------------------- */ +;* Returns a column number iff the line indentation is forced */ +;* (i.e. the previous line starts with a "[ \t]*;;;"). Otherwise */ +;* returns f. */ +;*---------------------------------------------------------------------*/ +(defun skribe-calculate-forced-indent () + (save-excursion + (previous-line 1) + (beginning-of-line) + (skip-chars-forward " \t") + (let ((s (current-column))) + (and (looking-at skribe-forced-indent-regexp) s)))) + +;*---------------------------------------------------------------------*/ +;* skribe-calculate-free-indent ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-calculate-free-indent (start &optional parse-start) + (save-excursion + (beginning-of-line) + (let ((indent-point (point)) state paren-depth desired-indent (retry t) + last-sexp containing-sexp first-sexp-list-p skribe-indent) + (if parse-start + (goto-char parse-start) + ;; TOBE IMPROVED + (goto-char (point-min))) +;* (beginning-of-defun)) */ + ;; Find outermost containing sexp + (while (< (point) indent-point) + (setq state (parse-partial-sexp (point) indent-point 0))) + ;; Find innermost containing sexp + (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) + (setq retry nil) + (setq last-sexp (nth 2 state)) + (setq containing-sexp (car (cdr state))) + ;; Position following last unclosed open. + (goto-char (1+ containing-sexp)) + ;; Is there a complete sexp since then? + (if (and last-sexp (> last-sexp (point))) + ;; Yes, but is there a containing sexp after that? + (let ((peek (parse-partial-sexp last-sexp indent-point 0))) + (if (setq retry (car (cdr peek))) (setq state peek)))) + (if (not retry) + ;; Innermost containing sexp found + (progn + (goto-char (1+ containing-sexp)) + (if (not last-sexp) + ;; indent-point immediately follows open paren. + ;; Don't call hook. + (setq desired-indent (current-column)) + ;; Move to first sexp after containing open paren + (parse-partial-sexp (point) last-sexp 0 t) + (setq first-sexp-list-p (looking-at "\\s(")) + (cond + ((> (save-excursion (forward-line 1) (point)) + last-sexp) + ;; Last sexp is on same line as containing sexp. + ;; It's almost certainly a function call. + (parse-partial-sexp (point) last-sexp 0 t) + (if (/= (point) last-sexp) + ;; Indent beneath first argument or, if only one sexp + ;; on line, indent beneath that. + (progn (forward-sexp 1) + (parse-partial-sexp (point) last-sexp 0 t))) + (backward-prefix-chars)) + (t + ;; Indent beneath first sexp on same line as last-sexp. + ;; Again, it's almost certainly a function call. + (goto-char last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) last-sexp 0 t) + (backward-prefix-chars))))))) + ;; If looking at a list, don't call hook. + (if first-sexp-list-p + (setq desired-indent (current-column))) + ;; Point is at the point to indent under unless we are inside a string. + ;; Call indentation hook except when overriden by skribe-indent-offset + ;; or if the desired indentation has already skriben computed. + '(message-box (format "start=%s\nfirst-sexp-lisp-p: %s\nstate: %s\ndesired-indent: %s\nintegerp=%s\nchar-after=%s\ncur-char=%s\npoint=%s\nskribe-indent-function-p=%s\n" start first-sexp-list-p state desired-indent + (integerp (car (nthcdr 1 state))) + (char-after (car (nthcdr 1 state))) + (char-after (point)) + (point) + (skribe-indent-method state))) + (cond ((car (nthcdr 3 state)) + ;; Inside a string, don't change indentation. + (goto-char indent-point) + (skip-chars-forward " \t") + (setq desired-indent (current-column))) + ((skribe-indent-bracket-p state) + ;; indenting a bracket + (save-excursion + (goto-char start) + (skip-chars-forward " \t") + (let ((c (car (nthcdr 9 state)))) + (if (and (consp c) (looking-at ",(") nil) + (let ((l (length c))) + (if (< l 2) + (setq desired-indent 0) + (progn + (goto-char (car (nthcdr (- l 2) c))) + (setq desired-indent (current-column))))) + (setq desired-indent 0))))) + ((setq skribe-indent (skribe-indent-method state)) + ;; skribe special form + (setq desired-indent skribe-indent)) + (skribe-scheme-indent-line + ;; scheme form + (goto-char start) + (funcall skribe-scheme-indent-line) + (setq desired-indent nil)) + (t + ;; use default indentation if not computed yet + (setq desired-indent (current-column)))) + desired-indent))) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-bracket-p ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-bracket-p (state) + (or (and (integerp (car (nthcdr 1 state))) + (eq (char-after (car (nthcdr 1 state))) ?[)) + (let ((op (car (nthcdr 9 state)))) + (and (consp op) + (let ((po (reverse op)) + (context 'unknown)) + (save-excursion + (while (and (consp po) (eq context 'unknown)) + (cond + ((eq (char-after (car po)) ?[) + (setq context 'skribe)) + ((and (eq (char-after (car po)) ?\() + (> (car po) (point-min)) + (eq (char-after (1- (car po))) ?,)) + (setq context 'scheme)) + (t + (setq po (cdr po)))))) + (eq context 'skribe)))))) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-method ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-method (state) + (let ((is (car (nthcdr 1 state)))) + (and (integerp is) + (save-excursion + (goto-char is) + (let* ((function (intern-soft + (buffer-substring + (progn (forward-char 1) (point)) + (progn (forward-sexp 1) (point))))) + (method (get function 'skribe-indent))) + (if (functionp method) + (funcall method state) + nil)))))) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-function ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-function (state) + (save-excursion + (goto-char (car (nthcdr 1 state))) + (+ (current-column) skribe-body-indent))) + +;*---------------------------------------------------------------------*/ +;* normal-indent ... */ +;*---------------------------------------------------------------------*/ +(defvar normal-indent 0) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-sexp ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-sexp () + "Indent each line of the list starting just after point." + (interactive) + (let ((indent-stack (list nil)) (next-depth 0) last-depth bol + outer-loop-done inner-loop-done state this-indent) + (save-excursion (forward-sexp 1)) + (save-excursion + (setq outer-loop-done nil) + (while (not outer-loop-done) + (setq last-depth next-depth + inner-loop-done nil) + (while (and (not inner-loop-done) + (not (setq outer-loop-done (eobp)))) + (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) + nil nil state)) + (setq next-depth (car state)) + (if (car (nthcdr 4 state)) + (progn (skribe-comment-indent) + (end-of-line) + (setcar (nthcdr 4 state) nil))) + (if (car (nthcdr 3 state)) + (progn + (forward-line 1) + (setcar (nthcdr 5 state) nil)) + (setq inner-loop-done t))) + (if (setq outer-loop-done (<= next-depth 0)) + nil + (while (> last-depth next-depth) + (setq indent-stack (cdr indent-stack) + last-depth (1- last-depth))) + (while (< last-depth next-depth) + (setq indent-stack (cons nil indent-stack) + last-depth (1+ last-depth))) + (forward-line 1) + (setq bol (point)) + (skip-chars-forward " \t") + (if (or (eobp) (looking-at ";\\(;;\\|[*]\\)")) + nil + (let ((val (skribe-calculate-indent + (point) + (if (car indent-stack) (- (car indent-stack)))))) + (cond + ((integerp val) + (setcar indent-stack (setq this-indent val))) + ((consp val) + (setcar indent-stack (- (car (cdr val)))) + (setq this-indent (car val))) + (t + (setq this-indent nil)))) + (if (and (integerp this-indent) (/= (current-column) this-indent)) + (progn (delete-region bol (point)) + (indent-to this-indent))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-comment-indent ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-comment-indent (&optional pos) + (save-excursion + (if pos (goto-char pos)) + (cond + ((looking-at ";;;") + (current-column)) + ((looking-at ";*") + 0) + ((looking-at "[ \t]*;;") + (let ((tem (skribe-calculate-indent (point)))) + (if (listp tem) (car tem) tem))) + (t + (skip-chars-backward " \t") + (max (if (bolp) 0 (1+ (current-column))) + comment-column))))) + +;*---------------------------------------------------------------------*/ +;* skribe-custom-indent ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-custom-indent () + (save-excursion + (goto-char (point-min)) + ;; The concat is used to split the regexp so that it is nolonger + ;; to find itself! Without the split, the skribe mode cannot be + ;; used to edit this source file! + (let ((regexp (concat "@ind" "ent:\\([^@]+\\)@"))) + (while (re-search-forward regexp (point-max) t) + (condition-case () + (eval-region (match-beginning 1) (match-end 1) nil) + (error nil)))))) + +;*---------------------------------------------------------------------*/ +;* skribe-indent-load ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-indent-load (file) + (let ((lp (cons skribe-emacs-dir load-path))) + (while (consp lp) + (let ((f (concat (car lp) "/" file))) + (if (file-exists-p f) + (progn + (load f) + (set! lp '())) + (set! lp (cdr lp))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-activate-mode ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-activate-mode () + ;; buffer local global variables + (make-variable-buffer-local 'ude-extra-identifier-chars) + (setq ude-extra-identifier-chars "-") + ;; the keymap + (skribe-activate-keymap skribe-mode-map) + ;; font lock + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(skribe-font-lock-keywords)) + (font-lock-mode nil) + (font-lock-mode t) + ;; paragraph + (make-variable-buffer-local 'paragraph-start) + (setq paragraph-start skribe-paragraph-start) + (make-variable-buffer-local 'paragraph-separate) + (setq paragraph-separate skribe-paragraph-separate) + ;; try to retreive the globa'paragraph-startl indentation binding + (if (not skribe-scheme-indent-line) + (setq skribe-scheme-indent-line (global-key-binding "\t"))) + ;; the toolbar + (use-local-map skribe-mode-map) + (ude-toolbar-set skribe-toolbar) + ;; the custom indentation + (skribe-custom-indent) + ;; we end with the skribe hooks + (run-hooks 'skribe-mode-hook) + t) + +;*---------------------------------------------------------------------*/ +;* skribe-activate-keymap ... */ +;*---------------------------------------------------------------------*/ +(defun skribe-activate-keymap (map) + (define-key map "\C-m" 'skribe-return) + (define-key map "\e\C-m" 'newline) + (define-key map "\t" 'skribe-indent-line) + (define-key map ")" 'skribe-parenthesis) + (define-key map "]" 'skribe-bracket) + (define-key map "\e\C-q" 'skribe-indent-sexp) + (cond + ((eq skribe-emacs 'xemacs) + (define-key map [(control \))] (lambda () (interactive) (insert ")"))) + (define-key map [(control \])] (lambda () (interactive) (insert "]")))) + (t + (define-key map [?\C-\)] (lambda () (interactive) (insert ")"))) + (define-key map [?\C-\]] (lambda () (interactive) (insert "]")))))) + +;*---------------------------------------------------------------------*/ +;* Standard Skribe indent forms */ +;*---------------------------------------------------------------------*/ +(put 'make-engine 'skribe-indent 'skribe-indent-function) +(put 'copy-engine 'skribe-indent 'skribe-indent-function) +(put 'markup-writer 'skribe-indent 'skribe-indent-function) +(put 'engine-custom 'skribe-indent 'skribe-indent-function) +(put 'engine-custom-set! 'skribe-indent 'skribe-indent-function) +(put 'document 'skribe-indent 'skribe-indent-function) +(put 'author 'skribe-indent 'skribe-indent-function) +(put 'chapter 'skribe-indent 'skribe-indent-function) +(put 'section 'skribe-indent 'skribe-indent-function) +(put 'subsection 'skribe-indent 'skribe-indent-function) +(put 'subsubsection 'skribe-indent 'skribe-indent-function) +(put 'paragraph 'skribe-indent 'skribe-indent-function) +(put 'footnote 'skribe-indent 'skribe-indent-function) +(put 'linebreak 'skribe-indent 'skribe-indent-function) +(put 'hrule 'skribe-indent 'skribe-indent-function) +(put 'color 'skribe-indent 'skribe-indent-function) +(put 'frame 'skribe-indent 'skribe-indent-function) +(put 'font 'skribe-indent 'skribe-indent-function) +(put 'flush 'skribe-indent 'skribe-indent-function) +(put 'center 'skribe-indent 'skribe-indent-function) +(put 'pre 'skribe-indent 'skribe-indent-function) +(put 'prog 'skribe-indent 'skribe-indent-function) +(put 'source 'skribe-indent 'skribe-indent-function) +(put 'language 'skribe-indent 'skribe-indent-function) +(put 'itemize 'skribe-indent 'skribe-indent-function) +(put 'enumerate 'skribe-indent 'skribe-indent-function) +(put 'description 'skribe-indent 'skribe-indent-function) +(put 'item 'skribe-indent 'skribe-indent-function) +(put 'figure 'skribe-indent 'skribe-indent-function) +(put 'table 'skribe-indent 'skribe-indent-function) +(put 'tr 'skribe-indent 'skribe-indent-function) +(put 'td 'skribe-indent 'skribe-indent-function) +(put 'th 'skribe-indent 'skribe-indent-function) +(put 'image 'skribe-indent 'skribe-indent-function) +(put 'blockquote 'skribe-indent 'skribe-indent-function) +(put 'roman 'skribe-indent 'skribe-indent-function) +(put 'bold 'skribe-indent 'skribe-indent-function) +(put 'underline 'skribe-indent 'skribe-indent-function) +(put 'strike 'skribe-indent 'skribe-indent-function) +(put 'emph 'skribe-indent 'skribe-indent-function) +(put 'kbdb 'skribe-indent 'skribe-indent-function) +(put 'it 'skribe-indent 'skribe-indent-function) +(put 'tt 'skribe-indent 'skribe-indent-function) +(put 'code 'skribe-indent 'skribe-indent-function) +(put 'var 'skribe-indent 'skribe-indent-function) +(put 'smap 'skribe-indent 'skribe-indent-function) +(put 'sf 'skribe-indent 'skribe-indent-function) +(put 'sc 'skribe-indent 'skribe-indent-function) +(put 'sub 'skribe-indent 'skribe-indent-function) +(put 'sup 'skribe-indent 'skribe-indent-function) +(put 'mailto 'skribe-indent 'skribe-indent-function) +(put 'mark 'skribe-indent 'skribe-indent-function) +(put 'handle 'skribe-indent 'skribe-indent-function) +(put 'ref 'skribe-indent 'skribe-indent-function) +(put 'resolve 'skribe-indent 'skribe-indent-function) +(put 'bibliography 'skribe-indent 'skribe-indent-function) +(put 'the-bibliography 'skribe-indent 'skribe-indent-function) +(put 'make-index 'skribe-indent 'skribe-indent-function) +(put 'index 'skribe-indent 'skribe-indent-function) +(put 'the-index 'skribe-indent 'skribe-indent-function) +(put 'char 'skribe-indent 'skribe-indent-function) +(put 'symbol 'skribe-indent 'skribe-indent-function) +(put '! 'skribe-indent 'skribe-indent-function) +(put 'processor 'skribe-indent 'skribe-indent-function) +(put 'slide 'skribe-indent 'skribe-indent-function) +(put 'counter 'skribe-indent 'skribe-indent-function) diff --git a/skribe/etc/ChangeLog b/skribe/etc/ChangeLog new file mode 100644 index 0000000..6987245 --- /dev/null +++ b/skribe/etc/ChangeLog @@ -0,0 +1,698 @@ +Thu Jun 2 10:58:23 CEST 2005 (Manuel Serrano): + + *** Minor changes in acmproc.skr and html.skr in order to improve + HTML div generation of abstracts. + + +Thu May 26 12:59:53 CEST 2005 (Manuel Serrano): + + *** Fix LaTeX author address printing. + + +Sun Apr 10 09:10:31 CEST 2005 (Manuel Serrano): + + * Handles correctly LaTeX \charNUMNUMNUM commands in Skribebibtex. + This enables handling ~ as \char126. + + +Fri Mar 4 08:44:36 CET 2005 (Manuel Serrano): + + *** Fix HTML inner links. If the reference pointed to by a link + is located inside the document, the link doest contain the file name + any longer. This enables the renaming of the HTML file while preserving + the correctness of the HTML links. + + +Wed Nov 17 11:10:53 CET 2004 (Erick Gallesio, Manuel Serrano): + + ********* release 1.2b. + + +Wed Nov 10 11:03:47 CET 2004 (Manuel Serrano): + + * The image conversion process is now coherent. That is, when an + image does not need conversion, it is still copied into the + output directory. + + +Mon Nov 8 11:00:07 CET 2004 (Erick Gallesio) + + * skr/web-book.skr: Added the option :margin-title to web-book + + +Thu Oct 28 21:53:34 CEST 2004 (Erick Gallesio) + + * New back-end using the ConTeXt TeX macro package + + +Tue Oct 26 10:52:05 CEST 2004 (Erick Gallesio): + + * Added the STklos skribebibtex. Makefile and hierearchy changed + accordingly. + + +Thu Oct 21 14:55:04 CEST 2004 (Ludovic Courtès): + + *** Bibliography parsers use SKRIBE-READ instead of READ. + + +Mon Oct 11 15:47:08 CEST 2004 (Manuel Serrano): + + *** Fix TABLE construction in src/common/api.scm. + + +Fri Oct 8 22:14:06 CEST 2004 (Manuel Serrano): + + *** Fix a bug in src/common/api.scm. The subsection environment + was erroneously represented as a shared constant instead of a + freshly allocated list. + + +Thu Sep 23 19:30:13 CEST 2004 (Manuel Serrano): + + *** Fix the definition of the ITEM markup that was erroneously + doubling its :key attribute. + + +Thu Sep 23 17:15:21 CEST 2004 (Erick Gallesio) + + * In the documentation the installed skribe-config script was used, + instead of the one of the distribution. Fixed. + + +Wed Sep 22 14:51:45 CEST 2004 (Damien Ciabrini): + + * New latex-simple.skr Skribe style that let's LaTex handling + references, links, and the enables non-breakable ~ character. + + +Wed Sep 22 14:11:36 CEST 2004 (Manuel Serrano): + + *** Improve error detections. + + +Wed Sep 22 02:13:59 CEST 2004 (Manuel Serrano): + + * Change the start and stop SOURCE markup. These can now be + integer standing for line numbers or then can be marks matched + against the beginning of the lines. + + +Sun Jul 11 10:38:23 CEST 2004 (Manuel Serrano): + + *** Fix SKRIBE.el paragraph delimiters. + + +Wed Jul 7 06:23:49 CEST 2004 (Manuel Serrano): + + *** Switch the execution order of verify and resolve. Resolve now + takes place *before* verify (because verify simply requires the + ast to be already resolved). + + +Wed Jun 23 16:56:57 CEST 2004 (Manuel Serrano): + + *** etc/bigloo/configure, README.java: add JVM visibility over the + environment variable SKRIBEPATH. + + +Tue Jun 22 09:47:37 CEST 2004 (Manuel Serrano): + + * skr/html.skr: Add the inline-css HTML engine custom. + + +Mon May 31 18:51:09 CEST 2004 (Erick Gallesio) + + *** skr/html.skr: Added the charset custom to html + + +Mon May 31 14:35:17 CEST 2004 (Manuel Serrano): + + *** skr/html.skr: fix a small HTML compliance bug in the TD/TH + background color emission. + + +Fri May 21 16:44:53 CEST 2004 (Yann Dirson): + + *** Add DESTDIR to generated Bigloo Makefiles (in order to ease + the Debian package). + + +Fri May 21 16:12:48 CEST 2004 (Stéphane Epardaud): + + *** src/bigloo/engine.scm: Fix a bug in ENGINE-FORMAT? + + +Fri May 21 15:54:46 CEST 2004 (Manuel Serrano): + + *** skr/web-book.skr: Add subsection to navigation tocs. + + +Mon May 17 10:14:25 CEST 2004 (Manuel Serrano): + + *** src/bigloo/xml.scm: Improve XML fontification. + + +Mon May 10 21:00:10 CEST 2004 (Manuel Serrano): + + *** skr/html.skr: Fix an error in negative relative font size handling. + + +Thu Apr 29 05:52:53 CEST 2004 (Manuel Serrano): + + *** skr/html.skr: Add JS custom. + + * src/common/lib.scm: Add ENGINE-CUSTOM-ADD!. + + +Tue Apr 20 13:40:00 CEST 2004 (Manuel Serrano): + + *** skr/html.skr: Add &html-figure-legend to the figure + writer. + + +Tue Apr 20 12:07:36 CEST 2004 (Manuel Serrano): + + *** skr/base.skr: fix a bug in &bib-entry emission. The writer + used to display the label of the entry (&bib-entry-label) was + the writer of the default engine instead of the engine of the + dynamically active engine. + + +Tue Apr 13 10:11:33 CEST 2004 (Manuel Serrano): + + *** skr/html.skr: Fix SUI mark reference generation. + + +Tue Apr 6 06:58:28 CEST 2004 (Manuel Serrano): + + *** doc/user/{engine,latexe}.skb: add document about engines. + + +Thu Apr 1 14:43:47 CEST 2004 (Manuel Serrano): + + *** src/bigloo/evapi.scm: export the SKRIBE-READ function into + the standard api. + + +Fri Mar 26 05:50:10 CET 2004 (Manuel Serrano): + + *** skr/latex.skr, skr/slide.skr: fix PRE and PROG LaTeX tabcolsep. + + +Wed Mar 24 16:37:06 CET 2004 (Manuel Serrano): + + *** skr/latex.skr: add the postdocument custom. + + *** skr/web-article.skr: fix illegal html identifiers (add + calls to STRING-CANONICALIZE). + + +Mon Mar 22 15:53:37 CET 2004 (Erick Gallesio): + + * Fix a bash problem in the configure driver script. + + +Tue Mar 16 09:44:49 CET 2004 (Erick Gallesio, Manuel Serrano): + + ********* release 1.1a. + + +Mon Mar 15 00:00:37 CET 2004 (Erick Gallesio): + + *** skr/html.skr: Changed the generated JavaScript for email + obfuscation to be conform to HTML 4. This is an ugly hack. + + +Thu Mar 11 11:28:17 CET 2004 (Manfred Lotz): + + *** emacs/emacs.el.in: Fix error in font lock declarations. + + *** skr/latex.skr: fix inconsistency in bold face generation. + + +Wed Mar 10 06:06:48 CET 2004 (Manuel Serrano): + + *** src/lib/bigloo.bgl, skr/latex.skr: fix a path bug in + BUILTIN-CONVERT-IMAGE. The generated image was generated in the + source directory but it should be generated in the target directory. + + +Mon Mar 8 11:40:46 CET 2004 (Manuel Serrano): + + * src/common/lib.scm: add an optional filler to LIST-SPLIT. + + +Sat Mar 6 21:17:45 CET 2004 (Manuel Serrano): + + *** skr/html.skr: change the generation of font markup. It now uses + <big> and <small> as much as possible. + + *** skr/html.skr: fix mailto markup. + + +Fri Mar 5 18:45:34 CET 2004 (Manuel Serrano): + + *** src/{bigloo,stklos}/{engine,types,writer}.{scm,stk} rename + inherit in delegate. + + +Sun Feb 29 06:40:53 CET 2004 (Manuel Serrano): + + *** src/bigloo/lib.bgl: change image conversion in order to avoid + new conversion when the target image already exists. + + *** src/bigloo/writer.scm: change MARKUP-WRITER-GET. The optional + argument PRED may now be #unspecified which means that writers + predicate are not checked during the search. + + +Sat Feb 28 10:18:16 CET 2004 (Erick Gallesio): + + *** src/stklos/reader.stk (%read-bracket): Bug correction: ",(" + sequences in strings were interpreted. + + +Thu Feb 26 20:44:50 CET 2004 (Erick Gallesio): + + *** main.stk: Added the --use-variant option + +Thu Feb 26 16:33:49 CET 2004 (Erick Gallesio): + + *** Documentation can now be conform to HTML 4.01, if compiled + using html4.skr + + +Thu Feb 26 10:18:21 CET 2004 (Manuel Serrano): + + * src/common/api.scm, skr/html.skr: ref markups have no default class. + The HTML engine generates a class which is the name of the protocol + of the reference (i.e., ftp, http, file, ...) for url references. + + +Wed Feb 25 06:41:51 CET 2004 (Manuel Serrano): + + *** src/bigloo/engine.scm: add PUSH-DEFAULT-ENGINE and + POP-DEFAULT-ENGINE. + + +Wed Feb 25 01:03:22 CET 2004 (Erick Gallesio): + + *** skr/html4.skr: File that must be preloaded to produce HTML + 4.01 output + + +Mon Feb 23 10:13:57 CET 2004 (Manuel Serrano): + + *** skr/latex.skr: change the output of URL-REF when a text is + provided. + + +Sat Feb 21 10:39:26 CET 2004 (Manuel Serrano): + + * Document standard packages (letter, french, web-book, acmproc, ...). + + +Fri Feb 20 07:36:09 CET 2004 (Manuel Serrano): + + *** skr/html.skr: add the lower case Nu greek symbol. + + +Thu Feb 19 18:28:43 CET 2004 (Manuel Serrano): + + * doc/skr/api.skr: Improve MAKE-ENGINE? predicate in order to + break deeply recursive searches. + +Wed Feb 19 00:48:47 CET 2004 (Erick Gallesio): + *** src/stklos/writer.stk: writers can be cloned with COPY-MARKUP-WRITER + +Wed Feb 18 22:55:20 CET 2004 (Erick Gallesio): + + *** src/stklos/output.stk: added a way to insert a validation phase + before outputting a markup. This should permit, for instance to + verify that a document is conform to certain constraints, as a DTD. + +Wed Feb 18 13:25:47 CET 2004 (Manuel Serrano): + + *** src/bigloo/lib.bgl: change STRING-CANONICALIZE to get rid + of #\# characters that pose problem for both HTML and LaTeX. + + +Wed Feb 18 12:03:11 CET 2004 (Manuel Serrano): + + *** skr/latex.skr: improve error detection of FONT markups. + + +Tue Feb 17 13:26:38 CET 2004 (Manuel Serrano): + + *** src/common/api.scm, skr/html.skr, skr/latex.skr: fix the big + mess about string used by references (string-canonicalize). + + *** src/common/api.scm, skr/html.skr, skr/latex.skr: fix bibliography + references. Bibliography database must be loaded prior to bibliography + entries are referenced. Otherwise, this causes a problem of fix + point iterations between citations and database printing. + + +Tue Feb 17 11:36:19 CET 2004 (Damien Ciabrini): + + *** src/common/sui.scm: fix sui subsection and subsubsection + searches. + + +Tue Feb 17 06:42:44 CET 2004 (Manuel Serrano): + + *** skr/html.skr, skr/latex.skr: add the TABLE rules 'header + option. + + +Mon Feb 16 15:02:19 CET 2004 (Manuel Serrano): + + *** tools/skribebibtex/skribebibtex.scm: add n~ and N~ character + parsing. + + +Thu Feb 12 22:26:31 CET 2004 (Manuel Serrano): + + *** Get rid of the user stage. + + +Thu Feb 12 16:31:41 CET 2004 (Manuel Serrano): + + *** src/common/api.scm: fix table border width handling (option + was ignored). + + +Thu Feb 12 16:13:48 CET 2004 (Manuel Serrano): + + *** src/common/api.scm, skr/html.skr: Improve HTML4.01 compliance. + + +Thu Feb 12 10:42:30 CET 2004 (Manuel Serrano): + + *** src/bigloo/lisp.scm, skr/html.skr, skr/latex.skr: add + &source-error markup. + + +Wed Feb 11 09:48:08 CET 2004 (Manuel Serrano): + + *** src/bigloo/types.scm: The functions LANGUAGE-NAME, + LANGUAGE-FONTIFIER, and LANGUAGE-EXTRACTOR are now exported and + visible from the standard Skribe runtime system. + + *** src/common/api.scm, skr/html.skr: Change the default table + attributes value for BORDER, CELLPADDING, and CELLSPACING in order + to get rid of warning messages when producing LaTeX documents. + + +Mon Feb 9 20:38:28 CET 2004 (Manuel Serrano): + + *** skr/latex.skr: fix tt, code, pre engine that were not using + the correct symbol table. + + +Mon Feb 9 09:44:59 CET 2004 (Manuel Serrano): + + *** src/bigloo/lib/bgl: fix the STRING-CANONICALIZE function + so now it turns #\space into #\_. + + +Mon Feb 9 06:40:33 CET 2004 (Manuel Serrano): + + *** src/bigloo/main.scm: the RC file (.skribe/skriberc) is now loaded + before the command line is parsed. + + +Sat Feb 7 08:23:38 CET 2004 (Manuel Serrano): + + * configure, src/bigloo/configure.bgl, src/common/configure.scm: + Improve the configuration mechanism (enabling dynamic configuration + tests). + + +Fri Feb 6 10:10:31 CET 2004 (Manuel Serrano): + + *** skr/html.skr, skr/slide.skr, skr/web-article.skr: redesign HTML + header generation. + + +Wed Feb 4 14:58:25 CET 2004 (Manuel Serrano): + + *** src/common/index.scm: indexes letter references are now + made unique. + + +Wed Feb 4 05:24:51 CET 2004 (Manuel Serrano): + + *** src/common/api.scm, src/{common,bigloo}/index.scm: improve + error localization for indexes. + + *** skr/base.skr: improve indexed generation. + + +Tue Feb 3 11:58:43 CET 2004 (Manuel Serrano): + + * src/bigloo/param.scm, src/bigloo/parse-args.scm, src/bigloo/eval.scm: + add the -w?level command line option. + + +Tue Feb 3 05:51:41 CET 2004 (Manuel Serrano): + + *** src/common/api.scm, skr/{html.skr,latex.skr}, doc/user/table.skb: + Redesign of tables. + + +Mon Feb 2 09:43:28 CET 2004 (Manuel Serrano): + + *** skr/html.skr: Improve HTML4.01 compliance. + + *** skr/latex.skr: Fix LaTeX symbol table. + + *** src/common/api.scm: Fix color declaration in TC and TR. + + +Sun Feb 1 06:18:08 CET 2004 (Manuel Serrano): + + *** src/bigloo/c.scm, src/bigloo/xml.scm: fix multi-lines + fontification in C and XML mode. Older fontification was producing + ill-formed LaTeX outputs. + + *** src/common/api.scm: fix figure identifier. + + +Wed Jan 28 20:57:11 CET 2004 (Manuel Serrano): + + * WEB-ARTICLE.SKR now supports the :css option that enables CSS + production and sets the CSS to be used. + + +Mon Jan 26 15:25:12 CET 2004 (Manuel Serrano): + + *** skr/html.skr: various HTML4.01 conformity fixes. + + +Sun Jan 25 18:31:19 CET 2004 (Manuel Serrano): + + *** skr/slide.skr: fix a error is the slide numbering. + + +Thu Jan 22 07:28:08 CET 2004 (Manuel Serrano): + + *** src/common/api.scm: fix a bug in multiple bib references. + + +Sun Jan 18 11:55:56 CET 2004 (Manuel Serrano): + + *** skr/html.skr: fix a bug in the HTML class attribute production. + + * src/bigloo/asm.scm: Creation of the assembly fontification (asm). + + +Sat Jan 17 18:26:00 CET 2004 (Manuel Serrano): + + * src/bigloo/api.sch, skr/slide.skr: Change the definition + of DEFINE-MARKUP. This macro now defines a function and a macro. + The macro adds an extra parameters called &SKRIBE-EVAL-LOCATION + that can be used inside the body of the defined function to retrieve + the location of the call. This is extremely useful for function + that defines new nodes. In general, it is desired that the location + associated with these nodes is the user call to the function that + has created the node, instead of the location of the call to + the constructor. + + +Fri Jan 16 06:56:14 CET 2004 (Manuel Serrano): + + * emacs/skribe.el.in: fontification of markups "PROG" and "SOURCE". + + * skr/html.skr, skr/web-article.skr: explicit introduction of two + dummy markups &HTML-DOCUMENT-HEADER and &HTML-DOCUMENT-TITLE for + enabling user fine-grain customizations. + + +Thu Jan 15 17:57:01 CET 2004 (Manuel Serrano): + + *** src/bigloo/eval.scm, src/bigloo/lib.bgl, src/bigloo/resolve.scm, + src/common/api.scm: + Improved location detection for unbound references (such as + unbound (ref :bib ...). + + +Wed Jan 14 08:03:18 CET 2004 (Manuel Serrano): + + * src/common/api.scm, src/common/bib.scm, src/bigloo/bib.bgl, + doc/user/bib.skb, doc/user/links.skb: change the bibliography + table mechanism. Bib tables are now first class citizen. + + +Tue Jan 13 16:22:30 CET 2004 (Manuel Serrano): + + * src/bigloo/eval.scm, src/bigloo/parse-args.scm, src/bigloo/lib.bgl, + src/common/api.scm, src/bigloo/source.scm, doc/user/lib.skb: + Creation of the SKRIBE-{IMAGE,BIB,SOURCE}-PATH and + SKRIBE-{IMAGE,BIB,SOURCE}-PATH-SET! functions. + + * src/common/api.scm, skr/html.skr, skr/latex.skr, doc/usr/image.skb: + Add :URL image option. + + +Tue Jan 13 09:02:18 CET 2004 (Manuel Serrano): + + *** src/bigloo/eval.scm, src/bigloo/parse-args.scm, doc/user/lib.skb: + Remove the SKRIBE-PATH-ADD! function. Only SKRIBE-PATH-SET! lefts. + + +Tue Jan 13 08:59:17 CET 2004 (Todd Dukes): + + *** configure: Fix illegal shell exports. + + +Mon Jan 12 13:50:29 CET 2004 (Manuel Serrano): + + * src/bigloo/eval.scm: Add the functions SKRIBE-PATH, SKRIBE-PATH-SET!, + and SKRIBE-PATH-ADD!. + + +Mon Jan 12 12:02:58 CET 2004 (Manuel Serrano): + + *** skr/latex.skr: fix when color were disabled. + + +Mon Jan 12 09:17:46 CET 2004 (Manuel Serrano): + + *** skr/html.skr: change the default value of css which used to + be '(quote ()) and which is now (). + + +Sat Jan 10 10:00:08 CET 2004 (Manuel Serrano): + + * src/common/api.scm, src/bigloo/types.scm, src/bigloo/output.scm: + Add the PROCEDURE field to PROCESSOR nodes . + + * skr/web-article.skb: Creation of this new package. + + +Fri Jan 9 15:35:03 CET 2004 (Manuel Serrano): + + * The slide.skr package is now documented in the user manual. + + * SKRIBE-LOAD and SKRIBE-LOAD-OPTIONS are now documented. + + +Wed Jan 7 16:37:52 CET 2004 (Manuel Serrano): + + * skr/html.skr, skr/latex.skr: fix &source-type and + &source-bracket markups implementation. + + +Wed Jan 7 11:29:16 CET 2004 (Manuel Serrano): + + * src/bigloo/color.scm: colors are lower case, the search + color search is lower case. + + *** src/bigloo/color.scm: fix a bug in the string search. + + *** skr/latex.skr: The LaTeX engines now uses the "symbol" itemize + option. + + *** skr/latex.skr: The LaTeX engines now uses the "key" item + option. + + +Wed Jan 7 06:12:53 CET 2004 (Manuel Serrano): + + * Add skribe-emacs-dir in emacs/skribe.el.in. + + * Add the skribe-indent-load in emacs/skribe.el.in. + + * Add --emacs-dir in etc/skribe-config. + + +Sat Jan 3 06:59:15 CET 2004 (Manuel Serrano): + + * etc/ChangeLog is now included in the distribution and included + in the Web page. + + * Extensions are now uploaded on the Skribe ftp server. They are + also listed from the Skribe Web page. + + +Fri Jan 2 21:21:52 CET 2004 (Manuel Serrano): + + * Add a chapter for skribe-config in the user documentation. + + * Creation of the directory documentation that gives information + about the installed extensions. + + +Thu Jan 1 06:21:39 CET 2004 (Manuel Serrano): + + * Implement the SUI link mechanisms. + + *** Fix RESOLVE-SEARCH-PARENT whose behavior was incorrect for orphans. + + * Add SKRIBE-DOC-DIR in configure.scm.in. + + +Dec 30 22:09:54 CET 2003 (Manuel Serrano): + + *** Fix FIND-MARKUP-IDENT whose return type was incorrect. + + * Add the :URL option to the INDEX markup. + + +Thu Dec 18 09:12:33 CET 2003 (Erick Gallesio, Manuel Serrano): + + ********* release 1.0a. + + +Wed Dec 17 10:22:27 CET 2003 (Manuel Serrano): + + * Change the processor nodes. The COMBINATOR argument is no longer + required to be a procedure. It can be #f. + + * Export predicates such as COMMAND?, UNRESOLVED? and PROCESSOR?. + Export the accessors associated with these primitive types. + + +Tue Dec 9 16:44:01 CET 2003 (Manuel Serrano): + + * the "q" markup now introduces a new node that is handled by the + engines. + + +Thu Dec 4 09:53:24 CET 2003 (Manuel Serrano): + + * Bib (Bigloo) manager now detects duplicate entries. + + *** Fix LaTeX engine (latex.skr). LaTeX titles (for chapters, + sections, ...) where incorrects. + + *** Various fixes in skribe.el. + + +Mon Nov 24 10:28:15 CET 2003 (Manuel Serrano): + + * Add -c, --custom command line options. + + * Re-design the SUI file generation. diff --git a/skribe/etc/Makefile b/skribe/etc/Makefile new file mode 100644 index 0000000..349fcf8 --- /dev/null +++ b/skribe/etc/Makefile @@ -0,0 +1,50 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/etc/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Sat Oct 25 08:29:30 2003 */ +#* Last change : Sat Jan 3 06:40:19 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Skribe Meta etc Makefile */ +#*=====================================================================*/ +include ../etc/Makefile.config +include ../etc/$(SYSTEM)/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo etc/Makefile etc/skribe-config.in etc/ChangeLog + @ (cd bigloo && $(MAKE) pop) + @ (cd stklos && $(MAKE) pop) + +#*---------------------------------------------------------------------*/ +#* Install/Uninstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: $(DESTDIR)$(INSTALL_EXTDIR) + cp skribe-config $(DESTDIR)$(INSTALL_BINDIR) && \ + chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe-config + +uninstall: + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe-config + +$(DESTDIR)$(INSTALL_EXTDIR): + mkdir -p $(DESTDIR)$(INSTALL_EXTDIR) && chmod a+rx $(DESTDIR)$(INSTALL_EXTDIR) + + +#*---------------------------------------------------------------------*/ +#* clean/distclean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean distclean + +clean: + (cd $(SYSTEM) && $(MAKE) clean) + +distclean: clean + (cd $(SYSTEM) && $(MAKE) distclean) + $(RM) -f skribe-config config diff --git a/skribe/etc/bigloo/Makefile b/skribe/etc/bigloo/Makefile new file mode 100644 index 0000000..82ffceb --- /dev/null +++ b/skribe/etc/bigloo/Makefile @@ -0,0 +1,114 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/etc/bigloo/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Thu Oct 23 08:58:55 2003 */ +#* Last change : Wed Nov 17 10:51:50 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Bigloo etc Makefile */ +#*=====================================================================*/ +include Makefile.skb +include ../Makefile.config + +#*---------------------------------------------------------------------*/ +#* TMPDIR */ +#*---------------------------------------------------------------------*/ +DISTRIBTMPDIR = /tmp +DISTRIBDIR = $$HOME/prgm/distrib + +#*---------------------------------------------------------------------*/ +#* POPULATION */ +#*---------------------------------------------------------------------*/ +POPULATION = configure Makefile Makefile.tpl + +#*---------------------------------------------------------------------*/ +#* distrib */ +#* ------------------------------------------------------------- */ +#* This rule must be executed in the main SKribe directory */ +#* (i.e. ../..). They must be run with a command such as: */ +#* "cd skribe; make -f etc/bigloo/Makefile distrib". */ +#*---------------------------------------------------------------------*/ +.PHONY: distrib distrib-src distrib-jvm + +distrib: distrib-src # distrib-jvm + +#*--- distrib-src -----------------------------------------------------*/ +distrib-src: + @ echo "[0m[1;31m>>> distrib-src[0m"; \ + (skribedir=`pwd` \ + && /bin/rm -rf $(DISTRIBTMPDIR)/skribe \ + && mkdir -p $(DISTRIBTMPDIR)/skribe \ + && cd $(DISTRIBTMPDIR)/skribe \ + && $(MAKE) -f $$skribedir/Makefile -I $$skribedir checkout \ + && /bin/rm -rf contribs \ + && $(MAKE) -f $$skribedir/etc/bigloo/Makefile -I $$skribedir/etc/bigloo do-distrib-src \ + && $(RM) -rf $(DISTRIBTMPDIR)/skribe$(SKRIBERELEASE)) + +.PHONY: do-distrib-src +do-distrib-src: + (cd .. && \ + mv skribe skribe$(SKRIBERELEASE) && \ + tar cvfz $(DISTRIBDIR)/skribe$(SKRIBERELEASE).tar.gz skribe$(SKRIBERELEASE)) + +#*--- distrib-jvm -----------------------------------------------------*/ +distrib-jvm: + @ echo "[0m[1;32m>>> distrib-jvm[0m"; \ + (skribedir=`pwd` \ + && /bin/rm -rf $(DISTRIBTMPDIR)/skribe \ + && mkdir -p $(DISTRIBTMPDIR)/skribe \ + && cd $(DISTRIBTMPDIR)/skribe \ + && $(MAKE) -f $$skribedir/Makefile -I $$skribedir checkout \ + && /bin/rm -rf contribs \ + && $(MAKE) -f $$skribedir/etc/bigloo/Makefile -I $$skribedir/etc/bigloo do-distrib-jvm \ + && $(RM) -rf $(DISTRIBTMPDIR)/skribe) + +.PHONY: do-distrib-jvm +do-distrib-jvm: lib bin lib/bigloo_s.zip + $(RM) -f $(DISTRIBDIR)/skribe$(SKRIBERELEASE).zip + (./configure --with-bigloo --jvm \ + && $(MAKE) \ + && cd .. \ + && zip -qr $(ZFLAGS) $(DISTRIBDIR)/skribe$(SKRIBERELEASE).zip \ + skribe \ + -x "*~" \ + -x "*/bin/*-bigloo" \ + -x "*.class" \ + -x "*.o") + +#*--- bigloo_s.zip ----------------------------------------------------*/ +lib/bigloo_s.zip: lib + cp $(FILDIR)/bigloo_s.zip $@ + +#*--- lib -------------------------------------------------------------*/ +lib: + mkdir -p lib + +#*--- bin -------------------------------------------------------------*/ +bin: + mkdir -p bin + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo $(POPULATION:%=etc/bigloo/%) + @ (cd autoconf && $(MAKE) -s pop) + +#*---------------------------------------------------------------------*/ +#* clean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean distclean + +clean: + /bin/rm -f ../../lib/bigloo_s.zip + +#*--- distclean -------------------------------------------------------*/ +distclean: + /bin/rm -f Makefile.skb + /bin/rm -f ../../src/common/configure.scm + + + diff --git a/skribe/etc/bigloo/Makefile.tpl b/skribe/etc/bigloo/Makefile.tpl new file mode 100644 index 0000000..24326c1 --- /dev/null +++ b/skribe/etc/bigloo/Makefile.tpl @@ -0,0 +1,200 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/etc/bigloo/Makefile.tpl */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Wed Nov 7 09:20:47 2001 */ +#* Last change : Wed Feb 18 11:23:12 2004 (serrano) */ +#* Copyright : 2001-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* Standard Skribe makefile to build various libraries. */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* Compilers, Tools and Destinations */ +#*---------------------------------------------------------------------*/ +# The heap file +HEAP_FILE = $(LIB)/$(TARGETNAME).heap +HEAPJVM_FILE = $(LIB)/$(TARGETNAME).jheap +# Where to store the library class files +PBASE = bigloo.skribe.$(TARGETNAME) +CLASS_DIR = o/class_s/bigloo/skribe/$(TARGETNAME) +O_DIR = o + +BUNSAFEFLAGS = -unsafe + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .scm .class .o + +#*---------------------------------------------------------------------*/ +#* The implicit rules */ +#*---------------------------------------------------------------------*/ +$(O_DIR)/%.o: %.scm + $(BIGLOO) $(BUNSAFEFLAGS) $(BCFLAGS) $(BCOMMONFLAGS) -c $< -o $@ + +$(CLASS_DIR)/%.class: %.scm + $(BIGLOO) $(BUNSAFEFLAGS) $(BJVMFLAGS) $(BCOMMONFLAGS) -c $< -o $@ + +#*---------------------------------------------------------------------*/ +#* bin */ +#*---------------------------------------------------------------------*/ +.PHONY: bin-c bin-jvm + +#*--- bin-c -----------------------------------------------------------*/ +bin-c: $(TAGS) .afile .etags $(O_DIR) $(SKRIBEBINDIR)/$(TARGETNAME).bigloo + +$(SKRIBEBINDIR)/$(TARGETNAME).bigloo: $(OBJECTS) + $(BIGLOO) $(BUNSAFEFLAGS) $(BLINKFLAGS) $(BCOMMONFLAGS) $(OBJECTS) -o $(SKRIBEBINDIR)/$(TARGETNAME).bigloo + @ echo "$(SKRIBEBINDIR)/$(TARGETNAME).bigloo done..." + @ echo "-------------------------------" + +#*--- bin-jvm ---------------------------------------------------------*/ +bin-jvm: $(TAGS) .afile .etags .jfile $(CLASS_DIR) $(SKRIBEBINDIR)/$(TARGETNAME).zip + +$(SKRIBEBINDIR)/$(TARGETNAME).zip: $(CLASSES) + @ /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).zip + @ (cd $(O_DIR)/class_s; \ + $(ZIP) -q $(ZFLAGS) $(SKRIBEBINDIR)/$(TARGETNAME).zip -r .) + @ echo "$(SKRIBEBINDIR)/$(TARGETNAME).zip done..." + @ echo "-------------------------------" + +#*---------------------------------------------------------------------*/ +#* Directories */ +#*---------------------------------------------------------------------*/ +$(O_DIR): + mkdir -p $(O_DIR) + +$(CLASS_DIR): + mkdir -p $(CLASS_DIR) + +#*---------------------------------------------------------------------*/ +#* The heap construction */ +#*---------------------------------------------------------------------*/ +.PHONY: heap heap-c heap-jvm + +heap-c: $(HEAP_FILE) +heap-jvm: $(HEAPJVM_FILE) + +$(HEAP_FILE): .afile make-lib.scm + @ \rm -f $(HEAP_FILE) + @ $(BIGLOO) $(BHEAPFLAGS) make-lib.scm -addheap $(HEAP_FILE) + @ echo "Heap Done..." + @ echo "-------------------------------" + +$(HEAPJVM_FILE): .jfile .afile make-lib.scm + @ \rm -f $(HEAPJVM_FILE) + @ $(BIGLOO) -jvm $(BHEAPFLAGS) make-lib.scm -addheap $(HEAPJVM_FILE) + @ echo "Heap JVM Done..." + @ echo "-------------------------------" + +#*---------------------------------------------------------------------*/ +#* lib */ +#*---------------------------------------------------------------------*/ +.PHONY: lib-c lib-jvm + +#*--- lib-c -----------------------------------------------------------*/ +lib-c: $(TAGS) .afile lib.$(SHAREDSUFFIX) lib.a + +lib.$(SHAREDSUFFIX): $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) $(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX) +lib.a: $(LIB)/lib$(TARGETNAME)_s.a $(LIB)/lib$(TARGETNAME)_u.a + +$(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX): $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) + cd $(LIB); \ + /bin/rm -f lib$(TARGETNAME)_u.$(SHAREDSUFFIX); \ + ln -s lib$(TARGETNAME)_s.$(SHAREDSUFFIX) lib$(TARGETNAME)_u.$(SHAREDSUFFIX) + +$(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX): .afile $(OBJECTS) + @ /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) + @ $(LD) -o $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) $(OBJECTS) -lm -lc + @ echo "lib$(TARGETNAME)_s.$(SHAREDSUFFIX) Done..." + @ echo "-------------------------------" + +$(LIB)/lib$(TARGETNAME)_u.a: $(LIB)/lib$(TARGETNAME)_s.a + cd $(LIB); \ + /bin/rm -f lib$(TARGETNAME)_u.a; \ + ln -s lib$(TARGETNAME)_s.a lib$(TARGETNAME)_u.a + +$(LIB)/lib$(TARGETNAME)_s.a: .afile $(OBJECTS) + @ /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.a + @ $(AR) $(ARFLAGS) $(LIB)/lib$(TARGETNAME)_s.a $(OBJECTS) + @ $(RANLIB) $(LIB)/lib$(TARGETNAME)_s.a + @ echo "lib$(TARGETNAME)_s.a Done..." + @ echo "-------------------------------" + +#*--- lib-jvm ---------------------------------------------------------*/ +lib-jvm: $(TAGS) $(CLASS_DIR) lib.zip + +lib.zip: .afile .jfile $(CLASSES) + @ /bin/rm -f $(LIB)/$(TARGETNAME).zip + @ (cd $(O_DIR)/class_s; \ + $(ZIP) -q $(ZFLAGS) \ + $(LIB)/$(TARGETNAME)_s.zip \ + $(CLASS_DIR:$(O_DIR)/class_s/%=%)/*.class) + @ echo "lib$(TARGETNAME)_s.zip done..." + @ echo "-------------------------------" + +#*---------------------------------------------------------------------*/ +#* ude */ +#*---------------------------------------------------------------------*/ +.PHONY: ude +ude: + @ $(MAKE) -f Makefile .afile .etags + +.afile: $(SOURCES) + @ $(AFILE) -o .afile $(_BGL_SOURCES) + +.jfile: $(SOURCES) + @ $(JFILE) -o .jfile -pbase $(PBASE) $(SOURCES) + +.etags: $(SOURCES) + @ $(BTAGS) -o .etags $(_BGL_SOURCES) + +#*---------------------------------------------------------------------*/ +#* stdclean */ +#*---------------------------------------------------------------------*/ +stdclean: + /bin/rm -f $(OBJECTS) $(_BGL_OBJECTS:%=%.c) + /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).bigloo + /bin/rm -f $(SKRIBEBINDIR)/$(TARGETNAME).zip + /bin/rm -f $(LIB)/lib$(TARGETNAME)_s.$(SHAREDSUFFIX) + /bin/rm -f $(LIB)/lib$(TARGETNAME)_u.$(SHAREDSUFFIX) + /bin/rm -f .afile .etags .jfile + /bin/rm -rf $(O_DIR) + /bin/rm -f *~ + /bin/rm -f *.mco + +#*---------------------------------------------------------------------*/ +#* install/uninstall */ +#*---------------------------------------------------------------------*/ +install: + $(MAKE) install-$(TARGET) + +uninstall: + $(MAKE) uninstall-$(TARGET) + +install-c: $(DESTDIR)$(INSTALL_BINDIR) + cp $(SKRIBEBINDIR)/$(TARGETNAME).bigloo $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo + /bin/rm -f $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) + ln -s $(TARGETNAME).bigloo $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) + +uninstall-c: + /bin/rm $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME).bigloo + /bin/rm $(DESTDIR)$(INSTALL_BINDIR)/$(TARGETNAME) + +install-jvm: $(DESTDIR)$(INSTALL_FILDIR) + cp $(SKRIBEBINDIR)/$(TARGETNAME).zip $(DESTDIR)$(INSTALL_FILDIR)/$(TARGETNAME).zip + cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) + +uninstall-jvm: + /bin/rm $(DESTDIR)$(INSTALL_FILDIR)/$(TARGETNAME).zip + /bin/rm -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip + +$(DESTDIR)$(INSTALL_BINDIR): + mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) + +$(FILDIR): + mkdir -p $(FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) + diff --git a/skribe/etc/bigloo/autoconf/Makefile b/skribe/etc/bigloo/autoconf/Makefile new file mode 100644 index 0000000..c077107 --- /dev/null +++ b/skribe/etc/bigloo/autoconf/Makefile @@ -0,0 +1,53 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/etc/bigloo/autoconf/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Thu Jun 19 20:48:50 1997 */ +#* Last change : Sat Oct 25 08:34:37 2003 (serrano) */ +#* Copyright : 1997-2003 Manuel Serrano, see LICENSE file */ +#* ------------------------------------------------------------- */ +#* The global autoconf Makefile (mainly for backuping). */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* Flags */ +#*---------------------------------------------------------------------*/ +POPULATION = Makefile bversion getbversion blibdir gmaketest \ + blstlen bfildir + +#*---------------------------------------------------------------------*/ +#* pop ... */ +#*---------------------------------------------------------------------*/ +pop: + @ echo $(POPULATION:%=etc/bigloo/autoconf/%) + +#*---------------------------------------------------------------------*/ +#* clean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean cleanall distclean + +clean: + @ find . \( -name '*[~%]' \ + -o -name '.??*[~%]' \ + -o -name '#*#' \ + -o -name '?*#' \ + -o -name \*core \) \ + -type f -exec rm {} \; + @ echo "cleanup done..." + @ echo "-------------------------------" + +cleanall: clean +distclean: cleanall + +#*---------------------------------------------------------------------*/ +#* distrib */ +#*---------------------------------------------------------------------*/ +distrib: $(POPULATION) + @ if [ `pwd` = $$HOME/prgm/project/bglk/autoconf ]; then \ + echo "*** ERROR:Illegal dir to make a distrib `pwd`"; \ + exit 1; \ + fi + @ $(MAKE) clean + @ chmod a+rx $(POPULATION) + + diff --git a/skribe/etc/bigloo/autoconf/bfildir b/skribe/etc/bigloo/autoconf/bfildir new file mode 100755 index 0000000..128d5c7 --- /dev/null +++ b/skribe/etc/bigloo/autoconf/bfildir @@ -0,0 +1,36 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/scribe/autoconf/bfildir */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Tue Jan 12 14:53:33 1999 */ +#* Last change : Wed Aug 7 21:41:06 2002 (serrano) */ +#* ------------------------------------------------------------- */ +#* Find out the directory where Bigloo is installed */ +#*=====================================================================*/ +bigloo=bigloo + +#*---------------------------------------------------------------------*/ +#* We parse the arguments */ +#*---------------------------------------------------------------------*/ +while : ; do + case $1 in + "") + break;; + --bigloo=*|-bigloo=*) + bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; + + -*) + echo "Unknown option \"$1\", ignored" >&2;; + esac + shift +done + +#*---------------------------------------------------------------------*/ +#* We spawn a bigloo process to check its version number */ +#*---------------------------------------------------------------------*/ +$bigloo -q -eval "(begin (print *default-lib-dir*) (exit 0))" + +exit 0 + + diff --git a/skribe/etc/bigloo/autoconf/blibdir b/skribe/etc/bigloo/autoconf/blibdir new file mode 100755 index 0000000..603d484 --- /dev/null +++ b/skribe/etc/bigloo/autoconf/blibdir @@ -0,0 +1,36 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/scribe/autoconf/blibdir */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Tue Jan 12 14:53:33 1999 */ +#* Last change : Wed Aug 7 21:41:48 2002 (serrano) */ +#* ------------------------------------------------------------- */ +#* Find out the directory where Bigloo library is read. */ +#*=====================================================================*/ +bigloo=bigloo + +#*---------------------------------------------------------------------*/ +#* We parse the arguments */ +#*---------------------------------------------------------------------*/ +while : ; do + case $1 in + "") + break;; + --bigloo=*|-bigloo=*) + bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; + + -*) + echo "Unknown option \"$1\", ignored" >&2;; + esac + shift +done + +#*---------------------------------------------------------------------*/ +#* We spawn a bigloo process to check its version number */ +#*---------------------------------------------------------------------*/ +$bigloo -q -eval "(begin (print *ld-library-dir*) (exit 0))" + +exit 0 + + diff --git a/skribe/etc/bigloo/autoconf/bversion b/skribe/etc/bigloo/autoconf/bversion new file mode 100755 index 0000000..1f24c86 --- /dev/null +++ b/skribe/etc/bigloo/autoconf/bversion @@ -0,0 +1,42 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/scribe/autoconf/bversion */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Tue Jan 12 14:33:21 1999 */ +#* Last change : Sun Jan 13 07:30:21 2002 (serrano) */ +#* ------------------------------------------------------------- */ +#* Check the current bigloo version */ +#*=====================================================================*/ + +bigloo=bigloo +version=2.4b + +#*---------------------------------------------------------------------*/ +#* We parse the arguments */ +#*---------------------------------------------------------------------*/ +while : ; do + case $1 in + "") + break;; + --bigloo=*|-bigloo=*) + bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --version=*|-version=*) + version="`echo $1 | sed 's/^[-a-z]*=//'`";; + + -*) + echo "Unknown option \"$1\", ignored" >&2;; + esac + shift +done + +#*---------------------------------------------------------------------*/ +#* We spawn a bigloo process to check its version number */ +#*---------------------------------------------------------------------*/ +bver=`$bigloo -q -eval "(exit (print *bigloo-version*))"` +echo $bver + +$bigloo -q -eval "(exit (if (string>=? *bigloo-version* \"$version\") 0 1))" + +exit $? diff --git a/skribe/etc/bigloo/autoconf/getbversion b/skribe/etc/bigloo/autoconf/getbversion new file mode 100755 index 0000000..ff83b1c --- /dev/null +++ b/skribe/etc/bigloo/autoconf/getbversion @@ -0,0 +1,36 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/bglk/autoconf/getbversion */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Tue Jan 12 14:33:21 1999 */ +#* Last change : Mon May 22 10:47:46 2000 (serrano) */ +#* ------------------------------------------------------------- */ +#* Get the current bigloo version (with the level) */ +#*=====================================================================*/ + +bigloo=bigloo + +#*---------------------------------------------------------------------*/ +#* We parse the arguments */ +#*---------------------------------------------------------------------*/ +while : ; do + case $1 in + "") + break;; + --bigloo=*|-bigloo=*) + bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --version=*|-version=*) + version="`echo $1 | sed 's/^[-a-z]*=//'`";; + + -*) + echo "Unknown option \"$1\", ignored" >&2;; + esac + shift +done + +#*---------------------------------------------------------------------*/ +#* We spawn a bigloo process to check its version number */ +#*---------------------------------------------------------------------*/ +$bigloo -q -eval "(begin (print *bigloo-version*) (exit 0))" diff --git a/skribe/etc/bigloo/autoconf/gmaketest b/skribe/etc/bigloo/autoconf/gmaketest new file mode 100755 index 0000000..1bedd72 --- /dev/null +++ b/skribe/etc/bigloo/autoconf/gmaketest @@ -0,0 +1,38 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/bigloo/autoconf/gmaketest */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Thu Jan 14 10:31:33 1999 */ +#* Last change : Thu May 18 07:19:28 2000 (serrano) */ +#* ------------------------------------------------------------- */ +#* Checsk that Make is GNU make */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* flags */ +#*---------------------------------------------------------------------*/ +make=make + +#*---------------------------------------------------------------------*/ +#* We parse the arguments */ +#*---------------------------------------------------------------------*/ +while : ; do + case $1 in + "") + break;; + + --make=*) + make="`echo $1 | sed 's/^[-a-z]*=//'`";; + + -*) + echo "Unknown option \"$1\", ignored" >&2;; + esac + shift +done + +# Check the make version number +$make -v --version | grep -i "gnu make" > /dev/null + +# Return the grep result +exit $? diff --git a/skribe/etc/bigloo/configure b/skribe/etc/bigloo/configure new file mode 100755 index 0000000..9215911 --- /dev/null +++ b/skribe/etc/bigloo/configure @@ -0,0 +1,552 @@ +#!/bin/sh +#*=====================================================================*/ +#* serrano/prgm/project/skribe/etc/bigloo/configure */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Tue Jan 25 16:05:10 1994 */ +#* Last change : Tue Aug 24 10:31:53 2004 (serrano) */ +#* Copyright : 1994-2004 Manuel Serrano, see LICENSE file */ +#* ------------------------------------------------------------- */ +#* The skribe configuration file */ +#*=====================================================================*/ + +# the name of the current bigloo compiler +bigloo=bigloo +target=c + +# bigloo compilation flags +bcommonflags="-no-hello -fno-reflection" +blinkflags="-no-hello -ld-relative -O3" +boptflags="$bcommonflags -O3" +bsafeflags="$bcommonflags -g" +bflags="$boptflags" +bheapflags="-unsafe -q -mkaddheap -mkaddlib" +bcflags="-copt \"$""(CPICFLAGS)\"" +bjvmflags="-jvm -jvm-purify -saw -jvm-env SKRIBEPATH" +prcs=/usr/bin/prcs + +# the afile, jfile and btags binaries +afile=afile +jfile= +btags=btags +bdepend=bdepend + +# C compilation (left blank for automatic configuration (from Bigloo setup)) +cc= +cflags= +ldopt= + +# path (left blank for automatic configuration (from Bigloo setup)) +bgllibdir= +bglbindir= +bgllddir= +bgldocdir= +skribebindir= +skribelibdir= +skribefildir= +skribeskrdir= +skribeextdir= +skribedocdir= +skribemandir= + +# mask of Skribe intalled files +smask=755 + +#*---------------------------------------------------------------------*/ +#* !!! DON'T EDIT AFTER THIS COMMENT !!! */ +#*---------------------------------------------------------------------*/ +if [ "x$DISTRIBDIR" = "x" ]; then + distribdir=$HOME/prgm/distrib +else + distribdir=$DISTRIBDIR +fi + +if [ "x$SKRIBERELEASE" = "x" ]; then + echo "*** ERROR:configure:release. Aborting" + echo "Variable \"SKRIBERELEASE\" is unset." + exit 1; +else + release=$SKRIBERELEASE +fi + +if [ "x$SKRIBEBETARELEASE" = "x" ]; then + if [ -f $prcs ]; then + beta=`$prcs info skribe 2>&1 /dev/null | tail --lines=1 | awk '{ print $2 }' | sed 's/[0-9]*[.][0-9]*[a-z]*/&-beta/'` + elif [ -f /usr/local/bin/prcs ]; then + beta=`/usr/local/bin/prcs info skribe 2>&1 /dev/null | tail --lines=1 | awk '{ print $2 }' | sed 's/[0-9]*[.][0-9]*[a-z]*/&-beta/'` + else + beta=no + fi +else + beta=$SKRIBEBETARELEASE +fi + +if [ "x$SKRIBEURL" = "x" ]; then + skribeurl="http://www.inria.fr/mimosa/fp/Skribe" +else + skribeurl=$SKRIBEURL +fi + +requiredbigloo=2.6c + +action=all +makefile_config=Makefile.skb +skribe_config=../../src/common/configure.scm +summary=yes + +http="www-sop.inria.fr/mimosa/fp" +autoconfdir=`dirname $0 2> /dev/null`/autoconf +bootconfig=false; + +if [ $? != "0" ]; then + autoconfdir="autoconf" +fi + +# Argument parsing +while : ; do + case $1 in + "") + break;; + + -c) + target=c;; + + -j|--jvm) + target=jvm;; + + -|--dotnet) + target=dotnet;; + + --skribe_config=*) + action="skribe_config"; + skribe_config="`echo $1 | sed 's/^[-a-z_.]*=//'`";; + + --makefile.skb=*) + action="makefile.skb"; + makefile_config="`echo $1 | sed 's/^[-Da-z.]*=//'`";; + + --bglbindir=*) + bglbindir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bgllibdir=*) + bgllibdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bgllddir=*) + bgllddir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bgldocdir=*) + bgldocdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bindir=*) + skribebindir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --libdir=*) + skribelibdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --fildir=*) + skribefildir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --skrdir=*) + skribeskrdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --extdir=*) + skribeextdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --docdir=*) + skribedocdir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --mandir=*) + skribemandir="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bigloo=*) + bigloo="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --afile=*) + afile="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --jfile=*) + jfile="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --btags=*) + btags="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --mask=*) + smask="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --cc=*) + cc="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --cflags=*) + cflags="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --ldopt=*) + ldopt="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --backends=*) + backends="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --no-summary) + summary=no;; + + --debug) + bflags="-g -cg $bsafeflags";; + + --debug2) + bflags="-g2 -cg $bsafeflags";; + + --debug3) + bflags="-g3 -cg $bsafeflags";; + + --optimize) + bflags=$boptflags;; + + --bjvmflags=*) + bjvmflags="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --bcflags=*) + bcflags="`echo $1 | sed 's/^[-a-z]*=//'`";; + + --prefix=*) + prefix="`echo $1 | sed 's/^[^=]*=//'`"; + skribebindir=$prefix/bin; + skribeskrdir=$prefix/share/skribe/$release/skr; + skribeextdir=$prefix/share/skribe/extensions; + skribelibdir=$prefix/lib + skribefildir=$skribelibdir/skribe/$release; + skribemandir=$prefix/man/man1; + skribedocdir=$prefix/doc/skribe-$release;; + + --bootconfig) + bootconfig=true;; + + -*) + echo "*** Configure error, unknown option $1" >&2; + echo >&2; + echo "Usage: configure --with-bigloo [options]" >&2; + echo " -c.................... uses the Bigloo C back-end" >&2; + echo " -j|--jvm.............. uses the Bigloo JVM back-end" >&2; + echo " -d|--dotnet........... uses the Bigloo .NET back-end" >&2; + echo " --skribe_config=file.. sets the name of the skribe-config file" >&2; + echo " --makefile.skb=file... sets the name of the Makefile.skb file" >&2; + echo " --prefix=dir.......... prefix to Skribe install" >&2; + echo " --bindir=file......... alternative Skribe bin directory" >&2; + echo " --libdir=file......... alternative Skribe lib directory" >&2; + echo " --fildir=file......... alternative Skribe file directory" >&2; + echo " --skrdir=file......... Skribe skr directory" >&2; + echo " --bglbindir=file...... Bigloo bin directory" >&2; + echo " --bgllibdir=file...... Bigloo lib directory" >&2; + echo " --bglfildir=file...... Bigloo file directory" >&2; + echo " --bgldocdir=file...... Bigloo doc directory" >&2; + echo " --docdir=file......... Documentation directory" >&2; + echo " --mandir=file......... Manual pages directory" >&2; + echo " --bigloo=comp......... The Bigloo compiler" >&2; + echo " --afile=afile......... The Bigloo afile tool" >&2; + echo " --jfile=jfile......... The Bigloo jfile tool" >&2; + echo " --btags=btags......... The Bigloo btags tool" >&2; + echo " --cc=comp............. The C compiler (for C back-end)" >&2; + echo " --cflags=args......... The C compilation options" >&2; + echo " --ldopt=args.......... The C link options" >&2; + echo " --smask=mask.......... The installation mask" >&2; + echo " --no-summary.......... Private option" >&2; + echo " --debug............... Enables Bigloo debug mode" >&2; + echo " --optimize............ Enables Bigloo optimization mode (default)" >&2; + echo " --bootconfig.......... Private option" >&2; + exit -1; + esac + shift +done + +#*---------------------------------------------------------------------*/ +#* First check if bigloo exists and if it is recent enough */ +#*---------------------------------------------------------------------*/ +if [ ! -f $bigloo ]; then + which $bigloo > /dev/null 2> /dev/null + if [ "$?" != "0" ]; then + echo "*** ERROR:configure:bigloo. Aborting" + echo "Can't find bigloo." + exit 1; + fi +fi + +installedbigloo=`$autoconfdir/bversion --bigloo=$bigloo --version=$requiredbigloo` + +if [ $? != "0" ]; then + echo "*** ERROR:configure:bigloo. Aborting" + echo "Your version ($installedbigloo) of Bigloo is too old." + echo "Release $requiredbigloo or more recent is required." + echo "Bigloo may be downloaded from $http" + exit 1; +fi + +#*---------------------------------------------------------------------*/ +#* The binary directory */ +#*---------------------------------------------------------------------*/ +if [ "$bglbindir " = " " ]; then + if [ "$bigloo " = " " ]; then + bgl=`which bigloo`; + else + bgl=`which $bigloo`; + fi + bglbindir=`dirname $bgl` +fi +if [ "$skribebindir " = " " ]; then + skribebindir=$prefix/bin; +fi + +#*---------------------------------------------------------------------*/ +#* The Bigloo library directory */ +#*---------------------------------------------------------------------*/ +if [ "$bgllibdir " = " " ]; then + bgllibdir=`$autoconfdir/blibdir --bigloo="$bigloo"` +fi +if [ "$bglfildir " = " " ]; then + bglfildir=`$autoconfdir/bfildir --bigloo="$bigloo"` +fi + +#*---------------------------------------------------------------------*/ +#* We check the installed Bigloo Makefile.config file */ +#*---------------------------------------------------------------------*/ +if [ ! -f $bglfildir/Makefile.config ]; then + echo "*** ERROR:configure:Can't find Makefile.config file" + echo "Should be $bglfildir/Makefile.config." + exit 1; +fi + +#*---------------------------------------------------------------------*/ +#* jfile */ +#*---------------------------------------------------------------------*/ +if [ "$jfile " = " " ]; then + if [ ! -f $bigloo ]; then + which jfile > /dev/null 2> /dev/null + if [ "$?" != "0" ]; then + jfile=true; + else + jfile=jfile; + fi + fi +fi + +#*---------------------------------------------------------------------*/ +#* We are now able to set the correct value for cc since we know */ +#* what Bigloo is. */ +#*---------------------------------------------------------------------*/ +if [ "$cc " = " " ]; then + cc=`$bigloo -eval '(begin (print *cc*) (exit 0))'` +fi + +if [ "$cflags " = " " ]; then + cflags=`grep '^CFLAGS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` +fi + +ldflags=`grep '^EXTRALIBS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` +cpicflags=`grep '^CPICFLAGS=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` + +#*---------------------------------------------------------------------*/ +#* Completing dirs */ +#*---------------------------------------------------------------------*/ +if [ "$skribelibdir " = " " ]; then + skribelibdir=$prefix/lib; +fi +if [ "$skribefildir " = " " ]; then + skribefildir=$skribelibdir/skribe/$release; +fi +if [ "$skribeskrdir " = " " ]; then + skribeskrdir=$prefix/share/skribe/$release/skr; +fi +if [ "$skribeextdir " = " " ]; then + skribeextdir=$prefix/share/skribe/extensions; +fi +if [ "$bgldocdir " = " " ]; then + bgldocdir=`grep '^DOCDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//' | sed 's/[$][(][^)]*[)]//'` +fi +if [ "$skribedocdir " = " " ]; then + skribedocdir=`dirname $bgldocdir`/skribe-$release +fi +if [ "$skribemandir " = " " ]; then + skribemandir=`grep '^MANDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` +fi +if [ "$skribeemacsdir " = " " ]; then + skribeemacsdir=`grep '^EMACSDIR=' $bglfildir/Makefile.config | sed 's/^[A-Z]*=//'` +fi + +#*---------------------------------------------------------------------*/ +#* emacs/skribe.el */ +#*---------------------------------------------------------------------*/ +cat ../../emacs/skribe.el \ + | sed "s|@SKRIBE_EMACSDIR@|$skribeemacsdir|" \ + | sed "s|@SKRIBE_HOSTSCHEMEDOCDIR@|$bgldocdir|" \ + > ../../emacs/skribe.el.aux \ + && mv ../../emacs/skribe.el.aux ../../emacs/skribe.el + +#*---------------------------------------------------------------------*/ +#* etc/skribe-config */ +#*---------------------------------------------------------------------*/ +cat ../skribe-config \ + | sed "s|@SKRIBE_EMACS_DIR@|$skribeemacsdir|" \ + > ../skribe-config.aux \ + && mv ../skribe-config.aux ../skribe-config + +#*---------------------------------------------------------------------*/ +#* makefile.skb */ +#* ------------------------------------------------------------- */ +#* This part of the configure script produces the file */ +#* makefile.skb. This file contains machine dependant */ +#* informations and location where Bigloo is to be installed. */ +#*---------------------------------------------------------------------*/ +if [ $action = "all" -o $action = "makefile.skb" ]; then + + # We create an unexisting temporary file name + name=foo + while( test -f "$name.c" -o -f "$name.o" ); do + name="$name"x; + done + + # We check the C compiler + cat > $name.c <<EOF + int foobar( int x ) { + return x; + } +EOF + + if $cc $cflags -c $name.c >/dev/null 2>&1 + then + true + else + echo "***ERROR:configure:$cc:Can't compile c file -- $cc $cflags -c $name.c"; + /bin/rm -f $name.c $name.o $name.a; + exit 1 + fi + /bin/rm -f $name.c $name.o $name.a; + + # We first cleanup the general Makefile config + rm -f ../Makefile.config 2> /dev/null + echo "## Skribe ($release) configure" > ../Makefile.config + echo "## Don't edit, file generated by etc/bigloo/configure" >> ../Makefile.config + echo "SKRIBERELEASE=$release" >> ../Makefile.config + echo "SKRIBEBETARELEASE=$beta" >> ../Makefile.config + echo >> ../Makefile.config + echo "SYSTEM=bigloo" >> ../Makefile.config + case $target in + jvm) + echo 'SKRIBE=java -classpath $(BINDIR)/skribe.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.main' >> ../Makefile.config; + echo 'SKRIBEINFO=java -classpath $(BINDIR)/skribeinfo.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.skribeinfo.main' >> ../Makefile.config; + echo 'SKRIBEBIBTEX=java -classpath $(BINDIR)/skribebibtex.zip:$(ZIPDIR)/bigloo_s.zip:$(LIBDIR)/bigloo_s.zip bigloo.skribe.skribebibtex.main' >> ../Makefile.config;; + *) + echo 'SKRIBE=$'"(BINDIR)/skribe.bigloo" >> ../Makefile.config; + echo 'SKRIBEINFO=$'"(BINDIR)/skribeinfo.bigloo" >> ../Makefile.config; + echo 'SKRIBEBIBTEX=$'"(BINDIR)/skribebibtex.bigloo" >> ../Makefile.config;; + esac + + # We first cleanup the file + rm -f $makefile_config 2> /dev/null + touch $makefile_config + echo "## Skribe ($release) configure" >> $makefile_config + echo "## Don't edit, file generated by etc/bigloo/configure" >> $makefile_config + echo >> $makefile_config + + # The Bigloo target (c, jvm, dotnet) + echo "TARGET=$target" >> $makefile_config + echo >> $makefile_config + + # The boot directories + echo "SKRIBEDIR=`pwd`/../.." >> $makefile_config + echo 'SKRIBEBINDIR=$'"(SKRIBEDIR)/bin" >> $makefile_config; + echo 'SKRIBELIBDIR=$'"(SKRIBEDIR)/lib" >> $makefile_config; + echo 'SKRIBEFILDIR=$'"(SKRIBEDIR)/lib" >> $makefile_config; + echo >> $makefile_config + + # The distribution directory + echo "DISTRIBDIR=$distribdir" >> $makefile_config + echo >> $makefile_config + + # The installation directories + echo "INSTALL_BINDIR=$skribebindir" >> $makefile_config + echo "INSTALL_LIBDIR=$skribelibdir" >> $makefile_config + echo "INSTALL_FILDIR=$skribefildir" >> $makefile_config + echo "INSTALL_SKRDIR=$skribeskrdir" >> $makefile_config + echo "INSTALL_EXTDIR=$skribeextdir" >> $makefile_config + if [ ! "$skribedocdir " = " " ]; then + echo "INSTALL_DOCDIR=$skribedocdir" >> $makefile_config; + fi + if [ ! "$skribemandir " = " " ]; then + echo "INSTALL_MANDIR=$skribemandir" >> $makefile_config; + fi + echo "INSTALL_HOSTHTTP=$skribehttphost" >> $makefile_config + echo "INSTALL_MASK=$smask" >> $makefile_config + echo >> $makefile_config + + # The bigloo configuration + cat $bglfildir/Makefile.config >> $makefile_config + echo >> $makefile_config + + # The bigloo compiler + echo "BIGLOO=$bigloo" >> $makefile_config + echo "BIGLOO_FILDIR=$bglfildir" >> $makefile_config + echo "BIGLOO_LIBDIR=$bgllibdir" >> $makefile_config + echo >> $makefile_config + + # The bigloo compiler options + echo "BLINKFLAGS=$blinkflags -ldopt '$ldopt'" >> $makefile_config + echo "BSAFEFLAGS=$bsafeflags" >> $makefile_config + echo "BHEAPFLAGS=$bheapflags" >> $makefile_config + echo "BCOMMONFLAGS=$bflags" >> $makefile_config + echo "BCFLAGS=$bcflags" >> $makefile_config + echo "BJVMFLAGS=$bjvmflags" >> $makefile_config + echo >> $makefile_config + + # Bigloo bde + echo "AFILE=$afile" >> $makefile_config + echo "JFILE=$jfile" >> $makefile_config + echo "BTAGS=$btags" >> $makefile_config + echo "BDEPEND=$bdepend" >> $makefile_config + echo "SKRIBEINDENT=bpp" >> $makefile_config + echo >> $makefile_config + + # Misc + echo "RM=/bin/rm" >> $makefile_config + echo >> $makefile_config +fi + +#*---------------------------------------------------------------------*/ +#* Ok, we are done now */ +#*---------------------------------------------------------------------*/ +if [ "$summary" = "yes" ]; then + echo + echo + echo "** Configuration summary **" + echo + echo "Release number:" + echo " Skribe release number................. $release" + echo " Skribe beta number.................... $beta" + echo " Minimum Bigloo version required....... $requiredbigloo" + echo " Installed Bigloo version.............. $installedbigloo" + echo + echo "Compilers:" + echo " Bigloo................................ $bigloo" + echo " Bigloo link flags..................... $blinkflags" + echo " Bigloo compilation flags.............. $bflags" + echo " Bigloo heap flags..................... $bheapflags" + echo " afile................................. $afile" + echo " jfile................................. $jfile" + echo " btags................................. $btags" + echo " cc.................................... $cc" + echo " cc compilation flags.................. $cflags" + echo " link options.......................... $ldopt" + echo + echo "Path:" + echo " Binary directory...................... $skribebindir" + echo " Skr directory......................... $skribeskrdir" + echo " Extensions directory.................. $skribeextdir" + echo " File directory........................ $skribefildir" + echo " Library directory..................... $skribelibdir" + echo " Documentation directory............... $skribedocdir" + echo " Man pages directory................... $skribemandir" + echo " Home page............................. $skribeurl" + echo + echo "Misc configuration:" + echo " mask for installed files.............. $smask" + echo + echo "Emacs:" + echo " Emacs Lisp files directory............ $skribeemacsdir" + echo +fi diff --git a/skribe/etc/skribe-config.in b/skribe/etc/skribe-config.in new file mode 100644 index 0000000..2a03e26 --- /dev/null +++ b/skribe/etc/skribe-config.in @@ -0,0 +1,64 @@ +#!/bin/sh +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 19-Nov-2003 21:04 (eg) +# Last file update: 19-Nov-2003 22:29 (eg) + + +function usage() +{ + cat <<EOF +Usage: skribe-config [OPTIONS] +Options: + [--prefix | -p] Prefix that was given during the build + [--version | -v] Version of Skribe that is installed + [--skr-dir | -k] Display the skr directory location + [--extension-dir | -e] Display the extension directory location + [--doc-dir | -d] Display the documentation directory location + [--emacs-dir | -m] Display the emacs directory location + [--scheme | -s] Display the Scheme systeme used + [--help | -h | -?] Show a list of options +EOF + exit $1 +} + + +if test $# -eq 0; then + usage 1 1>&2 +fi + +while test $# -gt 0; do + case $1 in + --prefix|-p) + echo @PREFIX@ + ;; + --version|-v) + echo @SKRIBE_RELEASE@ + ;; + --extension-dir|-e) + echo @SKRIBE_EXT_DIR@ + ;; + --skr-dir|-k) + echo @SKRIBE_SKR_DIR@ + ;; + --doc-dir|-d) + echo @SKRIBE_DOC_DIR@ + ;; + --emacs-dir|-m) + echo @SKRIBE_EMACS_DIR@ + ;; + --scheme|-s) + echo @SYSTEM@ + ;; + --help|-h|-\?) + usage 0 1>&2 + ;; + *) + echo "bad option $1" 1>&2 + usage 1 1>&2 + ;; + esac + shift +done +exit 0 + diff --git a/skribe/etc/stklos/Makefile.config.in b/skribe/etc/stklos/Makefile.config.in new file mode 100644 index 0000000..13a60d8 --- /dev/null +++ b/skribe/etc/stklos/Makefile.config.in @@ -0,0 +1,5 @@ +SYSTEM=@SYSTEM@ +SKRIBE=@SKRIBE@ +SKRIBEINFO=@SKRIBEINFO@ +SKRIBEBIBTEX=@SKRIBEBIBTEX@ + diff --git a/skribe/etc/stklos/Makefile.in b/skribe/etc/stklos/Makefile.in new file mode 100644 index 0000000..186fd58 --- /dev/null +++ b/skribe/etc/stklos/Makefile.in @@ -0,0 +1,44 @@ +# +# Makefile.in -- Skribe Makefile for Stklos +# +# Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +# +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +# USA. +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 10-Aug-2003 17:31 (eg) +# Last file update: 10-Nov-2003 19:48 (eg) +# + +PRCS_FILES=Makefile.config.in Makefile.in Makefile.skb.in configure.in \ +configure + +all: configure + + +configure: configure.in + autoconf + +clean: + /bin/rm -f config.* *~ + +pop: + @echo $(PRCS_FILES:%=etc/stklos/%) + +distclean: clean + (cd ../../src/stklos/; $(MAKE) distclean) + /bin/rm -f Makefile Makefile.skb ../Makefile.config diff --git a/skribe/etc/stklos/Makefile.skb.in b/skribe/etc/stklos/Makefile.skb.in new file mode 100644 index 0000000..7568474 --- /dev/null +++ b/skribe/etc/stklos/Makefile.skb.in @@ -0,0 +1,5 @@ +BMASK=0755 +INSTALL_DOCDIR=@PREFIX@/share/doc/skribe-@SKRIBE_RELEASE@ +INSTALL_BINDIR=@PREFIX@/bin +INSTALL_SKRDIR=@PREFIX@/share/skribe/@SKRIBE_RELEASE@/skr +INSTALL_EXTDIR=@PREFIX@/share/skribe/extensions diff --git a/skribe/etc/stklos/configure b/skribe/etc/stklos/configure new file mode 100755 index 0000000..e1d2526 --- /dev/null +++ b/skribe/etc/stklos/configure @@ -0,0 +1,830 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.13 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.13" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=../../src/common/api.scm + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +ac_exeext= +ac_objext=o +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +### AM_INIT_AUTOMAKE(skribe,0.0) +PACKAGE=skribe + +SYSTEM=stklos +SKRIBE='$(BINDIR)/skribe.stklos' +SKRIBEBIBTEX='$(BINDIR)/skribebibtex.stklos' + +## +## Initialize prefix +## +if test "${prefix}" = "NONE" -o "$prefix" = "" ;then + prefix="/usr/local" +fi + +## +## Get information from ../config +## +if test -f ../config ;then + . ../config +else + echo "You must configure Skribe from the ../.. directory" + exit 1 +fi + + +PREFIX=$prefix +SKRIBE_RELEASE=${release} +SKRIBE_URL=${skribeurl} + +## +## Substitutions +## + + + + + + + + + +# +# Outputs +# +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS <<EOF +#! /bin/sh +# Generated automatically by configure. +# Run this file to recreate the current configuration. +# This directory was configured as follows, +# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.13" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile ../../src/stklos/Makefile Makefile.config Makefile.skb" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS <<EOF + +# Protect against being on the right side of a sed subst in config.status. +sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; + s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@SHELL@%$SHELL%g +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@FFLAGS@%$FFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@PACKAGE@%$PACKAGE%g +s%@PREFIX@%$PREFIX%g +s%@SKRIBE_RELEASE@%$SKRIBE_RELEASE%g +s%@SKRIBE_URL@%$SKRIBE_URL%g +s%@SYSTEM@%$SYSTEM%g +s%@SKRIBE@%$SKRIBE%g +s%@SKRIBEINFO@%$SKRIBEINFO%g +s%@SKRIBEBIBTEX@%$SKRIBEBIBTEX%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <<EOF + +CONFIG_FILES=\${CONFIG_FILES-"Makefile ../../src/stklos/Makefile Makefile.config Makefile.skb"} +EOF +cat >> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +EOF +cat >> $CONFIG_STATUS <<EOF + +EOF +cat >> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + + +# Makefile.config must be in the parent directory +mv Makefile.config .. + diff --git a/skribe/etc/stklos/configure.in b/skribe/etc/stklos/configure.in new file mode 100644 index 0000000..956af77 --- /dev/null +++ b/skribe/etc/stklos/configure.in @@ -0,0 +1,57 @@ +dnl +dnl Configure.in for Skribe +dnl +dnl Author: Erick Gallesio [eg@essi.fr] +dnl Creation date: 23-Jul-2003 12:04 (eg) +dnl Last file update: 26-Oct-2004 20:24 (eg) + +AC_INIT(../../src/common/api.scm) +### AM_INIT_AUTOMAKE(skribe,0.0) +PACKAGE=skribe + +SYSTEM=stklos +SKRIBE='$(BINDIR)/skribe.stklos' +SKRIBEBIBTEX='$(BINDIR)/skribebibtex.stklos' + +## +## Initialize prefix +## +if test "${prefix}" = "NONE" -o "$prefix" = "" ;then + prefix="/usr/local" +fi + +## +## Get information from ../config +## +if test -f ../config ;then + . ../config +else + echo "You must configure Skribe from the ../.. directory" + exit 1 +fi + + +PREFIX=$prefix +SKRIBE_RELEASE=${release} +SKRIBE_URL=${skribeurl} + +## +## Substitutions +## +AC_SUBST(PACKAGE) +AC_SUBST(PREFIX) +AC_SUBST(SKRIBE_RELEASE) +AC_SUBST(SKRIBE_URL) +AC_SUBST(SYSTEM) +AC_SUBST(SKRIBE) +AC_SUBST(SKRIBEINFO) +AC_SUBST(SKRIBEBIBTEX) + +# +# Outputs +# +AC_OUTPUT(Makefile ../../src/stklos/Makefile Makefile.config Makefile.skb) + +# Makefile.config must be in the parent directory +mv Makefile.config .. + diff --git a/skribe/examples/Makefile b/skribe/examples/Makefile new file mode 100644 index 0000000..7f47f6e --- /dev/null +++ b/skribe/examples/Makefile @@ -0,0 +1,48 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/examples/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Fri Oct 24 13:25:43 2003 */ +#* Last change : Wed Feb 18 11:25:20 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The meta Makefile for the examples */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* All the examples */ +#*---------------------------------------------------------------------*/ +EXAMPLES=slide + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ for p in $(EXAMPLES); do \ + (cd $$p && $(MAKE) pop); \ + done + @ echo examples/Makefile + +#*---------------------------------------------------------------------*/ +#* Install/Uinstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: + +uninstall: + +#*---------------------------------------------------------------------*/ +#* cleaning */ +#*---------------------------------------------------------------------*/ +.PHONY: clean distclean + +clean: + for p in $(EXAMPLES); do \ + (cd $$p && $(MAKE) clean); \ + done + +distclean: clean + diff --git a/skribe/examples/slide/Makefile b/skribe/examples/slide/Makefile new file mode 100644 index 0000000..c9b7a84 --- /dev/null +++ b/skribe/examples/slide/Makefile @@ -0,0 +1,153 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/examples/slide/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Fri Jan 11 10:19:46 2002 */ +#* Last change : Thu Dec 18 09:21:41 2003 (serrano) */ +#* Copyright : 2002-03 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Slides example */ +#*=====================================================================*/ +include ../../etc/Makefile.config +include ../../etc/$(SYSTEM)/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Compiler and tools */ +#*---------------------------------------------------------------------*/ +BINDIR = ../../bin +LIBDIR = ../../lib + +#*---------------------------------------------------------------------*/ +#* Compilers and Tools */ +#*---------------------------------------------------------------------*/ +SFLAGS = -I txt -I skr -I skb -I ../../skr +LATEX = latex +DVIPS = dvips -Ppdf -G0 +TEXHOME = $$HOME/tex +PS2PDF = ps2pdf -dPDFSETTINGS=/prepress -sPAPERSIZE=a4 +MODE = advi + +#*---------------------------------------------------------------------*/ +#* Skribe variables */ +#*---------------------------------------------------------------------*/ +SKRIBEVARS = --eval "(define *mode* '$(MODE))" + +#*---------------------------------------------------------------------*/ +#* Sources */ +#*---------------------------------------------------------------------*/ +MASTER = skb/slides.skb + +INPUTSNAME = +EXNAME = skribe.skb syntax.scr +INPUTS = $(INPUTSNAME:%=skb/%.skb) $(EXNAME:%=ex/%) + +SOURCESNAME = +SOURCES = $(SOURCESNAME:%=scm/%.scm) + +STYLES = local +LSTYLES = $(STYLE:%=skr/%.skr) + +FIGS_SOURCES = +FIGURES = $(FIGS_SOURCES:%=fig/%.eps) $(FIGS_SOURCES:%=fig/%.png) + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .skb .skr .eps .fig .tex .ps .pdf .png .html .dvi + +#*---------------------------------------------------------------------*/ +#* All */ +#*---------------------------------------------------------------------*/ +all: ps html + +ps: slides.ps +slides.ps: slides.dvi + $(DVIPS) -o slides.ps slides.dvi + +pdf: slides.pdf +slides.pdf: slides.ps + $(PS2PDF) slides.ps slides.pdf + +dvi: slides.dvi +slides.dvi: slides.tex + $(LATEX) slides.tex + +slides.tex: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) + $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -o slides.tex + +html: slides.html +slides.html: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) + $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -o slides.html + +text: slides.text +slides.text: $(MASTER) $(INPUTS) $(LSTYLES) $(SOURCES) $(FIGURES) + $(SKRIBE) $(SKRIBEVARS) $(SFLAGS) $(MASTER) -t text -o slides.text + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo examples/slide/Makefile \ + examples/slide/README \ + examples/slide/advi.sty \ + examples/slide/PPRskribe.sty \ + examples/slide/skr/local.skr + @ echo $(MASTER:%=examples/slide/%) + @ echo $(EXNAME:%=examples/slide/ex/%) + +#*---------------------------------------------------------------------*/ +#* binary */ +#*---------------------------------------------------------------------*/ +getbinary: + echo "slides" + +#*---------------------------------------------------------------------*/ +#* re */ +#*---------------------------------------------------------------------*/ +.PHONY: re re.ps re.html + +re: re.ps re.html + +re.ps: + touch -m -d 0 slides.tex + $(MAKE) ps + +re.html: + touch -m -d 0 slides.html + $(MAKE) html + +#*---------------------------------------------------------------------*/ +#* .eps.png */ +#*---------------------------------------------------------------------*/ +.eps.png: + @ echo $*.png: + @ convert $*.eps $*.png + +#*---------------------------------------------------------------------*/ +#* .eps.fig */ +#*---------------------------------------------------------------------*/ +.fig.eps: + @ echo $*.fig: + @ fig2dev -L eps $*.fig > $*.eps + +#*---------------------------------------------------------------------*/ +#* Clean */ +#*---------------------------------------------------------------------*/ +clean: + -/bin/rm -f slides.tex 2> /dev/null + -/bin/rm -f slides.dvi 2> /dev/null + -/bin/rm -f *.aux *.log 2> /dev/null + -/bin/rm -f *~ 2> /dev/null + -/bin/rm -f */*~ 2> /dev/null + -/bin/rm -f */*/*~ 2> /dev/null + -/bin/rm -f slides.ps 2> /dev/null + -/bin/rm -f slides.pdf 2> /dev/null + -/bin/rm -f slides*.html 2> /dev/null + -/bin/rm -f slides.text 2> /dev/null + -/bin/rm -f slides.out 2> /dev/null + -/bin/rm -f $(FIGURES) + +cleanall: clean diff --git a/skribe/examples/slide/PPRskribe.sty b/skribe/examples/slide/PPRskribe.sty new file mode 100644 index 0000000..40b2d08 --- /dev/null +++ b/skribe/examples/slide/PPRskribe.sty @@ -0,0 +1,67 @@ +%============================================================================== +% Prosper -- (PPRskribe.sty) Style file +% A LaTeX class for creating slides +% Author: Manuel Serrano +% +% Permission is hereby granted, without written agreement and without +% license or royalty fees, to use, copy, modify, and distribute this +% software and its documentation for any purpose, provided that the +% above copyright notice and the following two paragraphs appear in +% all copies of this software. +% +% IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, +% SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF +% THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED +% OF THE POSSIBILITY OF SUCH DAMAGE. +% +% THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, +% INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +% AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS +% ON AN "AS IS" BASIS, AND THE AUTHOR HAS NO OBLIGATION TO +% PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. +%============================================================================== +\NeedsTeXFormat{LaTeX2e}[1995/12/01] +\ProvidesPackage{PPRskribe}[2003/10/21] +\typeout{`skribe' style for Prosper ---} +\typeout{ } + +\RequirePackage{amssymb} +% Loading packages necessary to define this slide style. +% none + +\FontTitle{% + \usefont{T1}{ptm}{b}{n}\fontsize{13.82pt}{12pt}\selectfont\blue}{% + \usefont{T1}{ptm}{b}{n}\fontsize{13.82pt}{12pt}\selectfont\blue} +\FontText{% + \black\usefont{T1}{phv}{m}{n}\fontsize{9.4pt}{9pt}\selectfont}{% + \black\usefont{T1}{phv}{m}{n}\fontsize{9.4pt}{9pt}\selectfont} + + +% Positionning of the title of a slide. +\newcommand{\slidetitle}[1]{% + \rput[c](5.25,4.4){\fontTitle{#1}} +} + +% Positionning for a logo +% \LogoPosition{-1,-1.1} + +% Definition of this style for slides. + +\newcommand{\BasicFrame}[1]{% + {#1}} + +%\NewSlideStyle[115mm]{t}{5.3,3.2}{BasicFrame} +\NewSlideStyle[125mm]{t}{5.3,3.8}{BasicFrame} +\PDFCroppingBox{10 40 594 800} +\RequirePackage{semhelv} + +\myitem{1}{$\bullet$} +\myitem{2}{$\circ$} +\myitem{3}{$\diamond$} + +\endinput + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: t +%%% End: diff --git a/skribe/examples/slide/README b/skribe/examples/slide/README new file mode 100644 index 0000000..cb9f303 --- /dev/null +++ b/skribe/examples/slide/README @@ -0,0 +1,11 @@ +This example shows how to program slides with Skribe. Three slide +formats can be produced: + +1. Advi + type `make MODE=advi' + +2. Plain PDF + type `make pdf MODE=pdf' + +3. LaTeX prosper + type `make pdf MODE=prosper' diff --git a/skribe/examples/slide/advi.sty b/skribe/examples/slide/advi.sty new file mode 100644 index 0000000..9b5e09f --- /dev/null +++ b/skribe/examples/slide/advi.sty @@ -0,0 +1,416 @@ +%% +%% This is the original source file advi.sty +%% +%% Package `advi' to use with LaTeX 2e +%% Copyright Roberto Di Cosmo, Jun Furuse, Didier Remy, and Pierre Weis +%% All rights reserved. + +% Which name is ours +\def \ActiveDVI {Active-DVI} + +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{advi} + [2001/29/08 v0.40 Advi Package for advi Previewer] + +%% + +%% Identification +%% Preliminary declarations + +\RequirePackage {keyval} + +%% Options + +\newif \ifadvi@ignore \advi@ignorefalse +\DeclareOption {ignore}{\advi@ignoretrue} + +\ProcessOptions +% \@ifundefined {AdviOptions}{}{\ExecuteOptions {\AdviOptions}} + +%% More declarations + +% Auxilliary macros + + +\def \advi@empty{} +\def \advi@ifempty #1{\def \@test {#1}\ifx \@test \advi@empty + \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} +\def \advi@error #1{\PackageError {Advi}{#1}{Type <RETURN> to proceed.}} +\def \advi@warning #1{\PackageWarning {Advi}{#1}} +\def \advi@undefinedenv {\advi@error {Environment \@currenvir\space undefined. +Maybe you mean \@currenvir ing}} +\def \advi@special@ {\advi@ifadvi{\special}{\advi@ignore}} +\def \advi@special #1{\advi@special@ {advi: #1}} +\def \advi@export #1#2{\@ifdefinable #1{\let #1#2}} +\def \advi@exportenv #1#2{% + \@ifundefined {#1}{\expandafter \let \csname #1\expandafter \endcsname + \csname end#1\endcsname }\relax + \expandafter \@ifdefinable \csname #1\endcsname + {\expandafter \let \csname #1\expandafter \endcsname \csname #2\endcsname + \expandafter \let \csname end#1\expandafter \endcsname + \csname end#2\endcsname}} + +\def \advi@ignore #1{} +\def \advi@id #1{#1} + +\def \advi@ifadvi {\ifadvi@ignore + \expandafter \@secondoftwo \else \expandafter \@firstoftwo \fi} +\advi@export \adviignore \advi@ignoretrue +\advi@export \ifadvi \advi@ifadvi + +%%% Record and play + +\newif \ifadvi@recording +\def \advi@ifrecording {\ifadvi@recording + \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} +\def \advi@ifrecordenv {\ifx \@currenvir \advi@recordenv + \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} + +\def \advi@start {start} +\def \advi@startplay {start play} +\define@key{advi@record}{play}[]{\let \advi@do \advi@startplay} +\def \advi@recordenv {advirecord} + +\newenvironment{advi@recording}[2][]% + {\begingroup + \let \advi@do \advi@start \setkeys{advi@record}{#1}% + \advi@special {proc=#2 record=\advi@do}% + \endgroup} + {\advi@special {proc record=end}} +\newcommand {\advi@record}[3][]{\advi@recording[#1]{#2}#3\endadvi@recording} + +\newcommand {\advi@play}[2][]% + {\begingroup + \advi@ifempty{#1}{}{\color {#1}}{\advi@special {proc=#2 play}}% + \endgroup} + +\advi@exportenv {advirecording}{advi@recording} +\advi@export \advirecord \advi@record +\let \endadvirecord \advi@undefinedenv +\advi@export \adviplay \advi@play + + +%%% Embedded applications + +\def \advi@embed@name{anonymous} +\def \advi@embed@mode{ephemeral} +\def \advi@embed@width{0pt} +\def \advi@embed@height{0pt} +\define@key {advi@embed}{name}{\def \advi@embed@name {#1}} +\define@key {advi@embed}{width}% + {\@tempdima#1\relax \edef \advi@embed@width {\the\@tempdima}} +\define@key {advi@embed}{height}% + {\@tempdima#1\relax \edef \advi@embed@height {\the\@tempdima}} +\def \advi@definemode #1{% + \define@key {advi@embed}{#1}[anonymous]{% + \def \advi@embed@mode {#1}\def\advi@embed@name {##1}% + }} +\advi@definemode{ephemeral} +\advi@definemode{persistent} +\advi@definemode{sticky} + +\def \advi@embed@ #1#2#3#4#5{% + \mbox{\advi@special + {embed name="#1" mode=#2 width=#3 height=#4 command="#5"}% + {\vbox to #4{\hbox to #3{}}}}} +\def \advi@length #1{\@tempdima #1\relax \the\@tempdima} +\newcommand{\advi@embed}[2][]{% + \mbox {\setkeys {advi@embed}{#1}% + \advi@embed@ {\advi@embed@name}{\advi@embed@mode} + {\advi@embed@width}{\advi@embed@height}{#2}}} + +\newcommand{\advi@killembed}[2][]{\advi@special {kill name="#2" signal="#1"}} + +\advi@export \adviembed \advi@embed + +\advi@export \advikillembed \advi@killembed + + +%%% Background colors and images + +\def \do #1{\expandafter \def \csname advi@geom@#1@\endcsname {#1}} +\do {center} +\do {left} +\do {right} +\do {bottom} +\do {top} +\do {topleft} +\do {topright} +\do {bottomleft} +\do {bottomright} +\let \do \relax +\def \advi@ifnine #1#2#3{\@ifundefined {advi@geom@#1@}{#3}{#2}} + +\let \advi@global \relax +\def \advi@global@ {global} +\newif \ifadvi@bgactive + +\def \advi@bg@do + {\do\advi@bgcolor \do\advi@bgimage \do \advi@bgalpha \do\advi@bgblend} +\def \advi@auto@ { fit=auto} +\def \advi@bgreset + {\def \do ##1{\expandafter \advi@global + \expandafter \let \noexpand ##1\advi@empty}\advi@bg@do + \advi@global \let \advi@bgfit \advi@auto@ + \advi@global \advi@bgactivefalse} +\advi@bgreset + +\def \advi@none@ {none} +\def \advi@ifnone #1{\def \@test{#1}\ifx \@test \advi@none@ + \let \@test \advi@empty \fi \ifx \@test \advi@empty + \expandafter \@firstoftwo \else \expandafter \@secondoftwo \fi} + +\def \advi@setbg #1#2#3{\advi@ifnone {#1} + {\advi@global \expandafter \let \noexpand #1\advi@empty} + {\advi@global \expandafter \def \noexpand #1{ #2=#3}% + \advi@global \advi@bgactivetrue}} +\define@key {advi@bg}{color}[]{\advi@setbg{\advi@bgcolor}{color}{#1}} +\define@key {advi@bg}{image}[]{\advi@setbg{\advi@bgimage}{image}{#1}} +\define@key {advi@bg}{alpha}[]{\advi@setbg{\advi@bgalpha}{alpha}{#1}} +\define@key {advi@bg}{blend}[]{\advi@setbg{\advi@bgblend}{blend}{#1}} +\define@key {advi@bg}{fit}[auto]{\def \advi@bgfit {#1}% + \ifx \advi@bgfit \advi@auto@ \else + \advi@ifnine {\advi@bgfit} + {\advi@global \def \advi@bgfit{ fit=#1}} + {\advi@error {Ill formed background fit=#1}}% + \fi} +\def \advi@bgset #1{\advi@ifnone {#1}{\advi@bgreset}{\setkeys {advi@bg}{#1}}} + +%\define@key {advi@bg}{inherit}[]{\advi@special{setbg inherit}} + +\def \advi@bgemit + {\advi@special + {setbg \advi@bgcolor \advi@bgimage \advi@bgalpha \advi@bgblend + \advi@bgfit + }} +\newif \ifadvi@bglocal + +\newcommand{\advi@bg}[2][]{% + \begingroup + \def \@test {#1}\ifx \@test \advi@global@ \let \advi@global \global + \advi@bgset {#2}\else + \ifx \@test \advi@empty \else \advi@warning + {Optional argument [#1] to \string \advibg ignored}\fi + \global \advi@bglocaltrue + \advi@bgset{#2}\advi@bgemit \fi + \endgroup} +\def \advi@bgpage + {\ifadvi@bgactive \ifadvi@bglocal\else \advi@bgemit \fi\fi + \global \advi@bglocalfalse} + +\advi@export \advibg \advi@bg + +%%% Pausing and waiting + +\def\advi@pause {\advi@special{pause}} +\def\advi@wait#1{\advi@special{wait sec=#1}} + +%% export +\newcommand {\adviwait}[1][]% + {\advi@ifempty {#1}{\advi@pause}{\advi@wait {#1}}} + +%%% Transparency and alpha blending +%%% To be revisited. + +\def\advi@epstransparent + {\advi@special{epstransparent push true}% + \aftergroup \advi@resetepstransparent} +\def\advi@epswhite + {\advi@special{epstransparent push false}% + \aftergroup \advi@resetepstransparent} +\def\advi@setalpha#1% + {\advi@special{alpha push #1}% + \aftergroup \advi@resetalpha} +\def\advi@setblend#1% + {\advi@special{blend push #1}% + \aftergroup\advi@resetblend} +\def\advi@resetepstransparent {\advi@special{epstransparent pop}} +\def\advi@resetalpha {\advi@special{alpha pop}} +\def\advi@resetblend {\advi@special{blend pop}} + +\advi@export \epstransparent \advi@epstransparent +\advi@export \epswhite \advi@epswhite +\advi@export \setalpha \advi@setalpha +\advi@export \setblend \advi@setblend + +%%% Animated transitions + +\def \advi@transfrom{} +\def \advi@transsteps{} +\def \advi@settrans {\advi@global \def} +\define@key {advi@trans}{none} []{\advi@settrans \advi@transmode {none}} +\define@key {advi@trans}{slide}[]{\advi@settrans \advi@transmode {slide}} +\define@key {advi@trans}{block}[]{\advi@settrans \advi@transmode {block}} +\define@key {advi@trans}{wipe} []{\advi@settrans \advi@transmode {wipe}} +\define@key {advi@trans}{from} {\advi@settrans \advi@transfrom { from=#1}} +\define@key {advi@trans}{steps}{\advi@settrans \advi@transsteps { steps=#1}} + +\def \advi@transemit + {\advi@special{trans \advi@transmode \advi@transfrom \advi@transsteps}} +\newif \ifadvi@translocal +\newcommand {\advi@transition}[2][]{% + \begingroup + \def \@test {#1}\ifx \@test \advi@global@ \let \advi@global \global + \setkeys {advi@trans}{#2}\else + \ifx \@test \advi@empty \else \advi@warning + {Optional argument [#1] to \string \advitransition ignored}\fi + \global \advi@translocaltrue + \setkeys {advi@trans}{#2}\advi@transemit \fi + \endgroup} + +\def \advi@transpage + {\@ifundefined {advi@transmode}{} + {\ifadvi@translocal\else \advi@transemit \fi}% + \global \advi@translocalfalse} + +%% Hook \advi@setpagesetyle at \@begindvi that run at every page + +\def \advi@setpagestyle {\advi@bgpage \advi@transpage} +\def \endpage@hook {} +\def \AtEndPage {\g@addto@macro \endpage@hook} +\AtEndPage {\advi@setpagestyle} + +% We must patch \@begindvi to put out hook. +% However, hyperref may patch it as well. So we should do it at begin +% document to have the control (no one after us). +% Howver, one must be careful, because \@begindvi redefines itself at the +% first call to its prerecorded final value. +% So our first patch will be overridden with the value that it was +% meant to have after the first page. +% Hence, we patch it a second time to put our hook to this final value. + +% we can use \g@addto@macro which redefines #1 to so that it procedes as +% before and then execute #2 at the end. + +\def \advi@begindvi@patch + {\g@addto@macro \@begindvi + {\endpage@hook \g@addto@macro \@begindvi {\endpage@hook}}} + +\AtBeginDocument {\advi@begindvi@patch} + +% {\let \advi@begindvi@save \@begindvi %% value at begindocument +% \def \@begindvi %% our new value +% {\advi@begindvi@save %% may redefine \@begindvi +% \global\let \advi@begindvi@save %% so we this new value +% \@begindvi +% \gdef \@begindvi %% now and forever +% {\advi@begindvi@save \endpage@hook}% +% \endpage@hook %% our hook for the +% }} + + + +%% Transitions + +\def\advi@transbox@save#1#2#3{\advi@special + {transbox save width=#1 height=#2 depth=#3}} +\def\advi@transbox@go#1{\advi@special{transbox go #1}} + +\def \advi@transslide {slide} +\def \advi@transbox #1{% + \def \advi@afterbox + {\hbox {\advi@transbox@save{\the\wd0 }{\the\ht0 }{\the\dp0}% + \unhbox0\setkeys {advi@trans}{#1}% + \advi@transbox@go + {\advi@transmode \advi@transfrom \advi@transsteps}}}% + \def \advi@@afterbox {\aftergroup \advi@afterbox} + \afterassignment \advi@@afterbox \setbox0 \hbox } + +\advi@export \advitransition \advi@transition +\advi@export \advitransbox \advi@transbox + +%%% For PS Tricks + +\def \advi@moveto {\advi@special {moveto}} +\def\advi@psput@special#1{% +\hbox{% +\pst@Verb{{ \pst@coor } +dup exec 2 copy moveto advi@Dict begin printpos end +\tx@PutCoor +\tx@PutBegin} +\hbox {\advi@moveto \box#1}% +\pst@Verb{\tx@PutEnd}}} + +\def\advi@ncput@iii{% +\leavevmode +\hbox{% +\pst@Verb{% +\pst@nodedict +/t \psk@npos def +tx@NodeDict /LPutPos known { LPutPos } { CP /Y ED /X ED /NAngle 0 +def } ifelse +LPutCoor +end +\tx@PutBegin +}% +\hbox {\box\pst@hbox}% +\pst@Verb{\tx@PutEnd}}} + +\def \advi@pstricks@patch + {\@ifundefined {psput@special}{} + {\let \psput@special \advi@psput@special + %\@ifundefined {ncput@iii}{}{\let \ncput@iii \advi@ncput@iii}% + \pstheader {advi.pro}}} +\AtBeginDocument {\advi@pstricks@patch} + + +%%% Active DVI + +\def \advi@over@ {over} +\def \advi@click@ {click} +\def \advi@null {\hbox {}} + +\newenvironment {advi@anchoring}[2][over]{% + \begingroup + \def \@test {#1}\ifx \@test \advi@over@ + \advi@special@ {html:<a advi="#2">}\else + \ifx \@test \advi@click@ + \advi@special@ {html:<a hdvi="#2">}\else + \advi@error {Incorect anchor mode #1}\fi \fi\endgroup} + {\advi@special@ {html:</a>}} +\newcommand {\advi@anchor}[3][over]% + {\advi@anchoring[#1]{#2}#3\endadvi@anchoring} + +\def \advi@endanchor #1{#1\endadvi@anchor \endgroup} +\advi@exportenv {advianchoring}{advi@anchoring} +\advi@export \advianchor \advi@anchor +\let \endadvianchor \advi@undefinedenv + +%%% Partial patch for overlays -- 0 will be shown > 0 will not be shown + +\def \advi@max {0} +\def \advi@overlay #1{% + \advi@ifadvi + {%\advance \c@overlay by 1 + \ifnum \c@overlay>\advi@max \global \xdef \advi@max {\the \c@overlay}\fi + \advi@recording {overlay@#1}\aftergroup \endadvi@recording} + {\latex@overlay {#1}}} + +\def \advi@overlay@loop + {\advi@ifadvi + {\begingroup + \c@overlay=0 + \@whilenum\c@overlay<\advi@max + \do {\advance \c@overlay by 1% + \adviwait \adviplay{overlay@\the\c@overlay}}% + \endgroup + \gdef \advi@max {0}} + {\latex@overlay@loop}} + +\def \advi@end@slide + {\advi@ifadvi {\overlay@loop}{}\latex@end@slide} + +\def \advi@overlay@patch {% + \let \latex@overlay \@overlay + \let \latex@end@slide \end@slide + \let \latex@overlay@loop \overlay@loop + \let \@overlay \advi@overlay + \let \overlay@loop \advi@overlay@loop + \let \end@slide \advi@end@slide + } + +\@ifundefined {overlay}{} + {\AtBeginDocument {\advi@overlay@patch}} + + +\endinput diff --git a/skribe/examples/slide/ex/skribe.skb b/skribe/examples/slide/ex/skribe.skb new file mode 100644 index 0000000..d1a525e --- /dev/null +++ b/skribe/examples/slide/ex/skribe.skb @@ -0,0 +1,11 @@ +(slide :title [Skribe] + (st [Skribe:]) + (itemize (item [A functional programming language based on Scheme]) + (item [A markup language ,(emph [à la]) XML]) + (item [A document ,(blue [is]) a program, + a program ,(blue [looks like]) a text with markups])) + + (p [ + ,(st [Example:]) + ,(slide-pause) + ,(skribe-prgm :file "ex/skribe.skb")])) diff --git a/skribe/examples/slide/ex/syntax.scr b/skribe/examples/slide/ex/syntax.scr new file mode 100644 index 0000000..8590f4a --- /dev/null +++ b/skribe/examples/slide/ex/syntax.scr @@ -0,0 +1 @@ +[text goodies: ,(bold "bold") and ,(it "italic").] diff --git a/skribe/examples/slide/skb/slides.skb b/skribe/examples/slide/skb/slides.skb new file mode 100644 index 0000000..c13b102 --- /dev/null +++ b/skribe/examples/slide/skb/slides.skb @@ -0,0 +1,286 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/examples/slide/skb/slides.skb */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Oct 8 16:04:59 2003 */ +;* Last change : Fri Oct 24 13:32:37 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe slide example */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Style */ +;*---------------------------------------------------------------------*/ +(case *mode* + ((advi) + (skribe-load "slide.skr" :advi #t)) + ((prosper) + (skribe-load "slide.skr" :prosper #t)) + (else + (skribe-load "slide.skr"))) + +(skribe-load "local.skr") + +;*---------------------------------------------------------------------*/ +;* latex configuration ... */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'transition 'slide) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage{pstricks,pst-node,pst-text,pst-3d}\n"))) + +;*---------------------------------------------------------------------*/ +;* sk-expression ... */ +;*---------------------------------------------------------------------*/ +(define (sk-expression) + (it "sk-expression")) +(define (sk-expressions) + (it "sk-expressions")) + +;*---------------------------------------------------------------------*/ +;* The document */ +;*---------------------------------------------------------------------*/ +(document +:title (red (sf (font :size +2. "This is Skribe!"))) +:author (author :name (it (magenta "Manuel Serrano, Erick Gallesio")) + :affiliation [Inria Sophia Antipolis, University of Nice] + :address (list "" (tt (skribe-url)))) + +;*---------------------------------------------------------------------*/ +;* First slide */ +;*---------------------------------------------------------------------*/ +(include "ex/skribe.skb") + +;* {*---------------------------------------------------------------------*} */ +;* {* Overview *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Skribe overview" */ +;* (center (image :width 90. :file "fig/overview.fig"))) */ + +;* {*---------------------------------------------------------------------*} */ +;* {* Examples *} */ +;* {*---------------------------------------------------------------------*} */ +;* (if (or (skribe-mgp?) (and (skribe-tex?) *skribe-slide-advi*)) */ +;* (slide :title "Skribe examples" */ +;* */ +;* (%embed :geometry *xterm.geo* *xterm*) */ +;* (%embed :geometry *xdvi.geo* *xdvi*) */ +;* */ +;* (st [1 Skribe document, 2 targets:]) */ +;* */ +;* (%vspace 0.0) */ +;* (itemize (item [A ,(sc [Nroff]) target:])) */ +;* (%vspace 3) */ +;* (itemize (item [A ,(sc [Dvi]) target:])))) */ + +;* {*---------------------------------------------------------------------*} */ +;* {* Skribe gallery *} */ +;* {*---------------------------------------------------------------------*} */ +;* {*--- math ------------------------------------------------------------*} */ +;* (slide :title "Gallery (1/2)" */ +;* */ +;* (st [Math skills:]) */ +;* (itemize (item [A ,(LaTeX) math formula in:])) */ +;* (p (font :size -3 */ +;* (color :bg *display-bg* */ +;* (center */ +;* (hook :after */ +;* (lambda () */ +;* (if (skribe-tex?) */ +;* (display "\\(\\sum_{i=1}^{n} x_{i} = \\int_{0}^{1} f\\)") */ +;* (display "∑<sub><font size='-2'>i=1</font></sub><sup><font size='-2'>i=1</font></sup> = ∫<sub><font size='-2'>0</font></sub><sup><font size='-2'>1</font></sup>f")))))))) */ +;* (itemize (item [Denotational semantics:])) */ +;* (p (font :size -3 */ +;* (color :bg *display-bg* */ +;* (prgm :language denotation :monospace (skribe-html?) */ +;* (map (lambda (d) */ +;* (from-file "scm/eval.scm" :definition d)) */ +;* '("ev-lambda1" "ev-funcall1")))))) */ +;* (itemize (item [SOS rule:])) */ +;* (p (font :size -4 */ +;* (color :bg *display-bg* */ +;* (labeled-component */ +;* "Assignment" */ +;* (rule */ +;* (evaluate "exp" "sched, env" "val" "sched', env'") */ +;* (rewrite "var = exp, sched, env" (TERM) "nothing, sched', env'<var = val>"))))))) */ +;* */ +;* {*--- misc ------------------------------------------------------------*} */ +;* (slide :title "Gallery (2/2)" */ +;* */ +;* (st [Misc:]) */ +;* (itemize (item [A computer program:])) */ +;* (p (font :size -1 (prgm :bg *example-bg* :language c :lnum 1 (from-file "ex/C-code.c")))) */ +;* (itemize (item [Images: */ +;* ,(p (image :width 75 :height 50 :file "img/img.jpg") */ +;* (hook :after (lambda () */ +;* (cond */ +;* ((skribe-tex?) */ +;* (display "\\ \\ \\ \\ ")) */ +;* (else */ +;* (display " "))))) */ +;* (image :width 25 :height 50 :file "img/img.jpg") */ +;* (hook :after (lambda () */ +;* (cond */ +;* ((skribe-tex?) */ +;* (display "\\ \\ \\ \\ ")) */ +;* (else */ +;* (display " "))))) */ +;* (image :width 150 :height 50 :file "img/img.jpg"))]))) */ +;* */ +;*---------------------------------------------------------------------*/ +;* Syntax */ +;*---------------------------------------------------------------------*/ +(slide :title "Skribe Syntax" :vspace 0.3 + +(st [,(sk-expression):]) + +(slide-pause) +(itemize (item [An ,(emph "atom") (a ,(red (it "string")), a ,(red (it "number")), ...)] (slide-pause)) + (item [A ,(emph "list") of ,(!latex "{\\rnode{NA}{$1}}" (sk-expressions))] (slide-pause)) + (item [A ,(emph "text") (,(red (tt [ ,(char "[")... ,(blue [,(char ",")(,(it "<expr>"))]) ...,(char "]") ])))] (slide-pause))) + +(slide-vspace 0.3) +(p [,(!latex "{\\rnode{NB}{$1}}" (st [Example:])) + ,(slide-pause) + ,(!latex "{\\nccurve[linecolor=red,angleA=90,angleB=270]{->}{NB}{NA}}") + ,(skribe-prgm :fsize 0 (source :file "ex/syntax.scr"))]) + +(p [is equivalent to: + ,(slide-pause) + ,(skribe-prgm :fsize 0 [(list "text goodies: " (bold "bold") "and" (it "italic") ".")])])) + +;* {*---------------------------------------------------------------------*} */ +;* {* Skribe documents *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Skribe Documents (1/2)" :vspace 0.5 */ +;* */ +;* (st [Skribe Document Structure:]) */ +;* (p (skribe-prgm [,(from-file "ex/skel.scr")]))) */ +;* */ +;* {*--- markup ----------------------------------------------------------*} */ +;* (slide :title "Skribe Documents (2/2)" :vspace 0.5 */ +;* (st [XML markup:]) */ +;* (p (prgm :language xml :bg *example-bg* [ */ +;* <elmt1 attr="val"> */ +;* Some text */ +;* <elmt2> */ +;* for the example */ +;* </elmt2> */ +;* </elmt1>])) */ +;* (%vspace 0.3) */ +;* (st [Sc-markup:]) */ +;* (p (skribe-prgm [,(from-file "ex/xml.scr")]))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Libraries *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Skribe Libraries" */ +;* */ +;* (st [A set of libraries containing the ,(q "usual") facilities. For instance:]) */ +;* */ +;* (p (skribe-prgm [,(from-file "ex/itemize.scr")])) */ +;* (%vspace 0.1) */ +;* (st [Produces the following output text:]) */ +;* (center (color :bg *display-bg* (font :size -2 (include "ex/itemize.scr"))))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Dynamic texts *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Dynamic texts (1/3)" :vspace 0.2 */ +;* */ +;* (st [Let us assume the factorial table:]) */ +;* (%vspace 0.5) */ +;* */ +;* (center (font :size -1 (color :bg *display-bg* (include "ex/fact.scr"))))) */ +;* */ +;* {*--- dynamic texts: the usual solution -------------------------------*} */ +;* (slide :title "Dynamic texts (2/3)" */ +;* */ +;* (st [The usual solution:]) */ +;* (p (skribe-prgm :fsize -1 (from-file "ex/factb.scr")))) */ +;* */ +;* {*--- dynamic texts: a better solution --------------------------------*} */ +;* (slide :title "Dynamic texts (3/3)" */ +;* */ +;* (st [A better solution:]) */ +;* (p (skribe-prgm (from-file "ex/fact.scr")))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Introspection *} */ +;* {*---------------------------------------------------------------------*} */ +;* {*--- Introspection ---------------------------------------------------*} */ +;* (slide :title "Introspection" */ +;* */ +;* (color :bg *image-bg* */ +;* (center (image :width 1. :file "fig/skribe.fig")))) */ +;* */ +;* {*--- Number of slides ------------------------------------------------*} */ +;* (slide :title "Introspection: an example (1/2)" */ +;* */ +;* (p (color :bg *display-bg* (include "ex/slide.scr")))) */ +;* */ +;* {*--- Number of slides (2/2) ------------------------------------------*} */ +;* (slide :title "Introspection: an example (2/2)" :vspace 0.5 */ +;* */ +;* (st [The previous output is produced with:]) */ +;* (p (skribe-prgm (from-file "ex/slide.scr")))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Conditional evaluation *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Conditional evaluation" :vspace 0.5 */ +;* */ +;* (st [Some features are dependent of the target format:]) */ +;* (itemize (item [Only specific back-ends may support specific features]) */ +;* (item [It is in charge of the back-ends to implement */ +;* ,(emph "reasonable") behaviors for unsupported features. */ +;* Examples: */ +;* ,(itemize (item [Hyper links]) */ +;* (item [Images]) */ +;* (item [...]))]) */ +;* (item [Skribe enables conditional evaluation: */ +;* ,(itemize (item [according to the target format]) */ +;* (item [enabling target format commands]))]))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Extensibility *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Extensibility" */ +;* */ +;* (st [User level:]) */ +;* (itemize (item [New markups can be defined in a document]) */ +;* (item [A markup is a Skribe (Scheme) function]) */ +;* (item [Example: the ,(code "(%pause)") slide facility:])) */ +;* */ +;* (p (skribe-prgm [ */ +;* (define (%pause) */ +;* (cond */ +;* ((skribe-mgp?) (hook :after (lambda () (display "%pause")))) */ +;* ((skribe-advi-tex?) (hook :after (lambda () (print "\\adviwait")))) */ +;* (else (linebreak))))])) */ +;* (%pause) */ +;* */ +;* (st [System level:]) */ +;* (itemize (item [New back-ends can be dynamically added]) */ +;* (item [The ,(sc-ast) can be extended]))) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* Conclusion *} */ +;* {*---------------------------------------------------------------------*} */ +;* (slide :title "Conclusion" :vspace 0.5 */ +;* */ +;* (st [Status:]) */ +;* (itemize (item [Available on-line: ,(ref :url (skribe-url))]) */ +;* (item [Available since a couple of months]) */ +;* (item [Used, by the authors, on a daily basis]) */ +;* (item [,(magenta (bold [Still too young])) ,(symbol '=>) */ +;* ,(itemize (item [Very few styles have been implemented]) */ +;* (item [It is still necessary to be aware of the */ +;* targets idiosyncrasies]) */ +;* (item [Difficult to tame the fix-point */ +;* iteration of the computation model]))])))) */ + +) diff --git a/skribe/examples/slide/skr/local.skr b/skribe/examples/slide/skr/local.skr new file mode 100644 index 0000000..2802a53 --- /dev/null +++ b/skribe/examples/slide/skr/local.skr @@ -0,0 +1,73 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/examples/slide/skr/local.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jun 3 15:32:25 2002 */ +;* Last change : Wed Oct 8 16:22:42 2003 (serrano) */ +;* Copyright : 2002-03 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The local style of the presentation */ +;*=====================================================================*/ + +;* {*---------------------------------------------------------------------*} */ +;* {* fg ... *} */ +;* {*---------------------------------------------------------------------*} */ +;* (define (fg c . body) */ +;* (apply color :fg c body)) */ +;* */ +;* {*---------------------------------------------------------------------*} */ +;* {* bg ... *} */ +;* {*---------------------------------------------------------------------*} */ +;* (define (bg c . body) */ +;* (apply color :bg c body)) */ +;* */ +;*---------------------------------------------------------------------*/ +;* colors ... */ +;*---------------------------------------------------------------------*/ +(define (green body) + (fg "darkgreen" body)) +(define (red body) + (fg "red" body)) +(define (blue body) + (bold (fg "darkblue" body))) +(define (magenta body) + (fg "darkmagenta" body)) +(define (orange body) + (fg "darkorange" body)) + +;*---------------------------------------------------------------------*/ +;* em ... */ +;*---------------------------------------------------------------------*/ +(define (em body) + (bold (magenta body))) + +;*---------------------------------------------------------------------*/ +;* st ... */ +;*---------------------------------------------------------------------*/ +(define (st body) + (sf (red body))) + +;*---------------------------------------------------------------------*/ +;* citem ... */ +;*---------------------------------------------------------------------*/ +(define-markup (citem #!rest opt #!key (color "black") (shape (math 'bullet))) + (item (list (fg color shape) " " (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* skribe-prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (skribe-prgm #!rest opt #!key file definition) + (cond + ((and definition file) + (font :size -4 + (color :bg "#ccffcc" (prog (source :language skribe + :file file + :definition definition))))) + (file + (font :size -4 + (color :bg "#ccffcc" (prog (source :language skribe + :file file))))) + (else + (font :size -4 + (color :bg "#ccffcc" (prog (source :language skribe + (the-body opt)))))))) diff --git a/skribe/skr/Makefile b/skribe/skr/Makefile new file mode 100644 index 0000000..dcc3e77 --- /dev/null +++ b/skribe/skr/Makefile @@ -0,0 +1,43 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/skr/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Sat Oct 25 08:21:20 2003 */ +#* Last change : Wed May 18 15:34:21 2005 (serrano) */ +#* Copyright : 2003-05 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Skribe SKR Makefile */ +#*=====================================================================*/ +include ../etc/Makefile.config +include ../etc/$(SYSTEM)/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* POPULATION */ +#*---------------------------------------------------------------------*/ +POPULATION= acmproc.skr sigplan.skr jfp.skr \ + slide.skr web-book.skr web-article.skr \ + base.skr latex.skr scribe.skr xml.skr \ + html.skr html4.skr lncs.skr skribe.skr \ + letter.skr french.skr latex-simple.skr context.skr Makefile + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo $(POPULATION:%=skr/%) + +#*---------------------------------------------------------------------*/ +#* Install/Uinstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: $(DESTDIR)$(INSTALL_SKRDIR) + cp *.skr $(DESTDIR)$(INSTALL_SKRDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_SKRDIR)/* + +uninstall: + +$(DESTDIR)$(INSTALL_SKRDIR): + mkdir -p $(DESTDIR)$(INSTALL_SKRDIR) && chmod a+rx $(DESTDIR)$(INSTALL_SKRDIR) + diff --git a/skribe/skr/acmproc.skr b/skribe/skr/acmproc.skr new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/skribe/skr/acmproc.skr @@ -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/skribe/skr/base.skr b/skribe/skr/base.skr new file mode 100644 index 0000000..ec987ec --- /dev/null +++ b/skribe/skr/base.skr @@ -0,0 +1,464 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/base.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:39:30 2003 */ +;* Last change : Wed Oct 27 11:24:20 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* BASE Skribe engine */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* base-engine ... */ +;*---------------------------------------------------------------------*/ +(define base-engine + (default-engine-set! + (make-engine 'base + :version 'plain + :symbol-table '(("iexcl" "!") + ("cent" "c") + ("lguillemet" "\"") + ("not" "!") + ("registered" "(r)") + ("degree" "o") + ("plusminus" "+/-") + ("micro" "o") + ("paragraph" "p") + ("middot" ".") + ("rguillemet" "\"") + ("iquestion" "?") + ("Agrave" "À") + ("Aacute" "A") + ("Acircumflex" "Â") + ("Atilde" "A") + ("Amul" "A") + ("Aring" "A") + ("AEligature" "AE") + ("Oeligature" "OE") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "E") + ("Igrave" "I") + ("Iacute" "I") + ("Icircumflex" "Î") + ("Iuml" "I") + ("ETH" "D") + ("Ntilde" "N") + ("Ograve" "O") + ("Oacute" "O") + ("Ocurcumflex" "O") + ("Otilde" "O") + ("Ouml" "O") + ("times" "x") + ("Oslash" "O") + ("Ugrave" "Ù") + ("Uacute" "U") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Y") + ("agrave" "à") + ("aacute" "a") + ("acircumflex" "â") + ("atilde" "a") + ("amul" "a") + ("aring" "a") + ("aeligature" "æ") + ("oeligature" "oe") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "e") + ("igrave" "i") + ("iacute" "i") + ("icircumflex" "î") + ("iuml" "i") + ("ntilde" "n") + ("ograve" "o") + ("oacute" "o") + ("ocurcumflex" "o") + ("otilde" "o") + ("ouml" "o") + ("divide" "/") + ("oslash" "o") + ("ugrave" "ù") + ("uacute" "u") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "y") + ("ymul" "y") + ;; punctuation + ("bullet" ".") + ("ellipsis" "...") + ("<-" "<-") + ("<--" "<--") + ("uparrow" "^;") + ("->" "->") + ("-->" "-->") + ("downarrow" "v") + ("<->" "<->") + ("<-->" "<-->") + ("<+" "<+") + ("<=" "<=;") + ("<==" "<==") + ("Uparrow" "^") + ("=>" "=>") + ("==>" "==>") + ("Downarrow" "v") + ("<=>" "<=>") + ("<==>" "<==>") + ;; Mathematical operators + ("asterisk" "*") + ("angle" "<") + ("and" "^;") + ("or" "v") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "~") + ("mid" "|") + ("langle" "<") + ("rangle" ">") + ;; LaTeX + ("circ" "o") + ("top" "T") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'symbol + :action (lambda (n e) + (let* ((s (markup-body n)) + (c (assoc s (engine-symbol-table e)))) + (if (pair? c) + (display (cadr c)) + (output s e))))) + +;*---------------------------------------------------------------------*/ +;* unref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'unref + :options 'all + :action (lambda (n e) + (let* ((s (markup-option n :skribe)) + (k (markup-option n 'kind)) + (f (cond + (s + (format "?~a@~a " k s)) + (else + (format "?~a " k)))) + (msg (list f (markup-body n))) + (n (list "[" (color :fg "red" (bold msg)) "]"))) + (skribe-eval n e)))) + +;*---------------------------------------------------------------------*/ +;* &the-bibliography ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-bibliography + :before (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-before w) n e)))) + :action (lambda (n e) + (when (pair? (markup-body n)) + (for-each (lambda (i) (output i e)) (markup-body n)))) + :after (lambda (n e) + (let ((w (markup-writer-get 'table e))) + (and (writer? w) (invoke (writer-after w) n e))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :before (lambda (n e) + (invoke (writer-before (markup-writer-get 'tr e)) n e)) + :action (lambda (n e) + (let ((wtc (markup-writer-get 'tc e))) + ;; the label + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'right) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-label e)) + (invoke (writer-after wtc) n e) + ;; the body + (markup-option-add! n :valign 'top) + (markup-option-add! n :align 'left) + (invoke (writer-before wtc) n e) + (output n e (markup-writer-get '&bib-entry-body)) + (invoke (writer-after wtc) n e))) + :after (lambda (n e) + (invoke (writer-after (markup-writer-get 'tr e)) n e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before "[" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "]") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-body + :action (lambda (n e) + (define (output-fields descr) + (let loop ((descr descr) + (pending #f) + (armed #f)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (loop (cdr descr) #f #t)) + (loop (cdr descr) pending armed)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author " -- " (or title url documenturl) " -- " + number ", " institution ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((article) + `(author " -- " (or title url documenturl) " -- " + journal ", " volume "" ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author " -- " (or title url documenturl) " -- " + booktitle ", " series ", " ("(" number ")") ", " + address ", " month ", " year ", " + ("pp. " pages) ".")) + ((book) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")) + ((phdthesis) + '(author " -- " (or title url documenturl) " -- " type ", " + school ", " address + ", " month ", " year".")) + ((misc) + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year".")) + (else + '(author " -- " (or title url documenturl) " -- " + publisher ", " address + ", " month ", " year ", " ("pp. " pages) ".")))))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-ident ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-ident + :action (lambda (n e) + (output (markup-option n 'number) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-publisher ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-publisher + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &the-index ... @label the-index@ */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index + :options '(:column) + :before (lambda (n e) + (output (markup-option n 'header) e)) + :action (lambda (n e) + (define (make-mark-entry n fst) + (let ((l (tr :class 'index-mark-entry + (td :colspan 2 :align 'left + (bold (it (sf n))))))) + (if fst + (list l) + (list (tr (td :colspan 2)) l)))) + (define (make-primary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (c (if note + (list b + (it (list " (" note ")"))) + b))) + (when p + (markup-option-add! b :text + (list (markup-option b :text) + ", p.")) + (markup-option-add! b :page #t)) + (tr :class 'index-primary-entry + (td :colspan 2 :valign 'top :align 'left c)))) + (define (make-secondary-entry n p) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (bb (markup-body b))) + (cond + ((not (or bb (is-markup? b 'url-ref))) + (skribe-error 'the-index + "Illegal entry" + b)) + (note + (let ((r (if bb + (it (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p + (list note ", p.") + note))) + (it (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p + (list note ", p.") + note)))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1. " ...") + (td :valign 'top :align 'left r)))) + (else + (let ((r (if bb + (ref :class "the-index-secondary" + :handle bb + :page p + :text (if p " ..., p." " ...")) + (ref :class "the-index-secondary" + :url (markup-option b :url) + :page p + :text (if p " ..., p." " ..."))))) + (tr :class 'index-secondary-entry + (td :valign 'top :align 'right :width 1.) + (td :valign 'top :align 'left r))))))) + (define (make-column ie p) + (let loop ((ie ie) + (f #t)) + (cond + ((null? ie) + '()) + ((not (pair? (car ie))) + (append (make-mark-entry (car ie) f) + (loop (cdr ie) #f))) + (else + (cons (make-primary-entry (caar ie) p) + (append (map (lambda (x) + (make-secondary-entry x p)) + (cdar ie)) + (loop (cdr ie) #f))))))) + (define (make-sub-tables ie nc p) + (let* ((l (length ie)) + (w (/ 100. nc)) + (iepc (let ((d (/ l nc))) + (if (integer? d) + (inexact->exact d) + (+ 1 (inexact->exact (truncate d)))))) + (split (list-split ie iepc))) + (tr (map (lambda (ies) + (td :valign 'top :width w + (if (pair? ies) + (table :width 100. (make-column ies p)) + ""))) + split)))) + (let* ((ie (markup-body n)) + (nc (markup-option n :column)) + (loc (ast-loc n)) + (pref (eq? (engine-custom e 'index-page-ref) #t)) + (t (cond + ((null? ie) + "") + ((or (not (integer? nc)) (= nc 1)) + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-column ie pref))) + (else + (table :width 100. + :&skribe-eval-location loc + :class "index-table" + (make-sub-tables ie nc pref)))))) + (output (skribe-eval t e) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;* ------------------------------------------------------------- */ +;* The index header is only useful for targets that support */ +;* hyperlinks such as HTML. */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) #f)) + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&prog-line + :before (lambda (n e) + (let ((n (markup-ident n))) + (if n (skribe-eval (it (list n) ": ") e)))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (n (markup-ident (handle-body (markup-body n))))) + (skribe-eval (it (if (integer? o) (+ o n) n)) e)))) + + + +;;;; A VIRER (mais handle-body n'est pas défini) +(markup-writer 'line-ref + :options '(:offset) + :action #f) diff --git a/skribe/skr/context.skr b/skribe/skr/context.skr new file mode 100644 index 0000000..5bc5316 --- /dev/null +++ b/skribe/skr/context.skr @@ -0,0 +1,1380 @@ +;;;; +;;;; context.skr -- ConTeXt mode for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 23-Sep-2004 17:21 (eg) +;;;; Last file update: 3-Nov-2004 12:54 (eg) +;;;; + +;;;; ====================================================================== +;;;; context-customs ... +;;;; ====================================================================== +(define context-customs + '((source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + (index-page-ref #t) + (image-format ("jpg")) + (font-size 11) + (font-type "roman") + (user-style #f) + (document-style "book"))) + +;;;; ====================================================================== +;;;; context-encoding ... +;;;; ====================================================================== +(define context-encoding + '((#\# "\\type{#}") + (#\| "\\type{|}") + (#\{ "$\\{$") + (#\} "$\\}$") + (#\~ "\\type{~}") + (#\& "\\type{&}") + (#\_ "\\type{_}") + (#\^ "\\type{^}") + (#\[ "\\type{[}") + (#\] "\\type{]}") + (#\< "\\type{<}") + (#\> "\\type{>}") + (#\$ "\\type{$}") + (#\% "\\%") + (#\\ "$\\backslash$"))) + +;;;; ====================================================================== +;;;; context-pre-encoding ... +;;;; ====================================================================== +(define context-pre-encoding + (append '((#\space "~") + (#\~ "\\type{~}")) + context-encoding)) + + +;;;; ====================================================================== +;;;; context-symbol-table ... +;;;; ====================================================================== +(define (context-symbol-table math) + `(("iexcl" "!`") + ("cent" "c") + ("pound" "\\pounds") + ("yen" "Y") + ("section" "\\S") + ("mul" ,(math "^-")) + ("copyright" "\\copyright") + ("lguillemet" ,(math "\\ll")) + ("not" ,(math "\\neg")) + ("degree" ,(math "^{\\small{o}}")) + ("plusminus" ,(math "\\pm")) + ("micro" ,(math "\\mu")) + ("paragraph" "\\P") + ("middot" ,(math "\\cdot")) + ("rguillemet" ,(math "\\gg")) + ("1/4" ,(math "\\frac{1}{4}")) + ("1/2" ,(math "\\frac{1}{2}")) + ("3/4" ,(math "\\frac{3}{4}")) + ("iquestion" "?`") + ("Agrave" "\\`{A}") + ("Aacute" "\\'{A}") + ("Acircumflex" "\\^{A}") + ("Atilde" "\\~{A}") + ("Amul" "\\\"{A}") + ("Aring" "{\\AA}") + ("AEligature" "{\\AE}") + ("Oeligature" "{\\OE}") + ("Ccedilla" "{\\c{C}}") + ("Egrave" "{\\`{E}}") + ("Eacute" "{\\'{E}}") + ("Ecircumflex" "{\\^{E}}") + ("Euml" "\\\"{E}") + ("Igrave" "{\\`{I}}") + ("Iacute" "{\\'{I}}") + ("Icircumflex" "{\\^{I}}") + ("Iuml" "\\\"{I}") + ("ETH" "D") + ("Ntilde" "\\~{N}") + ("Ograve" "\\`{O}") + ("Oacute" "\\'{O}") + ("Ocurcumflex" "\\^{O}") + ("Otilde" "\\~{O}") + ("Ouml" "\\\"{O}") + ("times" ,(math "\\times")) + ("Oslash" "\\O") + ("Ugrave" "\\`{U}") + ("Uacute" "\\'{U}") + ("Ucircumflex" "\\^{U}") + ("Uuml" "\\\"{U}") + ("Yacute" "\\'{Y}") + ("szlig" "\\ss") + ("agrave" "\\`{a}") + ("aacute" "\\'{a}") + ("acircumflex" "\\^{a}") + ("atilde" "\\~{a}") + ("amul" "\\\"{a}") + ("aring" "\\aa") + ("aeligature" "\\ae") + ("oeligature" "{\\oe}") + ("ccedilla" "{\\c{c}}") + ("egrave" "{\\`{e}}") + ("eacute" "{\\'{e}}") + ("ecircumflex" "{\\^{e}}") + ("euml" "\\\"{e}") + ("igrave" "{\\`{\\i}}") + ("iacute" "{\\'{\\i}}") + ("icircumflex" "{\\^{\\i}}") + ("iuml" "\\\"{\\i}") + ("ntilde" "\\~{n}") + ("ograve" "\\`{o}") + ("oacute" "\\'{o}") + ("ocurcumflex" "\\^{o}") + ("otilde" "\\~{o}") + ("ouml" "\\\"{o}") + ("divide" ,(math "\\div")) + ("oslash" "\\o") + ("ugrave" "\\`{u}") + ("uacute" "\\'{u}") + ("ucircumflex" "\\^{u}") + ("uuml" "\\\"{u}") + ("yacute" "\\'{y}") + ("ymul" "\\\"{y}") + ;; Greek + ("Alpha" "A") + ("Beta" "B") + ("Gamma" ,(math "\\Gamma")) + ("Delta" ,(math "\\Delta")) + ("Epsilon" "E") + ("Zeta" "Z") + ("Eta" "H") + ("Theta" ,(math "\\Theta")) + ("Iota" "I") + ("Kappa" "K") + ("Lambda" ,(math "\\Lambda")) + ("Mu" "M") + ("Nu" "N") + ("Xi" ,(math "\\Xi")) + ("Omicron" "O") + ("Pi" ,(math "\\Pi")) + ("Rho" "P") + ("Sigma" ,(math "\\Sigma")) + ("Tau" "T") + ("Upsilon" ,(math "\\Upsilon")) + ("Phi" ,(math "\\Phi")) + ("Chi" "X") + ("Psi" ,(math "\\Psi")) + ("Omega" ,(math "\\Omega")) + ("alpha" ,(math "\\alpha")) + ("beta" ,(math "\\beta")) + ("gamma" ,(math "\\gamma")) + ("delta" ,(math "\\delta")) + ("epsilon" ,(math "\\varepsilon")) + ("zeta" ,(math "\\zeta")) + ("eta" ,(math "\\eta")) + ("theta" ,(math "\\theta")) + ("iota" ,(math "\\iota")) + ("kappa" ,(math "\\kappa")) + ("lambda" ,(math "\\lambda")) + ("mu" ,(math "\\mu")) + ("nu" ,(math "\\nu")) + ("xi" ,(math "\\xi")) + ("omicron" ,(math "\\o")) + ("pi" ,(math "\\pi")) + ("rho" ,(math "\\rho")) + ("sigmaf" ,(math "\\varsigma")) + ("sigma" ,(math "\\sigma")) + ("tau" ,(math "\\tau")) + ("upsilon" ,(math "\\upsilon")) + ("phi" ,(math "\\varphi")) + ("chi" ,(math "\\chi")) + ("psi" ,(math "\\psi")) + ("omega" ,(math "\\omega")) + ("thetasym" ,(math "\\vartheta")) + ("piv" ,(math "\\varpi")) + ;; punctuation + ("bullet" ,(math "\\bullet")) + ("ellipsis" ,(math "\\ldots")) + ("weierp" ,(math "\\wp")) + ("image" ,(math "\\Im")) + ("real" ,(math "\\Re")) + ("tm" ,(math "^{\\sc\\tiny{tm}}")) + ("alef" ,(math "\\aleph")) + ("<-" ,(math "\\leftarrow")) + ("<--" ,(math "\\longleftarrow")) + ("uparrow" ,(math "\\uparrow")) + ("->" ,(math "\\rightarrow")) + ("-->" ,(math "\\longrightarrow")) + ("downarrow" ,(math "\\downarrow")) + ("<->" ,(math "\\leftrightarrow")) + ("<-->" ,(math "\\longleftrightarrow")) + ("<+" ,(math "\\hookleftarrow")) + ("<=" ,(math "\\Leftarrow")) + ("<==" ,(math "\\Longleftarrow")) + ("Uparrow" ,(math "\\Uparrow")) + ("=>" ,(math "\\Rightarrow")) + ("==>" ,(math "\\Longrightarrow")) + ("Downarrow" ,(math "\\Downarrow")) + ("<=>" ,(math "\\Leftrightarrow")) + ("<==>" ,(math "\\Longleftrightarrow")) + ;; Mathematical operators + ("forall" ,(math "\\forall")) + ("partial" ,(math "\\partial")) + ("exists" ,(math "\\exists")) + ("emptyset" ,(math "\\emptyset")) + ("infinity" ,(math "\\infty")) + ("nabla" ,(math "\\nabla")) + ("in" ,(math "\\in")) + ("notin" ,(math "\\notin")) + ("ni" ,(math "\\ni")) + ("prod" ,(math "\\Pi")) + ("sum" ,(math "\\Sigma")) + ("asterisk" ,(math "\\ast")) + ("sqrt" ,(math "\\surd")) + ("propto" ,(math "\\propto")) + ("angle" ,(math "\\angle")) + ("and" ,(math "\\wedge")) + ("or" ,(math "\\vee")) + ("cap" ,(math "\\cap")) + ("cup" ,(math "\\cup")) + ("integral" ,(math "\\int")) + ("models" ,(math "\\models")) + ("vdash" ,(math "\\vdash")) + ("dashv" ,(math "\\dashv")) + ("sim" ,(math "\\sim")) + ("cong" ,(math "\\cong")) + ("approx" ,(math "\\approx")) + ("neq" ,(math "\\neq")) + ("equiv" ,(math "\\equiv")) + ("le" ,(math "\\leq")) + ("ge" ,(math "\\geq")) + ("subset" ,(math "\\subset")) + ("supset" ,(math "\\supset")) + ("subseteq" ,(math "\\subseteq")) + ("supseteq" ,(math "\\supseteq")) + ("oplus" ,(math "\\oplus")) + ("otimes" ,(math "\\otimes")) + ("perp" ,(math "\\perp")) + ("mid" ,(math "\\mid")) + ("lceil" ,(math "\\lceil")) + ("rceil" ,(math "\\rceil")) + ("lfloor" ,(math "\\lfloor")) + ("rfloor" ,(math "\\rfloor")) + ("langle" ,(math "\\langle")) + ("rangle" ,(math "\\rangle")) + ;; Misc + ("loz" ,(math "\\diamond")) + ("spades" ,(math "\\spadesuit")) + ("clubs" ,(math "\\clubsuit")) + ("hearts" ,(math "\\heartsuit")) + ("diams" ,(math "\\diamondsuit")) + ("euro" "\\euro{}") + ;; ConTeXt + ("dag" "\\dag") + ("ddag" "\\ddag") + ("circ" ,(math "\\circ")) + ("top" ,(math "\\top")) + ("bottom" ,(math "\\bot")) + ("lhd" ,(math "\\triangleleft")) + ("rhd" ,(math "\\triangleright")) + ("parallel" ,(math "\\parallel")))) + +;;;; ====================================================================== +;;;; context-width +;;;; ====================================================================== +(define (context-width width) + (cond + ((string? width) + width) + ((and (number? width) (inexact? width)) + (string-append (number->string (/ width 100.)) "\\textwidth")) + (else + (string-append (number->string width) "pt")))) + +;;;; ====================================================================== +;;;; context-dim +;;;; ====================================================================== +(define (context-dim dimension) + (cond + ((string? dimension) + dimension) + ((number? dimension) + (string-append (number->string (inexact->exact (round dimension))) + "pt")))) + +;;;; ====================================================================== +;;;; context-url +;;;; ====================================================================== +(define(context-url url text e) + (let ((name (gensym 'url)) + (text (or text url))) + (printf "\\useURL[~A][~A][][" name url) + (output text e) + (printf "]\\from[~A]" name))) + +;;;; ====================================================================== +;;;; Color Management ... +;;;; ====================================================================== +(define *skribe-context-color-table* (make-hashtable)) + +(define (skribe-color->context-color spec) + (receive (r g b) + (skribe-color->rgb spec) + (let ((ff (exact->inexact #xff))) + (format "r=~a,g=~a,b=~a" + (number->string (/ r ff)) + (number->string (/ g ff)) + (number->string (/ b ff)))))) + + +(define (skribe-declare-used-colors) + (printf "\n%%Colors\n") + (for-each (lambda (spec) + (let ((c (hashtable-get *skribe-context-color-table* spec))) + (unless (string? c) + ;; Color was never used before + (let ((name (symbol->string (gensym 'col)))) + (hashtable-put! *skribe-context-color-table* spec name) + (printf "\\definecolor[~A][~A]\n" + name + (skribe-color->context-color spec)))))) + (skribe-get-used-colors)) + (newline)) + +(define (skribe-declare-standard-colors engine) + (for-each (lambda (x) + (skribe-use-color! (engine-custom engine x))) + '(source-comment-color source-define-color source-module-color + source-markup-color source-thread-color source-string-color + source-bracket-color source-type-color))) + +(define (skribe-get-color spec) + (let ((c (and (hashtable? *skribe-context-color-table*) + (hashtable-get *skribe-context-color-table* spec)))) + (if (not (string? c)) + (skribe-error 'context "Can't find color" spec) + c))) + +;;;; ====================================================================== +;;;; context-engine ... +;;;; ====================================================================== +(define context-engine + (default-engine-set! + (make-engine 'context + :version 1.0 + :format "context" + :delegate (find-engine 'base) + :filter (make-string-replace context-encoding) + :symbol-table (context-symbol-table (lambda (m) (format "$~a$" m))) + :custom context-customs))) + +;;;; ====================================================================== +;;;; document ... +;;;; ====================================================================== +(markup-writer 'document + :options '(:title :subtitle :author :ending :env) + :before (lambda (n e) + ;; Prelude + (printf "% interface=en output=pdftex\n") + (display "%%%% -*- TeX -*-\n") + (printf "%%%% File automatically generated by Skribe ~A on ~A\n\n" + (skribe-release) (date)) + ;; Make URLs active + (printf "\\setupinteraction[state=start]\n") + ;; Choose the document font + (printf "\\setupbodyfont[~a,~apt]\n" (engine-custom e 'font-type) + (engine-custom e 'font-size)) + ;; Color + (display "\\setupcolors[state=start]\n") + ;; Load Style + (printf "\\input skribe-context-~a.tex\n" + (engine-custom e 'document-style)) + ;; Insert User customization + (let ((s (engine-custom e 'user-style))) + (when s (printf "\\input ~a\n" s))) + ;; Output used colors + (skribe-declare-standard-colors e) + (skribe-declare-used-colors) + + (display "\\starttext\n\\StartTitlePage\n") + ;; title + (let ((t (markup-option n :title))) + (when t + (skribe-eval (new markup + (markup '&context-title) + (body t) + (options + `((subtitle ,(markup-option n :subtitle))))) + e + :env `((parent ,n))))) + ;; author(s) + (let ((a (markup-option n :author))) + (when a + (if (list? a) + ;; List of authors. Use multi-columns + (begin + (printf "\\defineparagraphs[Authors][n=~A]\n" (length a)) + (display "\\startAuthors\n") + (let Loop ((l a)) + (unless (null? l) + (output (car l) e) + (unless (null? (cdr l)) + (display "\\nextAuthors\n") + (Loop (cdr l))))) + (display "\\stopAuthors\n\n")) + ;; One author, that's easy + (output a e)))) + ;; End of the title + (display "\\StopTitlePage\n")) + :after (lambda (n e) + (display "\n\\stoptext\n"))) + + + +;;;; ====================================================================== +;;;; &context-title ... +;;;; ====================================================================== +(markup-writer '&context-title + :before "{\\DocumentTitle{" + :action (lambda (n e) + (output (markup-body n) e) + (let ((sub (markup-option n 'subtitle))) + (when sub + (display "\\\\\n\\switchtobodyfont[16pt]\\it{") + (output sub e) + (display "}\n")))) + :after "}}") + +;;;; ====================================================================== +;;;; author ... +;;;; ====================================================================== +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (out (lambda (n) + (output n e) + (display "\\\\\n")))) + (display "{\\midaligned{") + (when name (out name)) + (when title (out title)) + (when affiliation (out affiliation)) + (when (pair? address) (for-each out address)) + (when phone (out phone)) + (when email (out email)) + (when url (out url)) + (display "}}\n")))) + + +;;;; ====================================================================== +;;;; toc ... +;;;; ====================================================================== +(markup-writer 'toc + :options '() + :action (lambda (n e) (display "\\placecontent\n"))) + +;;;; ====================================================================== +;;;; context-block-before ... +;;;; ====================================================================== +(define (context-block-before name name-unnum) + (lambda (n e) + (let ((num (markup-option n :number))) + (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (printf "\\~a[~a]{" (if num name name-unnum) + (string-canonicalize (markup-ident n))) + (output (markup-option n :title) e) + (display "}\n")))) + + +;;;; ====================================================================== +;;;; chapter, section, ... +;;;; ====================================================================== +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :before (context-block-before 'chapter 'title)) + + +(markup-writer 'section + :options '(:title :number :toc :file :env) + :before (context-block-before 'section 'subject)) + + +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :before (context-block-before 'subsection 'subsubject)) + + +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :before (context-block-before 'subsubsection 'subsubsubject)) + +;;;; ====================================================================== +;;;; paragraph ... +;;;; ====================================================================== +(markup-writer 'paragraph + :options '(:title :number :toc :env) + :after "\\par\n") + +;;;; ====================================================================== +;;;; footnote ... +;;;; ====================================================================== +(markup-writer 'footnote + :before "\\footnote{" + :after "}") + +;;;; ====================================================================== +;;;; linebreak ... +;;;; ====================================================================== +(markup-writer 'linebreak + :action "\\crlf ") + +;;;; ====================================================================== +;;;; hrule ... +;;;; ====================================================================== +(markup-writer 'hrule + :options '(:width :height) + :before (lambda (n e) + (printf "\\blackrule[width=~A,height=~A]\n" + (context-width (markup-option n :width)) + (context-dim (markup-option n :height))))) + +;;;; ====================================================================== +;;;; color ... +;;;; ====================================================================== +(markup-writer 'color + :options '(:bg :fg :width :margin :border) + :before (lambda (n e) + (let ((bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (w (markup-option n :width)) + (m (markup-option n :margin)) + (b (markup-option n :border)) + (c (markup-option n :round-corner))) + (if (or bg w m b) + (begin + (printf "\\startframedtext[width=~a" (if w + (context-width w) + "fit")) + (printf ",rulethickness=~A" (if b (context-width b) "0pt")) + (when m + (printf ",offset=~A" (context-width m))) + (when bg + (printf ",background=color,backgroundcolor=~A" + (skribe-get-color bg))) + (when fg + (printf ",foregroundcolor=~A" + (skribe-get-color fg))) + (when c + (display ",framecorner=round")) + (printf "]\n")) + ;; Probably just a foreground was specified + (when fg + (printf "\\startcolor[~A] " (skribe-get-color fg)))))) + :after (lambda (n e) + (let ((bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (w (markup-option n :width)) + (m (markup-option n :margin)) + (b (markup-option n :border))) + (if (or bg w m b) + (printf "\\stopframedtext ") + (when fg + (printf "\\stopcolor ")))))) +;;;; ====================================================================== +;;;; frame ... +;;;; ====================================================================== +(markup-writer 'frame + :options '(:width :border :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (b (markup-option n :border)) + (c (markup-option n :round-corner))) + (printf "\\startframedtext[width=~a" (if w + (context-width w) + "fit")) + (printf ",rulethickness=~A" (context-dim b)) + (printf ",offset=~A" (context-width m)) + (when c + (display ",framecorner=round")) + (printf "]\n"))) + :after "\\stopframedtext ") + +;;;; ====================================================================== +;;;; font ... +;;;; ====================================================================== +(markup-writer 'font + :options '(:size) + :action (lambda (n e) + (let* ((size (markup-option n :size)) + (cs (engine-custom e 'font-size)) + (ns (cond + ((and (integer? size) (exact? size)) + (if (> size 0) + size + (+ cs size))) + ((and (number? size) (inexact? size)) + (+ cs (inexact->exact size))) + ((string? size) + (let ((nb (string->number size))) + (if (not (number? nb)) + (skribe-error + 'font + (format "Illegal font size ~s" size) + nb) + (+ cs nb)))))) + (ne (make-engine (gensym 'context) + :delegate e + :filter (engine-filter e) + :symbol-table (engine-symbol-table e) + :custom `((font-size ,ns) + ,@(engine-customs e))))) + (printf "{\\switchtobodyfont[~apt]" ns) + (output (markup-body n) ne) + (display "}")))) + + +;;;; ====================================================================== +;;;; flush ... +;;;; ====================================================================== +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\n\n\\midaligned{")) + ((left) + (display "\n\n\\leftaligned{")) + ((right) + (display "\n\n\\rightaligned{")))) + :after "}\n") + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before "\n\n\\midaligned{" + :after "}\n") + +;;;; ====================================================================== +;;;; pre ... +;;;; ====================================================================== +(markup-writer 'pre + :before "{\\tt\n\\startlines\n\\fixedspaces\n" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'context) + :delegate e + :filter (make-string-replace context-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after "\n\\stoplines\n}") + +;;;; ====================================================================== +;;;; prog ... +;;;; ====================================================================== +(markup-writer 'prog + :options '(:line :mark) + :before "{\\tt\n\\startlines\n\\fixedspaces\n" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'context) + :delegate e + :filter (make-string-replace context-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after "\n\\stoplines\n}") + + +;;;; ====================================================================== +;;;; itemize, enumerate ... +;;;; ====================================================================== +(define (context-itemization-action n e descr?) + (let ((symbol (markup-option n :symbol))) + (for-each (lambda (item) + (if symbol + (begin + (display "\\sym{") + (output symbol e) + (display "}")) + ;; output a \item iff not a description + (unless descr? + (display " \\item "))) + (output item e) + (newline)) + (markup-body n)))) + +(markup-writer 'itemize + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[serried]\n" + :action (lambda (n e) (context-itemization-action n e #f)) + :after "\\stopitemize\n\\stopnarrower\n") + + +(markup-writer 'enumerate + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[n][standard]\n" + :action (lambda (n e) (context-itemization-action n e #f)) + :after "\\stopitemize\n\\stopnarrower\n") + +;;;; ====================================================================== +;;;; description ... +;;;; ====================================================================== +(markup-writer 'description + :options '(:symbol) + :before "\\startnarrower[left]\n\\startitemize[serried]\n" + :action (lambda (n e) (context-itemization-action n e #t)) + :after "\\stopitemize\n\\stopnarrower\n") + +;;;; ====================================================================== +;;;; item ... +;;;; ====================================================================== +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (when k + ;; Output the key(s) + (let Loop ((l (if (pair? k) k (list k)))) + (unless (null? l) + (output (bold (car l)) e) + (unless (null? (cdr l)) + (display "\\crlf\n")) + (Loop (cdr l)))) + (display "\\nowhitespace\\startnarrower[left]\n")) + ;; Output body + (output (markup-body n) e) + ;; Terminate + (when k + (display "\n\\stopnarrower\n"))))) + +;;;; ====================================================================== +;;;; blockquote ... +;;;; ====================================================================== +(markup-writer 'blockquote + :before "\n\\startnarrower[left,right]\n" + :after "\n\\stopnarrower\n") + + +;;;; ====================================================================== +;;;; figure ... +;;;; ====================================================================== +(markup-writer 'figure + :options '(:legend :number :multicolumns) + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (unless number + (display "{\\setupcaptions[number=off]\n")) + (display "\\placefigure\n") + (printf " [~a]\n" (string-canonicalize ident)) + (display " {") (output legend e) (display "}\n") + (display " {") (output (markup-body n) e) (display "}") + (unless number + (display "}\n"))))) + +;;;; ====================================================================== +;;;; table ... +;;;; ====================================================================== + ;; width doesn't work +(markup-writer 'table + :options '(:width :border :frame :rules :cellpadding) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (cp (markup-option n :cellpadding)) + (cs (markup-option n :cellspacing))) + (printf "\n{\\bTABLE\n") + (printf "\\setupTABLE[") + (printf "width=~A" (if width (context-width width) "fit")) + (when border + (printf ",rulethickness=~A" (context-dim border))) + (when cp + (printf ",offset=~A" (context-width cp))) + (printf ",frame=off]\n") + + (when rules + (let ((hor "\\setupTABLE[row][bottomframe=on,topframe=on]\n") + (vert "\\setupTABLE[c][leftframe=on,rightframe=on]\n")) + (case rules + ((rows) (display hor)) + ((cols) (display vert)) + ((all) (display hor) (display vert))))) + + (when frame + ;; hsides, vsides, lhs, rhs, box, border + (let ((top "\\setupTABLE[row][first][frame=off,topframe=on]\n") + (bot "\\setupTABLE[row][last][frame=off,bottomframe=on]\n") + (left "\\setupTABLE[c][first][frame=off,leftframe=on]\n") + (right "\\setupTABLE[c][last][frame=off,rightframe=on]\n")) + (case frame + ((above) (display top)) + ((below) (display bot)) + ((hsides) (display top) (display bot)) + ((lhs) (display left)) + ((rhs) (display right)) + ((vsides) (display left) (diplay right)) + ((box border) (display top) (display bot) + (display left) (display right))))))) + + :after (lambda (n e) + (printf "\\eTABLE}\n"))) + + +;;;; ====================================================================== +;;;; tr ... +;;;; ====================================================================== +(markup-writer 'tr + :options '(:bg) + :before (lambda (n e) + (display "\\bTR") + (let ((bg (markup-option n :bg))) + (when bg + (printf "[background=color,backgroundcolor=~A]" + (skribe-get-color bg))))) + :after "\\eTR\n") + + +;;;; ====================================================================== +;;;; tc ... +;;;; ====================================================================== +(markup-writer 'tc + :options '(:width :align :valign :colspan) + :before (lambda (n e) + (let ((th? (eq? 'th (markup-option n 'markup))) + (width (markup-option n :width)) + (align (markup-option n :align)) + (valign (markup-option n :valign)) + (colspan (markup-option n :colspan)) + (rowspan (markup-option n :rowspan)) + (bg (markup-option n :bg))) + (printf "\\bTD[") + (printf "width=~a" (if width (context-width width) "fit")) + (when valign + ;; This is buggy. In fact valign an align can't be both + ;; specified in ConTeXt + (printf ",align=~a" (case valign + ((center) 'lohi) + ((bottom) 'low) + ((top) 'high)))) + (when align + (printf ",align=~a" (case align + ((left) 'right) ; !!!! + ((right) 'left) ; !!!! + (else 'middle)))) + (unless (equal? colspan 1) + (printf ",nx=~a" colspan)) + (display "]") + (when th? + ;; This is a TH, output is bolded + (display "{\\bf{")))) + + :after (lambda (n e) + (when (equal? (markup-option n 'markup) 'th) + ;; This is a TH, output is bolded + (display "}}")) + (display "\\eTD"))) + +;;;; ====================================================================== +;;;; image ... +;;;; ====================================================================== +(markup-writer 'image + :options '(:file :url :width :height :zoom) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (zoom (markup-option n :zoom)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("jpg")))))) + (if (not (string? img)) + (skribe-error 'context "Illegal image" file) + (begin + (printf "\\externalfigure[~A][frame=off" (strip-ref-base img)) + (if zoom (printf ",factor=~a" (inexact->exact zoom))) + (if width (printf ",width=~a" (context-width width))) + (if height (printf ",height=~apt" (context-dim height))) + (display "]")))))) + + +;;;; ====================================================================== +;;;; Ornaments ... +;;;; ====================================================================== +(markup-writer 'roman :before "{\\rm{" :after "}}") +(markup-writer 'bold :before "{\\bf{" :after "}}") +(markup-writer 'underline :before "{\\underbar{" :after "}}") +(markup-writer 'emph :before "{\\em{" :after "}}") +(markup-writer 'it :before "{\\it{" :after "}}") +(markup-writer 'code :before "{\\tt{" :after "}}") +(markup-writer 'var :before "{\\tt{" :after "}}") +(markup-writer 'sc :before "{\\sc{" :after "}}") +;;//(markup-writer 'sf :before "{\\sf{" :after "}}") +(markup-writer 'sub :before "{\\low{" :after "}}") +(markup-writer 'sup :before "{\\high{" :after "}}") + + +;;// +;;//(markup-writer 'tt +;;// :before "{\\texttt{" +;;// :action (lambda (n e) +;;// (let ((ne (make-engine +;;// (gensym 'latex) +;;// :delegate e +;;// :filter (make-string-replace latex-tt-encoding) +;;// :custom (engine-customs e) +;;// :symbol-table (engine-symbol-table e)))) +;;// (output (markup-body n) ne))) +;;// :after "}}") + +;;;; ====================================================================== +;;;; q ... +;;;; ====================================================================== +(markup-writer 'q + :before "\\quotation{" + :after "}") + +;;;; ====================================================================== +;;;; mailto ... +;;;; ====================================================================== +(markup-writer 'mailto + :options '(:text) + :action (lambda (n e) + (let ((text (markup-option n :text)) + (url (markup-body n))) + (when (pair? url) + (context-url (format "mailto:~A" (car url)) + (or text + (car url)) + e))))) +;;;; ====================================================================== +;;;; mark ... +;;;; ====================================================================== +(markup-writer 'mark + :before (lambda (n e) + (printf "\\reference[~a]{}\n" + (string-canonicalize (markup-ident n))))) + +;;;; ====================================================================== +;;;; ref ... +;;;; ====================================================================== +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection + :figure :mark :handle :page) + :action (lambda (n e) + (let* ((text (markup-option n :text)) + (page (markup-option n :page)) + (c (handle-ast (markup-body n))) + (id (markup-ident c))) + (cond + (page ;; Output the page only (this is a hack) + (when text (output text e)) + (printf "\\at[~a]" + (string-canonicalize id))) + ((or (markup-option n :chapter) + (markup-option n :section) + (markup-option n :subsection) + (markup-option n :subsubsection)) + (if text + (printf "\\goto{~a}[~a]" (or text id) + (string-canonicalize id)) + (printf "\\in[~a]" (string-canonicalize id)))) + ((markup-option n :mark) + (printf "\\goto{~a}[~a]" + (or text id) + (string-canonicalize id))) + (else ;; Output a little image indicating the direction + (printf "\\in[~a]" (string-canonicalize id))))))) + +;;;; ====================================================================== +;;;; bib-ref ... +;;;; ====================================================================== +(markup-writer 'bib-ref + :options '(:text :bib) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) + (let* ((obj (handle-ast (markup-body n))) + (title (markup-option obj :title)) + (ref (markup-option title 'number)) + (ident (markup-ident obj))) + (printf "\\goto{~a}[~a]" ref (string-canonicalize ident)))) + :after (lambda (n e) (output "]" e))) + +;;;; ====================================================================== +;;;; bib-ref+ ... +;;;; ====================================================================== +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (invoke (writer-action (markup-writer-get 'bib-ref e)) + (car rs) + e) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after (lambda (n e) (output "]" e))) + +;;;; ====================================================================== +;;;; url-ref ... +;;;; ====================================================================== +(markup-writer 'url-ref + :options '(:url :text) + :action (lambda (n e) + (context-url (markup-option n :url) (markup-option n :text) e))) + +;;//;*---------------------------------------------------------------------*/ +;;//;* line-ref ... */ +;;//;*---------------------------------------------------------------------*/ +;;//(markup-writer 'line-ref +;;// :options '(:offset) +;;// :before "{\\textit{" +;;// :action (lambda (n e) +;;// (let ((o (markup-option n :offset)) +;;// (v (string->number (markup-option n :text)))) +;;// (cond +;;// ((and (number? o) (number? v)) +;;// (display (+ o v))) +;;// (else +;;// (display v))))) +;;// :after "}}") + + +;;;; ====================================================================== +;;;; &the-bibliography ... +;;;; ====================================================================== +(markup-writer '&the-bibliography + :before "\n% Bibliography\n\n") + + +;;;; ====================================================================== +;;;; &bib-entry ... +;;;; ====================================================================== +(markup-writer '&bib-entry + :options '(:title) + :action (lambda (n e) + (skribe-eval (mark (markup-ident n)) e) + (output n e (markup-writer-get '&bib-entry-label e)) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n\n") + +;;;; ====================================================================== +;;;; &bib-entry-label ... +;;;; ====================================================================== +(markup-writer '&bib-entry-label + :options '(:title) + :before (lambda (n e) (output "[" e)) + :action (lambda (n e) (output (markup-option n :title) e)) + :after (lambda (n e) (output "] "e))) + +;;;; ====================================================================== +;;;; &bib-entry-title ... +;;;; ====================================================================== +(markup-writer '&bib-entry-title + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url #f ) ;;;;;;;;;;;;;;;// (markup-option en 'url)) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + + +;;//;*---------------------------------------------------------------------*/ +;;//;* &bib-entry-url ... */ +;;//;*---------------------------------------------------------------------*/ +;;//(markup-writer '&bib-entry-url +;;// :action (lambda (n e) +;;// (let* ((en (handle-ast (ast-parent n))) +;;// (url (markup-option en 'url)) +;;// (t (bold (markup-body url)))) +;;// (skribe-eval (ref :url (markup-body url) :text t) e)))) + + +;;;; ====================================================================== +;;;; &the-index ... +;;;; ====================================================================== +(markup-writer '&the-index + :options '(:column) + :action + (lambda (n e) + (define (make-mark-entry n) + (display "\\blank[medium]\n{\\bf\\it\\tfc{") + (skribe-eval (bold n) e) + (display "}}\\crlf\n")) + + (define (make-primary-entry n) + (let ((b (markup-body n))) + (markup-option-add! b :text (list (markup-option b :text) ", ")) + (markup-option-add! b :page #t) + (output n e))) + + (define (make-secondary-entry n) + (let* ((note (markup-option n :note)) + (b (markup-body n)) + (bb (markup-body b))) + (if note + (begin ;; This is another entry + (display "\\crlf\n ... ") + (markup-option-add! b :text (list note ", "))) + (begin ;; another line on an entry + (markup-option-add! b :text ", "))) + (markup-option-add! b :page #t) + (output n e))) + + ;; Writer body starts here + (let ((col (markup-option n :column))) + (when col + (printf "\\startcolumns[n=~a]\n" col)) + (for-each (lambda (item) + ;;(DEBUG "ITEM= ~S" item) + (if (pair? item) + (begin + (make-primary-entry (car item)) + (for-each (lambda (x) (make-secondary-entry x)) + (cdr item))) + (make-mark-entry item)) + (display "\\crlf\n")) + (markup-body n)) + (when col + (printf "\\stopcolumns\n"))))) + +;;;; ====================================================================== +;;;; &source-comment ... +;;;; ====================================================================== +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-line-comment ... +;;;; ====================================================================== +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-keyword ... +;;;; ====================================================================== +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (it (markup-body n)) e))) + +;;;; ====================================================================== +;;;; &source-error ... +;;;; ====================================================================== +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'error-color) cc) + (color :fg cc (it n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-define ... +;;;; ====================================================================== +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-module ... +;;;; ====================================================================== +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-markup ... +;;;; ====================================================================== +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-thread ... +;;;; ====================================================================== +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-string ... +;;;; ====================================================================== +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-bracket ... +;;;; ====================================================================== +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-type ... +;;;; ====================================================================== +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-key ... +;;;; ====================================================================== +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;;;; ====================================================================== +;;;; &source-type ... +;;;; ====================================================================== +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + + + +;;;; ====================================================================== +;;;; Context Only Markups +;;;; ====================================================================== + +;;; +;;; Margin -- put text in the margin +;;; +(define-markup (margin #!rest opts #!key (ident #f) (class "margin") + (side 'right) text) + (new markup + (markup 'margin) + (ident (or ident (symbol->string (gensym 'ident)))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +(markup-writer 'margin + :options '(:text) + :before (lambda (n e) + (display + "\\setupinmargin[align=right,style=\\tfx\\setupinterlinespace]\n") + (display "\\inright{") + (output (markup-option n :text) e) + (display "}{")) + :after "}") + +;;; +;;; ConTeXt and TeX +;;; +(define-markup (ConTeXt #!key (space #t)) + (if (engine-format? "context") + (! (if space "\\CONTEXT\\ " "\\CONTEXT")) + "ConTeXt")) + +(define-markup (TeX #!key (space #t)) + (if (engine-format? "context") + (! (if space "\\TEX\\ " "\\TEX")) + "ConTeXt")) + +;;;; ====================================================================== +;;;; Restore the base engine +;;;; ====================================================================== +(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/french.skr b/skribe/skr/french.skr new file mode 100644 index 0000000..373d076 --- /dev/null +++ b/skribe/skr/french.skr @@ -0,0 +1,19 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* French Skribe style */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/skribe/skr/html.skr b/skribe/skr/html.skr new file mode 100644 index 0000000..ebac5f2 --- /dev/null +++ b/skribe/skr/html.skr @@ -0,0 +1,2251 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/html.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 12:28:57 2003 */ +;* Last change : Thu Jun 2 10:57:42 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* HTML Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/htmle.skb:ref@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* html-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-engine + ;; setup the html engine + (default-engine-set! + (make-engine 'html + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@"))) + :custom `(;; the icon associated with the URL + (favicon #f) + ;; charset used + (charset "ISO-8859-1") + ;; enable/disable Javascript + (javascript #f) + ;; user html head + (head #f) + ;; user CSS + (css ()) + ;; user inlined CSS + (inline-css ()) + ;; user JS + (js ()) + ;; emit-sui + (emit-sui #f) + ;; the body + (background "#ffffff") + (foreground #f) + ;; the margins + (margin-padding 3) + (left-margin #f) + (chapter-left-margin #f) + (section-left-margin #f) + (left-margin-font #f) + (left-margin-size 17.) + (left-margin-background "#dedeff") + (left-margin-foreground #f) + (right-margin #f) + (chapter-right-margin #f) + (section-right-margin #f) + (right-margin-font #f) + (right-margin-size 17.) + (right-margin-background "#dedeff") + (right-margin-foreground #f) + ;; author configuration + (author-font #f) + ;; title configuration + (title-font #f) + (title-background "#8381de") + (title-foreground #f) + (file-title-separator " -- ") + ;; index configuration + (index-header-font-size +2.) + ;; chapter configuration + (chapter-number->string number->string) + (chapter-file #f) + ;; section configuration + (section-title-start "<h3>") + (section-title-stop "</h3>") + (section-title-background "#dedeff") + (section-title-foreground "black") + (section-title-number-separator " ") + (section-number->string number->string) + (section-file #f) + ;; subsection configuration + (subsection-title-start "<h3>") + (subsection-title-stop "</h3>") + (subsection-title-background "#ffffff") + (subsection-title-foreground "#8381de") + (subsection-title-number-separator " ") + (subsection-number->string number->string) + (subsection-file #f) + ;; subsubsection configuration + (subsubsection-title-start "<h4>") + (subsubsection-title-stop "</h4>") + (subsubsection-title-background #f) + (subsubsection-title-foreground "#8381de") + (subsubsection-title-number-separator " ") + (subsubsection-number->string number->string) + (subsubsection-file #f) + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + ;; image + (image-format ("png" "gif" "jpg" "jpeg"))) + :symbol-table '(("iexcl" "¡") + ("cent" "¢") + ("pound" "£") + ("currency" "¤") + ("yen" "¥") + ("section" "§") + ("mul" "¨") + ("copyright" "©") + ("female" "ª") + ("lguillemet" "«") + ("not" "¬") + ("registered" "®") + ("degree" "°") + ("plusminus" "±") + ("micro" "µ") + ("paragraph" "¶") + ("middot" "·") + ("male" "¸") + ("rguillemet" "»") + ("1/4" "¼") + ("1/2" "½") + ("3/4" "¾") + ("iquestion" "¿") + ("Agrave" "À") + ("Aacute" "Á") + ("Acircumflex" "Â") + ("Atilde" "Ã") + ("Amul" "Ä") + ("Aring" "Å") + ("AEligature" "Æ") + ("Oeligature" "Œ") + ("Ccedilla" "Ç") + ("Egrave" "È") + ("Eacute" "É") + ("Ecircumflex" "Ê") + ("Euml" "Ë") + ("Igrave" "Ì") + ("Iacute" "Í") + ("Icircumflex" "Î") + ("Iuml" "Ï") + ("ETH" "Ð") + ("Ntilde" "Ñ") + ("Ograve" "Ò") + ("Oacute" "Ó") + ("Ocurcumflex" "Ô") + ("Otilde" "Õ") + ("Ouml" "Ö") + ("times" "×") + ("Oslash" "Ø") + ("Ugrave" "Ù") + ("Uacute" "Ú") + ("Ucircumflex" "Û") + ("Uuml" "Ü") + ("Yacute" "Ý") + ("THORN" "Þ") + ("szlig" "ß") + ("agrave" "à") + ("aacute" "á") + ("acircumflex" "â") + ("atilde" "ã") + ("amul" "ä") + ("aring" "å") + ("aeligature" "æ") + ("oeligature" "œ") + ("ccedilla" "ç") + ("egrave" "è") + ("eacute" "é") + ("ecircumflex" "ê") + ("euml" "ë") + ("igrave" "ì") + ("iacute" "í") + ("icircumflex" "î") + ("iuml" "ï") + ("eth" "ð") + ("ntilde" "ñ") + ("ograve" "ò") + ("oacute" "ó") + ("ocurcumflex" "ô") + ("otilde" "õ") + ("ouml" "ö") + ("divide" "÷") + ("oslash" "ø") + ("ugrave" "ù") + ("uacute" "ú") + ("ucircumflex" "û") + ("uuml" "ü") + ("yacute" "ý") + ("thorn" "þ") + ("ymul" "ÿ") + ;; Greek + ("Alpha" "Α") + ("Beta" "Β") + ("Gamma" "Γ") + ("Delta" "Δ") + ("Epsilon" "Ε") + ("Zeta" "Ζ") + ("Eta" "Η") + ("Theta" "Θ") + ("Iota" "Ι") + ("Kappa" "Κ") + ("Lambda" "Λ") + ("Mu" "Μ") + ("Nu" "Ν") + ("Xi" "Ξ") + ("Omicron" "Ο") + ("Pi" "Π") + ("Rho" "Ρ") + ("Sigma" "Σ") + ("Tau" "Τ") + ("Upsilon" "Υ") + ("Phi" "Φ") + ("Chi" "Χ") + ("Psi" "Ψ") + ("Omega" "Ω") + ("alpha" "α") + ("beta" "β") + ("gamma" "γ") + ("delta" "δ") + ("epsilon" "ε") + ("zeta" "ζ") + ("eta" "η") + ("theta" "θ") + ("iota" "ι") + ("kappa" "κ") + ("lambda" "λ") + ("mu" "μ") + ("nu" "ν") + ("xi" "ξ") + ("omicron" "ο") + ("pi" "π") + ("rho" "ρ") + ("sigmaf" "ς") + ("sigma" "σ") + ("tau" "τ") + ("upsilon" "υ") + ("phi" "φ") + ("chi" "χ") + ("psi" "ψ") + ("omega" "ω") + ("thetasym" "ϑ") + ("piv" "ϖ") + ;; punctuation + ("bullet" "•") + ("ellipsis" "…") + ("weierp" "℘") + ("image" "ℑ") + ("real" "ℜ") + ("tm" "™") + ("alef" "ℵ") + ("<-" "←") + ("<--" "←") + ("uparrow" "↑") + ("->" "→") + ("-->" "→") + ("downarrow" "↓") + ("<->" "↔") + ("<-->" "↔") + ("<+" "↵") + ("<=" "⇐") + ("<==" "⇐") + ("Uparrow" "⇑") + ("=>" "⇒") + ("==>" "⇒") + ("Downarrow" "⇓") + ("<=>" "⇔") + ("<==>" "⇔") + ;; Mathematical operators + ("forall" "∀") + ("partial" "∂") + ("exists" "∃") + ("emptyset" "∅") + ("infinity" "∞") + ("nabla" "∇") + ("in" "∈") + ("notin" "∉") + ("ni" "∋") + ("prod" "∏") + ("sum" "∑") + ("asterisk" "∗") + ("sqrt" "√") + ("propto" "∝") + ("angle" "∠") + ("and" "∧") + ("or" "∨") + ("cap" "∩") + ("cup" "∪") + ("integral" "∫") + ("therefore" "∴") + ("models" "|=") + ("vdash" "|-") + ("dashv" "-|") + ("sim" "∼") + ("cong" "≅") + ("approx" "≈") + ("neq" "≠") + ("equiv" "≡") + ("le" "≤") + ("ge" "≥") + ("subset" "⊂") + ("supset" "⊃") + ("nsupset" "⊃") + ("subseteq" "⊆") + ("supseteq" "⊇") + ("oplus" "⊕") + ("otimes" "⊗") + ("perp" "⊥") + ("mid" "|") + ("lceil" "⌈") + ("rceil" "⌉") + ("lfloor" "⌊") + ("rfloor" "⌋") + ("langle" "〈") + ("rangle" "〉") + ;; Misc + ("loz" "◊") + ("spades" "♠") + ("clubs" "♣") + ("hearts" "♥") + ("diams" "♦") + ("euro" "ℐ") + ;; LaTeX + ("dag" "dag") + ("ddag" "ddag") + ("circ" "o") + ("top" "T") + ("bottom" "⊥") + ("lhd" "<") + ("rhd" ">") + ("parallel" "||"))))) + +;*---------------------------------------------------------------------*/ +;* html-title-engine ... */ +;*---------------------------------------------------------------------*/ +(define html-title-engine + (copy-engine 'html-title base-engine + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """))))) + +;*---------------------------------------------------------------------*/ +;* html-browser-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-browser-title n) + (and (markup? n) + (or (markup-option n :html-title) + (if (document? n) + (markup-option n :title) + (html-browser-title (ast-parent n)))))) + +;*---------------------------------------------------------------------*/ +;* html-file ... */ +;*---------------------------------------------------------------------*/ +(define html-file + (let ((table '()) + (filename (gensym))) + (define (get-file-name base suf) + (let* ((c (assoc base table)) + (n (if (pair? c) + (let ((n (+ 1 (cdr c)))) + (set-cdr! c n) + n) + (begin + (set! table (cons (cons base 1) table)) + 1)))) + (format "~a-~a.~a" base n suf))) + (lambda (node e) + (let ((f (markup-option node filename)) + (file (markup-option node :file))) + (cond + ((string? f) + f) + ((string? file) + file) + ((or file + (and (is-markup? node 'chapter) + (engine-custom e 'chapter-file)) + (and (is-markup? node 'section) + (engine-custom e 'section-file)) + (and (is-markup? node 'subsection) + (engine-custom e 'subsection-file)) + (and (is-markup? node 'subsubsection) + (engine-custom e 'subsubsection-file))) + (let* ((b (or (and (string? *skribe-dest*) + (prefix *skribe-dest*)) + "")) + (s (or (and (string? *skribe-dest*) + (suffix *skribe-dest*)) + "html")) + (nm (get-file-name b s))) + (markup-option-add! node filename nm) + nm)) + ((document? node) + *skribe-dest*) + (else + (let ((p (ast-parent node))) + (if (container? p) + (let ((file (html-file p e))) + (if (string? file) + (begin + (markup-option-add! node filename file) + file) + #f)) + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* html-container-number ... */ +;* ------------------------------------------------------------- */ +;* Returns a string representing the container number */ +;*---------------------------------------------------------------------*/ +(define (html-container-number c e) + (define (html-number n proc) + (cond + ((string? n) + n) + ((number? n) + (if (procedure? proc) + (proc n) + (number->string n))) + (else + ""))) + (define (html-chapter-number c) + (html-number (markup-option c :number) + (engine-custom e 'chapter-number->string))) + (define (html-section-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'section-number->string)))) + (cond + ((is-markup? p 'chapter) + (string-append (html-chapter-number p) "." s)) + (else + (string-append s))))) + (define (html-subsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsection-number->string)))) + (cond + ((is-markup? p 'section) + (string-append (html-section-number p) "." s)) + (else + (string-append "." s))))) + (define (html-subsubsection-number c) + (let ((p (ast-parent c)) + (s (html-number (markup-option c :number) + (engine-custom e 'subsubsection-number->string)))) + (cond + ((is-markup? p 'subsection) + (string-append (html-subsection-number p) "." s)) + (else + (string-append ".." s))))) + (define (inner-html-container-number c) + (html-number (markup-option c :number) #f)) + (let ((n (markup-option c :number))) + (if (not n) + "" + (case (markup-markup c) + ((chapter) + (html-chapter-number c)) + ((section) + (html-section-number c)) + ((subsection) + (html-subsection-number c)) + ((subsubsection) + (html-subsubsection-number c)) + (else + (if (container? c) + (inner-html-container-number c) + (skribe-error 'html-container-number + "Not a container" + (markup-markup c)))))))) + +;*---------------------------------------------------------------------*/ +;* html-counter ... */ +;*---------------------------------------------------------------------*/ +(define (html-counter cnts) + (cond + ((not cnts) + "") + ((null? cnts) + "") + ((not (pair? cnts)) + cnts) + ((null? (cdr cnts)) + (format "~a." (car cnts))) + (else + (let loop ((cnts cnts)) + (if (null? (cdr cnts)) + (format "~a" (car cnts)) + (format "~a.~a" (car cnts) (loop (cdr cnts)))))))) + +;*---------------------------------------------------------------------*/ +;* html-width ... */ +;*---------------------------------------------------------------------*/ +(define (html-width width) + (cond + ((and (integer? width) (exact? width)) + (format "~A" width)) + ((real? width) + (format "~A%" (inexact->exact (round width)))) + ((string? width) + width) + (else + (skribe-error 'html-width "bad width" width)))) + +;*---------------------------------------------------------------------*/ +;* html-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-class m) + (if (markup? m) + (let ((c (markup-class m))) + (if (or (string? c) (symbol? c) (number? c)) + (printf " class=\"~a\"" c))))) + +;*---------------------------------------------------------------------*/ +;* html-markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (html-markup-class m) + (lambda (n e) + (printf "<~a" m) + (html-class n) + (display ">"))) + +;*---------------------------------------------------------------------*/ +;* html-color-spec? ... */ +;*---------------------------------------------------------------------*/ +(define (html-color-spec? v) + (and v + (not (unspecified? v)) + (or (not (string? v)) (> (string-length v) 0)))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :html-title :env) + :action (lambda (n e) + (let* ((id (markup-ident n)) + (title (new markup + (markup '&html-document-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (options `((author ,(markup-option n :author)))) + (body (markup-option n :title))))) + (&html-generic-document n title e))) + :after (lambda (n e) + (if (engine-custom e 'emit-sui) + (document-sui n e)))) + +;*---------------------------------------------------------------------*/ +;* &html-html ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-html + :before "<!-- 95% W3C COMPLIANT, 95% CSS FREE, RAW HTML --> +<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> +<html>\n" + :after "</html>") + +;*---------------------------------------------------------------------*/ +;* &html-head ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-head + :before (lambda (n e) + (printf "<head>\n") + (printf "<meta http-equiv=\"Content-Type\" content=\"text/html;") + (printf "charset=~A\">\n" (engine-custom (find-engine 'html) + 'charset))) + :after "</head>\n\n") + +;*---------------------------------------------------------------------*/ +;* &html-body ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-body + :before (lambda (n e) + (let ((bg (engine-custom e 'background))) + (display "<body") + (html-class n) + (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (display ">\n"))) + :after "</body>\n") + +;*---------------------------------------------------------------------*/ +;* &html-page ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-page + :action (lambda (n e) + (define (html-margin m fn size bg fg cla) + (printf "<td align=\"left\" valign=\"top\" class=\"~a\"" cla) + (if size + (printf " width=\"~a\"" (html-width size))) + (if (html-color-spec? bg) + (printf " bgcolor=\"~a\">" bg) + (display ">")) + (printf "<div class=\"~a\">\n" cla) + (cond + ((and (string? fg) (string? fn)) + (printf "<font color=\"~a\" \"~a\">" fg fn)) + ((string? fg) + (printf "<font color=\"~a\">" fg)) + ((string? fn) + (printf "<font \"~a\">" fn))) + (if (procedure? m) + (skribe-eval (m n e) e) + (output m e)) + (if (or (string? fg) (string? fn)) + (display "</font>")) + (display "</div></td>\n")) + (let ((body (markup-body n)) + (lm (engine-custom e 'left-margin)) + (lmfn (engine-custom e 'left-margin-font)) + (lms (engine-custom e 'left-margin-size)) + (lmbg (engine-custom e 'left-margin-background)) + (lmfg (engine-custom e 'left-margin-foreground)) + (rm (engine-custom e 'right-margin)) + (rmfn (engine-custom e 'right-margin-font)) + (rms (engine-custom e 'right-margin-size)) + (rmbg (engine-custom e 'right-margin-background)) + (rmfg (engine-custom e 'right-margin-foreground))) + (cond + ((and lm rm) + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "</tr></table>")) + (lm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n" ac)) + (html-margin lm lmfn lms lmbg lmfg "skribe-left-margin") + (html-margin body #f #f #f #f "skribe-body") + (display "</tr></table>")) + (rm + (let* ((ep (engine-custom e 'margin-padding)) + (ac (if (number? ep) ep 0))) + (printf "<table cellpadding=\"~a\" cellspacing=\"0\" width=\"100%\" class=\"skribe-margins\"><tr>\n")) + (html-margin body #f #f #f #f "skribe-body") + (html-margin rm rmfn rms rmbg rmfg "skribe-right-margin") + (display "</tr></table>")) + (else + (display "<div class=\"skribe-body\">\n") + (output body e) + (display "</div>\n")))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-header ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-header n e) + (let* ((ic (engine-custom e 'favicon)) + (id (markup-ident n))) + (unless (string? id) + (skribe-error '&html-generic-header + (format "Illegal identifier `~a'" id) + n)) + ;; title + (output (new markup + (markup '&html-header-title) + (parent n) + (ident (string-append id "-title")) + (class (markup-class n)) + (body (markup-body n))) + e) + ;; favicon + (output (new markup + (markup '&html-header-favicon) + (parent n) + (ident (string-append id "-favicon")) + (body (cond + ((string? ic) + ic) + ((procedure? ic) + (ic d e))))) + e) + ;; style + (output (new markup + (markup '&html-header-style) + (parent n) + (ident (string-append id "-style")) + (class (markup-class n))) + e) + ;; css + (output (new markup + (markup '&html-header-css) + (parent n) + (ident (string-append id "-css")) + (body (let ((c (engine-custom e 'css))) + (if (string? c) + (list c) + c)))) + e) + ;; javascript + (output (new markup + (markup '&html-header-javascript) + (parent n) + (ident (string-append id "-javascript"))) + e))) + +(markup-writer '&html-header-title + :before "<title>" + :action (lambda (n e) + (output (markup-body n) html-title-engine)) + :after "</title>\n") + +(markup-writer '&html-header-favicon + :action (lambda (n e) + (let ((i (markup-body n))) + (when i + (printf " <link rel=\"shortcut icon\" href=~s>\n" i))))) + +(markup-writer '&html-header-css + :action (lambda (n e) + (let ((css (markup-body n))) + (when (pair? css) + (for-each (lambda (css) + (printf " <link href=~s rel=\"stylesheet\" type=\"text/css\">\n" css)) + css))))) + +(markup-writer '&html-header-style + :before " <style type=\"text/css\">\n <!--\n" + :action (lambda (n e) + (let ((hd (engine-custom e 'head)) + (icss (let ((ic (engine-custom e 'inline-css))) + (if (string? ic) + (list ic) + ic)))) + (display " pre { font-family: monospace }\n") + (display " tt { font-family: monospace }\n") + (display " code { font-family: monospace }\n") + (display " p.flushright { text-align: right }\n") + (display " p.flushleft { text-align: left }\n") + (display " span.sc { font-variant: small-caps }\n") + (display " span.sf { font-family: sans-serif }\n") + (display " span.skribetitle { font-family: sans-serif; font-weight: bolder; font-size: x-large; }\n") + (when hd (display (format " ~a\n" hd))) + (when (pair? icss) + (for-each (lambda (css) + (let ((p (open-input-file css))) + (if (not (input-port? p)) + (skribe-error + 'html-css + "Can't open CSS file for input" + css) + (begin + (let loop ((l (read-line p))) + (unless (eof-object? l) + (display l) + (newline) + (loop (read-line p)))) + (close-input-port p))))) + icss)))) + :after " -->\n </style>\n") + +(markup-writer '&html-header-javascript + :action (lambda (n e) + (when (engine-custom e 'javascript) + (display " <script language=\"JavaScript\" type=\"text/javascript\">\n") + (display " <!--\n") + (display " function skribenospam( n, d, f ) {\n") + (display " nn=n.replace( / /g , \".\" );\n" ) + (display " dd=d.replace( / /g , \".\" );\n" ) + (display " document.write( \"<a href=\\\"mailto:\" + nn + \"@\" + dd + \"\\\">\" );\n") + (display " if( f ) {\n") + (display " document.write( \"<tt>\" + nn + \"@\" + dd + \"</\" + \"tt><\" + \"/a>\" );\n") + (display " }\n") + (display " }\n") + (display " -->\n") + (display " </script>\n")) + (let* ((ejs (engine-custom e 'js)) + (js (cond + ((string? ejs) + (list ejs)) + ((list? ejs) + ejs) + (else + '())))) + (for-each (lambda (s) + (printf "<script type=\"text/javascript\" src=\"~a\"></script>" s)) + js)))) + + +;*---------------------------------------------------------------------*/ +;* &html-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-header :action &html-generic-header) +(markup-writer '&html-chapter-header :action &html-generic-header) +(markup-writer '&html-section-header :action &html-generic-header) +(markup-writer '&html-subsection-header :action &html-generic-header) +(markup-writer '&html-subsubsection-header :action &html-generic-header) + +;*---------------------------------------------------------------------*/ +;* &html-ending ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-ending + :before "<div class=\"skribe-ending\">" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval [ +,(hrule) +,(p :class "ending" (font :size -1 [ +This ,(sc "Html") page has been produced by +,(ref :url (skribe-url) :text "Skribe"). +,(linebreak) +Last update ,(it (date)).]))] e)))) + :after "</div>\n") + +;*---------------------------------------------------------------------*/ +;* &html-generic-title ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (when title + (display "<table width=\"100%\" class=\"skribetitle\" cellspacing=\"0\" cellpadding=\"0\"><tbody>\n<tr>") + (if (html-color-spec? tbg) + (printf "<td align=\"center\" bgcolor=\"~a\">" tbg) + (display "<td align=\"center\">")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (when title + (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>")))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table>\n")))) + +;*---------------------------------------------------------------------*/ +;* &html-document-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-document-title :action &html-generic-title) +(markup-writer '&html-chapter-title :action &html-generic-title) +(markup-writer '&html-section-title :action &html-generic-title) +(markup-writer '&html-subsection-title :action &html-generic-title) +(markup-writer '&html-subsubsection-title :action &html-generic-title) + +;*---------------------------------------------------------------------*/ +;* &html-footnotes */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-footnotes + :before (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (display "<div class=\"footnote\">") + (display "<br><br>\n") + (display "<hr width='20%' size='2' align='left'>\n")))) + :action (lambda (n e) + (let ((footnotes (markup-body n))) + (when (pair? footnotes) + (let loop ((fns footnotes)) + (if (pair? fns) + (let ((fn (car fns))) + (printf "<a name=\"footnote-~a\">" + (string-canonicalize + (container-ident fn))) + (printf "<sup><small>~a</small></sup></a>: " + (markup-option fn :number)) + (output (markup-body fn) e) + (display "\n<br>\n") + (loop (cdr fns))))) + (display "<div>"))))) + +;*---------------------------------------------------------------------*/ +;* html-title-authors ... */ +;*---------------------------------------------------------------------*/ +(define (html-title-authors authors e) + (define (html-authorsN authors cols first) + (define (make-row authors . opt) + (tr (map (lambda (v) + (apply td :align 'center :valign 'top v opt)) + authors))) + (define (make-rows authors) + (let loop ((authors authors) + (rows '()) + (row '()) + (cnum 0)) + (cond + ((null? authors) + (reverse! (cons (make-row (reverse! row)) rows))) + ((= cnum cols) + (loop authors + (cons (make-row (reverse! row)) rows) + '() + 0)) + (else + (loop (cdr authors) + rows + (cons (car authors) row) + (+ cnum 1)))))) + (output (table :cellpadding 10 + (if first + (cons (make-row (list (car authors)) :colspan cols) + (make-rows (cdr authors))) + (make-rows authors))) + e)) + (cond + ((pair? authors) + (display "<center>\n") + (let ((len (length authors))) + (case len + ((1) + (output (car authors) e)) + ((2 3) + (html-authorsN authors len #f)) + ((4) + (html-authorsN authors 2 #f)) + (else + (html-authorsN authors 3 #t)))) + (display "</center>\n")) + (else + (html-title-authors (list authors) e)))) + +;*---------------------------------------------------------------------*/ +;* document-sui ... */ +;*---------------------------------------------------------------------*/ +(define (document-sui n e) + (define (sui) + (display "(sui \"") + (skribe-eval (markup-option n :title) html-title-engine) + (display "\"\n") + (printf " :file ~s\n" (sui-referenced-file n e)) + (sui-marks n e) + (sui-blocks 'chapter n e) + (sui-blocks 'section n e) + (sui-blocks 'subsection n e) + (sui-blocks 'subsubsection n e) + (display " )\n")) + (if (string? *skribe-dest*) + (let ((f (format "~a.sui" (prefix *skribe-dest*)))) + (with-output-to-file f sui)) + (sui))) + +;*---------------------------------------------------------------------*/ +;* sui-referenced-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-referenced-file n e) + (let ((file (html-file n e))) + (if (member (suffix file) '("skb" "sui" "skr" "html")) + (string-append (strip-ref-base (prefix file)) ".html") + file))) + +;*---------------------------------------------------------------------*/ +;* sui-marks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-marks n e) + (printf " (marks") + (for-each (lambda (m) + (printf "\n (~s" (markup-ident m)) + (printf " :file ~s" (sui-referenced-file m e)) + (printf " :mark ~s" (markup-ident m)) + (when (markup-class m) + (printf " :class ~s" (markup-class m))) + (display ")")) + (search-down (lambda (n) (is-markup? n 'mark)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* sui-blocks ... */ +;*---------------------------------------------------------------------*/ +(define (sui-blocks kind n e) + (printf " (~as" kind) + (for-each (lambda (chap) + (display "\n (\"") + (skribe-eval (markup-option chap :title) html-title-engine) + (printf "\" :file ~s" (sui-referenced-file chap e)) + (printf " :mark ~s" (markup-ident chap)) + (when (markup-class chap) + (printf " :class ~s" (markup-class chap))) + (display ")")) + (container-search-down (lambda (n) (is-markup? n kind)) n)) + (display ")\n")) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (display "<table") + (html-class n) + (display "><tbody>\n")) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (define (row n) + (printf "<tr><td align=\"~a\">" align) + (output n e) + (display "</td></tr>")) + ;; name + (printf "<tr><td align=\"~a\">" align) + (if nfn + (printf "<font ~a>\n" nfn) + (display "<font size=\"+2\"><i>\n")) + (output name e) + (if nfn + (printf "</font>\n") + (display "</i></font>\n")) + (display "</td></tr>") + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url)))) + :after "</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :predicate (lambda (n e) (markup-option n :photo)) + :before (lambda (n e) + (display "<table") + (html-class n) + (display "><tbody>\n<tr>")) + :action (lambda (n e) + (let ((photo (markup-option n :photo))) + (display "<td>") + (output photo e) + (display "</td><td>") + (markup-option-add! n :photo #f) + (output n e) + (markup-option-add! n :photo photo) + (display "</td>"))) + :after "</tr>\n</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options 'all + :action (lambda (n e) + (define (col n) + (let loop ((i 0)) + (if (< i n) + (begin + (display "<td></td>") + (loop (+ i 1)))))) + (define (toc-entry fe level) + (let* ((c (car fe)) + (ch (cdr fe)) + (t (markup-option c :title)) + (id (markup-ident c)) + (f (html-file c e))) + (unless (string? id) + (skribe-error 'toc + (format "Illegal identifier `~a'" id) + c)) + (display " <tr>") + ;; blank columns + (col level) + ;; number + (printf "<td valign=\"top\" align=\"left\">~a</td>" + (html-container-number c e)) + ;; title + (printf "<td colspan=\"~a\" width=\"100%\">" + (- 4 level)) + (printf "<a href=\"~a#~a\">" + (if (string=? f *skribe-dest*) + "" + (strip-ref-base (or f *skribe-dest* ""))) + (string-canonicalize id)) + (output (markup-option c :title) e) + (display "</a></td>") + (display "</tr>\n") + ;; the children + (for-each (lambda (n) (toc-entry n (+ 1 level))) ch))) + (define (symbol->keyword s) + (cond-expand + (stklos + (make-keyword s)) + (bigloo + (string->keyword (string-append ":" (symbol->string s)))))) + (let* ((c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection)) + (b (markup-body n)) + (bb (if (handle? b) + (handle-ast b) + b))) + (if (not (container? bb)) + (error 'toc + "Illegal body (container expected)" + (if (markup? bb) + (markup-markup bb) + "???")) + (let ((lst (find-down (lambda (x) + (and (markup? x) + (markup-option x :toc) + (or (and sss (is-markup? x 'subsubsection)) + (and ss (is-markup? x 'subsection)) + (and s (is-markup? x 'section)) + (and c (is-markup? x 'chapter)) + (markup-option n (symbol->keyword + (markup-markup x)))))) + (container-body bb)))) + ;; avoid to produce an empty table + (unless (null? lst) + (display "<table cellspacing=\"1\" cellpadding=\"1\" width=\"100%\"") + (html-class n) + (display ">\n<tbody>\n") + + (for-each (lambda (n) (toc-entry n 0)) lst) + + (display "</tbody>\n</table>\n"))))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-document ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-document n title e) + (let* ((id (markup-ident n)) + (header (new markup + (markup '&html-chapter-header) + (ident (string-append id "-header")) + (class (markup-class n)) + (parent n) + (body (html-browser-title n)))) + (head (new markup + (markup '&html-head) + (ident (string-append id "-head")) + (class (markup-class n)) + (parent n) + (body header))) + (ftnote (new markup + (markup '&html-footnotes) + (ident (string-append id "-footnote")) + (class (markup-class n)) + (parent n) + (body (reverse! + (container-env-get n 'footnote-env))))) + (page (new markup + (markup '&html-page) + (ident (string-append id "-page")) + (class (markup-class n)) + (parent n) + (body (list (markup-body n) ftnote)))) + (ending (new markup + (markup '&html-ending) + (ident (string-append id "-ending")) + (class (markup-class n)) + (parent n) + (body (or (markup-option n :ending) + (let ((p (ast-document n))) + (and p (markup-option p :ending))))))) + (body (new markup + (markup '&html-body) + (ident (string-append id "-body")) + (class (markup-class n)) + (parent n) + (body (list title page ending)))) + (html (new markup + (markup '&html-html) + (ident (string-append id "-html")) + (class (markup-class n)) + (parent n) + (body (list head body))))) + ;; No file must be opened for documents. These files are + ;; directly opened by Skribe + (if (document? n) + (output html e) + (with-output-to-file (html-file n e) + (lambda () + (output html e)))))) + +;*---------------------------------------------------------------------*/ +;* &html-generic-subdocument ... */ +;*---------------------------------------------------------------------*/ +(define (&html-generic-subdocument n e) + (let* ((p (ast-document n)) + (id (markup-ident n)) + (ti (let* ((nb (html-container-number n e)) + (tc (markup-option n :title)) + (ti (if (document? p) + (list (markup-option p :title) + (engine-custom e 'file-title-separator) + tc) + tc)) + (sep (engine-custom + e + (symbol-append (markup-markup n) + '-title-number-separator))) + (nti (and tc + (if (and nb (not (equal? nb ""))) + (list nb + (if (unspecified? sep) ". " sep) + ti) + ti)))) + (new markup + (markup (symbol-append '&html- (markup-markup n) '-title)) + (ident (string-append id "-title")) + (parent n) + (options '((author ()))) + (body nti))))) + (case (markup-markup n) + ((chapter) + (skribe-message " [~s chapter: ~a]\n" (engine-ident e) id)) + ((section) + (skribe-message " [~s section: ~a]\n" (engine-ident e) id))) + (&html-generic-document n ti e))) + +;*---------------------------------------------------------------------*/ +;* chapter ... @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :before (lambda (n e) + (let ((title (markup-option n :title)) + (ident (markup-ident n))) + (display "<!-- ") + (output title html-title-engine) + (display " -->\n") + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (display "<center><h1") + (html-class n) + (display ">") + (output (html-container-number n e) e) + (display " ") + (output (markup-option n :title) e) + (display "</h1></center>"))) + :after "<br>") + +;; This writer is invoked only for chapters rendered inside separate files! +(markup-writer 'chapter + :options '(:title :number :file :toc :html-title :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'chapter-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* html-section-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-section-title n e) + (let* ((title (markup-option n :title)) + (number (markup-option n :number)) + (c (markup-class n)) + (ident (markup-ident n)) + (kind (markup-markup n)) + (tbg (engine-custom e (symbol-append kind '-title-background))) + (tfg (engine-custom e (symbol-append kind '-title-foreground))) + (tstart (engine-custom e (symbol-append kind '-title-start))) + (tstop (engine-custom e (symbol-append kind '-title-stop))) + (nsep (engine-custom e (symbol-append kind '-title-number-separator)))) + ;; the section header + (display "<!-- ") + (output title html-title-engine) + (display " -->\n") + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (if c + (printf "<div class=\"~a-atitle\">" c) + (printf "<div class=\"skribe~atitle\">" (markup-markup n))) + (when (html-color-spec? tbg) + (display "<table width=\"100%\">") + (printf "<tr><td bgcolor=\"~a\">" tbg)) + (display tstart) + (if tfg (printf "<font color=\"~a\">" tfg)) + (if number + (begin + (output (html-container-number n e) e) + (output nsep e))) + (output title e) + (if tfg (display "</font>\n")) + (display tstop) + (when (and (string? tbg) (> (string-length tbg) 0)) + (display "</td></tr></table>\n")) + (display "</div>") + (display "<div") + (html-class n) + (display ">")) + (newline)) + +;*---------------------------------------------------------------------*/ +;* section ... @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :before html-section-title + :after "</div><br>\n") + +;; on-file section writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'section-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "</div>\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :html-title :number :toc :env :file) + :before html-section-title + :after "</div>\n") + +;; on-file subsection writer +(markup-writer 'section + :options '(:title :html-title :number :toc :file :env) + :predicate (lambda (n e) + (or (markup-option n :file) + (engine-custom e 'subsubsection-file))) + :action &html-generic-subdocument) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :before (lambda (n e) + (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) + (printf "<span style=\"display: block; position: relative; left: -2cm; font-size: x-small; font-style: italic; color: ff8e1e;\">~a</span>" + (ast-location n))) + ((html-markup-class "p") n e)) + :after "</p>") + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :options '(:number) + :action (lambda (n e) + (printf "<a href=\"#footnote-~a\"><sup><small>~a</small></sup></a>" + (string-canonicalize (container-ident n)) + (markup-option n :number)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :before (lambda (n e) + (display "<br") + (html-class n) + (display "/>"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '(:width :height) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (height (markup-option n :height))) + (display "<hr") + (html-class n) + (if (< width 100) + (printf " width=\"~a\"" (html-width width))) + (if (> height 1) + (printf " size=\"~a\"" height)) + (display ">")))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when (html-color-spec? bg) + (display "<table cellspacing=\"0\"") + (html-class n) + (printf " cellpadding=\"~a\"" (if m m 0)) + (if w (printf " width=\"~a\"" (html-width w))) + (display "><tbody>\n<tr>") + (display "<td bgcolor=\"") + (output bg e) + (display "\">")) + (when (html-color-spec? fg) + (display "<font color=\"") + (output fg e) + (display "\">")))) + :after (lambda (n e) + (when (html-color-spec? (markup-option n :fg)) + (display "</font>")) + (when (html-color-spec? (markup-option n :bg)) + (display "</td></tr>\n</tbody></table>")))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + :options '(:width :margin :border) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (b (markup-option n :border)) + (w (markup-option n :width))) + (display "<table cellspacing=\"0\"") + (html-class n) + (printf " cellpadding=\"~a\"" (if m m 0)) + (printf " border=\"~a\"" (if b b 0)) + (if w (printf " width=\"~a\"" (html-width w))) + (display "><tbody>\n<tr><td>"))) + :after "</td></tr>\n</tbody></table>") + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size :face) + :before (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "<big>" "<small>")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s)))) + (when (or (and (number? size) (exact? size)) face) + (display "<font") + (html-class n) + (when (and (number? size) (exact? size) (not (= size 0))) + (printf " size=\"~a\"" size)) + (when face (printf " face=\"~a\"" face)) + (display ">")))) + :after (lambda (n e) + (let ((size (markup-option n :size)) + (face (markup-option n :face))) + (when (or (and (number? size) (exact? size) (not (= size 0))) + face) + (display "</font>")) + (when (and (number? size) (inexact? size)) + (let ((s (if (> size 0) "</big>" "</small>")) + (d (if (> size 0) 1 -1))) + (do ((i (inexact->exact size) (- i d))) + ((= i 0)) + (display s))))))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "<center") + (html-class n) + (display ">\n")) + ((left) + (display "<p style=\"text-align:left;\"") + (html-class n) + (display ">\n")) + ((right) + (display "<table ") + (html-class n) + (display "width=\"100%\" cellpadding=\"0\" cellspacing=\"0\" border=\"0\"><tr><td align=\"right\">")) + (else + (skribe-error 'flush + "Illegal side" + (markup-option n :side))))) + :after (lambda (n e) + (case (markup-option n :side) + ((center) + (display "</center>\n")) + ((right) + (display "</td></tr></table>\n")) + ((left) + (display "</p>\n"))))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before (html-markup-class "center") + :after "</center>\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre :before (html-markup-class "pre") :after "</pre>\n") + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before (html-markup-class "pre") + :after "</pre>\n") + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'itemize + :options '(:symbol) + :before (html-markup-class "ul") + :action (lambda (n e) + (for-each (lambda (item) + (display "<li") + (html-class item) + (display ">") + (output item e) + (display "</li>\n")) + (markup-body n))) + :after "</ul>") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before (html-markup-class "ol") + :action (lambda (n e) + (for-each (lambda (item) + (display "<li") + (html-class item) + (display ">") + (output item e) + (display "</li>\n")) + (markup-body n))) + :after "</ol>") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) + :before (html-markup-class "dl") + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (for-each (lambda (i) + (display " <dt") + (html-class i) + (display ">") + (output i e) + (display "</dt>")) + (if (pair? k) k (list k))) + (display "<dd") + (html-class item) + (display ">") + (output (markup-body item) e) + (display "</dd>\n"))) + (markup-body n))) + :after "</dl>") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (display "<b") + (html-class n) + (display ">") + (output k e) + (display "</b> ")))) + (output (markup-body n) e))) + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :options '() + :before (lambda (n e) + (display "<blockquote ") + (html-class n) + (display ">\n")) + :after "\n</blockquote>\n") + +;*---------------------------------------------------------------------*/ +;* figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'figure + :options '(:legend :number :multicolumns :legend-width) + :before (html-markup-class "br") + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend))) + (display "<a name=\"") + (display (string-canonicalize ident)) + (display "\"></a>\n") + (output (markup-body n) e) + (display "<br>\n") + (output (new markup + (markup '&html-figure-legend) + (parent n) + (ident (string-append ident "-legend")) + (class (markup-class n)) + (options `((:number ,number))) + (body legend)) + e))) + :after "<br>") + +;*---------------------------------------------------------------------*/ +;* &html-figure-legend ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-legend + :options '(:number) + :before (lambda (n e) + (display "<center>") + (let ((number (markup-option n :number)) + (legend (markup-option n :legend))) + (if number + (printf "<strong>Fig. ~a:</strong> " number) + (printf "<strong>Fig. :</strong> ")))) + :after "</center>") + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:border :width :frame :rules :cellstyle :cellpadding :cellspacing) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (border (markup-option n :border)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (cp (markup-option n :cellpadding)) + (cs (markup-option n :cellspacing))) + (display "<table") + (html-class n) + (if width (printf " width=\"~a\"" (html-width width))) + (if border (printf " border=\"~a\"" border)) + (if (and (number? cp) (>= cp 0)) + (printf " cellpadding=\"~a\"" cp)) + (if (and (number? cs) (>= cs 0)) + (printf " cellspacing=\"~a\"" cs)) + (cond + ((symbol? cstyle) + (printf " style=\"border-collapse: ~a;\"" cstyle)) + ((string? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~a\"" cstyle)) + ((number? cstyle) + (printf " style=\"border-collapse: separate; border-spacing=~apt\"" cstyle))) + (if frame + (printf " frame=\"~a\"" + (if (eq? frame 'none) "void" frame))) + (if (and rules (not (eq? rules 'header))) + (printf " rules=\"~a\"" rules)) + (display "><tbody>\n"))) + :after "</tbody></table>\n") + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '(:bg) + :before (lambda (n e) + (let ((bg (markup-option n :bg))) + (display "<tr") + (html-class n) + (when (html-color-spec? bg) (printf " bgcolor=\"~a\"" bg)) + (display ">"))) + :after "</tr>\n") + +;*---------------------------------------------------------------------*/ +;* tc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(markup :width :align :valign :colspan :rowspan :bg) + :before (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td)) + (width (markup-option n :width)) + (align (markup-option n :align)) + (valign (let ((v (markup-option n :valign))) + (cond + ((or (eq? v 'center) + (equal? v "center")) + "middle") + (else + v)))) + (colspan (markup-option n :colspan)) + (rowspan (markup-option n :rowspan)) + (bg (markup-option n :bg))) + (printf "<~a" markup) + (html-class n) + (if width (printf " width=\"~a\"" (html-width width))) + (if align (printf " align=\"~a\"" align)) + (if valign (printf " valign=\"~a\"" valign)) + (if colspan (printf " colspan=\"~a\"" colspan)) + (if rowspan (printf " rowspan=\"~a\"" rowspan)) + (when (html-color-spec? bg) + (printf " bgcolor=\"~a\"" bg)) + (display ">"))) + :after (lambda (n e) + (let ((markup (or (markup-option n 'markup) 'td))) + (printf "</~a>" markup)))) + +;*---------------------------------------------------------------------*/ +;* image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'image + :options '(:file :url :width :height) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("gif" "jpg" "png")))))) + (if (not (string? img)) + (skribe-error 'html "Illegal image" file) + (begin + (printf "<img src=\"~a\" border=\"0\"" img) + (html-class n) + (if body + (begin + (display " alt=\"") + (output body e) + (display "\"")) + (printf " alt=\"~a\"" file)) + (if width (printf " width=\"~a\"" (html-width width))) + (if height (printf " height=\"~a\"" height)) + (display ">")))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'roman :before "") +(markup-writer 'bold :before (html-markup-class "strong") :after "</strong>") +(markup-writer 'underline :before (html-markup-class "u") :after "</u>") +(markup-writer 'strike :before (html-markup-class "strike") :after "</strike>") +(markup-writer 'emph :before (html-markup-class "em") :after "</em>") +(markup-writer 'kbd :before (html-markup-class "kbd") :after "</kbd>") +(markup-writer 'it :before (html-markup-class "em") :after "</em>") +(markup-writer 'tt :before (html-markup-class "tt") :after "</tt>") +(markup-writer 'code :before (html-markup-class "code") :after "</code>") +(markup-writer 'var :before (html-markup-class "var") :after "</var>") +(markup-writer 'samp :before (html-markup-class "samp") :after "</samp>") +(markup-writer 'sc :before "<span class=\"sc\">" :after "</span>") +(markup-writer 'sf :before "<span class=\"sf\">" :after "</span>") +(markup-writer 'sub :before (html-markup-class "sub") :after "</sub>") +(markup-writer 'sup :before (html-markup-class "sup") :after "</sup>") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "\"" + :after "\"") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :action (lambda (n e) + (let ((text (markup-option n :text))) + (display "<a href=\"mailto:") + (output (markup-body n) e) + (display #\") + (html-class n) + (display #\>) + (if text + (output text e) + (skribe-eval (tt (markup-body n)) e)) + (display "</a>")))) + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :predicate (lambda (n e) + (and (engine-custom e 'javascript) + (or (string? (markup-body n)) + (and (pair? (markup-body n)) + (null? (cdr (markup-body n))) + (string? (car (markup-body n))))))) + :action (lambda (n e) + (let* ((body (markup-body n)) + (email (if (string? body) body (car body))) + (split (pregexp-split "@" email)) + (na (car split)) + (do (if (pair? (cdr split)) (cadr split) "")) + (nn (pregexp-replace* "[.]" na " ")) + (dd (pregexp-replace* "[.]" do " ")) + (text (markup-option n :text))) + (display "<script language=\"JavaScript\" type=\"text/javascript\"") + (if (not text) + (printf ">skribenospam( ~s, ~s, true )" nn dd) + (begin + (printf ">skribenospam( ~s, ~s, false )" nn dd) + (display "</script>") + (output text e) + (display "<script language=\"JavaScript\" type=\"text/javascript\">document.write(\"</\" + \"a>\")"))) + (display "</script>\n")))) + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :before (lambda (n e) + (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (html-class n) + (display ">")) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle) + :before (lambda (n e) + (let* ((c (handle-ast (markup-body n))) + (id (markup-ident c)) + (f (html-file c e)) + (class (if (markup-class n) + (markup-class n) + "inbound"))) + (printf "<a href=\"~a#~a\" class=\"~a\"" + (if (string=? f *skribe-dest*) + "" + (strip-ref-base (or f *skribe-dest* ""))) + (string-canonicalize id) + class) + (display ">"))) + :action (lambda (n e) + (let ((t (markup-option n :text)) + (m (markup-option n 'mark)) + (f (markup-option n :figure)) + (c (markup-option n :chapter)) + (s (markup-option n :section)) + (ss (markup-option n :subsection)) + (sss (markup-option n :subsubsection))) + (cond + (t + (output t e)) + (f + (output (new markup + (markup '&html-figure-ref) + (body (markup-body n))) + e)) + ((or c s ss sss) + (output (new markup + (markup '&html-section-ref) + (body (markup-body n))) + e)) + + ((not m) + (output (new markup + (markup '&html-unmark-ref) + (body (markup-body n))) + e)) + (else + (display m))))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* &html-figure-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-figure-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (or (not (markup? c)) + (not (is-markup? c 'figure))) + (display "???") + (output (markup-option c :number) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-section-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-section-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (output (markup-option c :title) e))))) + +;*---------------------------------------------------------------------*/ +;* &html-unmark-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&html-unmark-ref + :action (lambda (n e) + (let ((c (handle-ast (markup-body n)))) + (if (not (markup? c)) + (display "???") + (let ((t (markup-option c :title))) + (if t + (output t e) + (let ((l (markup-option c :legend))) + (if l + (output t e) + (display + (string-canonicalize + (markup-ident c))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) (output n e (markup-writer-get 'ref e))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (output (car rs) e (markup-writer-get 'ref e)) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* url-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :before (lambda (n e) + (let* ((url (markup-option n :url)) + (class (cond + ((markup-class n) + (markup-class n)) + ((not (string? url)) + #f) + (else + (let ((l (string-length url))) + (let loop ((i 0)) + (cond + ((= i l) + #f) + ((char=? (string-ref url i) #\:) + (substring url 0 i)) + (else + (loop (+ i 1)))))))))) + (display "<a href=\"") + (output url html-title-engine) + (display "\"") + (when class (printf " class=\"~a\"" class)) + (display ">"))) + :action (lambda (n e) + (let ((v (markup-option n :text))) + (output (or v (markup-option n :url)) e))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before (html-markup-class "i") + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (v (string->number (markup-option n :text)))) + (if (and (number? o) (number? v)) + (markup-option-add! n :text (+ o v))) + (output n e (markup-writer-get 'ref e)) + (if (and (number? o) (number? v)) + (markup-option-add! n :text v)))) + :after "</i>") + +;*---------------------------------------------------------------------*/ +;* page-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'page-ref + :options '(:mark :handle) + :action (lambda (n e) + (error 'page-ref:html "Not implemented yet" n))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before (lambda (n e) + (printf "<a name=\"~a\"" (string-canonicalize (markup-ident n))) + (html-class n) + (display ">")) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-label base-engine))) + :after "</a>") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url (or (markup-option en 'url) + (markup-option en 'documenturl))) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let* ((en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (t (bold (markup-body url)))) + (skribe-eval (ref :url (markup-body url) :text t) e)))) + +;*---------------------------------------------------------------------*/ +;* &the-index-header ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-index-header + :action (lambda (n e) + (display "<center") + (html-class n) + (display ">") + (for-each (lambda (h) + (let ((f (engine-custom e 'index-header-font-size))) + (if f + (skribe-eval (font :size f (bold (it h))) e) + (output h e)) + (display " "))) + (markup-body n)) + (display "</center>") + (skribe-eval (linebreak 2) e))) + +;*---------------------------------------------------------------------*/ +;* &source-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-line-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-keyword ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (bold (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &source-error ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-define ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-module ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-markup ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-thread ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-string ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-key ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/html4.skr b/skribe/skr/html4.skr new file mode 100644 index 0000000..acb7068 --- /dev/null +++ b/skribe/skr/html4.skr @@ -0,0 +1,165 @@ +;;;; +;;;; html4.skr -- HTML 4.01 Engine +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 18-Feb-2004 11:58 (eg) +;;;; Last file update: 26-Feb-2004 21:09 (eg) +;;;; + +(define (find-children node) + (define (flat l) + (cond + ((null? l) l) + ((pair? l) (append (flat (car l)) + (flat (cdr l)))) + (else (list l)))) + + (if (markup? node) + (flat (markup-body node)) + node)) + +;;; ====================================================================== + +(let ((le (find-engine 'html))) + ;;---------------------------------------------------------------------- + ;; Customizations + ;;---------------------------------------------------------------------- + (engine-custom-set! le 'html-variant "html4") + (engine-custom-set! le 'html4-logo "http://www.w3.org/Icons/valid-html401") + (engine-custom-set! le 'html4-validator "http://validator.w3.org/check/referer") + + ;;---------------------------------------------------------------------- + ;; &html-html ... + ;;---------------------------------------------------------------------- + (markup-writer '&html-html le + :before "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"> +<html>\n" + :after "</html>") + + ;;---------------------------------------------------------------------- + ;; &html-ending + ;;---------------------------------------------------------------------- + (let* ((img (engine-custom le 'html4-logo)) + (url (engine-custom le 'html4-validator)) + (bottom (list (hrule) + (table :width 100. + (tr + (td :align 'left + (font :size -1 [ + This ,(sc "Html") page has been produced by + ,(ref :url (skribe-url) :text "Skribe"). + ,(linebreak) + Last update ,(it (date)).])) + (td :align 'right :valign 'top + (ref :url url + :text (image :url img :width 88 :height 31)))))))) + (markup-writer '&html-ending le + :before "<div class=\"skribe-ending\">" + :action (lambda (n e) + (let ((body (markup-body n))) + (if body + (output body #t) + (skribe-eval bottom e)))) + :after "</div>\n")) + + ;;---------------------------------------------------------------------- + ;; color ... + ;;---------------------------------------------------------------------- + (markup-writer 'color le + :options '(:bg :fg :width :margin) + :before (lambda (n e) + (let ((m (markup-option n :margin)) + (w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg))) + (when bg + (display "<table cellspacing=\"0\"") + (html-class n) + (printf " cellpadding=\"~a\"" (if m m 0)) + (if w (printf " width=\"~a\"" (html-width w))) + (display "><tbody>\n<tr>") + (display "<td bgcolor=\"") + (output bg e) + (display "\">")) + (when fg + (display "<span style=\"color:") + (output fg e) + (display ";\">")))) + :after (lambda (n e) + (when (markup-option n :fg) + (display "</span>")) + (when (markup-option n :bg) + (display "</td></tr>\n</tbody></table>")))) + + ;;---------------------------------------------------------------------- + ;; font ... + ;;---------------------------------------------------------------------- + (markup-writer 'font le + :options '(:size :face) + :before (lambda (n e) + (let ((face (markup-option n :face)) + (size (let ((sz (markup-option n :size))) + (cond + ((or (unspecified? sz) (not sz)) + #f) + ((and (number? sz) (or (inexact? sz) (negative? sz))) + (format "~a%" + (+ 100 + (* 20 (inexact->exact (truncate sz)))))) + ((number? sz) + sz) + (else + (skribe-error 'font + (format "Illegal font size ~s" sz) + n)))))) + (display "<span ") + (html-class n) + (display "style=\"") + (if size (printf "font-size: ~a; " size)) + (if face (printf "font-family:'~a'; " face)) + (display "\">"))) + :after "</span>") + + ;;---------------------------------------------------------------------- + ;; paragraph ... + ;;---------------------------------------------------------------------- + (copy-markup-writer 'paragraph le + :validate (lambda (n e) + (let ((pred (lambda (x) + (and (container? x) + (not (memq (markup-markup x) '(font color))))))) + (not (any pred (find-children n)))))) + + ;;---------------------------------------------------------------------- + ;; roman ... + ;;---------------------------------------------------------------------- + (markup-writer 'roman le + :before "<span style=\"font-family: serif\">" + :after "</span>") + + ;;---------------------------------------------------------------------- + ;; table ... + ;;---------------------------------------------------------------------- + (let ((old-writer (markup-writer-get 'table le))) + (copy-markup-writer 'table le + :validate (lambda (n e) + (not (null? (markup-body n)))))) +) diff --git a/skribe/skr/jfp.skr b/skribe/skr/jfp.skr new file mode 100644 index 0000000..60b40f2 --- /dev/null +++ b/skribe/skr/jfp.skr @@ -0,0 +1,317 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/jfp.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for JFP articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/skribe/skr/latex-simple.skr b/skribe/skr/latex-simple.skr new file mode 100644 index 0000000..dd2eccb --- /dev/null +++ b/skribe/skr/latex-simple.skr @@ -0,0 +1,101 @@ +;;; +;;; LES CUSTOMS SONT TROP SPECIFIQUES POUR LA DISTRIBS. NE DOIT PAS VIRER +;;; CE FICHIER (sion simplifie il ne rest plus grand chose) +;;; Erick 27-10-04 +;;; + + +;*=====================================================================*/ +;* scmws04/src/latex-style.skr */ +;* ------------------------------------------------------------- */ +;* Author : Damien Ciabrini */ +;* Creation : Tue Aug 24 19:17:04 2004 */ +;* Last change : Thu Oct 28 21:45:25 2004 (eg) */ +;* Copyright : 2004 Damien Ciabrini, see LICENCE file */ +;* ------------------------------------------------------------- */ +;* Custom style for Latex... */ +;*=====================================================================*/ + +(let* ((le (find-engine 'latex)) + (oa (markup-writer-get 'author le))) + ; latex class & package for the workshop + (engine-custom-set! le 'documentclass "\\documentclass[letterpaper]{sigplan-proc}") + (engine-custom-set! le 'usepackage + "\\usepackage{epsfig} +\\usepackage{workshop} +\\conferenceinfo{Fifth Workshop on Scheme and Functional Programming.} + {September 22, 2004, Snowbird, Utah, USA.} +\\CopyrightYear{2004} +\\CopyrightHolder{Damien Ciabrini} +\\renewcommand{\\ttdefault}{cmtt} +") + (engine-custom-set! le 'image-format '("eps")) + (engine-custom-set! le 'source-define-color "#000080") + (engine-custom-set! le 'source-thread-color "#8080f0") + (engine-custom-set! le 'source-string-color "#000000") + + ; hyperref options + (engine-custom-set! le 'hyperref #t) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[bookmarksopen=true, bookmarksopenlevel=2,bookmarksnumbered=true,colorlinks,linkcolor=blue,citecolor=blue,pdftitle={Debugging Scheme Fair Threads}, pdfsubject={debugging cooperative threads based on reactive programming}, pdfkeywords={debugger, functional, reactive programming, Scheme}, pdfauthor={Damien Ciabrini}]{hyperref}") + ; nbsp with ~ char + (set! latex-encoding (delete! (assoc #\~ latex-encoding) latex-encoding)) + + ; let latex process citations + (markup-writer 'bib-ref le + :options '(:text :bib) + :before "\\cite{" + :action (lambda (n e) (display (markup-option n :bib))) + :after "}") + (markup-writer 'bib-ref+ le + :options '(:text :bib) + :before "\\cite{" + :action (lambda (n e) + (let loop ((bibs (markup-option n :bib))) + (if (pair? bibs) + (begin + (display (car bibs)) + (if (pair? (cdr bibs)) (display ", ")) + (loop (cdr bibs)))))) + :after "}") + (markup-writer '&the-bibliography le + :action (lambda (n e) + (print "\\bibliographystyle{abbrv}") + (display "\\bibliography{biblio}"))) + + ; ACM-style for authors + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (if (pair? body) + (print "\\numberofauthors{" (length body) "}")) + (print "\\author{"))) + :after "}\n") + (markup-writer 'author le + :options (writer-options oa) + :before "" + :action (lambda (n e) + (let ((name (markup-option n :name)) + (affiliation (markup-option n :affiliation)) + (address (markup-option n :address)) + (email (markup-option n :email))) + (define (row pre n post) + (display pre) + (output n e) + (display post) + (display "\\\\\n")) + ;; name + (if name (row "\\alignauthor " name "")) + ;; affiliation + (if affiliation (row "\\affaddr{" affiliation "}")) + ;; address + (if (pair? address) + (for-each (lambda (x) + (row "\\affaddr{" x "}")) address)) + ;; email + (if email (row "\\email{" email "}")))) + :after "") +) + +(define (include-biblio) + (the-bibliography)) diff --git a/skribe/skr/latex.skr b/skribe/skr/latex.skr new file mode 100644 index 0000000..bc20493 --- /dev/null +++ b/skribe/skr/latex.skr @@ -0,0 +1,1780 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/latex.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 09:46:09 2003 */ +;* Last change : Thu May 26 12:59:47 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* LaTeX Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/latexe.skb:ref@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* latex-verbatim-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-verbatim-encoding + '((#\\ "{\\char92}") + (#\^ "{\\char94}") + (#\{ "\\{") + (#\} "\\}") + (#\& "\\&") + (#\$ "\\$") + (#\# "\\#") + (#\_ "\\_") + (#\% "\\%") + (#\~ "$_{\\mbox{\\char126}}$") + (#\ç "\\c{c}") + (#\Ç "\\c{C}") + (#\â "\\^{a}") + (#\ "\\^{A}") + (#\à "\\`{a}") + (#\À "\\`{A}") + (#\é "\\'{e}") + (#\É "\\'{E}") + (#\è "\\`{e}") + (#\È "\\`{E}") + (#\ê "\\^{e}") + (#\Ê "\\^{E}") + (#\ù "\\`{u}") + (#\Ù "\\`{U}") + (#\û "\\^{u}") + (#\Û "\\^{U}") + (#\ø "{\\o}") + (#\ô "\\^{o}") + (#\Ô "\\^{O}") + (#\ö "\\\"{o}") + (#\Ö "\\\"{O}") + (#\î "\\^{\\i}") + (#\Î "\\^{I}") + (#\ï "\\\"{\\i}") + (#\Ï "\\\"{I}") + (#\] "{\\char93}") + (#\[ "{\\char91}") + (#\» "\\,{\\tiny{$^{\\gg}$}}") + (#\« "{\\tiny{$^{\\ll}$}}\\,"))) + +;*---------------------------------------------------------------------*/ +;* latex-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-encoding + (append '((#\| "$|$") + (#\< "$<$") + (#\> "$>$") + (#\: "{\\char58}") + (#\# "{\\char35}") + (#\Newline " %\n")) + latex-verbatim-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-tt-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-tt-encoding + (append '((#\. ".\\-") + (#\/ "/\\-")) + latex-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-pre-encoding ... */ +;*---------------------------------------------------------------------*/ +(define latex-pre-encoding + (append '((#\Space "\\ ") + (#\Newline "\\\\\n")) + latex-encoding)) + +;*---------------------------------------------------------------------*/ +;* latex-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define (latex-symbol-table math) + `(("iexcl" "!`") + ("cent" "c") + ("pound" "\\pounds") + ("yen" "Y") + ("section" "\\S") + ("mul" ,(math "^-")) + ("copyright" "\\copyright") + ("lguillemet" ,(math "\\ll")) + ("not" ,(math "\\neg")) + ("degree" ,(math "^{\\small{o}}")) + ("plusminus" ,(math "\\pm")) + ("micro" ,(math "\\mu")) + ("paragraph" "\\P") + ("middot" ,(math "\\cdot")) + ("rguillemet" ,(math "\\gg")) + ("1/4" ,(math "\\frac{1}{4}")) + ("1/2" ,(math "\\frac{1}{2}")) + ("3/4" ,(math "\\frac{3}{4}")) + ("iquestion" "?`") + ("Agrave" "\\`{A}") + ("Aacute" "\\'{A}") + ("Acircumflex" "\\^{A}") + ("Atilde" "\\~{A}") + ("Amul" "\\\"{A}") + ("Aring" "{\\AA}") + ("AEligature" "{\\AE}") + ("Oeligature" "{\\OE}") + ("Ccedilla" "{\\c{C}}") + ("Egrave" "{\\`{E}}") + ("Eacute" "{\\'{E}}") + ("Ecircumflex" "{\\^{E}}") + ("Euml" "\\\"{E}") + ("Igrave" "{\\`{I}}") + ("Iacute" "{\\'{I}}") + ("Icircumflex" "{\\^{I}}") + ("Iuml" "\\\"{I}") + ("ETH" "D") + ("Ntilde" "\\~{N}") + ("Ograve" "\\`{O}") + ("Oacute" "\\'{O}") + ("Ocurcumflex" "\\^{O}") + ("Otilde" "\\~{O}") + ("Ouml" "\\\"{O}") + ("times" ,(math "\\times")) + ("Oslash" "\\O") + ("Ugrave" "\\`{U}") + ("Uacute" "\\'{U}") + ("Ucircumflex" "\\^{U}") + ("Uuml" "\\\"{U}") + ("Yacute" "\\'{Y}") + ("szlig" "\\ss") + ("agrave" "\\`{a}") + ("aacute" "\\'{a}") + ("acircumflex" "\\^{a}") + ("atilde" "\\~{a}") + ("amul" "\\\"{a}") + ("aring" "\\aa") + ("aeligature" "\\ae") + ("oeligature" "{\\oe}") + ("ccedilla" "{\\c{c}}") + ("egrave" "{\\`{e}}") + ("eacute" "{\\'{e}}") + ("ecircumflex" "{\\^{e}}") + ("euml" "\\\"{e}") + ("igrave" "{\\`{\\i}}") + ("iacute" "{\\'{\\i}}") + ("icircumflex" "{\\^{\\i}}") + ("iuml" "\\\"{\\i}") + ("ntilde" "\\~{n}") + ("ograve" "\\`{o}") + ("oacute" "\\'{o}") + ("ocurcumflex" "\\^{o}") + ("otilde" "\\~{o}") + ("ouml" "\\\"{o}") + ("divide" ,(math "\\div")) + ("oslash" "\\o") + ("ugrave" "\\`{u}") + ("uacute" "\\'{u}") + ("ucircumflex" "\\^{u}") + ("uuml" "\\\"{u}") + ("yacute" "\\'{y}") + ("ymul" "\\\"{y}") + ;; Greek + ("Alpha" "A") + ("Beta" "B") + ("Gamma" ,(math "\\Gamma")) + ("Delta" ,(math "\\Delta")) + ("Epsilon" "E") + ("Zeta" "Z") + ("Eta" "H") + ("Theta" ,(math "\\Theta")) + ("Iota" "I") + ("Kappa" "K") + ("Lambda" ,(math "\\Lambda")) + ("Mu" "M") + ("Nu" "N") + ("Xi" ,(math "\\Xi")) + ("Omicron" "O") + ("Pi" ,(math "\\Pi")) + ("Rho" "P") + ("Sigma" ,(math "\\Sigma")) + ("Tau" "T") + ("Upsilon" ,(math "\\Upsilon")) + ("Phi" ,(math "\\Phi")) + ("Chi" "X") + ("Psi" ,(math "\\Psi")) + ("Omega" ,(math "\\Omega")) + ("alpha" ,(math "\\alpha")) + ("beta" ,(math "\\beta")) + ("gamma" ,(math "\\gamma")) + ("delta" ,(math "\\delta")) + ("epsilon" ,(math "\\varepsilon")) + ("zeta" ,(math "\\zeta")) + ("eta" ,(math "\\eta")) + ("theta" ,(math "\\theta")) + ("iota" ,(math "\\iota")) + ("kappa" ,(math "\\kappa")) + ("lambda" ,(math "\\lambda")) + ("mu" ,(math "\\mu")) + ("nu" ,(math "\\nu")) + ("xi" ,(math "\\xi")) + ("omicron" ,(math "\\o")) + ("pi" ,(math "\\pi")) + ("rho" ,(math "\\rho")) + ("sigmaf" ,(math "\\varsigma")) + ("sigma" ,(math "\\sigma")) + ("tau" ,(math "\\tau")) + ("upsilon" ,(math "\\upsilon")) + ("phi" ,(math "\\varphi")) + ("chi" ,(math "\\chi")) + ("psi" ,(math "\\psi")) + ("omega" ,(math "\\omega")) + ("thetasym" ,(math "\\vartheta")) + ("piv" ,(math "\\varpi")) + ;; punctuation + ("bullet" ,(math "\\bullet")) + ("ellipsis" ,(math "\\ldots")) + ("weierp" ,(math "\\wp")) + ("image" ,(math "\\Im")) + ("real" ,(math "\\Re")) + ("tm" ,(math "^{\\sc\\tiny{tm}}")) + ("alef" ,(math "\\aleph")) + ("<-" ,(math "\\leftarrow")) + ("<--" ,(math "\\longleftarrow")) + ("uparrow" ,(math "\\uparrow")) + ("->" ,(math "\\rightarrow")) + ("-->" ,(math "\\longrightarrow")) + ("downarrow" ,(math "\\downarrow")) + ("<->" ,(math "\\leftrightarrow")) + ("<-->" ,(math "\\longleftrightarrow")) + ("<+" ,(math "\\hookleftarrow")) + ("<=" ,(math "\\Leftarrow")) + ("<==" ,(math "\\Longleftarrow")) + ("Uparrow" ,(math "\\Uparrow")) + ("=>" ,(math "\\Rightarrow")) + ("==>" ,(math "\\Longrightarrow")) + ("Downarrow" ,(math "\\Downarrow")) + ("<=>" ,(math "\\Leftrightarrow")) + ("<==>" ,(math "\\Longleftrightarrow")) + ;; Mathematical operators + ("forall" ,(math "\\forall")) + ("partial" ,(math "\\partial")) + ("exists" ,(math "\\exists")) + ("emptyset" ,(math "\\emptyset")) + ("infinity" ,(math "\\infty")) + ("nabla" ,(math "\\nabla")) + ("in" ,(math "\\in")) + ("notin" ,(math "\\notin")) + ("ni" ,(math "\\ni")) + ("prod" ,(math "\\Pi")) + ("sum" ,(math "\\Sigma")) + ("asterisk" ,(math "\\ast")) + ("sqrt" ,(math "\\surd")) + ("propto" ,(math "\\propto")) + ("angle" ,(math "\\angle")) + ("and" ,(math "\\wedge")) + ("or" ,(math "\\vee")) + ("cap" ,(math "\\cap")) + ("cup" ,(math "\\cup")) + ("integral" ,(math "\\int")) + ("models" ,(math "\\models")) + ("vdash" ,(math "\\vdash")) + ("dashv" ,(math "\\dashv")) + ("sim" ,(math "\\sim")) + ("cong" ,(math "\\cong")) + ("approx" ,(math "\\approx")) + ("neq" ,(math "\\neq")) + ("equiv" ,(math "\\equiv")) + ("le" ,(math "\\leq")) + ("ge" ,(math "\\geq")) + ("subset" ,(math "\\subset")) + ("supset" ,(math "\\supset")) + ("subseteq" ,(math "\\subseteq")) + ("supseteq" ,(math "\\supseteq")) + ("oplus" ,(math "\\oplus")) + ("otimes" ,(math "\\otimes")) + ("perp" ,(math "\\perp")) + ("mid" ,(math "\\mid")) + ("lceil" ,(math "\\lceil")) + ("rceil" ,(math "\\rceil")) + ("lfloor" ,(math "\\lfloor")) + ("rfloor" ,(math "\\rfloor")) + ("langle" ,(math "\\langle")) + ("rangle" ,(math "\\rangle")) + ;; Misc + ("loz" ,(math "\\diamond")) + ("spades" ,(math "\\spadesuit")) + ("clubs" ,(math "\\clubsuit")) + ("hearts" ,(math "\\heartsuit")) + ("diams" ,(math "\\diamondsuit")) + ("euro" "\\euro{}") + ;; LaTeX + ("dag" "\\dag") + ("ddag" "\\ddag") + ("circ" ,(math "\\circ")) + ("top" ,(math "\\top")) + ("bottom" ,(math "\\bot")) + ("lhd" ,(math "\\triangleleft")) + ("rhd" ,(math "\\triangleright")) + ("parallel" ,(math "\\parallel")))) + +;*---------------------------------------------------------------------*/ +;* latex-engine ... */ +;*---------------------------------------------------------------------*/ +(define latex-engine + (default-engine-set! + (make-engine 'latex + :version 1.0 + :format "latex" + :delegate (find-engine 'base) + :filter (make-string-replace latex-encoding) + :custom '((documentclass "\\documentclass{article}") + (usepackage "\\usepackage{epsfig}\n") + (predocument "\\newdimen\\oldframetabcolsep\n\\newdimen\\oldcolortabcolsep\n\\newdimen\\oldpretabcolsep\n") + (postdocument #f) + (maketitle "\\date{}\n\\maketitle") + (%font-size 0) + ;; color + (color #t) + (color-usepackage "\\usepackage{color}\n") + ;; hyperref + (hyperref #t) + (hyperref-usepackage "\\usepackage[setpagesize=false]{hyperref}\n") + ;; source fontification + (source-color #t) + (source-comment-color "#ffa600") + (source-error-color "red") + (source-define-color "#6959cf") + (source-module-color "#1919af") + (source-markup-color "#1919af") + (source-thread-color "#ad4386") + (source-string-color "red") + (source-bracket-color "red") + (source-type-color "#00cf00") + (image-format ("eps")) + (index-page-ref #t)) + :symbol-table (latex-symbol-table + (lambda (m) + (format "\\begin{math}~a\\end{math}" m)))))) + +;*---------------------------------------------------------------------*/ +;* latex-title-engine ... */ +;*---------------------------------------------------------------------*/ +(define latex-title-engine + (make-engine 'latex-title + :version 1.0 + :format "latex-title" + :delegate latex-engine + :filter (make-string-replace latex-encoding) + :symbol-table (latex-symbol-table (lambda (m) (format "$~a$" m))))) + +;*---------------------------------------------------------------------*/ +;* latex-color? ... */ +;*---------------------------------------------------------------------*/ +(define (latex-color? e) + (engine-custom e 'color)) + +;*---------------------------------------------------------------------*/ +;* LaTeX ... */ +;*---------------------------------------------------------------------*/ +(define-markup (LaTeX #!key (space #t)) + (if (engine-format? "latex") + (! (if space "\\LaTeX\\ " "\\LaTeX")) + "LaTeX")) + +;*---------------------------------------------------------------------*/ +;* TeX ... */ +;*---------------------------------------------------------------------*/ +(define-markup (TeX #!key (space #t)) + (if (engine-format? "latex") + (! (if space "\\TeX\\ " "\\TeX")) + "TeX")) + +;*---------------------------------------------------------------------*/ +;* latex ... */ +;*---------------------------------------------------------------------*/ +(define-markup (!latex fmt #!rest opt) + (if (engine-format? "latex") + (apply ! fmt opt) + #f)) + +;*---------------------------------------------------------------------*/ +;* latex-width ... */ +;*---------------------------------------------------------------------*/ +(define (latex-width width) + (if (and (number? width) (inexact? width)) + (string-append (number->string (/ width 100.)) "\\linewidth") + (string-append (number->string width) "pt"))) + +;*---------------------------------------------------------------------*/ +;* latex-font-size ... */ +;*---------------------------------------------------------------------*/ +(define (latex-font-size size) + (case size + ((4) "Huge") + ((3) "huge") + ((2) "Large") + ((1) "large") + ((0) "normalsize") + ((-1) "small") + ((-2) "footnotesize") + ((-3) "scriptsize") + ((-4) "tiny") + (else (if (number? size) + (if (< size 0) "tiny" "Huge") + "normalsize")))) + +;*---------------------------------------------------------------------*/ +;* *skribe-latex-color-table* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-latex-color-table* #f) + +;*---------------------------------------------------------------------*/ +;* latex-declare-color ... */ +;*---------------------------------------------------------------------*/ +(define (latex-declare-color name rgb) + (printf "\\definecolor{~a}{rgb}{~a}\n" name rgb)) + +;*---------------------------------------------------------------------*/ +;* skribe-get-latex-color ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-latex-color spec) + (let ((c (and (hashtable? *skribe-latex-color-table*) + (hashtable-get *skribe-latex-color-table* spec)))) + (if (not (string? c)) + (skribe-error 'latex "Can't find color" spec) + c))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->latex-rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->latex-rgb spec) + (receive (r g b) + (skribe-color->rgb spec) + (cond + ((and (= r 0) (= g 0) (= b 0)) + "0.,0.,0.") + ((and (= r #xff) (= g #xff) (= b #xff)) + "1.,1.,1.") + (else + (let ((ff (exact->inexact #xff))) + (format "~a,~a,~a" + (number->string (/ r ff)) + (number->string (/ g ff)) + (number->string (/ b ff)))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-latex-declare-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-latex-declare-colors colors) + (set! *skribe-latex-color-table* (make-hashtable)) + (for-each (lambda (spec) + (let ((old (hashtable-get *skribe-latex-color-table* spec))) + (if (not (string? old)) + (let ((name (symbol->string (gensym 'c)))) + ;; bind the color + (hashtable-put! *skribe-latex-color-table* spec name) + ;; and emit a latex declaration + (latex-declare-color + name + (skribe-color->latex-rgb spec)))))) + colors)) + +;*---------------------------------------------------------------------*/ +;* &~ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&~ + :before "~" + :action #f) + +;*---------------------------------------------------------------------*/ +;* &latex-table-start */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-start + :options '() + :action (lambda (n e) + (let ((width (markup-option n 'width))) + (if (number? width) + (printf "\\begin{tabular*}{~a}" (latex-width width)) + (display "\\begin{tabular}"))))) + +;*---------------------------------------------------------------------*/ +;* &latex-table-stop */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-stop + :options '() + :action (lambda (n e) + (let ((width (markup-option n 'width))) + (if (number? width) + (display "\\end{tabular*}\n") + (display "\\end{tabular}\n"))))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'document + :options '(:title :author :ending :env) + :before (lambda (n e) + ;; documentclass + (let ((dc (engine-custom e 'documentclass))) + (if dc + (begin (display dc) (newline)) + (display "\\documentclass{article}\n"))) + (if (latex-color? e) + (display (engine-custom e 'color-usepackage))) + (if (engine-custom e 'hyperref) + (display (engine-custom e 'hyperref-usepackage))) + ;; usepackage + (let ((pa (engine-custom e 'usepackage))) + (if pa (begin (display pa) (newline)))) + ;; colors + (if (latex-color? e) + (begin + (skribe-use-color! (engine-custom e 'source-comment-color)) + (skribe-use-color! (engine-custom e 'source-define-color)) + (skribe-use-color! (engine-custom e 'source-module-color)) + (skribe-use-color! (engine-custom e 'source-markup-color)) + (skribe-use-color! (engine-custom e 'source-thread-color)) + (skribe-use-color! (engine-custom e 'source-string-color)) + (skribe-use-color! (engine-custom e 'source-bracket-color)) + (skribe-use-color! (engine-custom e 'source-type-color)) + (display "\n%% colors\n") + (skribe-latex-declare-colors (skribe-get-used-colors)) + (display "\n\n"))) + ;; predocument + (let ((pd (engine-custom e 'predocument))) + (when pd (display pd) (newline))) + ;; title + (let ((t (markup-option n :title))) + (when t + (skribe-eval (new markup + (markup '&latex-title) + (body t)) + e + :env `((parent ,n))))) + ;; author + (let ((a (markup-option n :author))) + (when a + (skribe-eval (new markup + (markup '&latex-author) + (body a)) + e + :env `((parent ,n))))) + ;; document + (display "\\begin{document}\n") + ;; postdocument + (let ((pd (engine-custom e 'postdocument))) + (if pd (begin (display pd) (newline)))) + ;; maketitle + (let ((mt (engine-custom e 'maketitle))) + (if mt (begin (display mt) (newline))))) + :action (lambda (n e) + (output (markup-body n) e)) + :after (lambda (n e) + (display "\n\\end{document}\n"))) + +;*---------------------------------------------------------------------*/ +;* &latex-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-title + :before "\\title{" + :after "}\n") + +;*---------------------------------------------------------------------*/ +;* &latex-author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-author + :before "\\author{\\centerline{\n" + :action (lambda (n e) + (let ((body (markup-body n))) + (if (pair? body) + (begin + (output (new markup + (markup '&latex-table-start) + (class "&latex-author-table")) + e) + (printf "{~a}\n" (make-string (length body) #\c)) + (let loop ((as body)) + (output (car as) e) + (if (pair? (cdr as)) + (begin + (display " & ") + (loop (cdr as))))) + (display "\\\\\n") + (output (new markup + (markup '&latex-table-stop) + (class "&latex-author-table")) + e)) + (output body e)))) + :after "}}\n") + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (output (new markup + (markup '&latex-table-start) + (class "author")) + e) + (printf "{~a}\n" + (case (markup-option n :align) + ((left) "l") + ((right) "r") + (else "c")))) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (cond + ((pair? address) + (for-each row address)) + ((string? address) + (row address))) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url)))) + :after (lambda (n e) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'author + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :predicate (lambda (n e) (markup-option n :photo)) + :before (lambda (n e) + (output (new markup + (markup '&latex-table-start) + (class "author")) + e) + (printf "{cc}\n")) + :action (lambda (n e) + (let ((photo (markup-option n :photo))) + (output photo e) + (display " & ") + (markup-option-add! n :photo #f) + (output n e) + (markup-option-add! n :photo photo) + (display "\\\\\n"))) + :after (lambda (n e) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'toc + :options '() + :action (lambda (n e) (display "\\tableofcontents\n"))) + +;*---------------------------------------------------------------------*/ +;* latex-block-before ... */ +;*---------------------------------------------------------------------*/ +(define (latex-block-before m) + (lambda (n e) + (let ((num (markup-option n :number))) + (printf "\n\n%% ~a\n" (string-canonicalize (markup-ident n))) + (printf "\\~a~a{" m (if (not num) "*" "")) + (output (markup-option n :title) latex-title-engine) + (display "}\n") + (when num + (printf "\\label{~a}\n" (string-canonicalize (markup-ident n))))))) + +;*---------------------------------------------------------------------*/ +;* section ... .. @label chapter@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'chapter + :options '(:title :number :toc :file :env) + :before (latex-block-before 'chapter)) + +;*---------------------------------------------------------------------*/ +;* section ... . @label section@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'section + :options '(:title :number :toc :file :env) + :before (latex-block-before 'section)) + +;*---------------------------------------------------------------------*/ +;* subsection ... @label subsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsection + :options '(:title :number :toc :file :env) + :before (latex-block-before 'subsection)) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... @label subsubsection@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'subsubsection + :options '(:title :number :toc :file :env) + :before (latex-block-before 'subsubsection)) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'paragraph + :options '(:title :number :toc :env) + :before (lambda (n e) + (when (and (>= (skribe-debug) 2) (location? (ast-loc n))) + (printf "\n\\makebox[\\linewidth][l]{\\hspace{-1.5cm}\\footnotesize{$\\triangleright$\\textit{~a}}}\n" + (ast-location n))) + (display "\\noindent ")) + :after "\\par\n") + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'footnote + :before "\\footnote{" + :after "}") + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'linebreak + :action (lambda (n e) + (display "\\makebox[\\linewidth]{}"))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'hrule + :options '() + :before "\\hrulefill" + :action #f) + +;*---------------------------------------------------------------------*/ +;* latex-color-counter */ +;*---------------------------------------------------------------------*/ +(define latex-color-counter 1) + +;*---------------------------------------------------------------------*/ +;* latex-color ... */ +;*---------------------------------------------------------------------*/ +(define latex-color + (lambda (bg fg n e) + (if (not (latex-color? e)) + (output n e) + (begin + (if bg + (printf "\\setbox~a \\vbox \\bgroup " latex-color-counter)) + (set! latex-color-counter (+ latex-color-counter 1)) + (if fg + (begin + (printf "\\textcolor{~a}{" (skribe-get-latex-color fg)) + (output n e) + (display "}")) + (output n e)) + (set! latex-color-counter (- latex-color-counter 1)) + (if bg + (printf "\\egroup\\colorbox{~a}{\\box~a}%\n" + (skribe-get-latex-color bg) latex-color-counter)))))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'color + :options '(:bg :fg :width) + :action (lambda (n e) + (let* ((w (markup-option n :width)) + (bg (markup-option n :bg)) + (fg (markup-option n :fg)) + (m (markup-option n :margin)) + (tw (cond + ((not w) + #f) + ((and (integer? w) (exact? w)) + w) + ((real? w) + (latex-width w))))) + (when bg + (display "\\setlength{\\oldcolortabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n") + (when m + (printf "\\addtolength{\\tabcolsep}{~a}" + (latex-width m))) + (output (new markup + (markup '&latex-table-start) + (class "color")) + e) + (if tw + (printf "{p{~a}}\n" tw) + (printf "{l}\n"))) + (latex-color bg fg (markup-body n) e) + (when bg + (output (new markup + (markup '&latex-table-stop) + (class "color")) + e) + (display "\\setlength{\\tabcolsep}{\\oldcolortabcolsep}\n"))))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'frame + :options '(:width :border :margin) + :before (lambda (n e) + (display "\\setlength{\\oldframetabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}") + (let ((m (markup-option n :margin))) + (when m + (printf "\\addtolength{\\tabcolsep}{~a}" (latex-width m)))) + (newline)) + :action (lambda (n e) + (let* ((b (markup-option n :border)) + (w (markup-option n :width)) + (tw (cond + ((not w) + ".96\\linewidth") + ((and (integer? w) (exact? w)) + w) + ((real? w) + (latex-width w))))) + (output (new markup + (markup '&latex-table-start) + (class "frame")) + e) + (if (and (integer? b) (> b 0)) + (begin + (printf "{|p{~a}|}\\hline\n" tw) + (output (markup-body n) e) + (display "\\\\\\hline\n")) + (begin + (printf "{p{~a}}\n" tw) + (output (markup-body n) e))) + (output (new markup + (markup '&latex-table-stop) + (class "author")) + e))) + :after "\\setlength{\\tabcolsep}{\\oldframetabcolsep}\n") + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'font + :options '(:size) + :action (lambda (n e) + (let* ((size (markup-option n :size)) + (cs (let ((n (engine-custom e '%font-size))) + (if (number? n) + n + 0))) + (ns (cond + ((and (integer? size) (exact? size)) + (if (> size 0) + size + (+ cs size))) + ((and (number? size) (inexact? size)) + (+ cs (inexact->exact size))) + ((string? size) + (let ((nb (string->number size))) + (if (not (number? nb)) + (skribe-error + 'font + (format "Illegal font size ~s" size) + nb) + (+ cs nb)))))) + (ne (make-engine (gensym 'latex) + :delegate e + :filter (engine-filter e) + :symbol-table (engine-symbol-table e) + :custom `((%font-size ,ns) + ,@(engine-customs e))))) + (printf "{\\~a{" (latex-font-size ns)) + (output (markup-body n) ne) + (display "}}")))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'flush + :options '(:side) + :before (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\\begin{center}\n")) + ((left) + (display "\\begin{flushleft}")) + ((right) + (display "\\begin{flushright}")))) + :after (lambda (n e) + (case (markup-option n :side) + ((center) + (display "\\end{center}\n")) + ((left) + (display "\\end{flushleft}\n")) + ((right) + (display "\\end{flushright}\n"))))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'center + :before "\\begin{center}\n" + :after "\\end{center}\n") + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'pre + :before (lambda (n e) + (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \n\\bgroup\n{\\noindent \\texttt{" + latex-color-counter) + (output (new markup + (markup '&latex-table-start) + (class "pre")) + e) + (display "{l}\n") + (set! latex-color-counter (+ latex-color-counter 1))) + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after (lambda (n e) + (set! latex-color-counter (- latex-color-counter 1)) + (output (new markup + (markup '&latex-table-stop) + (class "pre")) + e) + (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'prog + :options '(:line :mark) + :before (lambda (n e) + (printf "\\setlength{\\oldpretabcolsep}{\\tabcolsep}\n\\addtolength{\\tabcolsep}{-\\tabcolsep}\n{\\setbox~a \\vbox \\bgroup\n{\\noindent \\texttt{" + latex-color-counter) + (output (new markup + (markup '&latex-table-start) + (class "pre")) + e) + (display "{l}\n") + (set! latex-color-counter (+ latex-color-counter 1))) + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-pre-encoding) + :symbol-table (engine-symbol-table e) + :custom (engine-customs e)))) + (output (markup-body n) ne))) + :after (lambda (n e) + (set! latex-color-counter (- latex-color-counter 1)) + (output (new markup + (markup '&latex-table-stop) + (class "prog")) + e) + (printf "}}\n\\egroup{\\box~a}}%\n\\setlength{\\tabcolsep}{\\oldpretabcolsep}\n" latex-color-counter))) + +;*---------------------------------------------------------------------*/ +;* &prog-line ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&prog-line + :before (lambda (n e) + (let ((n (markup-ident n))) + (if n (skribe-eval (it (list n) ": ") e)))) + :after "\\\\\n") + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'itemize + :options '(:symbol) + :before "\\begin{itemize}\n" + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{itemize} ") + +(markup-writer 'itemize + :predicate (lambda (n e) (markup-option n :symbol)) + :options '(:symbol) + :before (lambda (n e) + (display "\\begin{list}{") + (output (markup-option n :symbol) e) + (display "}{}") + (newline)) + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{list}\n") + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'enumerate + :options '(:symbol) + :before "\\begin{enumerate}\n" + :action (lambda (n e) + (for-each (lambda (item) + (display " \\item ") + (output item e) + (newline)) + (markup-body n))) + :after "\\end{enumerate}\n") + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'description + :options '(:symbol) + :before "\\begin{description}\n" + :action (lambda (n e) + (for-each (lambda (item) + (let ((k (markup-option item :key))) + (for-each (lambda (i) + (display " \\item[") + (output i e) + (display "]\n")) + (if (pair? k) k (list k))) + (output (markup-body item) e))) + (markup-body n))) + :after "\\end{description}\n") + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'item + :options '(:key) + :action (lambda (n e) + (let ((k (markup-option n :key))) + (if k + (begin + (display "[") + (output k e) + (display "] ")))) + (output (markup-body n) e))) + +;*---------------------------------------------------------------------*/ +;* blockquote ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'blockquote + :before "\n\\begin{quote}\n" + :after "\n\\end{quote}") + +;*---------------------------------------------------------------------*/ +;* figure ... @label figure@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'figure + :options '(:legend :number :multicolumns) + :action (lambda (n e) + (let ((ident (markup-ident n)) + (number (markup-option n :number)) + (legend (markup-option n :legend)) + (mc (markup-option n :multicolumns))) + (display (if mc + "\\begin{figure*}[!th]\n" + "\\begin{figure}[ht]\n")) + (output (markup-body n) e) + (printf "\\caption{\\label{~a}" (string-canonicalize ident)) + (output legend e) + (display (if mc + "}\\end{figure*}\n" + "}\\end{figure}\n"))))) + +;*---------------------------------------------------------------------*/ +;* table-column-number ... */ +;* ------------------------------------------------------------- */ +;* Computes how many columns are contained in a table. */ +;*---------------------------------------------------------------------*/ +(define (table-column-number t) + (define (row-columns row) + (let luup ((cells (markup-body row)) + (nbcols 0)) + (cond + ((null? cells) + nbcols) + ((pair? cells) + (luup (cdr cells) + (+ nbcols (markup-option (car cells) :colspan)))) + (else + (skribe-type-error 'tr "Illegal tr body, " row "pair"))))) + (let loop ((rows (markup-body t)) + (nbcols 0)) + (if (null? rows) + nbcols + (loop (cdr rows) + (max (row-columns (car rows)) nbcols))))) + +;*---------------------------------------------------------------------*/ +;* table ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'table + :options '(:width :frame :rules :cellstyle) + :before (lambda (n e) + (let ((width (markup-option n :width)) + (frame (markup-option n :frame)) + (rules (markup-option n :rules)) + (cstyle (markup-option n :cellstyle)) + (nbcols (table-column-number n)) + (id (markup-ident n)) + (cla (markup-class n)) + (rows (markup-body n))) + ;; the table header + (output (new markup + (markup '&latex-table-start) + (class "table") + (options `((width ,width)))) + e) + ;; store the actual number of columns + (markup-option-add! n '&nbcols nbcols) + ;; compute the table header + (let ((cols (cond + ((= nbcols 0) + (skribe-error 'table + "Illegal empty table" + n)) + ((or (not width) (= nbcols 1)) + (make-string nbcols #\c)) + (else + (let ((v (make-vector + (- nbcols 1) + "@{\\extracolsep{\\fill}}c"))) + (apply string-append + (cons "c" (vector->list v)))))))) + (case frame + ((none) + (printf "{~a}\n" cols)) + ((border box) + (printf "{|~a|}" cols) + (markup-option-add! n '&lhs #t) + (markup-option-add! n '&rhs #t) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-above" id)) + (class "table-line-above")) + e)) + ((above hsides) + (printf "{~a}" cols) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-above" id)) + (class "table-line-above")) + e)) + ((vsides) + (markup-option-add! n '&lhs #t) + (markup-option-add! n '&rhs #t) + (printf "{|~a|}\n" cols)) + ((lhs) + (markup-option-add! n '&lhs #t) + (printf "{|~a}\n" cols)) + ((rhs) + (markup-option-add! n '&rhs #t) + (printf "{~a|}\n" cols)) + (else + (printf "{~a}\n" cols))) + ;; mark each row with appropriate '&tl (top-line) + ;; and &bl (bottom-line) options + (when (pair? rows) + (if (and (memq rules '(rows all)) + (or (not (eq? cstyle 'collapse)) + (not (memq frame '(border box above hsides))))) + (let ((frow (car rows))) + (if (is-markup? frow 'tr) + (markup-option-add! frow '&tl #t)))) + (if (eq? rules 'header) + (let ((frow (car rows))) + (if (is-markup? frow 'tr) + (markup-option-add! frow '&bl #t)))) + (when (and (pair? (cdr rows)) + (memq rules '(rows all))) + (for-each (lambda (row) + (if (is-markup? row 'tr) + (markup-option-add! row '&bl #t))) + rows) + (markup-option-add! (car (last-pair rows)) '&bl #f)) + (if (and (memq rules '(rows all)) + (or (not (eq? cstyle 'collapse)) + (not (memq frame '(border box above hsides))))) + (let ((lrow (car (last-pair rows)))) + (if (is-markup? lrow 'tr) + (markup-option-add! lrow '&bl #t)))))))) + :after (lambda (n e) + (case (markup-option n :frame) + ((hsides below box border) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (format "~a-below" (markup-ident n))) + (class "table-hline-below")) + e))) + (output (new markup + (markup '&latex-table-stop) + (class "table") + (options `((width ,(markup-option n :width))))) + e))) + +;*---------------------------------------------------------------------*/ +;* &latex-table-hline */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-table-hline + :action "\\hline\n") + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tr + :options '() + :action (lambda (n e) + (let* ((parent (ast-parent n)) + (_ (if (not (is-markup? parent 'table)) + (skribe-type-error 'tr "Illegal parent, " parent + "#<table>"))) + (nbcols (markup-option parent '&nbcols)) + (lhs (markup-option parent '&lhs)) + (rhs (markup-option parent '&rhs)) + (rules (markup-option parent :rules)) + (collapse (eq? (markup-option parent :cellstyle) + 'collapse)) + (vrules (memq rules '(cols all))) + (cells (markup-body n))) + (if (markup-option n '&tl) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (markup-ident n)) + (class (markup-class n))) + e)) + (if (> nbcols 0) + (let laap ((nbc nbcols) + (cs cells)) + (if (null? cs) + (when (> nbc 1) + (display " & ") + (laap (- nbc 1) cs)) + (let* ((c (car cs)) + (nc (- nbc (markup-option c :colspan)))) + (when (= nbcols nbc) + (cond + ((and lhs vrules (not collapse)) + (markup-option-add! c '&lhs "||")) + ((or lhs vrules) + (markup-option-add! c '&lhs #\|)))) + (when (= nc 0) + (cond + ((and rhs vrules (not collapse)) + (markup-option-add! c '&rhs "||")) + ((or rhs vrules) + (markup-option-add! c '&rhs #\|)))) + (when (and vrules (> nc 0) (< nc nbcols)) + (markup-option-add! c '&rhs #\|)) + (output c e) + (when (> nc 0) + (display " & ") + (laap nc (cdr cs))))))))) + :after (lambda (n e) + (display "\\\\") + (if (markup-option n '&bl) + (output (new markup + (markup '&latex-table-hline) + (parent n) + (ident (markup-ident n)) + (class (markup-class n))) + e) + (newline)))) + +;*---------------------------------------------------------------------*/ +;* tc */ +;*---------------------------------------------------------------------*/ +(markup-writer 'tc + :options '(:width :align :valign :colspan) + :action (lambda (n e) + (let ((id (markup-ident n)) + (cla (markup-class n))) + (let* ((o0 (markup-body n)) + (o1 (if (eq? (markup-option n 'markup) 'th) + (new markup + (markup '&latex-th) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o0)) + o0)) + (o2 (if (markup-option n :width) + (new markup + (markup '&latex-tc-parbox) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o1)) + o1)) + (o3 (if (or (> (markup-option n :colspan) 1) + (not (eq? (markup-option n :align) + 'center)) + (markup-option n '&lhs) + (markup-option n '&rhs)) + (new markup + (markup '&latex-tc-multicolumn) + (parent n) + (ident id) + (class cla) + (options (markup-options n)) + (body o2)) + o2))) + (output o3 e))))) + +;*---------------------------------------------------------------------*/ +;* &latex-th ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-th + :before "\\textsf{" + :after "}") + +;*---------------------------------------------------------------------*/ +;* &latex-tc-parbox ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-tc-parbox + :before (lambda (n e) + (let ((width (markup-option n :width)) + (valign (markup-option n :valign))) + (printf "\\parbox{~a}{" (latex-width width)))) + :after "}") + +;*---------------------------------------------------------------------*/ +;* &latex-tc-multicolumn ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&latex-tc-multicolumn + :before (lambda (n e) + (let ((colspan (markup-option n :colspan)) + (lhs (or (markup-option n '&lhs) "")) + (rhs (or (markup-option n '&rhs) "")) + (align (case (markup-option n :align) + ((left) #\l) + ((center) #\c) + ((right) #\r) + (else #\c)))) + (printf "\\multicolumn{~a}{~a~a~a}{" colspan lhs align rhs))) + :after "}") + +;*---------------------------------------------------------------------*/ +;* image ... @label image@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'image + :options '(:file :url :width :height :zoom) + :action (lambda (n e) + (let* ((file (markup-option n :file)) + (url (markup-option n :url)) + (width (markup-option n :width)) + (height (markup-option n :height)) + (zoom (markup-option n :zoom)) + (body (markup-body n)) + (efmt (engine-custom e 'image-format)) + (img (or url (convert-image file + (if (list? efmt) + efmt + '("eps")))))) + (if (not (string? img)) + (skribe-error 'latex "Illegal image" file) + (begin + (printf "\\epsfig{file=~a" (strip-ref-base img)) + (if width (printf ", width=~a" (latex-width width))) + (if height (printf ", height=~apt" height)) + (if zoom (printf ", zoom=\"~a\"" zoom)) + (display "}")))))) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'roman :before "{\\textrm{" :after "}}") +(markup-writer 'bold :before "{\\textbf{" :after "}}") +(markup-writer 'underline :before "{\\underline{" :after "}}") +(markup-writer 'emph :before "{\\em{" :after "}}") +(markup-writer 'it :before "{\\textit{" :after "}}") +(markup-writer 'code :before "{\\texttt{" :after "}}") +(markup-writer 'var :before "{\\texttt{" :after "}}") +(markup-writer 'sc :before "{\\sc{" :after "}}") +(markup-writer 'sf :before "{\\sf{" :after "}}") +(markup-writer 'sub :before "\\begin{math}\\sb{\\mbox{" :after "}}\\end{math}") +(markup-writer 'sup :before "\\begin{math}\\sp{\\mbox{" :after "}}\\end{math}") + +(markup-writer 'tt + :before "{\\texttt{" + :action (lambda (n e) + (let ((ne (make-engine + (gensym 'latex) + :delegate e + :filter (make-string-replace latex-tt-encoding) + :custom (engine-customs e) + :symbol-table (engine-symbol-table e)))) + (output (markup-body n) ne))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* q ... @label q@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'q + :before "``" + :after "''") + +;*---------------------------------------------------------------------*/ +;* mailto ... @label mailto@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mailto + :options '(:text) + :before "{\\texttt{" + :action (lambda (n e) + (let ((text (markup-option n :text))) + (output (or text (markup-body n)) e))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* mark ... @label mark@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'mark + :before (lambda (n e) + (printf "\\label{~a}" (string-canonicalize (markup-ident n))))) + +;*---------------------------------------------------------------------*/ +;* ref ... @label ref@ */ +;*---------------------------------------------------------------------*/ +(markup-writer 'ref + :options '(:text :chapter :section :subsection :subsubsection :figure :mark :handle :page) + :action (lambda (n e) + (let ((t (markup-option n :text))) + (if t + (begin + (output t e) + (output "~" e (markup-writer-get '&~ e)))))) + :after (lambda (n e) + (let* ((c (handle-ast (markup-body n))) + (id (markup-ident c))) + (if (markup-option n :page) + (printf "\\begin{math}{\\pageref{~a}}\\end{math}" + (string-canonicalize id)) + (printf "\\ref{~a}" + (string-canonicalize id)))))) + +;*---------------------------------------------------------------------*/ +;* bib-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (output (markup-option (handle-ast (markup-body n)) :title) e)) + :after "]") + +;*---------------------------------------------------------------------*/ +;* bib-ref+ ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'bib-ref+ + :options '(:text :bib) + :before "[" + :action (lambda (n e) + (let loop ((rs (markup-body n))) + (cond + ((null? rs) + #f) + (else + (if (is-markup? (car rs) 'bib-ref) + (invoke (writer-action (markup-writer-get 'bib-ref e)) + (car rs) + e) + (output (car rs) e)) + (if (pair? (cdr rs)) + (begin + (display ",") + (loop (cdr rs)))))))) + :after "]") + +;*---------------------------------------------------------------------*/ +;* url-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :action (lambda (n e) + (let ((text (markup-option n :text)) + (url (markup-option n :url))) + (if (not text) + (output url e) + (output text e))))) + +;*---------------------------------------------------------------------*/ +;* url-ref hyperref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'url-ref + :options '(:url :text) + :predicate (lambda (n e) + (engine-custom e 'hyperref)) + :action (lambda (n e) + (let ((body (markup-option n :text)) + (url (markup-option n :url))) + (if (and body (not (equal? body url))) + (begin + (display "\\href{") + (display url) + (display "}{") + (output body e) + (display "}")) + (begin + (display "\\href{") + (display url) + (printf "}{~a}" url)))))) + +;*---------------------------------------------------------------------*/ +;* line-ref ... */ +;*---------------------------------------------------------------------*/ +(markup-writer 'line-ref + :options '(:offset) + :before "{\\textit{" + :action (lambda (n e) + (let ((o (markup-option n :offset)) + (v (string->number (markup-option n :text)))) + (cond + ((and (number? o) (number? v)) + (display (+ o v))) + (else + (display v))))) + :after "}}") + +;*---------------------------------------------------------------------*/ +;* &the-bibliography ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&the-bibliography + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[21]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + \\itemsep 0pt + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-label e)) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-title ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-title + :predicate (lambda (n e) + (engine-custom e 'hyperref)) + :action (lambda (n e) + (let* ((t (bold (markup-body n))) + (en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (ht (if url (ref :url (markup-body url) :text t) t))) + (skribe-eval ht e)))) + +;*---------------------------------------------------------------------*/ +;* &bib-entry-label ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-label + :options '(:title) + :before "\\item[{\\char91}" + :action (lambda (n e) (output (markup-option n :title) e)) + :after "{\\char93}] ") + +;*---------------------------------------------------------------------*/ +;* &bib-entry-url ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&bib-entry-url + :action (lambda (n e) + (let* ((en (handle-ast (ast-parent n))) + (url (markup-option en 'url)) + (t (bold (markup-body url)))) + (skribe-eval (ref :url (markup-body url) :text t) e)))) + +;*---------------------------------------------------------------------*/ +;* &source-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (it (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-line-comment ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-line-comment + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-comment-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-keyword ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-keyword + :action (lambda (n e) + (skribe-eval (underline (markup-body n)) e))) + +;*---------------------------------------------------------------------*/ +;* &source-error ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-error + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-error-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'error-color) cc) + (color :fg cc (underline n1)) + (underline n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-define ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-define + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-define-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-module ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-module + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-module-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-markup ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-markup + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-markup-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-thread ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-thread + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-thread-color)) + (n1 (bold (markup-body n))) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-string ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-string + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-string-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + n1))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-bracket ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-bracket + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-bracket-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc n1) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-key ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-key + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg cc (bold n1)) + (it n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* &source-type ... */ +;*---------------------------------------------------------------------*/ +(markup-writer '&source-type + :action (lambda (n e) + (let* ((cc (engine-custom e 'source-type-color)) + (n1 (markup-body n)) + (n2 (if (and (engine-custom e 'source-color) cc) + (color :fg "red" (bold n1)) + (bold n1)))) + (skribe-eval n2 e)))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/skribe/skr/letter.skr b/skribe/skr/letter.skr new file mode 100644 index 0000000..17a0058 --- /dev/null +++ b/skribe/skr/letter.skr @@ -0,0 +1,146 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for letters */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "<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/skribe/skr/lncs.skr b/skribe/skr/lncs.skr new file mode 100644 index 0000000..4668404 --- /dev/null +++ b/skribe/skr/lncs.skr @@ -0,0 +1,147 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/lncs.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for LNCS articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/skribe/skr/scribe.skr b/skribe/skr/scribe.skr new file mode 100644 index 0000000..d9e3bb8 --- /dev/null +++ b/skribe/skr/scribe.skr @@ -0,0 +1,229 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/scribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 29 10:07:21 2003 */ +;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Scribe Compatibility kit */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/skribe/skr/sigplan.skr b/skribe/skr/sigplan.skr new file mode 100644 index 0000000..9bdb939 --- /dev/null +++ b/skribe/skr/sigplan.skr @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/sigplan.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Wed May 18 16:00:38 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/skribe/skr/skribe.skr b/skribe/skr/skribe.skr new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/skribe/skr/skribe.skr @@ -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/skribe/skr/slide.skr b/skribe/skr/slide.skr new file mode 100644 index 0000000..f8638ad --- /dev/null +++ b/skribe/skr/slide.skr @@ -0,0 +1,664 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (symbol->string (gensym 'slide))) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<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/skribe/skr/web-article.skr b/skribe/skr/web-article.skr new file mode 100644 index 0000000..e33328b --- /dev/null +++ b/skribe/skr/web-article.skr @@ -0,0 +1,230 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-article.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jan 10 09:09:43 2004 */ +;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* A Skribe style for producing web articles */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<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/skribe/skr/web-book.skr b/skribe/skr/web-book.skr new file mode 100644 index 0000000..f907c8b --- /dev/null +++ b/skribe/skr/web-book.skr @@ -0,0 +1,107 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-book.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:54:32 2003 */ +;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe web book style. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold "main page")))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (markup-option n :title))))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (if chap "Chapters" "Sections"))))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/skribe/skr/xml.skr b/skribe/skr/xml.skr new file mode 100644 index 0000000..784b6f0 --- /dev/null +++ b/skribe/skr/xml.skr @@ -0,0 +1,111 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/xml.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 2 09:46:09 2003 */ +;* Last change : Sat Mar 6 11:22:05 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Generic XML Skribe engine */ +;* ------------------------------------------------------------- */ +;* Implementation: */ +;* common: @path ../src/common/api.src@ */ +;* bigloo: @path ../src/bigloo/api.bgl@ */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/xmle.skb:ref@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* xml-engine ... */ +;*---------------------------------------------------------------------*/ +(define xml-engine + ;; setup the xml engine + (default-engine-set! + (make-engine 'xml + :version 1.0 + :format "html" + :delegate (find-engine 'base) + :filter (make-string-replace '((#\< "<") + (#\> ">") + (#\& "&") + (#\" """) + (#\@ "@")))))) + +;*---------------------------------------------------------------------*/ +;* markup ... */ +;*---------------------------------------------------------------------*/ +(let ((xml-margin 0)) + (define (make-margin) + (make-string xml-margin #\space)) + (define (xml-attribute? val) + (cond + ((or (string? val) (number? val) (boolean? val)) + #t) + ((list? val) + (every? xml-attribute? val)) + (else + #f))) + (define (xml-attribute att val) + (let ((s (keyword->string att))) + (printf " ~a=\"" (substring s 1 (string-length s))) + (let loop ((val val)) + (cond + ((or (string? val) (number? val)) + (display val)) + ((boolean? val) + (display (if val "true" "false"))) + ((pair? val) + (for-each loop val)) + (else + #f))) + (display #\"))) + (define (xml-option opt val e) + (let* ((m (make-margin)) + (ks (keyword->string opt)) + (s (substring ks 1 (string-length ks)))) + (printf "~a<~a>\n" m s) + (output val e) + (printf "~a</~a>\n" m s))) + (define (xml-options n e) + ;; display the true options + (let ((opts (filter (lambda (o) + (and (keyword? (car o)) + (not (xml-attribute? (cadr o))))) + (markup-options n)))) + (if (pair? opts) + (let ((m (make-margin))) + (display m) + (display "<options>\n") + (set! xml-margin (+ xml-margin 1)) + (for-each (lambda (o) + (xml-option (car o) (cadr o) e)) + opts) + (set! xml-margin (- xml-margin 1)) + (display m) + (display "</options>\n"))))) + (markup-writer #t + :options 'all + :before (lambda (n e) + (printf "~a<~a" (make-margin) (markup-markup n)) + ;; display the xml attributes + (for-each (lambda (o) + (if (and (keyword? (car o)) + (xml-attribute? (cadr o))) + (xml-attribute (car o) (cadr o)))) + (markup-options n)) + (set! xml-margin (+ xml-margin 1)) + (display ">\n")) + :action (lambda (n e) + ;; options + (xml-options n e) + ;; body + (output (markup-body n) e)) + :after (lambda (n e) + (printf "~a</~a>\n" (make-margin) (markup-markup n)) + (set! xml-margin (- xml-margin 1))))) + +;*---------------------------------------------------------------------*/ +;* Restore the base engine */ +;*---------------------------------------------------------------------*/ +(default-engine-set! (find-engine 'base)) diff --git a/skribe/skribe.prj b/skribe/skribe.prj new file mode 100644 index 0000000..1539075 --- /dev/null +++ b/skribe/skribe.prj @@ -0,0 +1,332 @@ +;; -*- Prcs -*- +(Created-By-Prcs-Version 1 3 3) +(Project-Description "") +(Project-Version skribe 1.2d 2) +(Parent-Version skribe 1.2d 1) +(Version-Log "") +(New-Version-Log "") +(Checkin-Time "Fri, 03 Jun 2005 16:52:04 +0200") +(Checkin-Login serrano) +(Populate-Ignore ("\\.o$" "\\~$" "\\.log$" "\\.ps$" "\\.aux$" "\\.date_of_backup$" "\\.so$" "\\.a$" "if_not_there$" "if_mach$" "threadlibs$")) +(Project-Keywords) +(Files +;; This is a comment. Fill in files here. +;; For example: (prcs/checkout.cc ()) + +;; Files added by populate at Thu, 18 Dec 2003 10:00:47 +0100, +;; to version 0.0(w), by serrano: + + (tools/Makefile (skribe/10_Makefile 1.3 640)) + (src/stklos/xml.stk (skribe/11_xml.stk 1.2 644)) + (src/stklos/writer.stk (skribe/12_writer.stk 1.3 644)) + (src/stklos/verify.stk (skribe/13_verify.stk 1.4 644)) + (src/stklos/vars.stk (skribe/14_vars.stk 1.3 644)) + (src/stklos/types.stk (skribe/16_types.stk 1.4 644)) + (src/stklos/source.stk (skribe/17_source.stk 1.3 644)) + (src/stklos/runtime.stk (skribe/18_runtime.st 1.4 644)) + (src/stklos/resolve.stk (skribe/19_resolve.st 1.2 644)) + (src/stklos/reader.stk (skribe/20_reader.stk 1.2 644)) + (src/stklos/prog.stk (skribe/21_prog.stk 1.1 644)) + (src/stklos/output.stk (skribe/22_output.stk 1.3 644)) + (src/stklos/main.stk (skribe/23_main.stk 1.3 644)) + (src/stklos/lisp.stk (skribe/24_lisp.stk 1.4 644)) + (src/stklos/lib.stk (skribe/25_lib.stk 1.4 644)) + (src/stklos/eval.stk (skribe/26_eval.stk 1.4 644)) + (src/stklos/engine.stk (skribe/27_engine.stk 1.4 644)) + (src/stklos/debug.stk (skribe/28_debug.stk 1.3 644)) + (src/stklos/color.stk (skribe/29_color.stk 1.2 644)) + (src/stklos/biblio.stk (skribe/30_biblio.stk 1.3 644)) + (src/stklos/Makefile.in (skribe/31_Makefile.i 1.3 644)) + (src/common/param.scm (skribe/32_param.scm 1.2 640)) + (src/common/lib.scm (skribe/33_lib.scm 1.4 640)) + (src/common/index.scm (skribe/34_index.scm 1.2 640)) + (src/common/configure.scm.in (skribe/35_configure. 1.3 640)) + (src/common/bib.scm (skribe/36_bib.scm 1.2 640)) + (src/common/api.scm (skribe/37_api.scm 1.9 640)) + (src/bigloo/xml.scm (skribe/38_xml.scm 1.3 640)) + (src/bigloo/writer.scm (skribe/39_writer.scm 1.3 640)) + (src/bigloo/verify.scm (skribe/40_verify.scm 1.6 640)) + (src/bigloo/types.scm (skribe/42_types.scm 1.6 640)) + (src/bigloo/source.scm (skribe/43_source.scm 1.5 640)) + (src/bigloo/resolve.scm (skribe/44_resolve.sc 1.4 640)) + (src/bigloo/read.scm (skribe/45_read.scm 1.2 640)) + (src/bigloo/prog.scm (skribe/46_prog.scm 1.3 640)) + (src/bigloo/param.bgl (skribe/48_param.bgl 1.4 640)) + (src/bigloo/output.scm (skribe/49_output.scm 1.3 640)) + (src/bigloo/new.sch (skribe/50_new.sch 1.1 640)) + (src/bigloo/main.scm (skribe/51_main.scm 1.4 640)) + (src/bigloo/lisp.scm (skribe/b/0_lisp.scm 1.5 640)) + (src/bigloo/lib.bgl (skribe/b/1_lib.bgl 1.5 640)) + (src/bigloo/index.bgl (skribe/b/2_index.bgl 1.2 640)) + (src/bigloo/evapi.scm (skribe/b/3_evapi.scm 1.6 640)) + (src/bigloo/eval.scm (skribe/b/4_eval.scm 1.7 640)) + (src/bigloo/engine.scm (skribe/b/5_engine.scm 1.4 640)) + (src/bigloo/debug.scm (skribe/b/6_debug.scm 1.2 640)) + (src/bigloo/debug.sch (skribe/b/7_debug.sch 1.2 640)) + (src/bigloo/configure.bgl (skribe/b/8_configure. 1.3 640)) + (src/bigloo/color.scm (skribe/b/9_color.scm 1.2 640)) + (src/bigloo/c.scm (skribe/b/10_c.scm 1.4 640)) + (src/bigloo/bib.bgl (skribe/b/11_bib.bgl 1.4 640)) + (src/bigloo/api.sch (skribe/b/12_api.sch 1.5 640)) + (src/bigloo/api.bgl (skribe/b/13_api.bgl 1.2 640)) + (src/bigloo/Makefile (skribe/b/14_Makefile 1.6 640)) + (src/Makefile (skribe/b/15_Makefile 1.2 640)) + (skr/xml.skr (skribe/b/16_xml.skr 1.2 640)) + (skr/web-book.skr (skribe/b/17_web-book.s 1.5 640)) + (skr/slide.skr (skribe/b/19_slide.skr 1.6 640)) + (skr/skribe.skr (skribe/b/20_skribe.skr 1.4 640)) + (skr/scribe.skr (skribe/b/21_scribe.skr 1.1 640)) + (skr/lncs.skr (skribe/b/22_lncs.skr 1.2 640)) + (skr/letter.skr (skribe/b/23_letter.skr 1.3 640)) + (skr/latex.skr (skribe/b/24_latex.skr 1.6 640)) + (skr/jfp.skr (skribe/b/25_jfp.skr 1.4 640)) + (skr/html.skr (skribe/b/26_html.skr 1.8 640)) + (skr/french.skr (skribe/b/27_french.skr 1.1 640)) + (skr/base.skr (skribe/b/28_base.skr 1.6 640)) + (skr/acmproc.skr (skribe/b/29_acmproc.sk 1.4 640)) + (skr/Makefile (skribe/b/30_Makefile 1.6 640)) + (examples/slide/skr/local.skr (skribe/b/34_local.skr 1.1 640)) + (examples/slide/skb/slides.skb (skribe/b/35_slides.skb 1.1 640)) + (examples/slide/ex/syntax.scr (skribe/b/36_syntax.scr 1.1 640)) + (examples/slide/ex/skribe.skb (skribe/b/37_skribe.skb 1.1 640)) + (examples/slide/advi.sty (skribe/b/38_advi.sty 1.1 640)) + (examples/slide/README (skribe/b/39_README 1.1 640)) + (examples/slide/PPRskribe.sty (skribe/b/40_PPRskribe. 1.1 640)) + (examples/slide/Makefile (skribe/b/41_Makefile 1.1 640)) + (examples/Makefile (skribe/b/42_Makefile 1.2 640)) + (etc/stklos/configure.in (skribe/b/43_configure. 1.2 640)) + (etc/stklos/configure (skribe/b/44_configure 1.2 751)) + (etc/stklos/Makefile.skb.in (skribe/b/45_Makefile.s 1.1 644)) + (etc/stklos/Makefile.in (skribe/b/46_Makefile.i 1.1 640)) + (etc/stklos/Makefile.config.in (skribe/b/47_Makefile.c 1.1 644)) + (etc/skribe-config.in (skribe/b/48_skribe-con 1.2 644)) + (etc/bigloo/configure (skribe/b/49_configure 1.6 740)) + (etc/bigloo/autoconf/gmaketest (skribe/b/50_gmaketest 1.1 750)) + (etc/bigloo/autoconf/getbversion (skribe/b/51_getbversio 1.1 750)) + (etc/bigloo/autoconf/bversion (skribe/c/0_bversion 1.1 750)) + (etc/bigloo/autoconf/blibdir (skribe/c/1_blibdir 1.1 750)) + (etc/bigloo/autoconf/bfildir (skribe/c/2_bfildir 1.1 750)) + (etc/bigloo/autoconf/Makefile (skribe/c/3_Makefile 1.1 640)) + (etc/bigloo/Makefile.tpl (skribe/c/4_Makefile.t 1.3 640)) + (etc/bigloo/Makefile (skribe/c/5_Makefile 1.4 640)) + (etc/Makefile (skribe/c/6_Makefile 1.3 640)) + (emacs/skribe.el.in (skribe/c/7_skribe.el. 1.6 640)) + (emacs/Makefile (skribe/c/8_Makefile 1.2 640)) + (doc/user/user.skb (skribe/c/9_user.skb 1.5 640)) + (doc/user/toc.skb (skribe/c/10_toc.skb 1.1 640)) + (doc/user/table.skb (skribe/c/11_table.skb 1.4 640)) + (doc/user/syntax.skb (skribe/c/12_syntax.skb 1.3 640)) + (doc/user/start.skb (skribe/c/13_start.skb 1.3 640)) + (doc/user/src/start5.skb (skribe/c/14_start5.skb 1.1 644)) + (doc/user/src/start4.skb (skribe/c/15_start4.skb 1.1 640)) + (doc/user/src/start3.skb (skribe/c/16_start3.skb 1.1 640)) + (doc/user/src/start2.skb (skribe/c/17_start2.skb 1.1 640)) + (doc/user/src/start1.skb (skribe/c/18_start1.skb 1.1 640)) + (doc/user/src/prgm3.skb (skribe/c/19_prgm3.skb 1.2 640)) + (doc/user/src/prgm2.skb (skribe/c/20_prgm2.skb 1.2 640)) + (doc/user/src/prgm1.skb (skribe/c/21_prgm1.skb 1.1 640)) + (doc/user/src/links2.skb (skribe/c/22_links2.skb 1.1 640)) + (doc/user/src/links1.skb (skribe/c/23_links1.skb 1.1 640)) + (doc/user/src/index3.skb (skribe/c/24_index3.skb 1.1 640)) + (doc/user/src/index2.skb (skribe/c/25_index2.skb 1.1 640)) + (doc/user/src/index1.skb (skribe/c/26_index1.skb 1.1 640)) + (doc/user/src/bib6.skb (skribe/c/27_bib6.skb 1.1 640)) + (doc/user/src/bib5.skb (skribe/c/28_bib5.skb 1.1 640)) + (doc/user/src/bib4.skb (skribe/c/29_bib4.skb 1.1 640)) + (doc/user/src/bib3.skb (skribe/c/30_bib3.skb 1.1 640)) + (doc/user/src/bib2.skb (skribe/c/31_bib2.skb 1.1 640)) + (doc/user/src/bib1.sbib (skribe/c/32_bib1.sbib 1.1 640)) + (doc/user/src/api9.skb (skribe/c/33_api9.skb 1.1 640)) + (doc/user/src/api8.skb (skribe/c/34_api8.skb 1.1 640)) + (doc/user/src/api7.skb (skribe/c/35_api7.skb 1.1 640)) + (doc/user/src/api6.skb (skribe/c/36_api6.skb 1.1 640)) + (doc/user/src/api5.skb (skribe/c/37_api5.skb 1.1 640)) + (doc/user/src/api4.skb (skribe/c/38_api4.skb 1.1 640)) + (doc/user/src/api3.skb (skribe/c/39_api3.skb 1.1 640)) + (doc/user/src/api20.skb (skribe/c/40_api20.skb 1.3 640)) + (doc/user/src/api2.skb (skribe/c/41_api2.skb 1.1 640)) + (doc/user/src/api19.skb (skribe/c/42_api19.skb 1.1 640)) + (doc/user/src/api18.skb (skribe/c/43_api18.skb 1.1 640)) + (doc/user/src/api17.skb (skribe/c/44_api17.skb 1.2 640)) + (doc/user/src/api16.skb (skribe/c/45_api16.skb 1.1 640)) + (doc/user/src/api15.skb (skribe/c/46_api15.skb 1.1 640)) + (doc/user/src/api14.skb (skribe/c/47_api14.skb 1.1 640)) + (doc/user/src/api13.skb (skribe/c/48_api13.skb 1.3 640)) + (doc/user/src/api12.skb (skribe/c/49_api12.skb 1.1 640)) + (doc/user/src/api11.skb (skribe/c/50_api11.skb 1.1 640)) + (doc/user/src/api10.skb (skribe/c/51_api10.skb 1.2 640)) + (doc/user/src/api1.skb (skribe/d/0_api1.skb 1.1 640)) + (doc/user/skribeinfo.skb (skribe/d/1_skribeinfo 1.1 640)) + (doc/user/skribec.skb (skribe/d/2_skribec.sk 1.3 640)) + (doc/user/sectioning.skb (skribe/d/3_sectioning 1.3 640)) + (doc/user/prgm.skb (skribe/d/4_prgm.skb 1.4 640)) + (doc/user/ornament.skb (skribe/d/5_ornament.s 1.1 640)) + (doc/user/markup.skb (skribe/d/6_markup.skb 1.2 640)) + (doc/user/links.skb (skribe/d/7_links.skb 1.5 640)) + (doc/user/line.skb (skribe/d/8_line.skb 1.1 640)) + (doc/user/lib.skb (skribe/d/9_lib.skb 1.3 644)) + (doc/user/latexe.skb (skribe/d/10_latexe.skb 1.4 640)) + (doc/user/justify.skb (skribe/d/11_justify.sk 1.1 640)) + (doc/user/index.skb (skribe/d/12_index.skb 1.4 640)) + (doc/user/image.skb (skribe/d/13_image.skb 1.3 640)) + (doc/user/htmle.skb (skribe/d/14_htmle.skb 1.6 640)) + (doc/user/footnote.skb (skribe/d/15_footnote.s 1.1 640)) + (doc/user/font.skb (skribe/d/16_font.skb 1.1 640)) + (doc/user/figure.skb (skribe/d/17_figure.skb 1.1 640)) + (doc/user/examples.skb (skribe/d/18_examples.s 1.2 640)) + (doc/user/enumeration.skb (skribe/d/19_enumeratio 1.1 640)) + (doc/user/engine.skb (skribe/d/20_engine.skb 1.4 640)) + (doc/user/emacs.skb (skribe/d/21_emacs.skb 1.3 640)) + (doc/user/document.skb (skribe/d/22_document.s 1.2 640)) + (doc/user/colframe.skb (skribe/d/23_colframe.s 1.3 640)) + (doc/user/char.skb (skribe/d/24_char.skb 1.2 640)) + (doc/user/bib.skb (skribe/d/25_bib.skb 1.5 640)) + (doc/img/linux.gif (skribe/d/29_linux.gif 1.2 640) :no-keywords) + (doc/img/lambda.gif (skribe/d/30_lambda.gif 1.1 640) :no-keywords) + (doc/img/bsd.gif (skribe/d/31_bsd.gif 1.1 640) :no-keywords) + (doc/Makefile (skribe/d/32_Makefile 1.6 640)) + (configure (skribe/d/33_configure 1.5 750)) + (README.java (skribe/d/34_README.jav 1.2 640)) + (README (skribe/d/35_README 1.1 640)) + (LICENSE (skribe/d/36_LICENSE 1.2 640)) + (INSTALL (skribe/d/37_INSTALL 1.2 640)) + (Makefile (skribe/d/38_Makefile 1.5 640)) + +;; Files added by populate at Sat, 17 Jan 2004 08:29:33 +0100, +;; to version 1.0b.1(w), by serrano: + + (src/common/sui.scm (skribe/d/39_sui.scm 1.2 640)) + (src/bigloo/sui.bgl (skribe/d/40_sui.bgl 1.1 640)) + (etc/ChangeLog (skribe/d/41_ChangeLog 1.11 640)) + (doc/user/src/slides.skb (skribe/d/42_slides.skb 1.2 640)) + (doc/user/slide.skb (skribe/d/43_slide.skb 1.4 640)) + (doc/user/skribe-config.skb (skribe/d/44_skribe-con 1.2 640)) + (doc/skr/manual.skr (skribe/d/45_manual.skr 1.3 640)) + (doc/skr/extension.skr (skribe/d/46_extension. 1.1 640)) + (doc/skr/env.skr (skribe/d/47_env.skr 1.2 640)) + (doc/skr/api.skr (skribe/d/48_api.skr 1.5 640)) + (doc/dir/dir.skb (skribe/d/49_dir.skb 1.1 640)) + (doc/Makefile.dir (skribe/d/50_Makefile.d 1.2 640)) + +;; Files added by populate at Sun, 18 Jan 2004 12:46:07 +0100, +;; to version 1.0b.4(w), by serrano: + + (src/bigloo/asm.scm (skribe/d/51_asm.scm 1.2 640)) + +;; Files added by populate at Wed, 18 Feb 2004 21:22:35 +0100, +;; to version 1.0b.5(w), by serrano: + + (src/stklos/xml-lex.l (skribe/e/0_xml-lex.l 1.1 644)) + (src/stklos/configure.stk (skribe/e/1_configure. 1.1 644)) + (doc/user/xmle.skb (skribe/e/2_xmle.skb 1.2 640)) + (contribs/tools/skribeinfo/src/Makefile (skribe/e/3_Makefile 1.2 640)) + (contribs/tools/skribeinfo/skr/skribeinfo.skr (skribe/e/4_skribeinfo 1.1 640)) + (contribs/tools/skribeinfo/doc/pckg/skribeinfo.skb (skribe/e/5_skribeinfo 1.1 640)) + (contribs/tools/skribeinfo/configure (skribe/e/6_configure 1.2 750)) + (contribs/tools/skribeinfo/README (skribe/e/7_README 1.2 640)) + (contribs/tools/skribeinfo/Makefile.in (skribe/e/8_Makefile.i 1.3 640)) + (contribs/tools/Makefile (skribe/e/9_Makefile 1.3 640)) + (contribs/ext/bc-table/src/skribebctable.scm (skribe/e/10_skribebcta 1.2 640)) + (contribs/ext/bc-table/src/example.bc (skribe/e/11_example.bc 1.1 640)) + (contribs/ext/bc-table/src/Makefile (skribe/e/12_Makefile 1.2 640)) + (contribs/ext/bc-table/skr/bc-table.skr (skribe/e/13_bc-table.s 1.4 640)) + (contribs/ext/bc-table/example/example.skb (skribe/e/14_example.sk 1.2 640)) + (contribs/ext/bc-table/doc/pckg/bc-table.skb (skribe/e/15_bc-table.s 1.2 640)) + (contribs/ext/bc-table/configure (skribe/e/16_configure 1.2 750)) + (contribs/ext/bc-table/README (skribe/e/17_README 1.1 640)) + (contribs/ext/bc-table/Makefile.in (skribe/e/18_Makefile.i 1.2 640)) + (contribs/ext/Makefile (skribe/e/19_Makefile 1.3 640)) + (contribs/Makefile (skribe/e/20_Makefile 1.1 640)) + +;; Files added by populate at Wed, 18 Feb 2004 21:24:57 +0100, +;; to version 1.0b.6(w), by serrano: + + (contribs/ext/longtable/skr/longtable.skr (skribe/e/21_longtable. 1.1 640)) + (contribs/ext/longtable/example/example.skb (skribe/e/22_example.sk 1.1 640)) + (contribs/ext/longtable/doc/pckg/longtable.skb (skribe/e/23_longtable. 1.1 640)) + (contribs/ext/longtable/configure (skribe/e/24_configure 1.2 750)) + (contribs/ext/longtable/README (skribe/e/25_README 1.1 640)) + (contribs/ext/longtable/Makefile.in (skribe/e/26_Makefile.i 1.3 640)) + +;; Files added by populate at Sat, 21 Feb 2004 10:39:55 +0100, +;; to version 1.0b.8(w), by serrano: + + (doc/user/package.skb (skribe/e/27_package.sk 1.3 640)) + (contribs/tools/skribeinfo/example/example.skb (skribe/e/28_example.sk 1.2 640)) + (contribs/ext/html-navbar/skr/html-navbar.skr (skribe/e/29_html-navba 1.2 640)) + (contribs/ext/html-navbar/example/example.skb (skribe/e/30_example.sk 1.2 640)) + (contribs/ext/html-navbar/doc/pckg/html-navbar.skb (skribe/e/31_html-navba 1.2 640)) + (contribs/ext/html-navbar/configure (skribe/e/32_configure 1.1 750)) + (contribs/ext/html-navbar/README (skribe/e/33_README 1.1 640)) + (contribs/ext/html-navbar/Makefile.in (skribe/e/34_Makefile.i 1.2 640)) + (contribs/ext/html-gui/skr/html-gui.skr (skribe/e/35_html-gui.s 1.3 640)) + (contribs/ext/html-gui/example/example.skb (skribe/e/36_example.sk 1.2 640)) + (contribs/ext/html-gui/doc/pckg/html-gui.skb (skribe/e/37_html-gui.s 1.2 640)) + (contribs/ext/html-gui/configure (skribe/e/38_configure 1.2 755)) + (contribs/ext/html-gui/README (skribe/e/39_README 1.1 640)) + (contribs/ext/html-gui/Makefile.in (skribe/e/40_Makefile.i 1.2 640)) + +;; Files added by populate at Wed, 19 May 2004 14:41:48 +0200, +;; to version 1.0b.9(w), by serrano: + + (src/stklos/lisp-lex.l (skribe/e/41_lisp-lex.l 1.2 644)) + (src/stklos/c.stk (skribe/e/42_c.stk 1.1 644)) + (src/stklos/c-lex.l (skribe/e/43_c-lex.l 1.1 644)) + (skr/web-article.skr (skribe/e/44_web-articl 1.1 640)) + (skr/html4.skr (skribe/e/45_html4.skr 1.1 644)) + (contribs/tools/skribeinfo/CONTRIB.skb (skribe/e/46_CONTRIB.sk 1.1 640)) + (contribs/tools/skribecolsel/src/skribecolsel.scm (skribe/e/47_skribecols 1.1 640)) + (contribs/tools/skribecolsel/src/Makefile (skribe/e/48_Makefile 1.1 640)) + (contribs/tools/skribecolsel/emacs/skribecolsel.el (skribe/e/49_skribecols 1.1 640)) + (contribs/tools/skribecolsel/configure (skribe/e/50_configure 1.1 750)) + (contribs/tools/skribecolsel/README (skribe/e/51_README 1.1 640)) + (contribs/tools/skribecolsel/Makefile.in (skribe/f/0_Makefile.i 1.1 640)) + (contribs/tools/skribecolsel/CONTRIB.skb (skribe/f/1_CONTRIB.sk 1.1 640)) + (contribs/ext/longtable/CONTRIB.skb (skribe/f/2_CONTRIB.sk 1.1 640)) + (contribs/ext/js-tricks/skr/js-tricks.skr (skribe/f/3_js-tricks. 1.1 640)) + (contribs/ext/js-tricks/example/example.skb (skribe/f/4_example.sk 1.2 640)) + (contribs/ext/js-tricks/doc/pckg/js-tricks.skb (skribe/f/5_js-tricks. 1.1 640)) + (contribs/ext/js-tricks/configure (skribe/f/6_configure 1.1 750)) + (contribs/ext/js-tricks/README (skribe/f/7_README 1.1 640)) + (contribs/ext/js-tricks/Makefile.in (skribe/f/8_Makefile.i 1.1 640)) + (contribs/ext/html-navtabs/skr/html-navtabs.skr (skribe/f/9_html-navta 1.1 640)) + (contribs/ext/html-navtabs/example/example.skb (skribe/f/10_example.sk 1.1 640)) + (contribs/ext/html-navtabs/doc/pckg/html-navtabs.skb (skribe/f/11_html-navta 1.1 640)) + (contribs/ext/html-navtabs/configure (skribe/f/12_configure 1.1 750)) + (contribs/ext/html-navtabs/README (skribe/f/13_README 1.1 640)) + (contribs/ext/html-navtabs/Makefile.in (skribe/f/14_Makefile.i 1.1 640)) + (contribs/ext/html-navtabs/CONTRIB.skb (skribe/f/15_CONTRIB.sk 1.1 640)) + (contribs/ext/html-gui/CONTRIB.skb (skribe/f/16_CONTRIB.sk 1.1 640)) + (contribs/ext/fontsample/skr/fontsample.skr (skribe/f/17_fontsample 1.1 640)) + (contribs/ext/fontsample/example/example.skb (skribe/f/18_example.sk 1.1 640)) + (contribs/ext/fontsample/doc/pckg/fontsample.skb (skribe/f/19_fontsample 1.1 640)) + (contribs/ext/fontsample/configure (skribe/f/20_configure 1.1 750)) + (contribs/ext/fontsample/README (skribe/f/21_README 1.1 640)) + (contribs/ext/fontsample/Makefile.in (skribe/f/22_Makefile.i 1.1 640)) + (contribs/ext/fontsample/CONTRIB.skb (skribe/f/23_CONTRIB.sk 1.1 640)) + +;; Files added by populate at Wed, 22 Sep 2004 02:17:27 +0200, +;; to version 1.1b.2(w), by serrano: + + (src/bigloo/parseargs.scm (skribe/f/24_parseargs. 1.2 640)) + +;; Files added by populate at Wed, 22 Sep 2004 14:53:18 +0200, +;; to version 1.1b.5(w), by serrano: + + (skr/latex-simple.skr (skribe/f/25_latex-simp 1.2 640)) + +;; Files added by populate at Fri, 03 Jun 2005 16:47:11 +0200, +;; to version 1.1b.7(w), by serrano: + + (tools/skribebibtex/stklos/main.stk (skribe/f/26_main.stk 1.1 644)) + (tools/skribebibtex/stklos/bibtex-parser.y (skribe/f/27_bibtex-par 1.1 644)) + (tools/skribebibtex/stklos/bibtex-lex.l (skribe/f/28_bibtex-lex 1.1 644)) + (tools/skribebibtex/stklos/Makefile (skribe/f/29_Makefile 1.1 644)) + (tools/skribebibtex/bigloo/skribebibtex.scm (skribe/f/30_skribebibt 1.1 640)) + (tools/skribebibtex/bigloo/main.scm (skribe/f/31_main.scm 1.1 640)) + (tools/skribebibtex/bigloo/Makefile (skribe/f/32_Makefile 1.1 640)) + (skr/sigplan.skr (skribe/f/33_sigplan.sk 1.1 640)) + (skr/context.skr (skribe/f/34_context.sk 1.1 644)) +) +(Merge-Parents) +(New-Merge-Parents) diff --git a/skribe/src/Makefile b/skribe/src/Makefile new file mode 100644 index 0000000..09e96d5 --- /dev/null +++ b/skribe/src/Makefile @@ -0,0 +1,41 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/src/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Sat Oct 25 08:15:57 2003 */ +#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The meta Makefile for the sources */ +#*=====================================================================*/ +include ../etc/Makefile.config + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo src/Makefile + @ (cd bigloo && $(MAKE) pop) + @ (cd stklos && $(MAKE) pop) + +#*---------------------------------------------------------------------*/ +#* Install/Uinstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: + (cd $(SYSTEM) && $(MAKE) install) + +uninstall: + (cd $(SYSTEM) && $(MAKE) uninstall) + +#*---------------------------------------------------------------------*/ +#* clean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean + +clean: + (cd $(SYSTEM) && $(MAKE) clean) + diff --git a/skribe/src/bigloo/Makefile b/skribe/src/bigloo/Makefile new file mode 100644 index 0000000..02d2b6a --- /dev/null +++ b/skribe/src/bigloo/Makefile @@ -0,0 +1,271 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/src/bigloo/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Mon Jul 21 18:21:11 2003 */ +#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Bigloo API */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* General inclusion */ +#*---------------------------------------------------------------------*/ +include ../../etc/bigloo/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Compilers and tools */ +#*---------------------------------------------------------------------*/ +BSKBFLAGS = -I $(SRCDIR)/bigloo + +#*---------------------------------------------------------------------*/ +#* Targets ... */ +#*---------------------------------------------------------------------*/ +PROJECT = skribe +CTARGET = $(SKRIBEBINDIR)/skribe.bigloo +JVMTARGET = $(SKRIBEBINDIR)/skribe.zip + +PBASE = bigloo.$(PROJECT) +ODIR = o +CLASSDIR = class_s/bigloo/$(PROJECT) +OBJDIR = obj/bigloo/$(PROJECT) + +#*---------------------------------------------------------------------*/ +#* Objects */ +#*---------------------------------------------------------------------*/ +SRCDIR = .. +SKRIBECOMMON = param api bib index lib sui +SKRIBEBGL = types parseargs main eval evapi \ + output resolve verify debug read prog source \ + lisp xml c asm engine writer color +SKRIBEINCLUDE = api new debug + +MODULES = $(SKRIBEBGL:%=%.scm) \ + $(SKRIBECOMMON:%=%.bgl) \ + configure.bgl +INCLUDES = $(SKRIBEINCLUDE:%=%.sch) +SOURCES = $(MODULES) \ + $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ + $(SRCDIR)/common/configure.scm \ + $(INCLUDES) +OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure +COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) +JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) + +#*---------------------------------------------------------------------*/ +#* Population */ +#*---------------------------------------------------------------------*/ +POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile +POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .scm .bgl .class .o .obj + +#*---------------------------------------------------------------------*/ +#* All */ +#*---------------------------------------------------------------------*/ +.PHONY: c jvm dotnet + +all: $(TARGET) + +c: $(CTARGET) +jvm: $(JVMTARGET) +dotnet: + echo "Not implemented yet" + +#*--- c ---------------------------------------------------------------*/ +$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) + $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) + +#*--- jvm -------------------------------------------------------------*/ +$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) + $(RM) -f $(JVMTARGET) + (cd $(ODIR)/class_s && \ + $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) + +$(SKRIBEBINDIR): + mkdir -p $(SKRIBEBINDIR) + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo $(POPULATIONSCM:%=src/common/%) + @ echo $(POPULATIONBGL:%=src/bigloo/%) + +#*---------------------------------------------------------------------*/ +#* ude */ +#*---------------------------------------------------------------------*/ +.PHONY: ude .etags .afile + +ude: + @ $(MAKE) -f Makefile .afile .etags dep + +.afile: + @ $(AFILE) -o .afile $(MODULES) + +.jfile: + @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) + +.etags: + @ $(BTAGS) -o .etags $(SOURCES) + +dep: + @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ + head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) + @ $(BDEPEND) -search-path ../common \ + -search-path ../bigloo \ + -strict-obj-dir $(ODIR) \ + -strict-class-dir $(CLASSDIR) \ + -fno-mco $(SOURCES) >> /tmp/Makefile.aux + @ mv /tmp/Makefile.aux Makefile + +getbinary: + @ echo $(PROJECT) + +getsources: + @ echo $(SOURCES) + +#*---------------------------------------------------------------------*/ +#* The implicit rules */ +#*---------------------------------------------------------------------*/ +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ + $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(OBJDIR)/%.obj: src/%.scm + $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ + +#*---------------------------------------------------------------------*/ +#* Ad hoc rules */ +#*---------------------------------------------------------------------*/ +$(ODIR): + mkdir -p $(ODIR) + +$(CLASSDIR): + mkdir -p $(CLASSDIR) + +$(OBJDIR): + mkdir -p $(OBJDIR) + + +#*---------------------------------------------------------------------*/ +#* install/uninstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm + +install: + $(MAKE) install-$(TARGET) + +uninstall: + $(MAKE) uninstall-$(TARGET) + +install-c: $(DESTDIR)$(INSTALL_BINDIR) + cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe + +uninstall-c: + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + +install-jvm: $(DESTDIR)$(INSTALL_FILDIR) + cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) + +uninstall-jvm: + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip + +$(DESTDIR)$(INSTALL_BINDIR): + mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) + +$(DESTDIR)$(INSTALL_FILDIR): + mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) + +#*---------------------------------------------------------------------*/ +#* Clean */ +#*---------------------------------------------------------------------*/ +clean: + $(RM) -f .afile + $(RM) -f .jfile + $(RM) -rf $(ODIR) + $(RM) -f $(CTARGET) + $(RM) -f $(JVMTARGET) + +#*---------------------------------------------------------------------*/ +#* Cleanall */ +#*---------------------------------------------------------------------*/ +cleanall: clean + +#*---------------------------------------------------------------------*/ +#* Manual dependency */ +#*---------------------------------------------------------------------*/ +o/eval.o o/class/bigloo/skribe/eval.class: \ + $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm + +#bdepend start (don't edit) +#*---------------------------------------------------------------------*/ +#* Dependencies ... */ +#*---------------------------------------------------------------------*/ +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch + +#bdepend stop diff --git a/skribe/src/bigloo/api.bgl b/skribe/src/bigloo/api.bgl new file mode 100644 index 0000000..55493b0 --- /dev/null +++ b/skribe/src/bigloo/api.bgl @@ -0,0 +1,117 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:21:34 2003 */ +;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo header for the API. */ +;* ------------------------------------------------------------- */ +;* Implementation: @label api@ */ +;* bigloo: @path ../common/api.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_api + + (include "new.sch" + "api.sch") + + (import skribe_param + skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_bib + skribe_index + skribe_prog + skribe_source + skribe_engine + skribe_color + skribe_sui) + + (export (include string) + + (document::%markup . opts) + (author::%markup . opts) + (toc::%markup . opts) + + (chapter::%markup . opts) + (section::%markup . opts) + (subsection::%markup . opts) + (subsubsection::%markup . opts) + (paragraph::%markup . opts) + + (footnote::%markup . opts) + + (linebreak . opts) + (hrule::%markup . opts) + + (color::%markup . opts) + (frame::%markup . opts) + (font::%markup . opts) + + (flush::%markup . opts) + (center::%markup . opts) + (pre::%markup . opts) + (prog::%markup . opts) + (source::obj . opts) + (language::obj . opts) + + (itemize::%markup . opts) + (enumerate::%markup . opts) + (description::%markup . opts) + (item::%markup . opts) + + (figure::%markup . opts) + + (table::%markup . opts) + (tr::%markup . opts) + (td::%markup . opts) + (th::%markup . opts) + + (image::%markup . opts) + + (blockquote::%markup . opts) + + (roman::%markup . opts) + (bold::%markup . opts) + (underline::%markup . opts) + (strike::%markup . opts) + (emph::%markup . opts) + (kbd::%markup . opts) + (it::%markup . opts) + (tt::%markup . opts) + (code::%markup . opts) + (var::%markup . opts) + (samp::%markup . opts) + (sf::%markup . opts) + (sc::%markup . opts) + (sub::%markup . opts) + (sup::%markup . opts) + + (mailto::%markup . opts) + (mark::%markup . opts) + + (handle . obj) + (ref::%ast . obj) + (resolve::%ast ::procedure) + + (bibliography . files) + (the-bibliography . opts) + + (make-index ::bstring) + (index . args) + (the-index . args) + + (char::bstring char) + (symbol::%markup symbol) + (!::%command string . args) + + (processor::%processor . opts) + + (html-processor::%processor . opts) + (tex-processor::%processor . opts))) diff --git a/skribe/src/bigloo/api.sch b/skribe/src/bigloo/api.sch new file mode 100644 index 0000000..390b8fa --- /dev/null +++ b/skribe/src/bigloo/api.sch @@ -0,0 +1,91 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:15:25 2003 */ +;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo macros for the API implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* define-pervasive-macro ... */ +;*---------------------------------------------------------------------*/ +(define-macro (define-pervasive-macro proto . body) + `(begin + (eval '(define-macro ,proto ,@body)) + (define-macro ,proto ,@body))) + +;*---------------------------------------------------------------------*/ +;* define-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-markup proto . body) + (define (s2k symbol) + (string->keyword (string-append ":" (symbol->string symbol)))) + (if (not (pair? proto)) + (error 'define-markup "Illegal markup definition" proto) + (let* ((id (car proto)) + (args (cdr proto)) + (dargs (dsssl-formals->scheme-formals args error))) + `(begin + ,(if (and (memq #!key args) + (memq '&skribe-eval-location args)) + `(define-expander ,id + (lambda (x e) + (append + (cons ',id (map (lambda (x) (e x e)) (cdr x))) + (list :&skribe-eval-location + '(skribe-eval-location))))) + #unspecified) + (define ,(cons id dargs) + ,(make-dsssl-function-prelude proto + args `(begin ,@body) + error s2k)))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-markup markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-container ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-container markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-processor-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-processor-markup proc) + `(define-markup (,proc #!rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + +;*---------------------------------------------------------------------*/ +;* new (at runtime) */ +;*---------------------------------------------------------------------*/ +(eval '(define-macro (new id . inits) + (cons (symbol-append 'new- id) + (map (lambda (i) + (list 'list (list 'quote (car i)) (cadr i))) + inits)))) diff --git a/skribe/src/bigloo/asm.scm b/skribe/src/bigloo/asm.scm new file mode 100644 index 0000000..03196ac --- /dev/null +++ b/skribe/src/bigloo/asm.scm @@ -0,0 +1,99 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* ASM fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_asm + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export asm)) + +;*---------------------------------------------------------------------*/ +;* asm ... */ +;*---------------------------------------------------------------------*/ +(define asm + (new language + (name "asm") + (fontifier asm-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* asm-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (asm-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "#" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((: (* (in #\tab #\space)) + (+ (out #\: #\Space #\Tab #\Newline)) #\:) + ;; labels + (let ((c (new markup + (markup '&source-define) + (body (the-string))))) + (cons c (ignore)))) + ((or (in "<>=!/\\+*-([])") + #\/ + (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(asm)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/skribe/src/bigloo/bib.bgl b/skribe/src/bigloo/bib.bgl new file mode 100644 index 0000000..6b0f7dd --- /dev/null +++ b/skribe/src/bigloo/bib.bgl @@ -0,0 +1,161 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Dec 7 06:12:29 2001 */ +;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe Bibliography */ +;* ------------------------------------------------------------- */ +;* Implementation: @label bib@ */ +;* bigloo: @path ../common/bib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_bib + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_read) + + (export (bib-table?::bool ::obj) + (make-bib-table ::bstring) + (default-bib-table) + (bib-load! ::obj ::bstring ::obj) + (bib-add! ::obj . entries) + (resolve-bib ::obj ::obj) + (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) + (bib-sort/authors::pair-nil ::pair-nil) + (bib-sort/idents::pair-nil ::pair-nil) + (bib-sort/dates::pair-nil ::pair-nil))) + +;*---------------------------------------------------------------------*/ +;* bib-table? ... */ +;*---------------------------------------------------------------------*/ +(define (bib-table? obj) + (hashtable? obj)) + +;*---------------------------------------------------------------------*/ +;* *bib-table* ... */ +;*---------------------------------------------------------------------*/ +(define *bib-table* #f) + +;*---------------------------------------------------------------------*/ +;* make-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-table ident) + (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* default-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (default-bib-table) + (if (not *bib-table*) + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;*---------------------------------------------------------------------*/ +;* bib-parse-error ... */ +;*---------------------------------------------------------------------*/ +(define (bib-parse-error entry) + (if (epair? entry) + (match-case (cer entry) + ((at ?fname ?pos ?-) + (error/location "parse-biblio" + "bibliography syntax error" + entry + fname + pos)) + (else + (error 'bib-parse "bibliography syntax error" entry))) + (error 'bib-parse "bibliography syntax error" entry))) + +;*---------------------------------------------------------------------*/ +;* bib-duplicate ... */ +;*---------------------------------------------------------------------*/ +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + +;*---------------------------------------------------------------------*/ +;* parse-bib ... */ +;*---------------------------------------------------------------------*/ +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (input-port-name port))) + (let loop ((entry (skribe-read port))) + (if (not (eof-object? entry)) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (else + (bib-parse-error entry)))))))) + +;*---------------------------------------------------------------------*/ +;* bib-add! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (else + (bib-parse-error entry)))) + entries))) + + + diff --git a/skribe/src/bigloo/c.scm b/skribe/src/bigloo/c.scm new file mode 100644 index 0000000..07290ce --- /dev/null +++ b/skribe/src/bigloo/c.scm @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/c.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Thu May 27 10:11:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* C fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_c + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export C)) + +;*---------------------------------------------------------------------*/ +;* C stamps */ +;*---------------------------------------------------------------------*/ +(define *keyword* (gensym)) +(define *cpp* (gensym)) + +;*---------------------------------------------------------------------*/ +;* C keywords */ +;*---------------------------------------------------------------------*/ +(for-each (lambda (symbol) + (putprop! symbol *keyword* #t)) + '(for class template while return try catch break continue + do if else typedef struct union goto switch case + static extern default finally throw)) +(let ((sharp (string->symbol "#"))) + (for-each (lambda (symbol) + (putprop! (symbol-append sharp symbol) *cpp* #t)) + '(include define if ifdef ifdef else endif))) + +;*---------------------------------------------------------------------*/ +;* C ... */ +;*---------------------------------------------------------------------*/ +(define C + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* c-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (c-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((in "{}") + ;; brackets + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-bracket) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) + ;; keywords + (let* ((string (the-string)) + (symbol (the-symbol))) + (cond + ((getprop symbol *keyword*) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((getprop symbol *cpp*) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons string (ignore)))))) + ((in "<>=!/\\+*-([])") + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(C)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/skribe/src/bigloo/color.scm b/skribe/src/bigloo/color.scm new file mode 100644 index 0000000..e40638b --- /dev/null +++ b/skribe/src/bigloo/color.scm @@ -0,0 +1,702 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/color.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Apr 10 13:46:50 2002 */ +;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Tex color manager */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_color + (import skribe_configure) + (export (skribe-color->rgb ::obj) + (skribe-get-used-colors) + (skribe-use-color! color))) + +;*---------------------------------------------------------------------*/ +;* *skribe-rgb-string* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-rgb-string* + "255 250 250 snow +248 248 255 ghostwhite +245 245 245 whitesmoke +220 220 220 gainsboro +255 250 240 floralwhite +253 245 230 oldlace +250 240 230 linen +250 235 215 antiquewhite +255 239 213 papayawhip +255 235 205 blanchedalmond +255 228 196 bisque +255 218 185 peachpuff +255 222 173 navajowhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemonchiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mintcream +240 255 255 azure +240 248 255 aliceblue +230 230 250 lavender +255 240 245 lavenderblush +255 228 225 mistyrose +255 255 255 white +0 0 0 black +47 79 79 darkslategrey +105 105 105 dimgrey +112 128 144 slategrey +119 136 153 lightslategrey +190 190 190 grey +211 211 211 lightgrey +25 25 112 midnightblue +0 0 128 navy +0 0 128 navyblue +100 149 237 cornflowerblue +72 61 139 darkslateblue +106 90 205 slateblue +123 104 238 mediumslateblue +132 112 255 lightslateblue +0 0 205 mediumblue +65 105 225 royalblue +0 0 255 blue +30 144 255 dodgerblue +0 191 255 deepskyblue +135 206 235 skyblue +135 206 250 lightskyblue +70 130 180 steelblue +176 196 222 lightsteelblue +173 216 230 lightblue +176 224 230 powderblue +175 238 238 paleturquoise +0 206 209 darkturquoise +72 209 204 mediumturquoise +64 224 208 turquoise +0 255 255 cyan +224 255 255 lightcyan +95 158 160 cadetblue +102 205 170 mediumaquamarine +127 255 212 aquamarine +0 100 0 darkgreen +85 107 47 darkolivegreen +143 188 143 darkseagreen +46 139 87 seagreen +60 179 113 mediumseagreen +32 178 170 lightseagreen +152 251 152 palegreen +0 255 127 springgreen +124 252 0 lawngreen +0 255 0 green +127 255 0 chartreuse +0 250 154 mediumspringgreen +173 255 47 greenyellow +50 205 50 limegreen +154 205 50 yellowgreen +34 139 34 forestgreen +107 142 35 olivedrab +189 183 107 darkkhaki +240 230 140 khaki +238 232 170 palegoldenrod +250 250 210 lightgoldenrodyellow +255 255 224 lightyellow +255 255 0 yellow +255 215 0 gold +238 221 130 lightgoldenrod +218 165 32 goldenrod +184 134 11 darkgoldenrod +188 143 143 rosybrown +205 92 92 indianred +139 69 19 saddlebrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandybrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 darksalmon +250 128 114 salmon +255 160 122 lightsalmon +255 165 0 orange +255 140 0 darkorange +255 127 80 coral +240 128 128 lightcoral +255 99 71 tomato +255 69 0 orangered +255 0 0 red +255 105 180 hotpink +255 20 147 deeppink +255 192 203 pink +255 182 193 lightpink +219 112 147 palevioletred +176 48 96 maroon +199 21 133 mediumvioletred +208 32 144 violetred +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 mediumorchid +153 50 204 darkorchid +148 0 211 darkviolet +138 43 226 blueviolet +160 32 240 purple +147 112 219 mediumpurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 antiquewhite1 +238 223 204 antiquewhite2 +205 192 176 antiquewhite3 +139 131 120 antiquewhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 peachpuff1 +238 203 173 peachpuff2 +205 175 149 peachpuff3 +139 119 101 peachpuff4 +255 222 173 navajowhite1 +238 207 161 navajowhite2 +205 179 139 navajowhite3 +139 121 94 navajowhite4 +255 250 205 lemonchiffon1 +238 233 191 lemonchiffon2 +205 201 165 lemonchiffon3 +139 137 112 lemonchiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 lavenderblush1 +238 224 229 lavenderblush2 +205 193 197 lavenderblush3 +139 131 134 lavenderblush4 +255 228 225 mistyrose1 +238 213 210 mistyrose2 +205 183 181 mistyrose3 +139 125 123 mistyrose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 slateblue1 +122 103 238 slateblue2 +105 89 205 slateblue3 +71 60 139 slateblue4 +72 118 255 royalblue1 +67 110 238 royalblue2 +58 95 205 royalblue3 +39 64 139 royalblue4 +0 0 255 blue1 +0 0 238 blue2 +0 0 205 blue3 +0 0 139 blue4 +30 144 255 dodgerblue1 +28 134 238 dodgerblue2 +24 116 205 dodgerblue3 +16 78 139 dodgerblue4 +99 184 255 steelblue1 +92 172 238 steelblue2 +79 148 205 steelblue3 +54 100 139 steelblue4 +0 191 255 deepskyblue1 +0 178 238 deepskyblue2 +0 154 205 deepskyblue3 +0 104 139 deepskyblue4 +135 206 255 skyblue1 +126 192 238 skyblue2 +108 166 205 skyblue3 +74 112 139 skyblue4 +176 226 255 lightskyblue1 +164 211 238 lightskyblue2 +141 182 205 lightskyblue3 +96 123 139 lightskyblue4 +202 225 255 lightsteelblue1 +188 210 238 lightsteelblue2 +162 181 205 lightsteelblue3 +110 123 139 lightsteelblue4 +191 239 255 lightblue1 +178 223 238 lightblue2 +154 192 205 lightblue3 +104 131 139 lightblue4 +224 255 255 lightcyan1 +209 238 238 lightcyan2 +180 205 205 lightcyan3 +122 139 139 lightcyan4 +187 255 255 paleturquoise1 +174 238 238 paleturquoise2 +150 205 205 paleturquoise3 +102 139 139 paleturquoise4 +152 245 255 cadetblue1 +142 229 238 cadetblue2 +122 197 205 cadetblue3 +83 134 139 cadetblue4 +0 245 255 turquoise1 +0 229 238 turquoise2 +0 197 205 turquoise3 +0 134 139 turquoise4 +0 255 255 cyan1 +0 238 238 cyan2 +0 205 205 cyan3 +0 139 139 cyan4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 +69 139 116 aquamarine4 +193 255 193 darkseagreen1 +180 238 180 darkseagreen2 +155 205 155 darkseagreen3 +105 139 105 darkseagreen4 +84 255 159 seagreen1 +78 238 148 seagreen2 +67 205 128 seagreen3 +46 139 87 seagreen4 +154 255 154 palegreen1 +144 238 144 palegreen2 +124 205 124 palegreen3 +84 139 84 palegreen4 +0 255 127 springgreen1 +0 238 118 springgreen2 +0 205 102 springgreen3 +0 139 69 springgreen4 +0 255 0 green1 +0 238 0 green2 +0 205 0 green3 +0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 +69 139 0 chartreuse4 +192 255 62 olivedrab1 +179 238 58 olivedrab2 +154 205 50 olivedrab3 +105 139 34 olivedrab4 +202 255 112 darkolivegreen1 +188 238 104 darkolivegreen2 +162 205 90 darkolivegreen3 +110 139 61 darkolivegreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 lightgoldenrod1 +238 220 130 lightgoldenrod2 +205 190 112 lightgoldenrod3 +139 129 76 lightgoldenrod4 +255 255 224 lightyellow1 +238 238 209 lightyellow2 +205 205 180 lightyellow3 +139 139 122 lightyellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 darkgoldenrod1 +238 173 14 darkgoldenrod2 +205 149 12 darkgoldenrod3 +139 101 8 darkgoldenrod4 +255 193 193 rosybrown1 +238 180 180 rosybrown2 +205 155 155 rosybrown3 +139 105 105 rosybrown4 +255 106 106 indianred1 +238 99 99 indianred2 +205 85 85 indianred3 +139 58 58 indianred4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 lightsalmon1 +238 149 114 lightsalmon2 +205 129 98 lightsalmon3 +139 87 66 lightsalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 darkorange1 +238 118 0 darkorange2 +205 102 0 darkorange3 +139 69 0 darkorange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 orangered1 +238 64 0 orangered2 +205 55 0 orangered3 +139 37 0 orangered4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 deeppink1 +238 18 137 deeppink2 +205 16 118 deeppink3 +139 10 80 deeppink4 +255 110 180 hotpink1 +238 106 167 hotpink2 +205 96 144 hotpink3 +139 58 98 hotpink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 lightpink1 +238 162 173 lightpink2 +205 140 149 lightpink3 +139 95 101 lightpink4 +255 130 171 palevioletred1 +238 121 159 palevioletred2 +205 104 137 palevioletred3 +139 71 93 palevioletred4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 violetred1 +238 58 140 violetred2 +205 50 120 violetred3 +139 34 82 violetred4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 mediumorchid1 +209 95 238 mediumorchid2 +180 82 205 mediumorchid3 +122 55 139 mediumorchid4 +191 62 255 darkorchid1 +178 58 238 darkorchid2 +154 50 205 darkorchid3 +104 34 139 darkorchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 +85 26 139 purple4 +171 130 255 mediumpurple1 +159 121 238 mediumpurple2 +137 104 205 mediumpurple3 +93 71 139 mediumpurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 +0 0 0 grey0 +3 3 3 grey1 +5 5 5 grey2 +8 8 8 grey3 +10 10 10 grey4 +13 13 13 grey5 +15 15 15 grey6 +18 18 18 grey7 +20 20 20 grey8 +23 23 23 grey9 +26 26 26 grey10 +28 28 28 grey11 +31 31 31 grey12 +33 33 33 grey13 +36 36 36 grey14 +38 38 38 grey15 +41 41 41 grey16 +43 43 43 grey17 +46 46 46 grey18 +48 48 48 grey19 +51 51 51 grey20 +54 54 54 grey21 +56 56 56 grey22 +59 59 59 grey23 +61 61 61 grey24 +64 64 64 grey25 +66 66 66 grey26 +69 69 69 grey27 +71 71 71 grey28 +74 74 74 grey29 +77 77 77 grey30 +79 79 79 grey31 +82 82 82 grey32 +84 84 84 grey33 +87 87 87 grey34 +89 89 89 grey35 +92 92 92 grey36 +94 94 94 grey37 +97 97 97 grey38 +99 99 99 grey39 +102 102 102 grey40 +105 105 105 grey41 +107 107 107 grey42 +110 110 110 grey43 +112 112 112 grey44 +115 115 115 grey45 +117 117 117 grey46 +120 120 120 grey47 +122 122 122 grey48 +125 125 125 grey49 +127 127 127 grey50 +130 130 130 grey51 +133 133 133 grey52 +135 135 135 grey53 +138 138 138 grey54 +140 140 140 grey55 +143 143 143 grey56 +145 145 145 grey57 +148 148 148 grey58 +150 150 150 grey59 +153 153 153 grey60 +156 156 156 grey61 +158 158 158 grey62 +161 161 161 grey63 +163 163 163 grey64 +166 166 166 grey65 +168 168 168 grey66 +171 171 171 grey67 +173 173 173 grey68 +176 176 176 grey69 +179 179 179 grey70 +181 181 181 grey71 +184 184 184 grey72 +186 186 186 grey73 +189 189 189 grey74 +191 191 191 grey75 +194 194 194 grey76 +196 196 196 grey77 +199 199 199 grey78 +201 201 201 grey79 +204 204 204 grey80 +207 207 207 grey81 +209 209 209 grey82 +212 212 212 grey83 +214 214 214 grey84 +217 217 217 grey85 +219 219 219 grey86 +222 222 222 grey87 +224 224 224 grey88 +227 227 227 grey89 +229 229 229 grey90 +232 232 232 grey91 +235 235 235 grey92 +237 237 237 grey93 +240 240 240 grey94 +242 242 242 grey95 +245 245 245 grey96 +247 247 247 grey97 +250 250 250 grey98 +252 252 252 grey99 +255 255 255 grey100 +169 169 169 darkgrey +0 0 139 darkblue +0 139 139 darkcyan +139 0 139 darkmagenta +139 0 0 darkred +144 238 144 lightgreen") + +;*---------------------------------------------------------------------*/ +;* *rgb-port* ... */ +;*---------------------------------------------------------------------*/ +(define *rgb-port* #unspecified) + +;*---------------------------------------------------------------------*/ +;* same-color? ... */ +;*---------------------------------------------------------------------*/ +(define (same-color? s1 s2) + (define (skip-rgb s) + (let ((l (string-length s))) + (let loop ((i 0)) + (if (=fx i l) + l + (let ((c (string-ref s i))) + (if (or (char-numeric? c) (char-whitespace? c)) + (loop (+fx i 1)) + i)))))) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (if (>fx l1 l2) + (let ((lc (skip-rgb s1))) + (and (=fx (-fx l1 lc) l2) + (let loop ((i1 (-fx l1 l2)) + (i2 0)) + (cond + ((=fx i1 l1) + #t) + ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) + (loop (+fx i1 1) (+fx i2 1))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* rgb-grep ... */ +;*---------------------------------------------------------------------*/ +(define (rgb-grep symbol) + (let ((parser (regular-grammar () + ((bol (: #\! (* all))) + (ignore)) + ((+ #\Newline) + (ignore)) + ((: (* (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ all)) + (let ((s (the-string))) + (if (same-color? s symbol) + (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) + (values (string->number (cadr m)) + (string->number (caddr m)) + (string->number (cadddr m)))) + (ignore)))) + (else + (values 0 0 0))))) + ;; initialization the port reading rgb.txt file + (with-input-from-string *skribe-rgb-string* + (lambda () + (read/rp parser (current-input-port)))))) + +;*---------------------------------------------------------------------*/ +;* *color-parser* ... */ +;*---------------------------------------------------------------------*/ +(define *color-parser* + (regular-grammar ((blank* (* blank)) + (blank+ (+ blank))) + + ;; rgb color + ((: #\# (+ xdigit)) + (let ((val (the-substring 1 (the-length)))) + (cond + ((=fx (string-length val) 6) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 2 4) 16) + (string->integer (substring val 4 6) 16))) + ((=fx (string-length val) 12) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 4 6) 16) + (string->integer (substring val 8 10) 16))) + (else + (values 0 0 0))))) + + ;; symbolic names + ((+ (out #\Newline)) + (let ((name (the-string))) + (cond + ((string-ci=? name "none") + (values 0 0 0)) + ((string-ci=? name "black") + (values #xff #xff #xff)) + ((string-ci=? name "white") + (values 0 0 0)) + (else + (rgb-grep name))))) + + ;; error + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->rgb spec) + (cond + ((string? spec) + (with-input-from-string spec + (lambda () + (read/rp *color-parser* (current-input-port))))) + ((fixnum? spec) + (values (bit-and #xff (bit-rsh spec 16)) + (bit-and #xff (bit-rsh spec 8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* *used-colors* ... */ +;*---------------------------------------------------------------------*/ +(define *used-colors* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-get-used-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-used-colors) + *used-colors*) + +;*---------------------------------------------------------------------*/ +;* skribe-use-color! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) diff --git a/skribe/src/bigloo/configure.bgl b/skribe/src/bigloo/configure.bgl new file mode 100644 index 0000000..e100d8d --- /dev/null +++ b/skribe/src/bigloo/configure.bgl @@ -0,0 +1,90 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:42:21 2003 */ +;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The general configuration options. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_configure + (export (skribe-release) + (skribe-url) + (skribe-doc-dir) + (skribe-ext-dir) + (skribe-default-path) + (skribe-scheme) + + (skribe-configure . opt) + (skribe-enforce-configure . opt))) + +;*---------------------------------------------------------------------*/ +;* skribe-configuration ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configuration) + `((:release ,(skribe-release)) + (:scheme ,(skribe-scheme)) + (:url ,(skribe-url)) + (:doc-dir ,(skribe-doc-dir)) + (:ext-dir ,(skribe-ext-dir)) + (:default-path ,(skribe-default-path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configure . opt) + (let ((conf (skribe-configuration))) + (cond + ((null? opt) + conf) + ((null? (cdr opt)) + (let ((cell (assq (car opt) conf))) + (if (pair? cell) + (cadr cell) + 'void))) + (else + (let loop ((opt opt)) + (cond + ((null? opt) + #t) + ((not (keyword? (car opt))) + #f) + ((or (null? (cdr opt)) (keyword? (cadr opt))) + #f) + (else + (let ((cell (assq (car opt) conf))) + (if (and (pair? cell) + (if (procedure? (cadr opt)) + ((cadr opt) (cadr cell)) + (equal? (cadr opt) (cadr cell)))) + (loop (cddr opt)) + #f))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-enforce-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-enforce-configure . opt) + (let loop ((o opt)) + (when (pair? o) + (cond + ((or (not (keyword? (car o))) + (null? (cdr o))) + (error 'skribe-enforce-configure + "Illegal enforcement" + opt)) + ((skribe-configure (car o) (cadr o)) + (loop (cddr o))) + (else + (error 'skribe-enforce-configure + (format "Configuration mismatch: ~a" (car o)) + (if (procedure? (cadr o)) + (format "provided `~a'" + (skribe-configure (car o))) + (format "provided `~a', required `~a'" + (skribe-configure (car o)) + (cadr o))))))))) diff --git a/skribe/src/bigloo/debug.sch b/skribe/src/bigloo/debug.sch new file mode 100644 index 0000000..9b53c84 --- /dev/null +++ b/skribe/src/bigloo/debug.sch @@ -0,0 +1,54 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu May 29 06:46:33 2003 */ +;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* directives */ +;*---------------------------------------------------------------------*/ +(directives + (import skribe_debug)) + +;*---------------------------------------------------------------------*/ +;* when-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (when-debug level . exp) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(if (>= *skribe-debug* ,level) (begin ,@exp)) + #unspecified)) + +;*---------------------------------------------------------------------*/ +;* with-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-debug level lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* with-push-trace ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-push-trace lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + (let ((r (gensym))) + `(let () + (c-push-trace ,lbl) + (let ((,r ,@arg*)) + (c-pop-trace) + ,r))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define-expander debug-item + (lambda (x e) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) + #unspecified))) diff --git a/skribe/src/bigloo/debug.scm b/skribe/src/bigloo/debug.scm new file mode 100644 index 0000000..8f1691c --- /dev/null +++ b/skribe/src/bigloo/debug.scm @@ -0,0 +1,188 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jun 11 10:01:47 2003 */ +;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_debug + + (export *skribe-debug* + *skribe-debug-symbols* + *skribe-debug-color* + + (skribe-debug::int) + (debug-port::output-port . ::obj) + (debug-margin::bstring) + (debug-color::bstring ::int . ::obj) + (debug-bold::bstring . ::obj) + (debug-string ::obj) + (debug-item . ::obj) + + (%with-debug ::obj ::obj ::procedure))) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-symbols* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-symbols* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-color* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-color* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-item* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-item* #f) + +;*---------------------------------------------------------------------*/ +;* *debug-port* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-port* (current-error-port)) + +;*---------------------------------------------------------------------*/ +;* *debug-depth* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-depth* 0) + +;*---------------------------------------------------------------------*/ +;* *debug-margin* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-margin* "") + +;*---------------------------------------------------------------------*/ +;* *skribe-margin-debug-level* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-margin-debug-level* 0) + +;*---------------------------------------------------------------------*/ +;* skribe-debug ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-debug) + *skribe-debug*) + +;*---------------------------------------------------------------------*/ +;* debug-port ... */ +;*---------------------------------------------------------------------*/ +(define (debug-port . o) + (cond + ((null? o) + *debug-port*) + ((output-port? (car o)) + (set! *debug-port* o) + o) + (else + (error 'debug-port "Illegal debug port" (car o))))) + +;*---------------------------------------------------------------------*/ +;* debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (debug-margin) + *debug-margin*) + +;*---------------------------------------------------------------------*/ +;* debug-color ... */ +;*---------------------------------------------------------------------*/ +(define (debug-color col::int . o) + (with-output-to-string + (if *skribe-debug-color* + (lambda () + (display* "[0m[1;" (+ 31 col) "m") + (apply display* o) + (display "[0m")) + (lambda () + (apply display* o))))) + +;*---------------------------------------------------------------------*/ +;* debug-bold ... */ +;*---------------------------------------------------------------------*/ +(define (debug-bold . o) + (apply debug-color -30 o)) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define (debug-item . args) + (if (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (begin + (display (debug-margin) *debug-port*) + (display (debug-color (-fx *debug-depth* 1) "- ")) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*)))) + +;*---------------------------------------------------------------------*/ +;* %with-debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+fx *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (-fx *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;*---------------------------------------------------------------------*/ +;* %with-debug ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (with-output-to-port *debug-port* + (lambda () + (display (debug-margin)) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl))) + (newline) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk))) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +;*---------------------------------------------------------------------*/ +;* debug-string ... */ +;*---------------------------------------------------------------------*/ +(define (debug-string o) + (with-output-to-string + (lambda () + (write o)))) + +;*---------------------------------------------------------------------*/ +;* example */ +;*---------------------------------------------------------------------*/ +;; (%with-debug 0 'foo1.1 +;; (lambda () +;; (debug-item 'foo2.1) +;; (debug-item 'foo2.2) +;; (%with-debug 0 'foo2.3 +;; (lambda () +;; (debug-item 'foo3.1) +;; (%with-debug 0 'foo3.2 +;; (lambda () +;; (debug-item 'foo4.1) +;; (debug-item 'foo4.2))) +;; (debug-item 'foo3.3))) +;; (debug-item 'foo2.4))) + diff --git a/skribe/src/bigloo/engine.scm b/skribe/src/bigloo/engine.scm new file mode 100644 index 0000000..bd8a027 --- /dev/null +++ b/skribe/src/bigloo/engine.scm @@ -0,0 +1,262 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 08:01:30 2003 */ +;* Last change : Fri May 21 16:12:32 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe engines */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_engine + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output) + + (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) + (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) + (find-engine ::symbol #!key version) + + (default-engine::obj) + (default-engine-set! ::%engine) + (push-default-engine ::%engine) + (pop-default-engine) + + (processor-get-engine ::obj ::obj ::%engine) + + (engine-format? ::bstring . e) + + (engine-custom::obj ::%engine ::symbol) + (engine-custom-set! ::%engine ::symbol ::obj) + + (engine-add-writer! ::%engine ::obj ::procedure ::obj + ::obj ::obj ::obj ::obj ::obj ::obj))) + +;*---------------------------------------------------------------------*/ +;* *engines* ... */ +;*---------------------------------------------------------------------*/ +(define *engines* '()) + +;*---------------------------------------------------------------------*/ +;* *default-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *default-engine* #f) +(define *default-engines* '()) + +;*---------------------------------------------------------------------*/ +;* default-engine-set! ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine-set! e) + (if (not (engine? e)) + (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) + (begin + (set! *default-engine* e) + (set! *default-engines* (cons *default-engine* *default-engines*)) + e))) + +;*---------------------------------------------------------------------*/ +;* default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine) + *default-engine*) + +;*---------------------------------------------------------------------*/ +;* push-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +;*---------------------------------------------------------------------*/ +;* pop-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + +;*---------------------------------------------------------------------*/ +;* processor-get-engine ... */ +;*---------------------------------------------------------------------*/ +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + +;*---------------------------------------------------------------------*/ +;* engine-format? ... */ +;*---------------------------------------------------------------------*/ +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + ((%engine? *skribe-engine*) *skribe-engine*) + (else (find-engine *skribe-engine*))))) + (if (not (%engine? e)) + (skribe-error 'engine-format? "No engine" e) + (string=? fmt (%engine-format e))))) + +;*---------------------------------------------------------------------*/ +;* make-engine ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine ident + #!key + (version #unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (instantiate::%engine + (ident ident) + (version version) + (format format) + (filter filter) + (delegate delegate) + (symbol-table symbol-table) + (customs custom) + (info info)))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + +;*---------------------------------------------------------------------*/ +;* copy-engine ... */ +;*---------------------------------------------------------------------*/ +(define (copy-engine ident + e + #!key + (version #unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((e (duplicate::%engine e + (ident ident) + (version version) + (filter (or filter (%engine-filter e))) + (delegate (or delegate (%engine-delegate e))) + (symbol-table (or symbol-table (%engine-symbol-table e))) + (customs (or custom (%engine-customs e)))))) + (set! *engines* (cons e *engines*)) + e)) + +;*---------------------------------------------------------------------*/ +;* find-loaded-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-loaded-engine id version) + (let loop ((es *engines*)) + (cond + ((null? es) + #f) + ((eq? (%engine-ident (car es)) id) + (cond + ((eq? version #unspecified) + (car es)) + ((eq? version (%engine-version (car es))) + (car es)) + (else + (loop (cdr es))))) + (else + (loop (cdr es)))))) + +;*---------------------------------------------------------------------*/ +;* find-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-engine id #!key (version #unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + (or (find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and (pair? c) (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (find-loaded-engine id version)) + #f))))) + +;*---------------------------------------------------------------------*/ +;* engine-custom ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom e id) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (cadr c) + #unspecified)))) + +;*---------------------------------------------------------------------*/ +;* engine-custom-set! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom-set! e id val) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (set! customs (cons (list id val) customs)))))) + +;*---------------------------------------------------------------------*/ +;* engine-add-writer! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-add-writer! e id pred upred opt before action after class va) + ;; check the arity of a procedure + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error id "Illegal procedure" proc)) + ((not (correct-arity? proc arity)) + (skribe-error id + (string-append "Illegal `" name "'procedure") + proc)))) + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + ;; check the engine + (if (not (engine? e)) + (skribe-error id "Illegal engine" e)) + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error id "Illegal options" opt)) + ;; check the correctness of the predicate and the validator + (check-procedure "predicate" pred 2) + (when va (check-procedure "validate" va 2)) + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + ;; create a new writer... + (let ((n (instantiate::%writer + (ident (if (symbol? id) id 'all)) + (class class) + (pred pred) + (upred upred) + (options opt) + (before before) + (action action) + (after after) + (validate va)))) + ;; ...and bind it + (with-access::%engine e (writers) + (set! writers (cons n writers)) + n))) diff --git a/skribe/src/bigloo/eval.scm b/skribe/src/bigloo/eval.scm new file mode 100644 index 0000000..b5c6548 --- /dev/null +++ b/skribe/src/bigloo/eval.scm @@ -0,0 +1,335 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed May 18 15:52:01 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe evaluator */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_eval + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_param + skribe_types + skribe_resolve + skribe_verify + skribe_output + skribe_read + skribe_lib + skribe_engine) + + (export (skribe-eval-location) + (skribe-error ::obj ::obj ::obj) + (skribe-type-error ::obj ::obj ::obj ::bstring) + (skribe-warning ::int . obj) + (skribe-warning/ast ::int ::%ast . obj) + (skribe-message ::bstring . obj) + (skribe-load ::bstring #!rest opt #!key engine path) + (skribe-load-options) + (skribe-include ::bstring . rest) + (skribe-open-bib-file ::bstring ::obj) + (skribe-eval-port ::input-port ::obj #!key env) + (skribe-eval ::obj ::%engine #!key env) + (skribe-path::pair-nil) + (skribe-path-set! ::obj) + (skribe-image-path::pair-nil) + (skribe-image-path-set! ::obj) + (skribe-bib-path::pair-nil) + (skribe-bib-path-set! ::obj) + (skribe-source-path::pair-nil) + (skribe-source-path-set! ::obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-location ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-location) + (evmeaning-location)) + +;*---------------------------------------------------------------------*/ +;* skribe-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error/evloc proc msg obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-type-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-type-error proc msg obj etype) + (let ((ty (if (%markup? obj) + (format "~a#~a" (markup-markup obj) (markup-ident obj)) + (find-runtime-type obj)))) + (skribe-error proc + (bigloo-type-error-msg msg etype ty) + obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-ast-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (%markup? obj) + (%markup-markup obj) + (find-runtime-type obj)))) + (if (location? l) + (error/location proc msg shape (location-file l) (location-pos l)) + (error/evloc proc msg shape)))) + +;*---------------------------------------------------------------------*/ +;* error/evloc ... */ +;*---------------------------------------------------------------------*/ +(define (error/evloc proc msg obj) + (let ((l (evmeaning-location))) + (if (location? l) + (error/location proc msg obj (location-file l) (location-pos l)) + ((begin error) proc msg obj)))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (let ((l (evmeaning-location))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply warning obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning/ast ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (%ast-loc ast))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply skribe-warning level obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-message ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-message fmt . obj) + (if (> *skribe-verbose* 0) + (apply fprintf (current-error-port) fmt obj))) + +;*---------------------------------------------------------------------*/ +;* *skribe-loaded* ... */ +;* ------------------------------------------------------------- */ +;* This hash table stores the list of loaded files in order */ +;* to avoid one file to be loaded twice. */ +;*---------------------------------------------------------------------*/ +(define *skribe-loaded* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* *skribe-load-options* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-load-options* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-load ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load file #!rest opt #!key engine path) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + (let* ((ei (cond + ((not engine) + *skribe-engine*) + ((engine? engine) + engine) + ((not (symbol? engine)) + (skribe-error 'skribe-load "Illegal engine" engine)) + (else + engine))) + (path (cond + ((not path) + (skribe-path)) + ((string? path) + (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else + path))) + (filep (find-file/path file path))) + (set! *skribe-load-options* opt) + (if (and (string? filep) (file-exists? filep)) + (if (not (hashtable-get *skribe-loaded* filep)) + (begin + (hashtable-put! *skribe-loaded* filep #t) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [loading file: " filep " " opt "]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [loading file: " filep "]"))) + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))))) + (skribe-error 'skribe-load + (format "Can't find file `~a' in path" file) + path))))) + +;*---------------------------------------------------------------------*/ +;* skribe-load-options ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load-options) + *skribe-load-options*) + +;*---------------------------------------------------------------------*/ +;* evaluate ... */ +;*---------------------------------------------------------------------*/ +(define (evaluate exp) + (try (eval exp) + (lambda (a p m o) + (evmeaning-notify-error p m o) + (flush-output-port (current-error-port))))) + +;*---------------------------------------------------------------------*/ +;* skribe-include ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-include file . rest) + (let* ((path (cond + ((or (null? rest) (null? (cdr rest))) + (skribe-path)) + ((not (every? string? (cdr rest))) + (skribe-error 'skribe-include "Illegal path" (cdr rest))) + (else + (cdr rest)))) + (filep (find-file/path file (if (null? path) (skribe-path) path)))) + (if (and (string? filep) (file-exists? filep)) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [including file: " filep "]")) + (with-input-from-file filep + (lambda () + (let loop ((exp (skribe-read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (loop (skribe-read (current-input-port)) + (cons (evaluate exp) res))))))) + (skribe-error 'skribe-include + (format "Can't find file `~a 'in path" file) + path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-open-bib-file ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-open-bib-file file command) + (let ((filep (find-file/path file *skribe-bib-path*))) + (if (string? filep) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [loading bib: " filep "]")) + (open-input-file (if (string? command) + (string-append "| " + (format command filep)) + filep))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-port ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-port port ei #!key (env '())) + (with-debug 2 'skribe-eval-port + (debug-item "ei=" ei) + (let ((e (if (symbol? ei) (find-engine ei) ei))) + (debug-item "e=" e) + (if (not (%engine? e)) + (skribe-error 'find-engine "Can't find engine" ei) + (let loop ((exp (skribe-read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (if (not (eof-object? exp)) + (begin + (skribe-eval (evaluate exp) e :env env) + (loop (skribe-read port))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval a e #!key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (%engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;*---------------------------------------------------------------------*/ +;* skribe-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path) + *skribe-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path) + *skribe-image-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path) + *skribe-bib-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path) + *skribe-source-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) diff --git a/skribe/src/bigloo/evapi.scm b/skribe/src/bigloo/evapi.scm new file mode 100644 index 0000000..6f0d49e --- /dev/null +++ b/skribe/src/bigloo/evapi.scm @@ -0,0 +1,39 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:57:09 2003 */ +;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo eval declarations */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_evapi + (import skribe_types + skribe_lib + skribe_api + skribe_engine + skribe_writer + skribe_output + skribe_eval + skribe_read + skribe_resolve + skribe_param + skribe_source + skribe_index + skribe_configure + skribe_lisp + skribe_xml + skribe_c + skribe_asm + skribe_bib + skribe_color + skribe_sui + skribe_debug) + (eval (export-all))) + + diff --git a/skribe/src/bigloo/index.bgl b/skribe/src/bigloo/index.bgl new file mode 100644 index 0000000..9697981 --- /dev/null +++ b/skribe/src/bigloo/index.bgl @@ -0,0 +1,32 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 24 08:01:45 2003 */ +;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe indexes Bigloo module declaration */ +;* ------------------------------------------------------------- */ +;* Implementation: @label index@ */ +;* bigloo: @path ../common/index.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_index + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (index?::bool ::obj) + (default-index) + (make-index-table ::bstring) + (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) + diff --git a/skribe/src/bigloo/lib.bgl b/skribe/src/bigloo/lib.bgl new file mode 100644 index 0000000..6dd6d37 --- /dev/null +++ b/skribe/src/bigloo/lib.bgl @@ -0,0 +1,340 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe runtime (i.e., the style user functions). */ +;* ------------------------------------------------------------- */ +;* Implementation: @label lib@ */ +;* bigloo: @path ../common/lib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lib + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output + skribe_engine) + + (export (markup-option ::%markup ::obj) + (markup-option-add! ::%markup ::obj ::obj) + (markup-class ::%markup) + + (container-env-get ::%container ::symbol) + (container-search-down::pair-nil ::procedure ::%container) + (search-down::pair-nil ::procedure ::obj) + + (find-markup-ident::pair-nil ::bstring) + + (find-down::pair-nil ::procedure ::obj) + (find1-down::obj ::procedure ::obj) + (find-up::pair-nil ::procedure ::obj) + (find1-up::obj ::procedure ::obj) + + (ast-document ::%ast) + (ast-chapter ::%ast) + (ast-section ::%ast) + + (the-body ::pair-nil) + (the-options ::pair-nil . rest) + + (list-split::pair-nil ::pair-nil ::int . ::obj) + + (generic ast->string::bstring ::obj) + + (strip-ref-base ::bstring) + (ast->file-location ::%ast) + + (convert-image ::bstring ::pair-nil) + + (make-string-replace ::pair-nil) + (string-canonicalize::bstring ::bstring) + (inline unspecified?::bool ::obj))) + +;*---------------------------------------------------------------------*/ +;* markup-option ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option m opt) + (if (%markup? m) + (with-access::%markup m (options) + (let ((c (assq opt options))) + (and (pair? c) (pair? (cdr c)) (cadr c)))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-option-add! ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option-add! m opt val) + (if (%markup? m) + (with-access::%markup m (options) + (set! options (cons (list opt val) options))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (markup-class m) + (%markup-class m)) + +;*---------------------------------------------------------------------*/ +;* container-env-get ... */ +;*---------------------------------------------------------------------*/ +(define (container-env-get m key) + (with-access::%container m (env) + (let ((c (assq key env))) + (and (pair? c) (cadr c))))) + +;*---------------------------------------------------------------------*/ +;* strip-ref-base ... */ +;*---------------------------------------------------------------------*/ +(define (strip-ref-base file) + (if (not (string? *skribe-ref-base*)) + file + (let ((l (string-length *skribe-ref-base*))) + (cond + ((not (>fx (string-length file) (+fx l 2))) + file) + ((not (substring=? file *skribe-ref-base* l)) + file) + ((not (char=? (string-ref file l) (file-separator))) + file) + (else + (substring file (+fx l 1) (string-length file))))))) + +;*---------------------------------------------------------------------*/ +;* ast->file-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format "~a:~a" (location-file l) (location-pos l)) + ""))) + +;*---------------------------------------------------------------------*/ +;* builtin-convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (builtin-convert-image from fmt dir) + (let* ((s (suffix from)) + (f (string-append (prefix (basename from)) "." fmt)) + (to (make-file-name dir f))) + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append "fig2dev -L " fmt " " from " > " to) + (string-append "convert " from " " to)))) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [converting image: " from " (" c ")]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [converting image: " from "]"))) + (if (=fx (system c) 0) to #f)))))) + +;*---------------------------------------------------------------------*/ +;* convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (convert-image file formats) + (let ((path (find-file/path file (skribe-image-path)))) + (if (not (string? path)) + (skribe-error 'image + (format "Can't find `~a' image file in path: " file) + (skribe-image-path)) + (let ((suf (suffix file))) + (if (member suf formats) + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + #f))) + (if dir + (let ((dest (basename path))) + (copy-file path (make-file-name dir dest)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + +;*---------------------------------------------------------------------*/ +;* html-string ... */ +;*---------------------------------------------------------------------*/ +(define (html-string str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (if (=fx nlen len) + str + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let ((c (string-ref-ur str r))) + (case c + ((#\<) + (blit-string! "<" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\>) + (blit-string! ">" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\&) + (blit-string! "&" 0 res w 5) + (loop (+fx r 1) (+fx w 5))) + ((#\") + (blit-string! """ 0 res w 6) + (loop (+fx r 1) (+fx w 6))) + (else + (string-set! res w c) + (loop (+fx r 1) (+fx w 1))))))))) + (case (string-ref-ur str r) + ((#\< #\>) + (loop (+fx r 1) (+fx nlen 3))) + ((#\&) + (loop (+fx r 1) (+fx nlen 4))) + ((#\") + (loop (+fx r 1) (+fx nlen 5))) + (else + (loop (+fx r 1) nlen))))))) + +;*---------------------------------------------------------------------*/ +;* make-generic-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-generic-string-replace lst) + (lambda (str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (let ((pl (string-length (cadr p)))) + (blit-string! (cadr p) 0 res w pl) + (loop (+fx r 1) (+fx w pl))) + (begin + (string-set! res w c) + (loop (+fx r 1) (+fx w 1)))))))) + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (loop (+fx r 1) + (+fx nlen (-fx (string-length (cadr p)) 1))) + (loop (+fx r 1) + nlen)))))))) + +;*---------------------------------------------------------------------*/ +;* make-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2)))))) + (cond + ((equal? l '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) + html-string) + (else + (make-generic-string-replace lst))))) + +;*---------------------------------------------------------------------*/ +;* ast->string ... */ +;*---------------------------------------------------------------------*/ +(define-generic (ast->string ast) + (cond + ((string? ast) + ast) + ((number? ast) + (number->string ast)) + ((pair? ast) + (let* ((t (map ast->string ast)) + (res (make-string + (apply + -1 (length t) (map string-length t)) + #\space))) + (let loop ((t t) + (w 0)) + (if (null? t) + res + (let ((l (string-length (car t)))) + (blit-string! (car t) 0 res w l) + (loop (cdr t) (+ w l 1))))))) + (else + ""))) + +;*---------------------------------------------------------------------*/ +;* ast->string ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (ast->string ast::%node) + (ast->string (%node-body ast))) + +;*---------------------------------------------------------------------*/ +;* string-canonicalize ... */ +;*---------------------------------------------------------------------*/ +(define (string-canonicalize old) + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((=fx r l) + (cond + ((=fx w 0) + "") + ((char-whitespace? (string-ref new (-fx w 1))) + (substring new 0 (-fx w 1))) + ((=fx w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+fx r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (char=? (string-ref old r) #\,) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+fx r 1) (+fx w 1) #f)))))) + +;*---------------------------------------------------------------------*/ +;* unspecified? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unspecified? obj) + (eq? obj #unspecified)) + +;*---------------------------------------------------------------------*/ +;* base */ +;* ------------------------------------------------------------- */ +;* A base engine must pre-exist before anything is loaded. In */ +;* particular, this dummy base engine is used to load the */ +;* actual definition of base. */ +;*---------------------------------------------------------------------*/ +(make-engine 'base :version 'bootstrap) + diff --git a/skribe/src/bigloo/lisp.scm b/skribe/src/bigloo/lisp.scm new file mode 100644 index 0000000..65a8227 --- /dev/null +++ b/skribe/src/bigloo/lisp.scm @@ -0,0 +1,530 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Aug 29 08:14:59 2003 */ +;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Handling of lispish source files. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lisp + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export bigloo + scheme + lisp + skribe)) + +;*---------------------------------------------------------------------*/ +;* keys ... */ +;*---------------------------------------------------------------------*/ +(define *the-key* #f) +(define *bracket-highlight* #t) +(define *bigloo-key* #f) +(define *scheme-key* #f) +(define *lisp-key* #f) +(define *skribe-key* #f) + +;*---------------------------------------------------------------------*/ +;* init-bigloo-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-bigloo-fontifier!) + (if (not *bigloo-key*) + (begin + (set! *bigloo-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'symbol)) + '(set! if let cond case quote begin letrec let* + lambda export extern class generic inline + static import foreign type with-access instantiate + duplicate labels + match-case match-lambda + syntax-rules pragma widen! shrink! + wide-class profile profile/gc + regular-grammar lalr-grammar apply)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'define)) + '(define define-inline define-struct define-macro + define-generic define-method define-syntax + define-expander)) + ;; error + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'error)) + '(bind-exit unwind-protect call/cc error warning)) + ;; module + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'module)) + '(module import export library)) + ;; thread + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'thread)) + '(make-thread thread-start! thread-yield! + thread-await! thread-await*! + thread-sleep! thread-join! + thread-terminate! thread-suspend! + thread-resume! thread-yield! + thread-specific thread-specific-set! + thread-name thread-name-set! + scheduler-react! scheduler-start! + broadcast! scheduler-broadcast! + current-thread thread? + current-scheduler scheduler? make-scheduler + make-input-signal make-output-signal + make-connect-signal make-process-signal + make-accept-signal make-timer-signal + thread-get-values! thread-get-values*!))))) + +;*---------------------------------------------------------------------*/ +;* init-lisp-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-lisp-fontifier!) + (if (not *lisp-key*) + (begin + (set! *lisp-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'symbol)) + '(setq if let cond case else progn letrec let* + lambda labels try unwind-protect apply funcall)) + ;; defun + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'define)) + '(define defun defvar defmacro))))) + +;*---------------------------------------------------------------------*/ +;* init-skribe-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-skribe-fontifier!) + (if (not *skribe-key*) + (begin + (set! *skribe-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'symbol)) + '(set! bold it emph tt color ref index underline + figure center pre flush hrule linebreak + image kbd code var samp sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font lambda)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'define)) + '(define define-markup)) + ;; markup + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'markup)) + '(document chapter section subsection subsubsection + paragraph p handle resolve processor + abstract margin toc table-of-contents + current-document current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide))))) + +;*---------------------------------------------------------------------*/ +;* bigloo ... */ +;*---------------------------------------------------------------------*/ +(define bigloo + (new language + (name "bigloo") + (fontifier bigloo-fontifier) + (extractor bigloo-extractor))) + +;*---------------------------------------------------------------------*/ +;* scheme ... */ +;*---------------------------------------------------------------------*/ +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;*---------------------------------------------------------------------*/ +;* lisp ... */ +;*---------------------------------------------------------------------*/ +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;*---------------------------------------------------------------------*/ +;* bigloo-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-fontifier s) + (init-bigloo-fontifier!) + (set! *the-key* *bigloo-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* bigloo-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (eq? def fun)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* skribe ... */ +;*---------------------------------------------------------------------*/ +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;*---------------------------------------------------------------------*/ +;* skribe-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-fontifier s) + (init-skribe-fontifier!) + (set! *the-key* *skribe-key*) + (set! *bracket-highlight* #t) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* skribe-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + ((markup-output (quote ?mk) . ?-) + (eq? mk def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* scheme-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-fontifier s) s) + +;*---------------------------------------------------------------------*/ +;* scheme-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* lisp-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-fontifier s) + (init-lisp-fontifier!) + (set! *the-key* *lisp-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* lisp-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (eq? def fun)) + ((defvar ?var . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* definition-search ... */ +;* ------------------------------------------------------------- */ +;* This function seeks a Bigloo definition. If it finds it, it */ +;* returns two values the starting char number of the definition */ +;* and the stop char. */ +;*---------------------------------------------------------------------*/ +(define (definition-search ip tab semipred) + (cond-expand + (bigloo2.6 + (define (reader-current-line-number) + (let* ((port (open-input-string "(9)")) + (exp (read port #t))) + (close-input-port port) + (line-number exp))) + (define (line-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos ?line) + line)))) + (reader-reset!) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (line-number exp)) + (e (reader-current-line-number))) + (source-read-lines (input-port-name ip) b e tab))))))) + (else + (define (char-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos) + pos)))) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (char-number exp)) + (e (input-port-position ip))) + (source-read-chars (input-port-name ip) + b + e + tab))))))))) + + +;*---------------------------------------------------------------------*/ +;* fontify-lisp ... */ +;*---------------------------------------------------------------------*/ +(define (fontify-lisp port::input-port) + (let ((g (regular-grammar () + ((: ";;" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";*" (* all)) + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-string))) + (cons str (ignore)))) + ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-substring 1 (the-length)))) + (cons str (ignore)))) + ((+ #\Space) + ;; separators + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + (#\( + ;; open parenthesis + (let ((str (highlight (the-string)))) + (pupush-highlight) + (cons str (ignore)))) + (#\) + ;; close parenthesis + (let ((str (highlight (the-string) -1))) + (cons str (ignore)))) + ((+ (in "[]")) + ;; brackets + (let ((s (the-string))) + (if *bracket-highlight* + (let ((c (new markup + (markup '&source-bracket) + (body s)))) + (cons c (ignore))) + (cons s (ignore))))) + ((+ #\Tab) + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((: #\( (+ (out "; \t()[]:\"\n"))) + ;; keywords + (let* ((string (the-substring 1 (the-length))) + (symbol (string->symbol string)) + (key (getprop symbol *the-key*))) + (cons + "(" + (case key + ((symbol) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((define) + (let ((c (new markup + (markup '&source-define) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-define) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((error) + (let ((c (new markup + (markup '&source-error) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((module) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((markup) + (let ((c (new markup + (markup '&source-markup) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((thread) + (let ((c (new markup + (markup '&source-thread) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons (highlight string 1) (ignore))))))) + ((+ (out "; \t()[]:\"\n")) + (let ((string (the-string))) + (cons (highlight string 1) (ignore)))) + ((+ #\Newline) + ;; newline + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (ident (symbol->string (gensym))) + (body s)))) + str) + (ignore)))) + ((: "::" (+ (out ";\n \t()[]:\""))) + ;; type annotations + (let ((c (new markup + (markup '&source-type) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) + ;; keywords annotations + (let ((c (new markup + (markup '&source-key) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\: #\; #\")) + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + ((: #\# #\\ (+ (out " \n\t"))) + ;; characters + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(lisp)" "Unexpected character" c))))))) + (reset-highlight!) + (read/rp g port))) + +;*---------------------------------------------------------------------*/ +;* *highlight* ... */ +;*---------------------------------------------------------------------*/ +(define *highlight* '()) + +;*---------------------------------------------------------------------*/ +;* reset-highlight! ... */ +;*---------------------------------------------------------------------*/ +(define (reset-highlight!) + (set! *highlight* '())) + +;*---------------------------------------------------------------------*/ +;* push-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (push-highlight col pv) + (set! *highlight* (cons (cons col pv) *highlight*))) + +;*---------------------------------------------------------------------*/ +;* pupush-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pupush-highlight) + (if (pair? *highlight*) + (let ((c (car *highlight*))) + (set-cdr! c 100000)))) + +;*---------------------------------------------------------------------*/ +;* pop-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pop-highlight pv) + (case pv + ((-1) + (set! *highlight* (cdr *highlight*))) + ((0) + 'nop) + (else + (let ((c (car *highlight*))) + (if (>fx (cdr c) 1) + (set-cdr! c (-fx (cdr c) 1)) + (set! *highlight* (cdr *highlight*))))))) + +;*---------------------------------------------------------------------*/ +;* highlight ... */ +;*---------------------------------------------------------------------*/ +(define (highlight exp . pop) + (if (pair? *highlight*) + (let* ((c (car *highlight*)) + (r (if (>fx (cdr c) 0) + ((car c) exp) + exp))) + (if (pair? pop) (pop-highlight (car pop))) + r) + exp)) + + diff --git a/skribe/src/bigloo/main.scm b/skribe/src/bigloo/main.scm new file mode 100644 index 0000000..5b9e5e5 --- /dev/null +++ b/skribe/src/bigloo/main.scm @@ -0,0 +1,96 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/main.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:51:49 2003 */ +;* Last change : Wed May 18 15:45:27 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe main entry point */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_main + + (include "debug.sch") + + (import skribe_types + skribe_parse-args + skribe_param + skribe_lib + skribe_eval + skribe_read + skribe_engine + skribe_evapi) + + (main main)) + +;*---------------------------------------------------------------------*/ +;* main ... */ +;*---------------------------------------------------------------------*/ +(define (main args) + (with-debug 2 'main + (debug-item "parse env variables...") + (parse-env-variables) + + (debug-item "load rc file...") + (load-rc) + + (debug-item "parse command line...") + (parse-args args) + + (debug-item "load base...") + (skribe-load "base.skr" :engine 'base) + + (debug-item "preload... (" *skribe-engine* ")") + (for-each (lambda (f) + (skribe-load f :engine *skribe-engine*)) + *skribe-preload*) + + ;; Load the specified variants + (debug-item "variant... (" *skribe-variants* ")") + (for-each (lambda (x) + (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) + (reverse! *skribe-variants*)) + + (debug-item "body..." *skribe-engine*) + (if (string? *skribe-dest*) + (cond-expand + (bigloo2.6 + (try (with-output-to-file *skribe-dest* doskribe) + (lambda (e a b c) + (delete-file *skribe-dest*) + (let ((s (with-output-to-string + (lambda () (write c))))) + (notify-error a b s)) + (exit -1)))) + (else + (with-exception-handler + (lambda (e) + (if (&warning? e) + (raise e) + (begin + (delete-file *skribe-dest*) + (if (&error? e) + (error-notify e) + (raise e)) + (exit 1)))) + (lambda () + (with-output-to-file *skribe-dest* doskribe))))) + (doskribe)))) + +;*---------------------------------------------------------------------*/ +;* doskribe ... */ +;*---------------------------------------------------------------------*/ +(define (doskribe) + (let ((e (find-engine *skribe-engine*))) + (if (and (engine? e) (pair? *skribe-precustom*)) + (for-each (lambda (cv) + (engine-custom-set! e (car cv) (cdr cv))) + *skribe-precustom*)) + (if (pair? *skribe-src*) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) + *skribe-src*) + (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/skribe/src/bigloo/new.sch b/skribe/src/bigloo/new.sch new file mode 100644 index 0000000..16bb7d5 --- /dev/null +++ b/skribe/src/bigloo/new.sch @@ -0,0 +1,17 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/new.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 17 11:58:30 2003 */ +;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The new facility */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* new ... */ +;*---------------------------------------------------------------------*/ +(define-macro (new id . inits) + `(,(symbol-append 'instantiate::% id) ,@inits)) + diff --git a/skribe/src/bigloo/output.scm b/skribe/src/bigloo/output.scm new file mode 100644 index 0000000..4bc6271 --- /dev/null +++ b/skribe/src/bigloo/output.scm @@ -0,0 +1,167 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/output.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe engine */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_output + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (output ::obj ::%engine . w))) + +;*---------------------------------------------------------------------*/ +;* output ... */ +;*---------------------------------------------------------------------*/ +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (pair? writer) + (cond + ((%writer? (car writer)) + (out/writer node e (car writer))) + ((not (car writer)) + (skribe-error 'output + (format "Illegal `~a' user writer" (%engine-ident e)) + (if (markup? node) (%markup-markup node) node))) + (else + (skribe-error 'output "Illegal user writer" (car writer)))) + (out node e)))) + +;*---------------------------------------------------------------------*/ +;* out/writer ... */ +;*---------------------------------------------------------------------*/ +(define (out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" (find-runtime-type n) + " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (%engine-ident e)) + (debug-item "w=" (%writer-ident w)) + (if (%writer? w) + (with-access::%writer w (before action after) + (invoke before n e) + (invoke action n e) + (invoke after n e))))) + +;*---------------------------------------------------------------------*/ +;* out ... */ +;*---------------------------------------------------------------------*/ +(define-generic (out node e::%engine) + (cond + ((pair? node) + (out* node e)) + ((string? node) + (let ((f (%engine-filter e))) + (if (procedure? f) + (display (f node)) + (display node)))) + ((number? node) + (display node)) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* out ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (out n::%processor e::%engine) + (with-access::%processor n (combinator engine body procedure) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + +;*---------------------------------------------------------------------*/ +;* out ::%command ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%command e::%engine) + (with-access::%command node (fmt body) + (let ((lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (skribe-error '! + "Too few arguments provided" + node))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (skribe-error '! + "Too few arguments provided" + node)))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0)))))))) + +;*---------------------------------------------------------------------*/ +;* out ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%handle e::%engine) + #unspecified) + +;*---------------------------------------------------------------------*/ +;* out ::%unresolved ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%unresolved e::%engine) + (error 'output "Orphan unresolved" node)) + +;*---------------------------------------------------------------------*/ +;* out ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%markup e::%engine) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (out/writer node e w) + (output (%markup-body node) e)))) + +;*---------------------------------------------------------------------*/ +;* out* ... */ +;*---------------------------------------------------------------------*/ +(define (out* n+ e) + (let loop ((n* n+)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (error 'output "Illegal argument" n*))))) + + diff --git a/skribe/src/bigloo/param.bgl b/skribe/src/bigloo/param.bgl new file mode 100644 index 0000000..6ff6b42 --- /dev/null +++ b/skribe/src/bigloo/param.bgl @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 14:03:15 2003 */ +;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe parameters */ +;* ------------------------------------------------------------- */ +;* Implementation: @label param@ */ +;* bigloo: @path ../common/param.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_param + + (import skribe_configure) + + (export *skribe-verbose* + *skribe-warning* + *skribe-path* + *skribe-bib-path* + *skribe-source-path* + *skribe-image-path* + *load-rc* + + *skribe-src* + *skribe-dest* + *skribe-engine* + *skribe-variants* + *skribe-chapter-split* + + *skribe-ref-base* + + *skribe-rc-directory* + *skribe-rc-file* + *skribe-auto-mode-alist* + *skribe-auto-load-alist* + *skribe-preload* + *skribe-precustom* + + *skribebib-auto-mode-alist*)) + +;*---------------------------------------------------------------------*/ +;* *skribe-verbose* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-verbose* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-warning* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-warning* 5) + +;*---------------------------------------------------------------------*/ +;* *skribe-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-path* (skribe-default-path)) + +;*---------------------------------------------------------------------*/ +;* *skribe-bib-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-bib-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-source-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-source-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-image-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-image-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *load-rc* ... */ +;*---------------------------------------------------------------------*/ +(define *load-rc* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-src* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-src* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-dest* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-dest* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-engine* 'html) + +;*---------------------------------------------------------------------*/ +;* *skribe-variants* */ +;*---------------------------------------------------------------------*/ +(define *skribe-variants* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-chapter-split* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-chapter-split* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-ref-base* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-ref-base* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-rc-directory* ... */ +;* ------------------------------------------------------------- */ +;* The "runtime command" file directory. */ +;*---------------------------------------------------------------------*/ +(define *skribe-rc-directory* + (let ((home (getenv "HOME")) + (host (hostname))) + (let loop ((host (if (not (string? host)) (getenv "HOST") host))) + (if (string? host) + (let ((home/host (string-append home "/.skribe" host))) + (if (and (file-exists? home/host) (directory? home/host)) + home/host + (if (string=? (suffix host) "") + (let ((home/def (make-file-name home ".skribe"))) + (cond + ((and (file-exists? home/def) + (directory? home/def)) + home/def) + (else + home))) + (loop (prefix host))))))))) + diff --git a/skribe/src/bigloo/parseargs.scm b/skribe/src/bigloo/parseargs.scm new file mode 100644 index 0000000..4ce58c4 --- /dev/null +++ b/skribe/src/bigloo/parseargs.scm @@ -0,0 +1,186 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:52:53 2003 */ +;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Argument parsing */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_parse-args + + (include "debug.sch") + + (import skribe_configure + skribe_param + skribe_read + skribe_types + skribe_eval) + + (export (parse-env-variables) + (parse-args ::pair) + (load-rc))) + +;*---------------------------------------------------------------------*/ +;* parse-env-variables ... */ +;*---------------------------------------------------------------------*/ +(define (parse-env-variables) + (let ((e (getenv "SKRIBEPATH"))) + (if (string? e) + (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) + +;*---------------------------------------------------------------------*/ +;* parse-args ... */ +;*---------------------------------------------------------------------*/ +(define (parse-args args) + (define (usage args-parse-usage) + (print "usage: skribe [options] [input]") + (newline) + (args-parse-usage #f) + (newline) + (print "Rc file:") + (newline) + (print " *skribe-rc* (searched in \".\" then $HOME)") + (newline) + (print "Target formats:") + (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) + (newline) + (print "Shell Variables:") + (newline) + (for-each (lambda (var) + (print " - " (car var) " " (cdr var))) + '(("SKRIBEPATH" . "Skribe input path (all files)")))) + (define (version) + (print "skribe v" (skribe-release))) + (define (query) + (version) + (newline) + (for-each (lambda (x) + (let ((s (keyword->string (car x)))) + (printf " ~a: ~a\n" + (substring s 1 (string-length s)) + (cadr x)))) + (skribe-configure))) + (let ((np '()) + (engine #f)) + (args-parse (cdr args) + ((("-h" "--help") (help "This message")) + (usage args-parse-usage) + (exit 0)) + (("--options" (help "Display the skribe options and exit")) + (args-parse-usage #t) + (exit 0)) + (("--version" (help "The version of Skribe")) + (version) + (exit 0)) + ((("-q" "--query") (help "Display informations about the Skribe configuration")) + (query) + (exit 0)) + ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) + (let ((l (string-length key=val))) + (let loop ((i 0)) + (cond + ((= i l) + (skribe-error 'skribe "Illegal option" key=val)) + ((char=? (string-ref key=val i) #\=) + (let ((key (substring key=val 0 i)) + (val (substring key=val (+ i 1) l))) + (set! *skribe-precustom* + (cons (cons (string->symbol key) val) + *skribe-precustom*)))) + (else + (loop (+ i 1))))))) + (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) + (set! *skribe-verbose* (string->integer level)))) + (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-warning* (+fx 1 *skribe-warning*)) + (set! *skribe-warning* (string->integer level)))) + (("-g?level" (help "Increase or set debug level")) + (if (string=? level "") + (set! *skribe-debug* (+fx 1 *skribe-debug*)) + (let ((l (string->integer level))) + (if (= l 0) + (begin + (set! *skribe-debug* 1) + (set! *skribe-debug-symbols* + (cons (string->symbol level) + *skribe-debug-symbols*))) + (set! *skribe-debug* l))))) + (("--no-color" (help "Disable coloring for debug")) + (set! *skribe-debug-color* #f)) + ((("-t" "--target") ?e (help "The output target format")) + (set! engine (string->symbol e))) + (("-I" ?path (help "Add <path> to skribe path")) + (set! np (cons path np))) + (("-B" ?path (help "Add <path> to skribe bibliography path")) + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("-S" ?path (help "Add <path> to skribe source path")) + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("-P" ?path (help "Add <path> to skribe image path")) + (skribe-image-path-set! (cons path (skribe-image-path)))) + ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files")) + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("--eval" ?expr (help "Evaluate expression")) + (with-input-from-string expr + (lambda () + (eval (skribe-read))))) + (("--no-init-file" (help "Dont load rc Skribe file")) + (set! *load-rc* #f)) + ((("-p" "--preload") ?file (help "Preload file")) + (set! *skribe-preload* (cons file *skribe-preload*))) + ((("-u" "--use-variant") ?variant (help "use <variant> output format")) + (set! *skribe-variants* (cons variant *skribe-variants*))) + ((("-o" "--output") ?o (help "The output target name")) + (set! *skribe-dest* o) + (let* ((s (suffix o)) + (c (assoc s *skribe-auto-mode-alist*))) + (if (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks")) + (set! *skribe-ref-base* base)) + ;; skribe rc directory + ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory")) + (set! *skribe-rc-directory* dir)) + (else + (set! *skribe-src* (cons else *skribe-src*)))) + ;; we have to configure according to the environment variables + (if engine (set! *skribe-engine* engine)) + (set! *skribe-src* (reverse! *skribe-src*)) + (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH") + (reverse! np) + (skribe-path))))) + +;*---------------------------------------------------------------------*/ +;* build-path-from-shell-variable ... */ +;*---------------------------------------------------------------------*/ +(define (build-path-from-shell-variable var) + (let ((val (getenv var))) + (if (string? val) + (string-case val + ((+ (out #\:)) + (let* ((str (the-string)) + (res (ignore))) + (cons str res))) + (#\: + (ignore)) + (else + '())) + '()))) + +;*---------------------------------------------------------------------*/ +;* load-rc ... */ +;*---------------------------------------------------------------------*/ +(define (load-rc) + (if *load-rc* + (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*))) + (if (and (string? file) (file-exists? file)) + (loadq file))))) + diff --git a/skribe/src/bigloo/prog.scm b/skribe/src/bigloo/prog.scm new file mode 100644 index 0000000..baad0f0 --- /dev/null +++ b/skribe/src/bigloo/prog.scm @@ -0,0 +1,196 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Aug 27 09:14:28 2003 */ +;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe prog bigloo implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_prog + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (make-prog-body ::obj ::obj ::obj ::obj) + (resolve-line ::bstring))) + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (integer->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (multiple-value-bind (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((%node? line) + (multiple-value-bind (m l) + (extract-mark (%node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (%node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((=fx r2 l) + (if (=fx r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+fx r2 1) + (+fx r2 1) + (if (=fx r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+fx r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (integer->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (integer->string (+fx (if (integer? ldigit) + (max lnum (expt 10 (-fx ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (multiple-value-bind (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) diff --git a/skribe/src/bigloo/read.scm b/skribe/src/bigloo/read.scm new file mode 100644 index 0000000..91cd345 --- /dev/null +++ b/skribe/src/bigloo/read.scm @@ -0,0 +1,482 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/read.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Dec 27 11:16:00 1994 */ +;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ +;* ------------------------------------------------------------- */ +;* Skribe's reader */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Le module */ +;*---------------------------------------------------------------------*/ +(module skribe_read + (export (skribe-read . port))) + +;*---------------------------------------------------------------------*/ +;* Global counteurs ... */ +;*---------------------------------------------------------------------*/ +(define *par-open* 0) + +;*---------------------------------------------------------------------*/ +;* Parenthesis mismatch (or unclosing) errors. */ +;*---------------------------------------------------------------------*/ +(define *list-error-level* 20) +(define *list-errors* (make-vector *list-error-level* #unspecified)) +(define *vector-errors* (make-vector *list-error-level* #unspecified)) + +;*---------------------------------------------------------------------*/ +;* Control variables. */ +;*---------------------------------------------------------------------*/ +(define *end-of-list* (cons 0 0)) +(define *dotted-mark* (cons 1 1)) + +;*---------------------------------------------------------------------*/ +;* skribe-reader-reset! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-reader-reset!) + (set! *par-open* 0)) + +;*---------------------------------------------------------------------*/ +;* read-error ... */ +;*---------------------------------------------------------------------*/ +(define (read-error msg obj port) + (let* ((obj-loc (if (epair? obj) + (match-case (cer obj) + ((at ?fname ?pos ?-) + pos) + (else + #f)) + #f)) + (loc (if (number? obj-loc) + obj-loc + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (if (<fx open-key (vector-length *list-errors*)) + (vector-ref *list-errors* open-key) + #f))) + (else + #f))))) + (if (fixnum? loc) + (error/location "skribe-read" msg obj (input-port-name port) loc) + (error "skribe-read" msg obj)))) + +;*---------------------------------------------------------------------*/ +;* make-list! ... */ +;*---------------------------------------------------------------------*/ +(define (make-list! l port) + (define (reverse-proper-list! l) + (let nr ((l l) + (r '())) + (cond + ((eq? (car l) *dotted-mark*) + (read-error "Illegal pair" r port)) + ((null? (cdr l)) + (set-cdr! l r) + l) + (else + (let ((cdrl (cdr l))) + (nr cdrl + (begin (set-cdr! l r) + l))))))) + (define (reverse-improper-list! l) + (let nr ((l (cddr l)) + (r (car l))) + (cond + ((eq? (car l) *dotted-mark*) + (read-error "Illegal pair" r port)) + ((null? (cdr l)) + (set-cdr! l r) + l) + (else + (let ((cdrl (cdr l))) + (nr cdrl + (begin (set-cdr! l r) + l))))))) + (cond + ((null? l) + l) + ((and (pair? l) (pair? (cdr l)) (eq? (cadr l) *dotted-mark*)) + (if (null? (cddr l)) + (car l) + (reverse-improper-list! l))) + (else + (reverse-proper-list! l)))) + +;*---------------------------------------------------------------------*/ +;* make-at ... */ +;*---------------------------------------------------------------------*/ +(define (make-at name pos) + (cond-expand + ((or bigloo2.4 bigloo2.5 bigloo2.6) + `(at ,name ,pos _)) + (else + `(at ,name ,pos)))) + +;*---------------------------------------------------------------------*/ +;* collect-up-to ... */ +;* ------------------------------------------------------------- */ +;* The first pair of the list is special because of source file */ +;* location. We want the location to be associated to the first */ +;* open parenthesis, not the last character of the car of the list. */ +;*---------------------------------------------------------------------*/ +(define-inline (collect-up-to ignore kind port) + (let ((name (input-port-name port))) + (let* ((pos (input-port-position port)) + (item (ignore))) + (if (eq? item *end-of-list*) + '() + (let loop ((acc (econs item '() (make-at name pos)))) + (let ((item (ignore))) + (if (eq? item *end-of-list*) + acc + (loop (let ((new-pos (input-port-position port))) + (econs item + acc + (make-at name new-pos))))))))))) + +;*---------------------------------------------------------------------*/ +;* read-quote ... */ +;*---------------------------------------------------------------------*/ +(define (read-quote kwote port ignore) + (let* ((pos (input-port-position port)) + (obj (ignore))) + (if (or (eof-object? obj) (eq? obj *end-of-list*)) + (error/location "read" + "Illegal quotation" + kwote + (input-port-name port) + pos)) + (econs kwote + (cons obj '()) + (make-at (input-port-name port) pos)))) + +;*---------------------------------------------------------------------*/ +;* *sexp-grammar* ... */ +;*---------------------------------------------------------------------*/ +(define *sexp-grammar* + (regular-grammar ((float (or (: (* digit) "." (+ digit)) + (: (+ digit) "." (* digit)))) + (letter (in ("azAZ") (#a128 #a255))) + (special (in "!@~$%^&*></-_+\\=?.:{}")) + (kspecial (in "!@~$%^&*></-_+\\=?.")) + (quote (in "\",'`")) + (paren (in "()")) + (id (: (* digit) + (or letter special) + (* (or letter special digit (in ",'`"))))) + (kid (: (* digit) + (or letter kspecial) + (* (or letter kspecial digit (in ",'`"))))) + (blank (in #\Space #\Tab #a012 #a013))) + + ;; newlines + ((+ #\Newline) + (ignore)) + + ;; blank lines + ((+ blank) + (ignore)) + + ;; comments + ((: ";" (* all)) + (ignore)) + + ;; the interpreter header or the dsssl named constants + ((: "#!" (+ (in letter))) + (let* ((str (the-string))) + (cond + ((string=? str "#!optional") + boptional) + ((string=? str "#!rest") + brest) + ((string=? str "#!key") + bkey) + (else + (ignore))))) + + ;; characters + ((: (uncase "#a") (= 3 digit)) + (let ((string (the-string))) + (if (not (=fx (the-length) 5)) + (error/location "skribe-read" + "Illegal ascii character" + string + (input-port-name (the-port)) + (input-port-position (the-port))) + (integer->char (string->integer (the-substring 2 5)))))) + ((: "#\\" (or letter digit special (in "|#; []" quote paren))) + (string-ref (the-string) 2)) + ((: "#\\" (>= 2 letter)) + (let ((char-name (string->symbol + (string-upcase! + (the-substring 2 (the-length)))))) + (case char-name + ((NEWLINE) + #\Newline) + ((TAB) + #\tab) + ((SPACE) + #\space) + ((RETURN) + (integer->char 13)) + (else + (error/location "skribe-read" + "Illegal character" + (the-string) + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; ucs-2 characters + ((: "#u" (= 4 xdigit)) + (integer->ucs2 (string->integer (the-substring 2 6) 16))) + + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 1 (-fx (the-length) 1)))) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (escape-C-string str)))) + ;; ucs2 strings + ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 3 (-fx (the-length) 1)))) + (utf8-string->ucs2-string str))) + + ;; fixnums + ((: (? (in "-+")) (+ digit)) + (the-fixnum)) + ((: "#o" (? (in "-+")) (+ (in ("07")))) + (string->integer (the-substring 2 (the-length)) 8)) + ((: "#d" (? (in "-+")) (+ (in ("09")))) + (string->integer (the-substring 2 (the-length)) 10)) + ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af")))))) + (string->integer (the-substring 2 (the-length)) 16)) + ((: "#e" (? (in "-+")) (+ digit)) + (string->elong (the-substring 2 (the-length)) 10)) + ((: "#l" (? (in "-+")) (+ digit)) + (string->llong (the-substring 2 (the-length)) 10)) + + ;; flonum + ((: (? (in "-+")) + (or float + (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit)))) + (the-flonum)) + + ;; doted pairs + ("." + (if (<=fx *par-open* 0) + (error/location "read" + "Illegal token" + #\. + (input-port-name (the-port)) + (input-port-position (the-port))) + *dotted-mark*)) + + ;; unspecified and eof-object + ((: "#" (in "ue") (+ (in "nspecified-objt"))) + (let ((symbol (string->symbol + (string-upcase! + (the-substring 1 (the-length)))))) + (case symbol + ((UNSPECIFIED) + unspec) + ((EOF-OBJECT) + beof) + (else + (error/location "read" + "Illegal identifier" + symbol + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; booleans + ((: "#" (uncase #\t)) + #t) + ((: "#" (uncase #\f)) + #f) + + ;; keywords + ((or (: ":" kid) (: kid ":")) + ;; since the keyword expression is also matched by the id + ;; rule, keyword rule has to be placed before the id rule. + (the-keyword)) + + ;; identifiers + (id + ;; this rule has to be placed after the rule matching the `.' char + (the-symbol)) + ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|") + (if (=fx (the-length) 2) + (the-symbol) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (string->symbol (escape-C-string str))))) + + ;; quotations + ("'" + (read-quote 'quote (the-port) ignore)) + ("`" + (read-quote 'quasiquote (the-port) ignore)) + ("," + (read-quote 'unquote (the-port) ignore)) + (",@" + (read-quote 'unquote-splicing (the-port) ignore)) + + ;; lists + (#\( + ;; if possible, we store the opening parenthesis. + (if (and (vector? *list-errors*) + (<fx *par-open* (vector-length *list-errors*))) + (vector-set! *list-errors* + *par-open* + (input-port-position (the-port)))) + ;; we increment the number of open parenthesis + (set! *par-open* (+fx 1 *par-open*)) + ;; and then, we compute the result list... + (make-list! (collect-up-to ignore "list" (the-port)) (the-port))) + (#\) + ;; we decrement the number of open parenthesis + (set! *par-open* (-fx *par-open* 1)) + (if (<fx *par-open* 0) + (begin + (warning/location (input-port-name (the-port)) + (input-port-position (the-port)) + "read" + "Superfluous closing parenthesis `" + (the-string) + "'") + (set! *par-open* 0) + (ignore)) + *end-of-list*)) + + ;; list of strings + (#\[ + (let ((exp (read/rp *text-grammar* (the-port)))) + (list 'quasiquote exp))) + + ;; vectors + ("#(" + ;; if possible, we store the opening parenthesis. + (if (and (vector? *vector-errors*) + (<fx *par-open* (vector-length *vector-errors*))) + (let ((pos (input-port-position (the-port)))) + (vector-set! *vector-errors* *par-open* pos))) + ;; we increment the number of open parenthesis + (set! *par-open* (+fx 1 *par-open*)) + (list->vector (reverse! (collect-up-to ignore "vector" (the-port))))) + + ;; error or eof + (else + (let ((port (the-port)) + (char (the-failure))) + (if (eof-object? char) + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (skribe-reader-reset!) + (if (and (<fx open-key (vector-length *list-errors*)) + (fixnum? (vector-ref *list-errors* open-key))) + (error/location "skribe-read" + "Unclosed list" + char + (input-port-name port) + (vector-ref *list-errors* open-key)) + (error "skribe-read" + "Unexpected end-of-file" + "Unclosed list")))) + (else + (reset-eof port) + char)) + (error/location "skribe-read" + "Illegal char" + (illegal-char-rep char) + (input-port-name port) + (input-port-position port))))))) + +;*---------------------------------------------------------------------*/ +;* *text-grammar* ... */ +;* ------------------------------------------------------------- */ +;* The grammar that parses texts (the [...] forms). */ +;*---------------------------------------------------------------------*/ +(define *text-grammar* + (regular-grammar () + ((: (* (out ",[]\\")) #\]) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1)))) + (econs item '() loc))) + ((: (* (out ",[\\")) ",]") + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1)))) + (econs item '() loc))) + ((: (* (out ",[]\\")) #\,) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1))) + (sexp (read/rp *sexp-grammar* (the-port))) + (rest (ignore))) + (if (string=? item "") + (cons (list 'unquote sexp) rest) + (econs item (cons (list 'unquote sexp) rest) loc)))) + ((or (+ (out ",[]\\")) + (+ #\Newline) + (: (* (out ",[]\\")) #\, (out "([]\\"))) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-string)) + (rest (ignore))) + (econs item rest loc))) + ("\\\\" + (cons "\\" (ignore))) + ("\\n" + (cons "\n" (ignore))) + ("\\t" + (cons "\t" (ignore))) + ("\\]" + (cons "]" (ignore))) + ("\\[" + (cons "[" (ignore))) + ("\\," + (cons "," (ignore))) + (#\\ + (cons "\\" (ignore))) + (else + (let ((c (the-failure)) + (port (the-port))) + (define (err msg) + (error/location "skribe-read-text" + msg + (the-failure) + (input-port-name port) + (input-port-position port))) + (cond + ((eof-object? c) + (err "Illegal `end of file'")) + ((char=? c #\[) + (err "Illegal nested `[...]' form")) + (else + (err "Illegal string character"))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-read ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-read . input-port) + (cond + ((null? input-port) + (read/rp *sexp-grammar* (current-input-port))) + ((not (input-port? (car input-port))) + (error "read" "type `input-port' expected" (car input-port))) + (else + (let ((port (car input-port))) + (if (closed-input-port? port) + (error "read" "Illegal closed input port" port) + (read/rp *sexp-grammar* port)))))) + diff --git a/skribe/src/bigloo/resolve.scm b/skribe/src/bigloo/resolve.scm new file mode 100644 index 0000000..7507560 --- /dev/null +++ b/skribe/src/bigloo/resolve.scm @@ -0,0 +1,281 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/resolve.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jul 25 09:31:18 2003 */ +;* Last change : Sun Jul 11 09:17:52 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe resolve stage */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_resolve + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_bib + skribe_eval) + + (import skribe_index) + + (export (resolve! ::obj ::%engine ::pair-nil) + (resolve-children ::obj) + (resolve-children* ::obj) + (resolve-parent ::%ast ::pair-nil) + (resolve-search-parent ::%ast ::pair-nil ::procedure) + (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o) + (resolve-ident ::bstring ::obj ::%ast ::obj))) + +;*---------------------------------------------------------------------*/ +;* *unresolved* ... */ +;*---------------------------------------------------------------------*/ +(define *unresolved* #f) + +;*---------------------------------------------------------------------*/ +;* resolve! ... */ +;* ------------------------------------------------------------- */ +;* This function iterates over an ast until all unresolved */ +;* references are resolved. */ +;*---------------------------------------------------------------------*/ +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + (let ((old *unresolved*)) + (let loop ((ast ast)) + (set! *unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if *unresolved* + (loop ast) + (begin + (set! *unresolved* old) + ast))))))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ... */ +;*---------------------------------------------------------------------*/ +(define-generic (do-resolve! ast engine env) + (if (pair? ast) + (do-resolve*! ast engine env) + ast)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%node engine env) + (with-access::%node node (body options parent) + (with-debug 5 'do-resolve::body + (debug-item "node=" (if (markup? node) + (markup-markup node) + (find-runtime-type node))) + (debug-item "body=" (find-runtime-type body)) + (if (not (eq? parent #unspecified)) + node + (let ((p (assq 'parent env))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (if (pair? options) + (begin + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options))))) + (set! body (do-resolve! body engine env)) + node))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%container ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%container engine env0) + (with-access::%container node (body options env parent) + (with-debug 5 'do-resolve::%container + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" (find-runtime-type body)) + (debug-item "env0=" env0) + (debug-item "env=" env) + (if (not (eq? parent #unspecified)) + node + (let ((p (assq 'parent env0))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (if (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))) + (let ((e `((parent ,node) ,@env ,@env0))) + (set! body (do-resolve! body engine e)) + node)))) + ;; return the container + node)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%document ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%document engine env0) + (with-access::%document node (env) + (call-next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (%engine-customs engine))) + ;; return the container + node)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%unresolved ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%unresolved engine env) + (with-debug 5 'do-resolve::%unresolved + (debug-item "node=" node) + (with-access::%unresolved node (proc parent loc) + (let ((p (assq 'parent env))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + (let ((res (resolve! (proc node engine env) engine env))) + (if (ast? res) (%ast-loc-set! res loc)) + (debug-item "res=" res) + (set! *unresolved* #t) + res)))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%handle engine env) + node) + +;*---------------------------------------------------------------------*/ +;* do-resolve*! ... */ +;*---------------------------------------------------------------------*/ +(define (do-resolve*! n+ engine env) + (let loop ((n* n+)) + (cond + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (loop (cdr n*))) + ((not (null? n*)) + (skribe-error 'do-resolve "Illegal argument" n*)) + (else + n+)))) + +;*---------------------------------------------------------------------*/ +;* resolve-children ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-children n) + (if (pair? n) + n + (list n))) + +;*---------------------------------------------------------------------*/ +;* resolve-children* ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-children* n) + (cond + ((pair? n) + (map resolve-children* n)) + ((%container? n) + (cons n (resolve-children* (%container-body n)))) + (else + (list n)))) + +;*---------------------------------------------------------------------*/ +;* resolve-parent ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (%ast? n)) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (%ast-parent n) #unspecified) + (skribe-error 'resolve-parent "Orphan node" n)) + (else + (%ast-parent n))))) + +;*---------------------------------------------------------------------*/ +;* resolve-search-parent ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" (find-runtime-type n)) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" (find-runtime-type p) " " + (if (markup? p) (markup-markup p) "???")) + (cond + ((pred p) + p) + ((%unresolved? p) + p) + ((not p) + #f) + (else + (resolve-search-parent p e pred)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-counter ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-ident ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) diff --git a/skribe/src/bigloo/source.scm b/skribe/src/bigloo/source.scm new file mode 100644 index 0000000..babadff --- /dev/null +++ b/skribe/src/bigloo/source.scm @@ -0,0 +1,238 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/source.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Aug 29 07:27:25 2003 */ +;* Last change : Tue Nov 2 14:25:50 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo handling of Skribe programs. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_source + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param) + + (export (source-read-chars::bstring ::bstring ::int ::int ::obj) + (source-read-lines::bstring ::bstring ::obj ::obj ::obj) + (source-read-definition::bstring ::bstring ::obj ::obj ::obj) + (source-fontify ::obj ::obj) + (split-string-newline::pair-nil ::bstring))) + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-chars file start stop tab) + (define (readl p) + (read/rp (regular-grammar () + ((: (* (out #\Newline)) (? #\Newline)) + (the-string)) + (else + (the-failure))) + p)) + (let ((p (find-file/path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let loop ((c -1) + (s (readl (current-input-port))) + (r '())) + (let ((p (input-port-position (current-input-port)))) + (cond + ((eof-object? s) + (apply string-append (reverse! r))) + ((>=fx p stop) + (let* ((len (-fx (-fx stop start) c)) + (line (untabify (substring s 0 len) tab))) + (apply string-append + (reverse! (cons line r))))) + ((>=fx c 0) + (loop (+fx (string-length s) c) + (readl (current-input-port)) + (cons (untabify s tab) r))) + ((>=fx p start) + (let* ((len (string-length s)) + (nc (-fx p start))) + (if (>fx p stop) + (untabify + (substring s + (-fx len (-fx p start)) + (-fx (-fx p stop) 1)) + tab) + (loop nc + (readl (current-input-port)) + (list + (untabify + (substring s + (-fx len (-fx p start)) + len) + tab)))))) + (else + (loop c (readl (current-input-port)) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-file/path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) + (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+fx l 1) #t (read-line) r)) + (else + (loop (+fx l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((=fx i len) + (let ((nlen (-fx col 1))) + (if (=fx len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((=fx i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (*fx (/fx (+fx col tabl) + tabl) + tabl))) + (liip (+fx i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+fx i 1) (+fx j 1) (+fx col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+fx i 1) + (*fx (/fx (+fx col tabl) tabl) tabl))) + (else + (loop (+fx i 1) (+fx col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-file/path file (skribe-source-path)))) + (cond + ((not (%language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + lang)) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((%language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (%language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((=fx i l) + (if (=fx i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+fx i 1) + (+fx i 1) + (if (=fx i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #a013) + (<fx (+fx i 1) l) + (char=? (string-ref str (+fx i 1)) #\Newline)) + (loop (+fx i 2) + (+fx i 2) + (if (=fx i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+fx i 1) j r)))))) + diff --git a/skribe/src/bigloo/sui.bgl b/skribe/src/bigloo/sui.bgl new file mode 100644 index 0000000..63c5477 --- /dev/null +++ b/skribe/src/bigloo/sui.bgl @@ -0,0 +1,34 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/sui.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Thu Jan 1 16:16:03 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe runtime (i.e., the style user functions). */ +;* ------------------------------------------------------------- */ +;* Implementation: @label sui@ */ +;* bigloo: @path ../common/sui.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_sui + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output + skribe_engine) + + (export (load-sui ::bstring) + (sui-ref->url ::bstring ::obj ::obj ::pair-nil) + (sui-title::bstring ::pair-nil) + (sui-file::obj ::pair-nil) + (sui-key::obj ::pair-nil ::obj) + (sui-filter::pair-nil ::obj ::procedure ::procedure))) + diff --git a/skribe/src/bigloo/types.scm b/skribe/src/bigloo/types.scm new file mode 100644 index 0000000..b8babd4 --- /dev/null +++ b/skribe/src/bigloo/types.scm @@ -0,0 +1,685 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/types.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:40:42 2003 */ +;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The definition of the Skribe classes */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_types + + (export (abstract-class %ast + (parent (default #unspecified)) + (loc (default (evmeaning-location)))) + + (class %command::%ast + (fmt::bstring read-only) + (body (default #f))) + + (class %unresolved::%ast + (proc::procedure read-only)) + + (class %handle::%ast + (ast (default #f))) + + (abstract-class %node::%ast + (required-options::pair-nil read-only (default '())) + (options::pair-nil (default '())) + (body (default #f))) + + (class %processor::%node + (combinator (default (lambda (e1 e2) e1))) + (procedure::procedure (default (lambda (n e) n))) + engine) + + (class %markup::%node + (markup-init) + (ident (default #f)) + (class (default #f)) + (markup::symbol read-only)) + + (class %container::%markup + (env::pair-nil (default '()))) + + (class %document::%container) + + (class %engine + (ident::symbol read-only) + (format::bstring (default "raw")) + (info::pair-nil (default '())) + (version::obj read-only (default #unspecified)) + (delegate read-only (default #f)) + (writers::pair-nil (default '())) + (filter::obj (default #f)) + (customs::pair-nil (default '())) + (symbol-table::pair-nil (default '()))) + + (class %writer + (ident::symbol read-only) + (class read-only) + (pred::procedure read-only) + (upred read-only) + (options::obj read-only) + (verified?::bool (default #f)) + (validate (default #f)) + (before read-only) + (action read-only) + (after read-only)) + + (class %language + (name::bstring read-only) + (fontifier read-only (default #f)) + (extractor read-only (default #f))) + + (markup-init ::%markup) + (find-markups ::bstring) + + (inline ast?::bool ::obj) + (inline ast-parent::obj ::%ast) + (inline ast-loc::obj ::%ast) + (inline ast-loc-set!::obj ::%ast ::obj) + (ast-location::bstring ::%ast) + + (new-command . inits) + (inline command?::bool ::obj) + (inline command-fmt::bstring ::%command) + (inline command-body::obj ::%command) + + (new-unresolved . inits) + (inline unresolved?::bool ::obj) + (inline unresolved-proc::procedure ::%unresolved) + + (new-handle . inits) + (inline handle?::bool ::obj) + (inline handle-ast::obj ::%handle) + + (inline node?::bool ::obj) + (inline node-body::obj ::%node) + (inline node-options::pair-nil ::%node) + (inline node-loc::obj ::%node) + + (new-processor . inits) + (inline processor?::bool ::obj) + (inline processor-combinator::obj ::%processor) + (inline processor-engine::obj ::%processor) + + (new-markup . inits) + (inline markup?::bool ::obj) + (inline is-markup?::bool ::obj ::symbol) + (inline markup-markup::obj ::%markup) + (inline markup-ident::obj ::%markup) + (inline markup-body::obj ::%markup) + (inline markup-options::pair-nil ::%markup) + + (new-container . inits) + (inline container?::bool ::obj) + (inline container-ident::obj ::%container) + (inline container-body::obj ::%container) + (inline container-options::pair-nil ::%container) + + (new-document . inits) + (inline document?::bool ::obj) + (inline document-ident::bool ::%document) + (inline document-body::bool ::%document) + (inline document-options::pair-nil ::%document) + (inline document-env::pair-nil ::%document) + + (inline engine?::bool ::obj) + (inline engine-ident::obj ::obj) + (inline engine-format::obj ::obj) + (inline engine-customs::pair-nil ::obj) + (inline engine-filter::obj ::obj) + (inline engine-symbol-table::pair-nil ::%engine) + + (inline writer?::bool ::obj) + (inline writer-before::obj ::%writer) + (inline writer-action::obj ::%writer) + (inline writer-after::obj ::%writer) + (inline writer-options::obj ::%writer) + + (inline language?::bool ::obj) + (inline language-name::obj ::obj) + (inline language-fontifier::obj ::obj) + (inline language-extractor::obj ::obj) + + (new-language . inits) + + (location?::bool ::obj) + (location-file::bstring ::pair) + (location-pos::int ::pair))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate ... */ +;*---------------------------------------------------------------------*/ +(define-macro (skribe-instantiate type values . slots) + `(begin + (skribe-instantiate-check-values ',type ,values ',slots) + (,(symbol-append 'instantiate::% type) + ,@(map (lambda (slot) + (let ((id (if (pair? slot) (car slot) slot)) + (def (if (pair? slot) (cadr slot) #f))) + `(,id (new-get-value ',id ,values ,def)))) + slots)))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate-check-values ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-instantiate-check-values id values slots) + (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) + (when (pair? bs) + (for-each (lambda (b) + (error (symbol-append '|new | id) + "Illegal field" + b)) + bs)))) + +;*---------------------------------------------------------------------*/ +;* object-print ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-print obj::%ast port print-slot::procedure) + (let* ((class (object-class obj)) + (class-name (class-name class))) + (display "#|" port) + (display class-name port) + (display #\| port))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%ast ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%ast . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a>" + (find-runtime-type n))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a>" + (find-runtime-type n) + (markup-markup n))) + +;*---------------------------------------------------------------------*/ +;* object-write ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-write n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a:~a>" + (find-runtime-type n) + (markup-markup n) + (find-runtime-type (markup-body n)))) + +;*---------------------------------------------------------------------*/ +;* *node-table* */ +;* ------------------------------------------------------------- */ +;* A private hashtable that stores all the nodes of an ast. It */ +;* is used for retreiving a node from its identifier. */ +;*---------------------------------------------------------------------*/ +(define *node-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* ast? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast? obj) + (%ast? obj)) + +;*---------------------------------------------------------------------*/ +;* ast-parent ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-parent obj) + (%ast-parent obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc obj) + (%ast-loc obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc-set! ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc-set! obj loc) + (%ast-loc-set! obj loc)) + +;*---------------------------------------------------------------------*/ +;* ast-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast-location obj) + (with-access::%ast obj (loc) + (if (location? loc) + (let* ((fname (location-file loc)) + (char (location-pos loc)) + (pwd (pwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (and (>fx lenf len))) + (substring fname len (+fx 1 (string-length fname))) + fname))) + (format "~a, char ~a" file char)) + "no source location"))) + +;*---------------------------------------------------------------------*/ +;* new-command ... */ +;*---------------------------------------------------------------------*/ +(define (new-command . init) + (skribe-instantiate command init + (parent #unspecified) + (loc #f) + fmt + (body #f))) + +;*---------------------------------------------------------------------*/ +;* command? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command? obj) + (%command? obj)) + +;*---------------------------------------------------------------------*/ +;* command-fmt ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-fmt cmd) + (%command-fmt cmd)) + +;*---------------------------------------------------------------------*/ +;* command-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-body cmd) + (%command-body cmd)) + +;*---------------------------------------------------------------------*/ +;* new-unresolved ... */ +;*---------------------------------------------------------------------*/ +(define (new-unresolved . init) + (skribe-instantiate unresolved init + (parent #unspecified) + loc + proc)) + +;*---------------------------------------------------------------------*/ +;* unresolved? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved? obj) + (%unresolved? obj)) + +;*---------------------------------------------------------------------*/ +;* unresolved-proc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved-proc unr) + (%unresolved-proc unr)) + +;*---------------------------------------------------------------------*/ +;* new-handle ... */ +;*---------------------------------------------------------------------*/ +(define (new-handle . init) + (skribe-instantiate handle init + (parent #unspecified) + loc + (ast #f))) + +;*---------------------------------------------------------------------*/ +;* handle? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle? obj) + (%handle? obj)) + +;*---------------------------------------------------------------------*/ +;* handle-ast ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle-ast obj) + (%handle-ast obj)) + +;*---------------------------------------------------------------------*/ +;* node? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node? obj) + (%node? obj)) + +;*---------------------------------------------------------------------*/ +;* node-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-body obj) + (%node-body obj)) + +;*---------------------------------------------------------------------*/ +;* node-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-options obj) + (%node-options obj)) + +;*---------------------------------------------------------------------*/ +;* node-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-loc obj) + (%node-loc obj)) + +;*---------------------------------------------------------------------*/ +;* new-processor ... */ +;*---------------------------------------------------------------------*/ +(define (new-processor . init) + (skribe-instantiate processor init + (parent #unspecified) + loc + (combinator (lambda (e1 e2) e1)) + engine + (body #f))) + +;*---------------------------------------------------------------------*/ +;* processor? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor? obj) + (%processor? obj)) + +;*---------------------------------------------------------------------*/ +;* processor-combinator ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-combinator proc) + (%processor-combinator proc)) + +;*---------------------------------------------------------------------*/ +;* processor-engine ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-engine proc) + (%processor-engine proc)) + +;*---------------------------------------------------------------------*/ +;* new-markup ... */ +;*---------------------------------------------------------------------*/ +(define (new-markup . init) + (skribe-instantiate markup init + (parent #unspecified) + (loc #f) + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()))) + +;*---------------------------------------------------------------------*/ +;* markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup? obj) + (%markup? obj)) + +;*---------------------------------------------------------------------*/ +;* is-markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (is-markup? obj markup) + (and (markup? obj) (eq? (markup-markup obj) markup))) + +;*---------------------------------------------------------------------*/ +;* markup-init ... */ +;* ------------------------------------------------------------- */ +;* The markup constructor simply stores in the markup table the */ +;* news markups. */ +;*---------------------------------------------------------------------*/ +(define (markup-init markup) + (bind-markup! markup)) + +;*---------------------------------------------------------------------*/ +;* bind-markup! ... */ +;*---------------------------------------------------------------------*/ +(define (bind-markup! node) + (hashtable-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + +;*---------------------------------------------------------------------*/ +;* find-markups ... */ +;*---------------------------------------------------------------------*/ +(define (find-markups ident) + (hashtable-get *node-table* ident)) + +;*---------------------------------------------------------------------*/ +;* markup-markup ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-markup obj) + (%markup-markup obj)) + +;*---------------------------------------------------------------------*/ +;* markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-ident obj) + (%markup-ident obj)) + +;*---------------------------------------------------------------------*/ +;* markup-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-body obj) + (%markup-body obj)) + +;*---------------------------------------------------------------------*/ +;* markup-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-options obj) + (%markup-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-container ... */ +;*---------------------------------------------------------------------*/ +(define (new-container . init) + (skribe-instantiate container init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* container? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container? obj) + (%container? obj)) + +;*---------------------------------------------------------------------*/ +;* container-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-ident obj) + (%container-ident obj)) + +;*---------------------------------------------------------------------*/ +;* container-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-body obj) + (%container-body obj)) + +;*---------------------------------------------------------------------*/ +;* container-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-options obj) + (%container-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-document ... */ +;*---------------------------------------------------------------------*/ +(define (new-document . init) + (skribe-instantiate document init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* document? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document? obj) + (%document? obj)) + +;*---------------------------------------------------------------------*/ +;* document-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-options doc) + (%document-options doc)) + +;*---------------------------------------------------------------------*/ +;* document-env ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-env doc) + (%document-env doc)) + +;*---------------------------------------------------------------------*/ +;* document-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-ident doc) + (%document-ident doc)) + +;*---------------------------------------------------------------------*/ +;* document-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-body doc) + (%document-body doc)) + +;*---------------------------------------------------------------------*/ +;* engine? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine? obj) + (%engine? obj)) + +;*---------------------------------------------------------------------*/ +;* engine-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-ident obj) + (%engine-ident obj)) + +;*---------------------------------------------------------------------*/ +;* engine-format ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-format obj) + (%engine-format obj)) + +;*---------------------------------------------------------------------*/ +;* engine-customs ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-customs obj) + (%engine-customs obj)) + +;*---------------------------------------------------------------------*/ +;* engine-filter ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-filter obj) + (%engine-filter obj)) + +;*---------------------------------------------------------------------*/ +;* engine-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-symbol-table obj) + (%engine-symbol-table obj)) + +;*---------------------------------------------------------------------*/ +;* writer? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer? obj) + (%writer? obj)) + +;*---------------------------------------------------------------------*/ +;* writer-before ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-before obj) + (%writer-before obj)) + +;*---------------------------------------------------------------------*/ +;* writer-action ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-action obj) + (%writer-action obj)) + +;*---------------------------------------------------------------------*/ +;* writer-after ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-after obj) + (%writer-after obj)) + +;*---------------------------------------------------------------------*/ +;* writer-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-options obj) + (%writer-options obj)) + +;*---------------------------------------------------------------------*/ +;* language? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language? obj) + (%language? obj)) + +;*---------------------------------------------------------------------*/ +;* language-name ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-name lg) + (%language-name lg)) + +;*---------------------------------------------------------------------*/ +;* language-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-fontifier lg) + (%language-fontifier lg)) + +;*---------------------------------------------------------------------*/ +;* language-extractor ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-extractor lg) + (%language-extractor lg)) + +;*---------------------------------------------------------------------*/ +;* new-get-value ... */ +;*---------------------------------------------------------------------*/ +(define (new-get-value key init def) + (let ((c (assq key init))) + (match-case c + ((?- ?v) + v) + (else + def)))) + +;*---------------------------------------------------------------------*/ +;* new-language ... */ +;*---------------------------------------------------------------------*/ +(define (new-language . init) + (skribe-instantiate language init name fontifier extractor)) + +;*---------------------------------------------------------------------*/ +;* location? ... */ +;*---------------------------------------------------------------------*/ +(define (location? o) + (match-case o + ((at ?- ?-) + #t) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* location-file ... */ +;*---------------------------------------------------------------------*/ +(define (location-file o) + (match-case o + ((at ?fname ?-) + fname) + (else + (error 'location-file "Illegal location" o)))) + +;*---------------------------------------------------------------------*/ +;* location-pos ... */ +;*---------------------------------------------------------------------*/ +(define (location-pos o) + (match-case o + ((at ?- ?loc) + loc) + (else + (error 'location-pos "Illegal location" o)))) diff --git a/skribe/src/bigloo/verify.scm b/skribe/src/bigloo/verify.scm new file mode 100644 index 0000000..602a951 --- /dev/null +++ b/skribe/src/bigloo/verify.scm @@ -0,0 +1,143 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jul 25 09:54:55 2003 */ +;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe verification stage */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_verify + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (generic verify ::obj ::%engine))) + +;*---------------------------------------------------------------------*/ +;* check-required-options ... */ +;*---------------------------------------------------------------------*/ +(define (check-required-options n::%markup w::%writer e::%engine) + (with-access::%markup n (required-options) + (with-access::%writer w (ident options verified?) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (%engine-ident e) + (format "Option unsupported: ~a, supported options: ~a" o options) + n))) + required-options) + (set! verified? #t)))))) + +;*---------------------------------------------------------------------*/ +;* check-options ... */ +;* ------------------------------------------------------------- */ +;* Only keywords are checked, symbols are voluntary left unchecked. */ +;*---------------------------------------------------------------------*/ +(define (check-options eo*::pair-nil m::%markup e::%engine) + (with-debug 6 'check-options + (debug-item "markup=" (%markup-markup m)) + (debug-item "options=" (%markup-options m)) + (debug-item "eo*=" eo*) + (for-each (lambda (o2) + (for-each (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o eo*))) + (skribe-warning/ast + 3 + m + 'verify + (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" + (%engine-ident e) + (%markup-markup m) + o + (markup-option m o))))) + o2)) + (%markup-options m)))) + +;*---------------------------------------------------------------------*/ +;* verify :: ... */ +;*---------------------------------------------------------------------*/ +(define-generic (verify node e) + (if (pair? node) + (for-each (lambda (n) (verify n e)) node)) + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify n::%processor e) + (with-access::%processor n (combinator engine body) + (verify body (processor-get-engine combinator engine e)) + n)) + +;*---------------------------------------------------------------------*/ +;* verify ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%node e) + (with-access::%node node (body options) + (verify body e) + (for-each (lambda (o) (verify (cadr o) e)) options) + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%markup e) + (with-debug 5 'verify::%markup + (debug-item "node=" (%markup-markup node)) + (debug-item "options=" (%markup-options node)) + (debug-item "e=" (%engine-ident e)) + (call-next-method) + (let ((w (lookup-markup-writer node e))) + (if (%writer? w) + (begin + (check-required-options node w e) + (if (pair? (%writer-options w)) + (check-options (%writer-options w) node e)) + (let ((validate (%writer-validate w))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format "Node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)) + node))))))) + ;; return the node + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%document ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%document e) + (call-next-method) + ;; verify the engine custom + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (%engine-customs e)) + ;; return the node + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%handle e) + node) + diff --git a/skribe/src/bigloo/writer.scm b/skribe/src/bigloo/writer.scm new file mode 100644 index 0000000..ce515bf --- /dev/null +++ b/skribe/src/bigloo/writer.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 06:19:57 2003 */ +;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe writer management */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_writer + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_engine + skribe_output + skribe_lib) + + (export (invoke proc node e) + + (lookup-markup-writer ::%markup ::%engine) + + (markup-writer ::obj #!optional e #!key p class opt va bef aft act) + (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) + (markup-writer-get ::obj #!optional e #!key class pred) + (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) + +;*---------------------------------------------------------------------*/ +;* invoke ... */ +;*---------------------------------------------------------------------*/ +(define (invoke proc node e) + (let ((id (if (markup? node) + (string->symbol + (format "~a#~a" + (%engine-ident e) + (%markup-markup node))) + (%engine-ident e)))) + (with-push-trace id + (with-debug 5 'invoke + (debug-item "e=" (%engine-ident e)) + (debug-item "node=" (find-runtime-type node) + " " (if (markup? node) (%markup-markup node) "")) + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))))) + +;*---------------------------------------------------------------------*/ +;* lookup-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (lookup-markup-writer node e) + (with-access::%engine e (writers delegate) + (let loop ((w* writers)) + (cond + ((pair? w*) + (with-access::%writer (car w*) (pred) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* make-writer-predicate ... */ +;*---------------------------------------------------------------------*/ +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (%markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (correct-arity? predicate 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;*---------------------------------------------------------------------*/ +;* markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (markup-writer markup + #!optional + engine + #!key + (predicate #f) + (class #f) + (options '()) + (validate #f) + (before #f) + (action #unspecified) + (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action #unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action #unspecified) + (lambda (n e) + (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + +;*---------------------------------------------------------------------*/ +;* copy-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (copy-markup-writer markup old-engine + #!optional new-engine + #!key + (predicate #unspecified) + (class #unspecified) + (options #unspecified) + (validate #unspecified) + (before #unspecified) + (action #unspecified) + (after #unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) + (%writer-pred old) + predicate) + :class (if (unspecified? class) + (%writer-class old) + class) + :options (if (unspecified? options) + (%writer-options old) + options) + :validate (if (unspecified? validate) + (%writer-validate old) + validate) + :before (if (unspecified? before) + (%writer-before old) + before) + :action (if (unspecified? action) + (%writer-action old) + action) + :after (if (unspecified? after) + (%writer-after old) after)))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get ... */ +;* ------------------------------------------------------------- */ +;* Finds the writer that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (%engine-writers e))) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class) + (or (eq? pred #unspecified) + (eq? (%writer-upred (car w*)) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get* ... */ +;* ------------------------------------------------------------- */ +;* Finds alll writers that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get* markup #!optional engine #!key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (%engine-writers e)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e) res)) + (else + (reverse! res))))))))) diff --git a/skribe/src/bigloo/xml.scm b/skribe/src/bigloo/xml.scm new file mode 100644 index 0000000..d4c662e --- /dev/null +++ b/skribe/src/bigloo/xml.scm @@ -0,0 +1,92 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Mon May 17 10:14:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* XML fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_xml + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export xml)) + +;*---------------------------------------------------------------------*/ +;* xml ... */ +;*---------------------------------------------------------------------*/ +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* xml-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (xml-fontifier s) + (let ((g (regular-grammar () + ((: #\; (in "<!--") (* (or all #\Newline)) "-->") + ;; italic comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>) + ;; markup + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-module) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\< #\> #\Space #\Tab #\= #\")) + ;; regular text + (let ((string (the-string))) + (cons string (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((in "\"=") + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(xml)" "Unexpected character" c))))))) + (with-input-from-string s + (lambda () + (read/rp g (current-input-port)))))) + diff --git a/skribe/src/common/api.scm b/skribe/src/common/api.scm new file mode 100644 index 0000000..397ba09 --- /dev/null +++ b/skribe/src/common/api.scm @@ -0,0 +1,1243 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/api.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:11:56 2003 */ +;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Scribe API */ +;* ------------------------------------------------------------- */ +;* Implementation: @label api@ */ +;* bigloo: @path ../bigloo/api.bgl@ */ +;* Documentation: */ +;* @path ../../doc/user/markup.skb@ */ +;* @path ../../doc/user/document.skb@ */ +;* @path ../../doc/user/sectioning.skb@ */ +;* @path ../../doc/user/toc.skb@ */ +;* @path ../../doc/user/ornament.skb@ */ +;* @path ../../doc/user/line.skb@ */ +;* @path ../../doc/user/font.skb@ */ +;* @path ../../doc/user/justify.skb@ */ +;* @path ../../doc/user/enumeration.skb@ */ +;* @path ../../doc/user/colframe.skb@ */ +;* @path ../../doc/user/figure.skb@ */ +;* @path ../../doc/user/image.skb@ */ +;* @path ../../doc/user/table.skb@ */ +;* @path ../../doc/user/footnote.skb@ */ +;* @path ../../doc/user/char.skb@ */ +;* @path ../../doc/user/links.skb@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* include ... */ +;*---------------------------------------------------------------------*/ +(define-markup (include file) + (if (not (string? file)) + (skribe-error 'include "Illegal file (string expected)" file) + (skribe-include file))) + +;*---------------------------------------------------------------------*/ +;* document ... */ +;*---------------------------------------------------------------------*/ +(define-markup (document #!rest + opts + #!key + (ident #f) (class "document") + (title #f) (html-title #f) (author #f) + (ending #f) (env '())) + (new document + (markup 'document) + (ident (or ident + (ast->string title) + (symbol->string (gensym 'document)))) + (class class) + (required-options '(:title :author :ending)) + (options (the-options opts :ident :class :env)) + (body (the-body opts)) + (env (append env + (list (list 'chapter-counter 0) (list 'chapter-env '()) + (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()) + (list 'figure-counter 0) (list 'figure-env '())))))) + +;*---------------------------------------------------------------------*/ +;* author ... */ +;*---------------------------------------------------------------------*/ +(define-markup (author #!rest + opts + #!key + (ident #f) (class "author") + name + (title #f) + (affiliation #f) + (email #f) + (url #f) + (address #f) + (phone #f) + (photo #f) + (align 'center)) + (if (not (memq align '(center left right))) + (skribe-error 'author "Illegal align value" align) + (new container + (markup 'author) + (ident (or ident (symbol->string (gensym 'author)))) + (class class) + (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) + (options `((:name ,name) + (:align ,align) + ,@(the-options opts :ident :class))) + (body #f)))) + +;*---------------------------------------------------------------------*/ +;* toc ... */ +;*---------------------------------------------------------------------*/ +(define-markup (toc #!rest + opts + #!key + (ident #f) (class "toc") + (chapter #t) (section #t) (subsection #f)) + (let ((body (the-body opts))) + (new container + (markup 'toc) + (ident (or ident (symbol->string (gensym 'toc)))) + (class class) + (required-options '()) + (options `((:chapter ,chapter) + (:section ,section) + (:subsection ,subsection) + ,@(the-options opts :ident :class))) + (body (cond + ((null? body) + (new unresolved + (proc (lambda (n e env) + (handle + (resolve-search-parent n env document?)))))) + ((null? (cdr body)) + (if (handle? (car body)) + (car body) + (skribe-error 'toc + "Illegal argument (handle expected)" + (if (markup? (car body)) + (markup-markup (car body)) + "???")))) + (else + (skribe-error 'toc "Illegal argument" body))))))) + +;*---------------------------------------------------------------------*/ +;* chapter ... ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:chapter@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:chapter@ */ +;*---------------------------------------------------------------------*/ +(define-markup (chapter #!rest + opts + #!key + (ident #f) (class "chapter") + title (html-title #f) (file #f) (toc #t) (number #t)) + (new container + (markup 'chapter) + (ident (or ident (ast->string title))) + (class class) + (required-options '(:title :file :toc :number)) + (options `((:toc ,toc) + (:number ,(and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n + env + 'chapter + number)))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'section-counter 0) (list 'section-env '()) + (list 'footnote-counter 0) (list 'footnote-env '()))))) + +;*---------------------------------------------------------------------*/ +;* section-number ... */ +;*---------------------------------------------------------------------*/ +(define (section-number number markup) + (and number + (new unresolved + (proc (lambda (n e env) + (resolve-counter n env markup number)))))) + +;*---------------------------------------------------------------------*/ +;* section ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:section@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:sectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (section #!rest + opts + #!key + (ident #f) (class "section") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'section) + (ident (or ident (ast->string title))) + (class class) + (required-options '(:title :toc :file :toc :number)) + (options `((:number ,(section-number number 'section)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (if file + (list (list 'subsection-counter 0) (list 'subsection-env '()) + (list 'footnote-counter 0) (list 'footnote-env '())) + (list (list 'subsection-counter 0) (list 'subsection-env '())))))) + +;*---------------------------------------------------------------------*/ +;* subsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsection #!rest + opts + #!key + (ident #f) (class "subsection") + title (file #f) (toc #t) (number #t)) + (new container + (markup 'subsection) + (ident (or ident (ast->string title))) + (class class) + (required-options '(:title :toc :file :number)) + (options `((:number ,(section-number number 'subsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)) + (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) + +;*---------------------------------------------------------------------*/ +;* subsubsection ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:subsubsectionr@ */ +;*---------------------------------------------------------------------*/ +(define-markup (subsubsection #!rest + opts + #!key + (ident #f) (class "subsubsection") + title (file #f) (toc #f) (number #t)) + (new container + (markup 'subsubsection) + (ident (or ident (ast->string title))) + (class class) + (required-options '(:title :toc :number :file)) + (options `((:number ,(section-number number 'subsubsection)) + (:toc ,toc) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* paragraph ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup paragraph) + +;*---------------------------------------------------------------------*/ +;* footnote ... */ +;*---------------------------------------------------------------------*/ +(define-markup (footnote #!rest opts + #!key (ident #f) (class "footnote") (number #f)) + (new container + (markup 'footnote) + (ident (symbol->string (gensym 'footnote))) + (class class) + (required-options '()) + (options `((:number + ,(new unresolved + (proc (lambda (n e env) + (resolve-counter n env 'footnote #t))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) + (let ((ln (new markup + (ident (or ident (symbol->string (gensym 'linebreak)))) + (class class) + (markup 'linebreak))) + (num (the-body opts))) + (cond + ((null? num) + ln) + ((not (null? (cdr num))) + (skribe-error 'linebreak "Illegal arguments" num)) + ((not (and (integer? (car num)) (positive? (car num)))) + (skribe-error 'linebreak "Illegal argument" (car num))) + (else + (vector->list (make-vector (car num) ln)))))) + +;*---------------------------------------------------------------------*/ +;* hrule ... */ +;*---------------------------------------------------------------------*/ +(define-markup (hrule #!rest + opts + #!key + (ident #f) (class #f) + (width 100.) (height 1)) + (new markup + (markup 'hrule) + (ident (or ident (symbol->string (gensym 'hrule)))) + (class class) + (required-options '()) + (options `((:width ,width) + (:height ,height) + ,@(the-options opts :ident :class))) + (body #f))) + +;*---------------------------------------------------------------------*/ +;* color ... */ +;*---------------------------------------------------------------------*/ +(define-markup (color #!rest + opts + #!key + (ident #f) (class "color") + (bg #f) (fg #f) (width #f) (margin #f)) + (new container + (markup 'color) + (ident (or ident (symbol->string (gensym 'color)))) + (class class) + (required-options '(:bg :fg :width)) + (options `((:bg ,(if bg (skribe-use-color! bg) bg)) + (:fg ,(if fg (skribe-use-color! fg) fg)) + ,@(the-options opts :ident :class :bg :fg))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define-markup (frame #!rest + opts + #!key + (ident #f) (class "frame") + (width #f) (margin 2) (border 1)) + (new container + (markup 'frame) + (ident (or ident (symbol->string (gensym 'frame)))) + (class class) + (required-options '(:width :border :margin)) + (options `((:margin ,margin) + (:border ,(cond + ((integer? border) border) + (border 1) + (else #f))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* font ... */ +;*---------------------------------------------------------------------*/ +(define-markup (font #!rest + opts + #!key + (ident #f) (class #f) + (size #f) (face #f)) + (new container + (markup 'font) + (ident (or ident (symbol->string (gensym 'font)))) + (class class) + (required-options '(:size)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* flush ... */ +;*---------------------------------------------------------------------*/ +(define-markup (flush #!rest + opts + #!key + (ident #f) (class #f) + side) + (case side + ((center left right) + (new container + (markup 'flush) + (ident (or ident (symbol->string (gensym 'flush)))) + (class class) + (required-options '(:side)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + (else + (skribe-error 'flush "Illegal side" side)))) + +;*---------------------------------------------------------------------*/ +;* center ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container center) + +;*---------------------------------------------------------------------*/ +;* pre ... */ +;*---------------------------------------------------------------------*/ +(define-simple-container pre) + +;*---------------------------------------------------------------------*/ +;* prog ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:prog@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:prog@ */ +;*---------------------------------------------------------------------*/ +(define-markup (prog #!rest + opts + #!key + (ident #f) (class "prog") + (line 1) (linedigit #f) (mark ";!")) + (if (not (or (string? mark) (eq? mark #f))) + (skribe-error 'prog "Illegal mark" mark) + (new container + (markup 'prog) + (ident (or ident (symbol->string (gensym 'prog)))) + (class class) + (required-options '(:line :mark)) + (options (the-options opts :ident :class :linedigit)) + (body (make-prog-body (the-body opts) line linedigit mark))))) + +;*---------------------------------------------------------------------*/ +;* source ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:source@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:source@ */ +;*---------------------------------------------------------------------*/ +(define-markup (source #!rest + opts + #!key + language + (file #f) (start #f) (stop #f) + (definition #f) (tab 8)) + (let ((body (the-body opts))) + (cond + ((and (not (null? body)) (or file start stop definition)) + (skribe-error 'source + "file, start/stop, and definition are exclusive with body" + body)) + ((and start stop definition) + (skribe-error 'source + "start/stop are exclusive with a definition" + body)) + ((and (or start stop definition) (not file)) + (skribe-error 'source + "start/stop and definition require a file specification" + file)) + ((and definition (not language)) + (skribe-error 'source + "definition requires a language specification" + definition)) + ((and file (not (string? file))) + (skribe-error 'source "Illegal file" file)) + ((and start (not (or (integer? start) (string? start)))) + (skribe-error 'source "Illegal start" start)) + ((and stop (not (or (integer? stop) (string? stop)))) + (skribe-error 'source "Illegal start" stop)) + ((and (integer? start) (integer? stop) (> start stop)) + (skribe-error 'source + "start line > stop line" + (format "~a/~a" start stop))) + ((and language (not (language? language))) + (skribe-error 'source "Illegal language" language)) + ((and tab (not (integer? tab))) + (skribe-error 'source "Illegal tab" tab)) + (file + (let ((s (if (not definition) + (source-read-lines file start stop tab) + (source-read-definition file definition tab language)))) + (if language + (source-fontify s language) + s))) + (language + (source-fontify body language)) + (else + body)))) + +;*---------------------------------------------------------------------*/ +;* language ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/prgm.skb:language@ */ +;*---------------------------------------------------------------------*/ +(define-markup (language #!key name (fontifier #f) (extractor #f)) + (if (not (string? name)) + (skribe-type-error 'language "Illegal name, " name "string") + (new language + (name name) + (fontifier fontifier) + (extractor extractor)))) + +;*---------------------------------------------------------------------*/ +;* figure ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/figure.skb:figure@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:figure@ */ +;*---------------------------------------------------------------------*/ +(define-markup (figure #!rest + opts + #!key + (ident #f) (class "figure") + (legend #f) (number #t) (multicolumns #f)) + (new container + (markup 'figure) + (ident (or ident + (let ((s (ast->string legend))) + (if (not (string=? s "")) + s + (symbol->string (gensym 'figure)))))) + (class class) + (required-options '(:legend :number :multicolumns)) + (options `((:number + ,(new unresolved + (proc (lambda (n e env) + (resolve-counter n env 'figure number))))) + ,@(the-options opts :ident :class))) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* parse-list-of ... */ +;* ------------------------------------------------------------- */ +;* The function table accepts two different prototypes. It */ +;* may receive its N elements in a list of N elements or in */ +;* a list of one element which is a list of N elements. This */ +;* gets rid of APPLY when calling container markup such as ITEMIZE */ +;* or TABLE. */ +;*---------------------------------------------------------------------*/ +(define (parse-list-of for markup lst) + (cond + ((null? lst) + '()) + ((and (pair? lst) + (or (pair? (car lst)) (null? (car lst))) + (null? (cdr lst))) + (parse-list-of for markup (car lst))) + (else + (let loop ((lst lst)) + (cond + ((null? lst) + '()) + ((pair? (car lst)) + (loop (car lst))) + (else + (let ((r (car lst))) + (if (not (is-markup? r markup)) + (skribe-warning 2 + for + (format "Illegal `~a' element, `~a' expected" + (if (markup? r) + (markup-markup r) + (find-runtime-type r)) + markup))) + (cons r (loop (cdr lst)))))))))) + +;*---------------------------------------------------------------------*/ +;* itemize ... */ +;*---------------------------------------------------------------------*/ +(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) + (new container + (markup 'itemize) + (ident (or ident (symbol->string (gensym 'itemize)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'itemize 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* enumerate ... */ +;*---------------------------------------------------------------------*/ +(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) + (new container + (markup 'enumerate) + (ident (or ident (symbol->string (gensym 'enumerate)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'enumerate 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* description ... */ +;*---------------------------------------------------------------------*/ +(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) + (new container + (markup 'description) + (ident (or ident (symbol->string (gensym 'description)))) + (class class) + (required-options '(:symbol)) + (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) + (body (parse-list-of 'description 'item (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* item ... */ +;*---------------------------------------------------------------------*/ +(define-markup (item #!rest opts #!key (ident #f) (class #f) key) + (if (and key (not (or (string? key) + (number? key) + (markup? key) + (pair? key)))) + (skribe-type-error 'item "Illegal key:" key "node") + (new container + (markup 'item) + (ident (or ident (symbol->string (gensym 'item)))) + (class class) + (required-options '(:key)) + (options `((:key ,key) ,@(the-options opts :ident :class :key))) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* table */ +;*---------------------------------------------------------------------*/ +(define-markup (table #!rest + opts + #!key + (ident #f) (class #f) + (border #f) (width #f) + (frame 'none) (rules 'none) + (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) + (let ((frame (cond + ((string? frame) + (string->symbol frame)) + ((not frame) + #f) + (else + frame))) + (rules (cond + ((string? rules) + (string->symbol rules)) + ((not rules) + #f) + (else + rules))) + (frame-vals '(none above below hsides vsides lhs rhs box border)) + (rules-vals '(none rows cols all header)) + (cells-vals '(collapse separate))) + (cond + ((and frame (not (memq frame frame-vals))) + (skribe-error 'table + (format "frame should be one of \"~a\"" frame-vals) + frame)) + ((and rules (not (memq rules rules-vals))) + (skribe-error 'table + (format "rules should be one of \"~a\"" rules-vals) + rules)) + ((not (or (memq cellstyle cells-vals) + (string? cellstyle) + (number? cellstyle))) + (skribe-error 'table + (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) + cellstyle)) + (else + (new container + (markup 'table) + (ident (or ident (symbol->string (gensym 'table)))) + (class class) + (required-options '(:width :frame :rules)) + (options `((:frame ,frame) + (:rules ,rules) + (:cellstyle ,cellstyle) + ,@(the-options opts :ident :class))) + (body (parse-list-of 'table 'tr (the-body opts)))))))) + +;*---------------------------------------------------------------------*/ +;* tr ... */ +;*---------------------------------------------------------------------*/ +(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) + (new container + (markup 'tr) + (ident (or ident (symbol->string (gensym 'tr)))) + (class class) + (required-options '()) + (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) + ,@(the-options opts :ident :class :bg))) + (body (parse-list-of 'tr 'tc (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* tc... */ +;*---------------------------------------------------------------------*/ +(define-markup (tc m + #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (let ((align (if (string? align) + (string->symbol align) + align)) + (valign (if (string? valign) + (string->symbol valign) + valign))) + (cond + ((not (integer? colspan)) + (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) + ((not (symbol? align)) + (skribe-type-error 'tc "Illegal align, " align "align")) + ((not (memq align '(#f center left right))) + (skribe-error + 'tc + "align should be one of 'left', `center', or `right'" + align)) + ((not (memq valign '(#f top middle center bottom))) + (skribe-error + 'tc + "valign should be one of 'top', `middle', `center', or `bottom'" + valign)) + (else + (new container + (markup 'tc) + (ident (or ident (symbol->string (gensym 'tc)))) + (class class) + (required-options '(:width :align :valign :colspan)) + (options `((markup ,m) + (:align ,align) + (:valign ,valign) + (:colspan ,colspan) + ,@(if bg + `((:bg ,(if bg (skribe-use-color! bg) bg))) + '()) + ,@(the-options opts :ident :class :bg :align :valign))) + (body (the-body opts))))))) + +;*---------------------------------------------------------------------*/ +;* th ... */ +;*---------------------------------------------------------------------*/ +(define-markup (th #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (apply tc 'th opts)) + +;*---------------------------------------------------------------------*/ +;* td ... */ +;*---------------------------------------------------------------------*/ +(define-markup (td #!rest + opts + #!key + (ident #f) (class #f) + (width #f) (align 'center) (valign #f) + (colspan 1) (bg #f)) + (apply tc 'td opts)) + +;*---------------------------------------------------------------------*/ +;* image ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/image.skb:image@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:image@ */ +;* latex: @ref ../../skr/latex.skr:image@ */ +;*---------------------------------------------------------------------*/ +(define-markup (image #!rest + opts + #!key + (ident #f) (class #f) + file (url #f) (width #f) (height #f) (zoom #f)) + (cond + ((not (or (string? file) (string? url))) + (skribe-error 'image "No file or url provided" file)) + ((and (string? file) (string? url)) + (skribe-error 'image "Both file and url provided" (list file url))) + (else + (new markup + (markup 'image) + (ident (or ident (symbol->string (gensym 'image)))) + (class class) + (required-options '(:file :url :width :height)) + (options (the-options opts :ident :class)) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* blockquote */ +;*---------------------------------------------------------------------*/ +(define-simple-markup blockquote) + +;*---------------------------------------------------------------------*/ +;* Ornaments ... */ +;*---------------------------------------------------------------------*/ +(define-simple-markup roman) +(define-simple-markup bold) +(define-simple-markup underline) +(define-simple-markup strike) +(define-simple-markup emph) +(define-simple-markup kbd) +(define-simple-markup it) +(define-simple-markup tt) +(define-simple-markup code) +(define-simple-markup var) +(define-simple-markup samp) +(define-simple-markup sf) +(define-simple-markup sc) +(define-simple-markup sub) +(define-simple-markup sup) + +;*---------------------------------------------------------------------*/ +;* char ... */ +;*---------------------------------------------------------------------*/ +(define-markup (char char) + (cond + ((char? char) + (string char)) + ((integer? char) + (string (integer->char char))) + ((and (string? char) (= (string-length char) 1)) + char) + (else + (skribe-error 'char "Illegal char" char)))) + +;*---------------------------------------------------------------------*/ +;* symbol ... */ +;*---------------------------------------------------------------------*/ +(define-markup (symbol symbol) + (let ((v (cond + ((symbol? symbol) + (symbol->string symbol)) + ((string? symbol) + symbol) + (else + (skribe-error 'symbol + "Illegal argument (symbol expected)" + symbol))))) + (new markup + (markup 'symbol) + (body v)))) + +;*---------------------------------------------------------------------*/ +;* ! ... */ +;*---------------------------------------------------------------------*/ +(define-markup (! format #!rest node) + (if (not (string? format)) + (skribe-type-error '! "Illegal format:" format "string") + (new command + (fmt format) + (body node)))) + +;*---------------------------------------------------------------------*/ +;* processor ... */ +;*---------------------------------------------------------------------*/ +(define-markup (processor #!rest opts + #!key (combinator #f) (engine #f) (procedure #f)) + (cond + ((and combinator (not (procedure? combinator))) + (skribe-error 'processor "Combinator not a procedure" combinator)) + ((and engine (not (engine? engine))) + (skribe-error 'processor "Illegal engine" engine)) + ((and procedure + (or (not (procedure? procedure)) + (not (correct-arity? procedure 2)))) + (skribe-error 'processor "Illegal procedure" procedure)) + (else + (new processor + (combinator combinator) + (engine engine) + (procedure (or procedure (lambda (n e) n))) + (body (the-body opts)))))) + +;*---------------------------------------------------------------------*/ +;* Processors ... */ +;*---------------------------------------------------------------------*/ +(define-processor-markup html-processor) +(define-processor-markup tex-processor) + +;*---------------------------------------------------------------------*/ +;* handle ... */ +;*---------------------------------------------------------------------*/ +(define-markup (handle #!rest opts + #!key (ident #f) (class "handle") value section) + (let ((body (the-body opts))) + (cond + (section + (error 'handle "Illegal handle `section' option" section) + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident section 'section n env))) + (new handle + (ast s))))))) + ((and (pair? body) + (null? (cdr body)) + (markup? (car body))) + (new handle + (ast (car body)))) + (else + (skribe-error 'handle "Illegal handle" opts))))) + +;*---------------------------------------------------------------------*/ +;* mailto ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mailto@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mailto@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) + (new markup + (markup 'mailto) + (ident (or ident (symbol->string (gensym 'ident)))) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* *mark-table* ... */ +;*---------------------------------------------------------------------*/ +(define *mark-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* mark ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:mark@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:mark@ */ +;*---------------------------------------------------------------------*/ +(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) + (let ((bd (the-body opts))) + (cond + ((and (pair? bd) (not (null? (cdr bd)))) + (skribe-error 'mark "Too many argument provided" bd)) + ((null? bd) + (skribe-error 'mark "Missing argument" '())) + ((not (string? (car bd))) + (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) + (ident + (skribe-error 'mark "Illegal `ident:' option" ident)) + (else + (let* ((bs (ast->string bd)) + (n (new markup + (markup 'mark) + (ident bs) + (class class) + (options (the-options opts :ident :class :text)) + (body text)))) + (hashtable-put! *mark-table* bs n) + n))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/links.skb:ref@ */ +;* writer: */ +;* html: @ref ../../skr/html.skr:ref@ */ +;* latex: @ref ../../skr/latex.skr:ref@ */ +;*---------------------------------------------------------------------*/ +(define-markup (ref #!rest + opts + #!key + (class #f) + (ident #f) + (text #f) + (chapter #f) + (section #f) + (subsection #f) + (subsubsection #f) + (bib #f) + (bib-table (default-bib-table)) + (url #f) + (figure #f) + (mark #f) + (handle #f) + (line #f) + (skribe #f) + (page #f)) + (define (unref ast text kind) + (let ((msg (format "Can't find `~a': " kind))) + (if (ast? ast) + (begin + (skribe-warning/ast 1 ast 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string 'unref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body (list text ": " (ast->file-location ast))))) + (begin + (skribe-warning 1 'ref msg text) + (new markup + (markup 'unref) + (ident (symbol->string 'unref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) ,@(the-options opts :ident :class))) + (body text)))))) + (define (skribe-ref skribe) + (let ((path (find-file/path skribe (skribe-path)))) + (if (not path) + (unref #f skribe 'sui-file) + (let* ((sui (load-sui path)) + (os (the-options opts :skribe :class :text)) + (u (sui-ref->url (dirname path) sui ident os))) + (if (not u) + (unref #f os 'sui-ref) + (ref :url u :text text :ident ident :class class)))))) + (define (handle-ref text) + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind handle) ,@(the-options opts :ident :class))) + (body text))) + (define (doref text kind) + (if (not (string? text)) + (skribe-type-error 'ref "Illegal reference" text "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (resolve-ident text kind n env))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind ,kind) + (mark ,text) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n text (or kind 'ident))))))))) + (define (mark-ref mark) + (if (not (string? mark)) + (skribe-type-error 'mark "Illegal mark, " mark "string") + (new unresolved + (proc (lambda (n e env) + (let ((s (hashtable-get *mark-table* mark))) + (if s + (new markup + (markup 'ref) + (ident (symbol->string 'ref)) + (class class) + (required-options '(:text)) + (options `((kind mark) + (mark ,mark) + ,@(the-options opts :ident :class))) + (body (new handle + (ast s)))) + (unref n mark 'mark)))))))) + (define (make-bib-ref v) + (let ((s (resolve-bib bib-table v))) + (if s + (let* ((n (new markup + (markup 'bib-ref) + (ident (symbol->string 'bib-ref)) + (class class) + (required-options '(:text)) + (options (the-options opts :ident :class)) + (body (new handle + (ast s))))) + (h (new handle (ast n))) + (o (markup-option s 'used))) + (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) + n) + (unref #f v 'bib)))) + (define (bib-ref text) + (if (pair? text) + (new markup + (markup 'bib-ref+) + (ident (symbol->string 'bib-ref+)) + (class class) + (options (the-options opts :ident :class)) + (body (map make-bib-ref text))) + (make-bib-ref text))) + (define (url-ref) + (new markup + (markup 'url-ref) + (ident (symbol->string 'url-ref)) + (class class) + (required-options '(:url :text)) + (options (the-options opts :ident :class)))) + (define (line-ref line) + (new unresolved + (proc (lambda (n e env) + (let ((l (resolve-line line))) + (if (pair? l) + (new markup + (markup 'line-ref) + (ident (symbol->string 'line-ref)) + (class class) + (options `((:text ,(markup-ident (car l))) + ,@(the-options opts :ident :class))) + (body (new handle + (ast (car l))))) + (unref n line 'line))))))) + (let ((b (the-body opts))) + (if (not (null? b)) + (skribe-warning 1 'ref "Arguments ignored " b)) + (cond + (skribe (skribe-ref skribe)) + (handle (handle-ref handle)) + (ident (doref ident #f)) + (chapter (doref chapter 'chapter)) + (section (doref section 'section)) + (subsection (doref subsection 'subsection)) + (subsubsection (doref subsubsection 'subsubsection)) + (figure (doref figure 'figure)) + (mark (mark-ref mark)) + (bib (bib-ref bib)) + (url (url-ref)) + (line (line-ref line)) + (else (skribe-error 'ref "Illegal reference" opts))))) + +;*---------------------------------------------------------------------*/ +;* resolve ... */ +;*---------------------------------------------------------------------*/ +(define-markup (resolve fun) + (new unresolved + (proc fun))) + +;*---------------------------------------------------------------------*/ +;* bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (bibliography #!rest files + #!key + (command #f) (bib-table (default-bib-table))) + (for-each (lambda (f) + (cond + ((string? f) + (bib-load! bib-table f command)) + ((pair? f) + (bib-add! bib-table f)) + (else + (skribe-error "bibliography" "Illegal entry" f)))) + (the-body files))) + +;*---------------------------------------------------------------------*/ +;* the-bibliography ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/bib.skb:the-bibliography@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-bibliography@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-bibliography #!rest opts + #!key + pred + (bib-table (default-bib-table)) + (sort bib-sort/authors) + (count 'partial)) + (if (not (memq count '(partial full))) + (skribe-error 'the-bibliography + "Cound must be either `partial' or `full'" + count) + (new unresolved + (proc (lambda (n e env) + (resolve-the-bib bib-table + (new handle (ast n)) + sort + pred + count + (the-options opts))))))) + +;*---------------------------------------------------------------------*/ +;* make-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:make-index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (make-index ident) + (make-index-table ident)) + +;*---------------------------------------------------------------------*/ +;* index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:index@ */ +;*---------------------------------------------------------------------*/ +(define-markup (index #!rest + opts + #!key + (ident #f) (class "index") + (note #f) (index #f) (shape #f) + (url #f)) + (let* ((entry-name (the-body opts)) + (ename (cond + ((string? entry-name) + entry-name) + ((and (pair? entry-name) (every string? entry-name)) + (apply string-append entry-name)) + (else + (skribe-error + 'index + "entry-name must be either a string or a list of strings" + entry-name)))) + (table (cond + ((not index) (default-index)) + ((index? index) index) + (else (skribe-type-error 'index + "Illegal index table, " + index + "index")))) + (m (mark (symbol->string (gensym)))) + (h (new handle (ast m))) + (new (new markup + (markup '&index-entry) + (ident (or ident (symbol->string (gensym 'index)))) + (class class) + (options `((name ,ename) ,@(the-options opts :ident :class))) + (body (if url + (ref :url url :text (or shape ename)) + (ref :handle h :text (or shape ename))))))) + ;; New is bound to a dummy option of the mark in order + ;; to make new options verified. + (markup-option-add! m 'to-verify new) + (hashtable-update! table + ename + (lambda (cur) (cons new cur)) + (list new)) + m)) + +;*---------------------------------------------------------------------*/ +;* the-index ... */ +;* ------------------------------------------------------------- */ +;* doc: */ +;* @ref ../../doc/user/index.skb:the-index@ */ +;* writer: */ +;* base: @ref ../../skr/base.skr:the-index@ */ +;* html: @ref ../../skr/html.skr:the-index-header@ */ +;*---------------------------------------------------------------------*/ +(define-markup (the-index #!rest + opts + #!key + (ident #f) + (class "the-index") + (split #f) + (char-offset 0) + (header-limit 50) + (column 1)) + (let ((bd (the-body opts))) + (cond + ((not (and (integer? char-offset) (>= char-offset 0))) + (skribe-error 'the-index "Illegal char offset" char-offset)) + ((not (integer? column)) + (skribe-error 'the-index "Illegal column number" column)) + ((not (every? index? bd)) + (skribe-error 'the-index + "Illegal indexes" + (filter (lambda (o) (not (index? o))) bd))) + (else + (new unresolved + (proc (lambda (n e env) + (resolve-the-index (ast-loc n) + ident class + bd + split + char-offset + header-limit + column)))))))) diff --git a/skribe/src/common/bib.scm b/skribe/src/common/bib.scm new file mode 100644 index 0000000..b73c5f0 --- /dev/null +++ b/skribe/src/common/bib.scm @@ -0,0 +1,192 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/bib.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Dec 7 06:12:29 2001 */ +;* Last change : Wed Jan 14 08:02:45 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe Bibliography */ +;* ------------------------------------------------------------- */ +;* Implementation: @label bib@ */ +;* bigloo: @path ../bigloo/bib.bgl@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* bib-load! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-load! table filename command) + (if (not (bib-table? table)) + (skribe-error 'bib-load "Illegal bibliography table" table) + ;; read the file + (let ((p (skribe-open-bib-file filename command))) + (if (not (input-port? p)) + (skribe-error 'bib-load "Can't open data base" filename) + (unwind-protect + (parse-bib table p) + (close-input-port p)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-bib table ident) + (if (not (bib-table? table)) + (skribe-error 'resolve-bib "Illegal bibliography table" table) + (let* ((i (cond + ((string? ident) ident) + ((symbol? ident) (symbol->string ident)) + (else (skribe-error 'resolve-bib "Illegal ident" ident)))) + (en (hashtable-get table i))) + (if (is-markup? en '&bib-entry) + en + #f)))) + +;*---------------------------------------------------------------------*/ +;* make-bib-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-entry kind ident fields from) + (let* ((m (new markup + (markup '&bib-entry) + (ident ident) + (options `((kind ,kind) (from ,from))))) + (h (new handle + (ast m)))) + (for-each (lambda (f) + (if (and (pair? f) + (pair? (cdr f)) + (null? (cddr f)) + (symbol? (car f))) + (markup-option-add! m + (car f) + (new markup + (markup (symbol-append + '&bib-entry- + (car f))) + (parent h) + (body (cadr f)))) + (bib-parse-error f))) + fields) + m)) + +;*---------------------------------------------------------------------*/ +;* bib-sort/authors ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/authors l) + (define (cmp i1 i2 def) + (cond + ((and (markup? i1) (markup? i2)) + (cmp (markup-body i1) (markup-body i2) def)) + ((markup? i1) + (cmp (markup-body i1) i2 def)) + ((markup? i2) + (cmp i1 (markup-body i2) def)) + ((and (string? i1) (string? i2)) + (if (string=? i1 i2) + (def) + (string<? i1 i2))) + ((string? i1) + #f) + ((string? i2) + #t) + (else + (def)))) + (sort l (lambda (e1 e2) + (cmp (markup-option e1 'author) + (markup-option e2 'author) + (lambda () + (cmp (markup-option e1 'year) + (markup-option e2 'year) + (lambda () + (cmp (markup-option e1 'title) + (markup-option e2 'title) + (lambda () + (cmp (markup-ident e1) + (markup-ident e2) + (lambda () + #t))))))))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/idents ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/idents l) + (sort l (lambda (e f) (string<? (markup-ident e) (markup-ident f))))) + +;*---------------------------------------------------------------------*/ +;* bib-sort/dates ... */ +;*---------------------------------------------------------------------*/ +(define (bib-sort/dates l) + (sort l (lambda (p1 p2) + (define (month-num m) + (let ((body (markup-body m))) + (if (not (string? body)) + 13 + (let* ((s (if (> (string-length body) 3) + (substring body 0 3) + body)) + (sy (string->symbol (string-downcase body))) + (c (assq sy '((jan . 1) + (feb . 2) + (mar . 3) + (apr . 4) + (may . 5) + (jun . 6) + (jul . 7) + (aug . 8) + (sep . 9) + (oct . 10) + (nov . 11) + (dec . 12))))) + (if (pair? c) (cdr c) 13))))) + (let ((d1 (markup-option p1 'year)) + (d2 (markup-option p2 'year))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((y1 (markup-body d1)) + (y2 (markup-body d2))) + (cond + ((string>? y1 y2) #t) + ((string<? y1 y2) #f) + (else + (let ((d1 (markup-option p1 'month)) + (d2 (markup-option p2 'month))) + (cond + ((not (markup? d1)) #f) + ((not (markup? d2)) #t) + (else + (let ((m1 (month-num d1)) + (m2 (month-num d2))) + (> m1 m2)))))))))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-the-bib ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-bib table n sort pred count opts) + (define (count! entries) + (let loop ((es entries) + (i 1)) + (if (pair? es) + (begin + (markup-option-add! (car es) + :title + (new markup + (markup '&bib-entry-ident) + (parent (car es)) + (options `((number ,i))) + (body (new handle + (ast (car es)))))) + (loop (cdr es) (+ i 1)))))) + (if (not (bib-table? table)) + (skribe-error 'resolve-the-bib "Illegal bibliography table" table) + (let* ((es (sort (hashtable->list table))) + (fes (filter (if (procedure? pred) + (lambda (m) (pred m n)) + (lambda (m) (pair? (markup-option m 'used)))) + es))) + (count! (if (eq? count 'full) es fes)) + (new markup + (markup '&the-bibliography) + (options opts) + (body fes))))) + diff --git a/skribe/src/common/configure.scm.in b/skribe/src/common/configure.scm.in new file mode 100644 index 0000000..830ec4d --- /dev/null +++ b/skribe/src/common/configure.scm.in @@ -0,0 +1,6 @@ +(define (skribe-release) "@SKRIBE_RELEASE@") +(define (skribe-url) "@SKRIBE_URL@") +(define (skribe-doc-dir) "@SKRIBE_DOC_DIR@") +(define (skribe-ext-dir) "@SKRIBE_EXT_DIR@") +(define (skribe-default-path) @SKRIBE_SKR_PATH@) +(define (skribe-scheme) "@SKRIBE_SCHEME@") diff --git a/skribe/src/common/index.scm b/skribe/src/common/index.scm new file mode 100644 index 0000000..65c271f --- /dev/null +++ b/skribe/src/common/index.scm @@ -0,0 +1,126 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/index.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 24 08:01:45 2003 */ +;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe indexes */ +;* ------------------------------------------------------------- */ +;* Implementation: @label index@ */ +;* bigloo: @path ../bigloo/index.bgl@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* index? ... */ +;*---------------------------------------------------------------------*/ +(define (index? obj) + (hashtable? obj)) + +;*---------------------------------------------------------------------*/ +;* *index-table* ... */ +;*---------------------------------------------------------------------*/ +(define *index-table* #f) + +;*---------------------------------------------------------------------*/ +;* make-index-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-index-table ident) + (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* default-index ... */ +;*---------------------------------------------------------------------*/ +(define (default-index) + (if (not *index-table*) + (set! *index-table* (make-index-table "default-index"))) + *index-table*) + +;*---------------------------------------------------------------------*/ +;* resolve-the-index ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-the-index loc i c indexes split char-offset header-limit col) + ;; fetch the descriminating index name letter + (define (index-ref n) + (let ((name (markup-option n 'name))) + (if (>= char-offset (string-length name)) + (skribe-error 'the-index "char-offset out of bound" char-offset) + (string-ref name char-offset)))) + ;; sort a bucket of entries (the entries in a bucket share there name) + (define (sort-entries-bucket ie) + (sort ie + (lambda (i1 i2) + (or (not (markup-option i1 :note)) + (markup-option i2 :note))))) + ;; accumulate all the entries starting with the same letter + (define (letter-references refs) + (let ((letter (index-ref (car (car refs))))) + (let loop ((refs refs) + (acc '())) + (if (or (null? refs) + (not (char-ci=? letter (index-ref (car (car refs)))))) + (values (char-upcase letter) acc refs) + (loop (cdr refs) (cons (car refs) acc)))))) + ;; merge the buckets that comes from different index tables + (define (merge-buckets buckets) + (if (null? buckets) + '() + (let loop ((buckets buckets) + (res '())) + (cond + ((null? (cdr buckets)) + (reverse! (cons (car buckets) res))) + ((string=? (markup-option (car (car buckets)) 'name) + (markup-option (car (cadr buckets)) 'name)) + ;; we merge + (loop (cons (append (car buckets) (cadr buckets)) + (cddr buckets)) + res)) + (else + (loop (cdr buckets) + (cons (car buckets) res))))))) + (let* ((entries (apply append (map hashtable->list indexes))) + (sorted (map sort-entries-bucket + (merge-buckets + (sort entries + (lambda (e1 e2) + (string-ci<? + (markup-option (car e1) 'name) + (markup-option (car e2) 'name)))))))) + (if (and (not split) (< (apply + (map length sorted)) header-limit)) + (new markup + (markup '&the-index) + (loc loc) + (ident i) + (class c) + (options `((:column ,col))) + (body sorted)) + (let loop ((refs sorted) + (lrefs '()) + (body '())) + (if (null? refs) + (new markup + (markup '&the-index) + (loc loc) + (ident i) + (class c) + (options `((:column ,col) + (header ,(new markup + (markup '&the-index-header) + (loc loc) + (body (reverse! lrefs)))))) + (body (reverse! body))) + (call-with-values + (lambda () (letter-references refs)) + (lambda (l lr next-refs) + (let* ((s (string l)) + (m (mark (symbol->string (gensym s)) :text s)) + (h (new handle (loc loc) (ast m))) + (r (ref :handle h :text s))) + (ast-loc-set! m loc) + (ast-loc-set! r loc) + (loop next-refs + (cons r lrefs) + (append lr (cons m body))))))))))) + diff --git a/skribe/src/common/lib.scm b/skribe/src/common/lib.scm new file mode 100644 index 0000000..b0fa2d0 --- /dev/null +++ b/skribe/src/common/lib.scm @@ -0,0 +1,238 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/lib.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Sep 10 11:57:54 2003 */ +;* Last change : Wed Oct 27 12:16:40 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Scheme independent lib part. */ +;* ------------------------------------------------------------- */ +;* Implementation: @label lib@ */ +;* bigloo: @path ../bigloo/lib.bgl@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* engine-custom-add! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom-add! e id val) + (let ((old (engine-custom e id))) + (if (unspecified? old) + (engine-custom-set! e id (list val)) + (engine-custom-set! e id (cons val old))))) + +;*---------------------------------------------------------------------*/ +;* find-markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define (find-markup-ident ident) + (let ((r (find-markups ident))) + (if (or (pair? r) (null? r)) + r + '()))) + +;*---------------------------------------------------------------------*/ +;* container-search-down ... */ +;*---------------------------------------------------------------------*/ +(define (container-search-down pred obj) + (with-debug 4 'container-search-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((container? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '()))))) + +;*---------------------------------------------------------------------*/ +;* search-down ... */ +;*---------------------------------------------------------------------*/ +(define (search-down pred obj) + (with-debug 4 'search-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj (markup-body obj))) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (let ((rest (loop (markup-body obj)))) + (if (pred obj) + (cons obj rest) + rest))) + ((pred obj) + (list obj)) + (else + '()))))) + +;*---------------------------------------------------------------------*/ +;* find-down ... */ +;*---------------------------------------------------------------------*/ +(define (find-down pred obj) + (with-debug 4 'find-down + (debug-item "obj=" (find-runtime-type obj)) + (let loop ((obj obj)) + (cond + ((pair? obj) + (apply append (map (lambda (o) (loop o)) obj))) + ((markup? obj) + (debug-item "loop=" (find-runtime-type obj) + " " (markup-ident obj)) + (if (pred obj) + (list (cons obj (loop (markup-body obj)))) + '())) + (else + (if (pred obj) + (list obj) + '())))))) + +;*---------------------------------------------------------------------*/ +;* find1-down ... */ +;*---------------------------------------------------------------------*/ +(define (find1-down pred obj) + (with-debug 4 'find1-down + (let loop ((obj obj) + (stack '())) + (debug-item "obj=" (find-runtime-type obj) + " " (if (markup? obj) (markup-markup obj) "???") + " " (if (markup? obj) (markup-ident obj) "")) + (cond + ((memq obj stack) + (skribe-error 'find1-down "Illegal cyclic object" obj)) + ((pair? obj) + (let liip ((obj obj)) + (cond + ((null? obj) + #f) + (else + (or (loop (car obj) (cons obj stack)) + (liip (cdr obj))))))) + ((pred obj) + obj) + ((markup? obj) + (loop (markup-body obj) (cons obj stack))) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* find-up ... */ +;*---------------------------------------------------------------------*/ +(define (find-up pred obj) + (let loop ((obj obj) + (res '())) + (cond + ((not (ast? obj)) + res) + ((pred obj) + (loop (ast-parent obj) (cons obj res))) + (else + (loop (ast-parent obj) (cons obj res)))))) + +;*---------------------------------------------------------------------*/ +;* find1-up ... */ +;*---------------------------------------------------------------------*/ +(define (find1-up pred obj) + (let loop ((obj obj)) + (cond + ((not (ast? obj)) + #f) + ((pred obj) + obj) + (else + (loop (ast-parent obj)))))) + +;*---------------------------------------------------------------------*/ +;* ast-document ... */ +;*---------------------------------------------------------------------*/ +(define (ast-document m) + (find1-up document? m)) + +;*---------------------------------------------------------------------*/ +;* ast-chapter ... */ +;*---------------------------------------------------------------------*/ +(define (ast-chapter m) + (find1-up (lambda (n) (is-markup? n 'chapter)) m)) + +;*---------------------------------------------------------------------*/ +;* ast-section ... */ +;*---------------------------------------------------------------------*/ +(define (ast-section m) + (find1-up (lambda (n) (is-markup? n 'section)) m)) + +;*---------------------------------------------------------------------*/ +;* the-body ... */ +;* ------------------------------------------------------------- */ +;* Filter out the options */ +;*---------------------------------------------------------------------*/ +(define (the-body opt+) + (let loop ((opt* opt+) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-body "Illegal body" opt*)) + ((keyword? (car opt*)) + (if (null? (cdr opt*)) + (skribe-error 'the-body "Illegal option" (car opt*)) + (loop (cddr opt*) res))) + (else + (loop (cdr opt*) (cons (car opt*) res)))))) + +;*---------------------------------------------------------------------*/ +;* the-options ... */ +;* ------------------------------------------------------------- */ +;* Returns an list made of options. The OUT argument contains */ +;* keywords that are filtered out. */ +;*---------------------------------------------------------------------*/ +(define (the-options opt+ . out) + (let loop ((opt* opt+) + (res '())) + (cond + ((null? opt*) + (reverse! res)) + ((not (pair? opt*)) + (skribe-error 'the-options "Illegal options" opt*)) + ((keyword? (car opt*)) + (cond + ((null? (cdr opt*)) + (skribe-error 'the-options "Illegal option" (car opt*))) + ((memq (car opt*) out) + (loop (cdr opt*) res)) + (else + (loop (cdr opt*) + (cons (list (car opt*) (cadr opt*)) res))))) + (else + (loop (cdr opt*) res))))) + +;*---------------------------------------------------------------------*/ +;* list-split ... */ +;*---------------------------------------------------------------------*/ +(define (list-split l num . fill) + (let loop ((l l) + (i 0) + (acc '()) + (res '())) + (cond + ((null? l) + (reverse! (cons (if (or (null? fill) (= i num)) + (reverse! acc) + (append! (reverse! acc) + (make-list (- num i) (car fill)))) + res))) + ((= i num) + (loop l + 0 + '() + (cons (reverse! acc) res))) + (else + (loop (cdr l) + (+ i 1) + (cons (car l) acc) + res))))) + diff --git a/skribe/src/common/param.scm b/skribe/src/common/param.scm new file mode 100644 index 0000000..ba8d489 --- /dev/null +++ b/skribe/src/common/param.scm @@ -0,0 +1,69 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/param.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 30 09:06:53 2003 */ +;* Last change : Thu Oct 28 21:51:49 2004 (eg) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Common Skribe parameters */ +;* Implementation: @label param@ */ +;* bigloo: @path ../bigloo/param.bgl@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* *skribe-rc-file* ... */ +;* ------------------------------------------------------------- */ +;* The "runtime command" file. */ +;*---------------------------------------------------------------------*/ +(define *skribe-rc-file* "skriberc") + +;*---------------------------------------------------------------------*/ +;* *skribe-auto-mode-alist* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-auto-mode-alist* + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) + +;*---------------------------------------------------------------------*/ +;* *skribe-auto-load-alist* ... */ +;* ------------------------------------------------------------- */ +;* Autoload engines. */ +;*---------------------------------------------------------------------*/ +(define *skribe-auto-load-alist* + '((base . "base.skr") + (html . "html.skr") + (sui . "html.skr") + (latex . "latex.skr") + (context . "context.skr") + (xml . "xml.skr"))) + +;*---------------------------------------------------------------------*/ +;* *skribe-preload* ... */ +;* ------------------------------------------------------------- */ +;* The list of skribe files (e.g. styles) to be loaded at boot-time */ +;*---------------------------------------------------------------------*/ +(define *skribe-preload* + '("skribe.skr")) + +;*---------------------------------------------------------------------*/ +;* *skribe-precustom* ... */ +;* ------------------------------------------------------------- */ +;* The list of pair <custom x value> to be assigned to the default */ +;* engine. */ +;*---------------------------------------------------------------------*/ +(define *skribe-precustom* + '()) + +;*---------------------------------------------------------------------*/ +;* *skribebib-auto-mode-alist* ... */ +;*---------------------------------------------------------------------*/ +(define *skribebib-auto-mode-alist* + '(("bib" . "skribebibtex"))) diff --git a/skribe/src/common/sui.scm b/skribe/src/common/sui.scm new file mode 100644 index 0000000..eb6134b --- /dev/null +++ b/skribe/src/common/sui.scm @@ -0,0 +1,166 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/common/sui.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Dec 31 11:44:33 2003 */ +;* Last change : Tue Feb 17 11:35:32 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe Url Indexes */ +;* ------------------------------------------------------------- */ +;* Implementation: @label lib@ */ +;* bigloo: @path ../bigloo/sui.bgl@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* *sui-table* ... */ +;*---------------------------------------------------------------------*/ +(define *sui-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* load-sui ... */ +;* ------------------------------------------------------------- */ +;* Returns a SUI sexp if already loaded. Load it otherwise. */ +;* Raise an error if the file cannot be open. */ +;*---------------------------------------------------------------------*/ +(define (load-sui path) + (let ((sexp (hashtable-get *sui-table* path))) + (or sexp + (begin + (when (> *skribe-verbose* 0) + (fprintf (current-error-port) " [loading sui: ~a]\n" path)) + (let ((p (open-input-file path))) + (if (not (input-port? p)) + (skribe-error 'load-sui + "Can't find `Skribe Url Index' file" + path) + (unwind-protect + (let ((sexp (read p))) + (match-case sexp + ((sui (? string?) . ?-) + (hashtable-put! *sui-table* path sexp)) + (else + (skribe-error 'load-sui + "Illegal `Skribe Url Index' file" + path))) + sexp) + (close-input-port p)))))))) + +;*---------------------------------------------------------------------*/ +;* sui-ref->url ... */ +;*---------------------------------------------------------------------*/ +(define (sui-ref->url dir sui ident opts) + (let ((refs (sui-find-ref sui ident opts))) + (and (pair? refs) + (let ((base (sui-file sui)) + (file (car (car refs))) + (mark (cdr (car refs)))) + (format "~a/~a#~a" dir (or file base) mark))))) + +;*---------------------------------------------------------------------*/ +;* sui-title ... */ +;*---------------------------------------------------------------------*/ +(define (sui-title sexp) + (match-case sexp + ((sui (and ?title (? string?)) . ?-) + title) + (else + (skribe-error 'sui-title "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-file ... */ +;*---------------------------------------------------------------------*/ +(define (sui-file sexp) + (sui-key sexp :file)) + +;*---------------------------------------------------------------------*/ +;* sui-key ... */ +;*---------------------------------------------------------------------*/ +(define (sui-key sexp key) + (match-case sexp + ((sui ?- . ?rest) + (let loop ((rest rest)) + (and (pair? rest) + (if (eq? (car rest) key) + (and (pair? (cdr rest)) + (cadr rest)) + (loop (cdr rest)))))) + (else + (skribe-error 'sui-key "Illegal `sui' format" sexp)))) + +;*---------------------------------------------------------------------*/ +;* sui-find-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-find-ref sui ident opts) + (let ((ident (assq :ident opts)) + (mark (assq :mark opts)) + (class (let ((c (assq :class opts))) + (and (pair? c) (cadr c)))) + (chapter (assq :chapter opts)) + (section (assq :section opts)) + (subsection (assq :subsection opts)) + (subsubsection (assq :subsubsection opts))) + (match-case sui + ((sui (? string?) . ?refs) + (cond + (mark (sui-search-ref 'marks refs (cadr mark) class)) + (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) + (section (sui-search-ref 'sections refs (cadr section) class)) + (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) + (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) + (ident (sui-search-all-refs sui ident class)) + (else '()))) + (else + (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) + +;*---------------------------------------------------------------------*/ +;* sui-search-all-refs ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-all-refs sui id refs) + '()) + +;*---------------------------------------------------------------------*/ +;* sui-search-ref ... */ +;*---------------------------------------------------------------------*/ +(define (sui-search-ref kind refs val class) + (define (find-ref refs val class) + (map (lambda (r) + (let ((f (memq :file r)) + (c (memq :mark r))) + (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) + (filter (if class + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val) + (let ((c (memq :class m))) + (and (pair? c) + (eq? (cadr c) class))))) + (lambda (m) + (and (pair? m) + (string? (car m)) + (string=? (car m) val)))) + refs))) + (let loop ((refs refs)) + (if (pair? refs) + (if (and (pair? (car refs)) (eq? (caar refs) kind)) + (find-ref (cdar refs) val class) + (loop (cdr refs))) + '()))) + +;*---------------------------------------------------------------------*/ +;* sui-filter ... */ +;*---------------------------------------------------------------------*/ +(define (sui-filter sui pred1 pred2) + (match-case sui + ((sui (? string?) . ?refs) + (let loop ((refs refs) + (res '())) + (if (pair? refs) + (if (and (pred1 (car refs))) + (loop (cdr refs) + (cons (filter pred2 (cdar refs)) res)) + (loop (cdr refs) res)) + (reverse! res)))) + (else + (skribe-error 'sui-filter "Illegal `sui' format" sui)))) diff --git a/skribe/src/stklos/Makefile.in b/skribe/src/stklos/Makefile.in new file mode 100644 index 0000000..80a26de --- /dev/null +++ b/skribe/src/stklos/Makefile.in @@ -0,0 +1,110 @@ +# +# Makefile.in -- Skribe Src Makefile +# +# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +# +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +# USA. +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 10-Aug-2003 20:26 (eg) +# Last file update: 6-Mar-2004 16:00 (eg) +# +include ../../etc/stklos/Makefile.skb + +prefix=@PREFIX@ + +SKR = $(wildcard ../../skr/*.skr) + +DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ + ../common/index.scm ../common/bib.scm ../common/lib.scm + +SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ + eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ + resolve.stk runtime.stk source.stk types.stk vars.stk \ + verify.stk writer.stk xml.stk + +LEXFILES = c-lex.l lisp-lex.l xml-lex.l + +LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk + +BINDIR=../../bin + +EXE= $(BINDIR)/skribe.stklos + +PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) + +SFLAGS= + +all: $(EXE) + +Makefile: Makefile.in + (cd ../../etc/stklos; autoconf; configure) + +$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) + stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ + chmod $(BMASK) $(EXE) + +# +# Lex files +# +lisp-lex.stk: lisp-lex.l + stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex + +xml-lex.stk: xml-lex.l + stklos-genlex xml-lex.l xml-lex.stk xml-lex + +c-lex.stk: c-lex.l + stklos-genlex c-lex.l c-lex.stk c-lex + + +install: $(INSTALL_BINDIR) + cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ + && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos + rm -f $(INSTALL_BINDIR)/skribe + ln -s skribe.stklos $(INSTALL_BINDIR)/skribe + +uninstall: + rm $(INSTALL_BINDIR)/skribe + rm $(INSTALL_BINDIR)/skribe.stklos + +$(BINDIR): + mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) + +$(INSTALL_BINDIR): + mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) + +## +## Services +## +tags: TAGS + +TAGS: $(SRCS) + etags -l scheme $(SRCS) + +pop: + @echo $(PRCS_FILES:%=src/stklos/%) + +links: + ln -s $(DEPS) . + ln -s $(SKR) . + +clean: + /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr + +distclean: clean + /bin/rm -f Makefile + /bin/rm -f ../common/configure.scm diff --git a/skribe/src/stklos/biblio.stk b/skribe/src/stklos/biblio.stk new file mode 100644 index 0000000..5691588 --- /dev/null +++ b/skribe/src/stklos/biblio.stk @@ -0,0 +1,161 @@ +;;;; +;;;; biblio.stk -- Bibliography functions +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA.main.st +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 31-Aug-2003 22:07 (eg) +;;;; Last file update: 28-Oct-2004 21:19 (eg) +;;;; + + + +(define-module SKRIBE-BIBLIO-MODULE + (import SKRIBE-RUNTIME-MODULE) + (export bib-tables? make-bib-table default-bib-table + bib-load! resolve-bib resolve-the-bib + bib-sort/authors bib-sort/idents bib-sort/dates) + +(define *bib-table* #f) + +;; Forward declarations +(define skribe-open-bib-file #f) +(define parse-bib #f) + +(include "../common/bib.scm") + +;;;; ====================================================================== +;;;; +;;;; Utilities +;;;; +;;;; ====================================================================== + +(define (make-bib-table ident) + (make-hashtable)) + +(define (bib-table? obj) + (hashtable? obj)) + +(define (default-bib-table) + (unless *bib-table* + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;; +;; Utilities +;; +(define (%bib-error who entry) + (let ((msg "bibliography syntax error on entry")) + (if (%epair? entry) + (skribe-line-error (%epair-file entry) (%epair-line entry) who msg entry) + (skribe-error who msg entry)))) + +;;;; ====================================================================== +;;;; +;;;; BIB-DUPLICATE +;;;; +;;;; ====================================================================== +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + + +;;;; ====================================================================== +;;;; +;;;; PARSE-BIB +;;;; +;;;; ====================================================================== +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (port-file-name port))) + (let Loop ((entry (read port))) + (unless (eof-object? entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table key))) + (if old + (bib-duplicate ident from old) + (hash-table-put! table + key + (make-bib-entry kind key fields from))) + (Loop (read port)))) + (else + (%bib-error 'bib-parse entry)))))))) + + +;;;; ====================================================================== +;;;; +;;;; BIB-ADD! +;;;; +;;;; ====================================================================== +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (cond + ((and (list? entry) (> (length entry) 2)) + (let* ((kind (car entry)) + (key (format "~A" (cadr entry))) + (fields (cddr entry)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate key #f old) + (hash-table-put! table + key + (make-bib-entry kind key fields #f))))) + (else + (%bib-error 'bib-add! entry)))) + entries))) + + +;;;; ====================================================================== +;;;; +;;;; SKRIBE-OPEN-BIB-FILE +;;;; +;;;; ====================================================================== +;; FIXME: Factoriser +(define (skribe-open-bib-file file command) + (let ((path (find-path file *skribe-bib-path*))) + (if (string? path) + (begin + (when (> *skribe-verbose* 0) + (format (current-error-port) " [loading bibliography: ~S]\n" path)) + (open-input-file (if (string? command) + (string-append "| " + (format command path)) + path))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) + +) diff --git a/skribe/src/stklos/c-lex.l b/skribe/src/stklos/c-lex.l new file mode 100644 index 0000000..a5b337e --- /dev/null +++ b/skribe/src/stklos/c-lex.l @@ -0,0 +1,67 @@ +;;;; +;;;; c-lex.l -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:10 (eg) +;;;; + +space [ \n\9] +letter [_a-zA-Z] +alphanum [_a-zA-Z0-9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +;;Comments +/\*.*\*/ (new markup + (markup '&source-line-comment) + (body yytext)) +//.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) +[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) + (tmp (memq ident *the-keys*))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text +[^\"a-zA-Z]+ (begin yytext) + + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext) + + + + + + +
\ No newline at end of file diff --git a/skribe/src/stklos/c.stk b/skribe/src/stklos/c.stk new file mode 100644 index 0000000..265c421 --- /dev/null +++ b/skribe/src/stklos/c.stk @@ -0,0 +1,95 @@ +;;;; +;;;; c.stk -- C fontifier for Skribe +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 6-Mar-2004 15:35 (eg) +;;;; Last file update: 7-Mar-2004 00:12 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module SKRIBE-C-MODULE + (export c java) + (import SKRIBE-SOURCE-MODULE) + +(include "c-lex.stk") ;; SILex generated + + +(define *the-keys* #f) + +(define *c-keys* #f) +(define *java-keys* #f) + + +(define (fontifier s) + (let ((lex (c-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; C +;;;; +;;;; ====================================================================== +(define (init-c-keys) + (unless *c-keys* + (set! *c-keys* '(for while return break continue void + do if else typedef struct union goto switch case + static extern default))) + *c-keys*) + +(define (c-fontifier s) + (fluid-let ((*the-keys* (init-c-keys))) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;;;; ====================================================================== +;;;; +;;;; JAVA +;;;; +;;;; ====================================================================== +(define (init-java-keys) + (unless *java-keys* + (set! *java-keys* (append (init-c-keys) + '(public final class throw catch)))) + *java-keys*) + +(define (java-fontifier s) + (fluid-let ((*the-keys* (init-java-keys))) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) + +) + diff --git a/skribe/src/stklos/color.stk b/skribe/src/stklos/color.stk new file mode 100644 index 0000000..0cb829f --- /dev/null +++ b/skribe/src/stklos/color.stk @@ -0,0 +1,622 @@ +;;;; +;;;; color.stk -- Skribe Color Management +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 25-Oct-2003 00:10 (eg) +;;;; Last file update: 12-Feb-2004 18:24 (eg) +;;;; + +(define-module SKRIBE-COLOR-MODULE + (export skribe-color->rgb skribe-get-used-colors skribe-use-color!) + +(define *used-colors* '()) + +(define *skribe-rgb-alist* '( + ("snow" . "255 250 250") + ("ghostwhite" . "248 248 255") + ("whitesmoke" . "245 245 245") + ("gainsboro" . "220 220 220") + ("floralwhite" . "255 250 240") + ("oldlace" . "253 245 230") + ("linen" . "250 240 230") + ("antiquewhite" . "250 235 215") + ("papayawhip" . "255 239 213") + ("blanchedalmond" . "255 235 205") + ("bisque" . "255 228 196") + ("peachpuff" . "255 218 185") + ("navajowhite" . "255 222 173") + ("moccasin" . "255 228 181") + ("cornsilk" . "255 248 220") + ("ivory" . "255 255 240") + ("lemonchiffon" . "255 250 205") + ("seashell" . "255 245 238") + ("honeydew" . "240 255 240") + ("mintcream" . "245 255 250") + ("azure" . "240 255 255") + ("aliceblue" . "240 248 255") + ("lavender" . "230 230 250") + ("lavenderblush" . "255 240 245") + ("mistyrose" . "255 228 225") + ("white" . "255 255 255") + ("black" . "0 0 0") + ("darkslategrey" . "47 79 79") + ("dimgrey" . "105 105 105") + ("slategrey" . "112 128 144") + ("lightslategrey" . "119 136 153") + ("grey" . "190 190 190") + ("lightgrey" . "211 211 211") + ("midnightblue" . "25 25 112") + ("navy" . "0 0 128") + ("navyblue" . "0 0 128") + ("cornflowerblue" . "100 149 237") + ("darkslateblue" . "72 61 139") + ("slateblue" . "106 90 205") + ("mediumslateblue" . "123 104 238") + ("lightslateblue" . "132 112 255") + ("mediumblue" . "0 0 205") + ("royalblue" . "65 105 225") + ("blue" . "0 0 255") + ("dodgerblue" . "30 144 255") + ("deepskyblue" . "0 191 255") + ("skyblue" . "135 206 235") + ("lightskyblue" . "135 206 250") + ("steelblue" . "70 130 180") + ("lightsteelblue" . "176 196 222") + ("lightblue" . "173 216 230") + ("powderblue" . "176 224 230") + ("paleturquoise" . "175 238 238") + ("darkturquoise" . "0 206 209") + ("mediumturquoise" . "72 209 204") + ("turquoise" . "64 224 208") + ("cyan" . "0 255 255") + ("lightcyan" . "224 255 255") + ("cadetblue" . "95 158 160") + ("mediumaquamarine" . "102 205 170") + ("aquamarine" . "127 255 212") + ("darkgreen" . "0 100 0") + ("darkolivegreen" . "85 107 47") + ("darkseagreen" . "143 188 143") + ("seagreen" . "46 139 87") + ("mediumseagreen" . "60 179 113") + ("lightseagreen" . "32 178 170") + ("palegreen" . "152 251 152") + ("springgreen" . "0 255 127") + ("lawngreen" . "124 252 0") + ("green" . "0 255 0") + ("chartreuse" . "127 255 0") + ("mediumspringgreen" . "0 250 154") + ("greenyellow" . "173 255 47") + ("limegreen" . "50 205 50") + ("yellowgreen" . "154 205 50") + ("forestgreen" . "34 139 34") + ("olivedrab" . "107 142 35") + ("darkkhaki" . "189 183 107") + ("khaki" . "240 230 140") + ("palegoldenrod" . "238 232 170") + ("lightgoldenrodyellow" . "250 250 210") + ("lightyellow" . "255 255 224") + ("yellow" . "255 255 0") + ("gold" . "255 215 0") + ("lightgoldenrod" . "238 221 130") + ("goldenrod" . "218 165 32") + ("darkgoldenrod" . "184 134 11") + ("rosybrown" . "188 143 143") + ("indianred" . "205 92 92") + ("saddlebrown" . "139 69 19") + ("sienna" . "160 82 45") + ("peru" . "205 133 63") + ("burlywood" . "222 184 135") + ("beige" . "245 245 220") + ("wheat" . "245 222 179") + ("sandybrown" . "244 164 96") + ("tan" . "210 180 140") + ("chocolate" . "210 105 30") + ("firebrick" . "178 34 34") + ("brown" . "165 42 42") + ("darksalmon" . "233 150 122") + ("salmon" . "250 128 114") + ("lightsalmon" . "255 160 122") + ("orange" . "255 165 0") + ("darkorange" . "255 140 0") + ("coral" . "255 127 80") + ("lightcoral" . "240 128 128") + ("tomato" . "255 99 71") + ("orangered" . "255 69 0") + ("red" . "255 0 0") + ("hotpink" . "255 105 180") + ("deeppink" . "255 20 147") + ("pink" . "255 192 203") + ("lightpink" . "255 182 193") + ("palevioletred" . "219 112 147") + ("maroon" . "176 48 96") + ("mediumvioletred" . "199 21 133") + ("violetred" . "208 32 144") + ("magenta" . "255 0 255") + ("violet" . "238 130 238") + ("plum" . "221 160 221") + ("orchid" . "218 112 214") + ("mediumorchid" . "186 85 211") + ("darkorchid" . "153 50 204") + ("darkviolet" . "148 0 211") + ("blueviolet" . "138 43 226") + ("purple" . "160 32 240") + ("mediumpurple" . "147 112 219") + ("thistle" . "216 191 216") + ("snow1" . "255 250 250") + ("snow2" . "238 233 233") + ("snow3" . "205 201 201") + ("snow4" . "139 137 137") + ("seashell1" . "255 245 238") + ("seashell2" . "238 229 222") + ("seashell3" . "205 197 191") + ("seashell4" . "139 134 130") + ("antiquewhite1" . "255 239 219") + ("antiquewhite2" . "238 223 204") + ("antiquewhite3" . "205 192 176") + ("antiquewhite4" . "139 131 120") + ("bisque1" . "255 228 196") + ("bisque2" . "238 213 183") + ("bisque3" . "205 183 158") + ("bisque4" . "139 125 107") + ("peachpuff1" . "255 218 185") + ("peachpuff2" . "238 203 173") + ("peachpuff3" . "205 175 149") + ("peachpuff4" . "139 119 101") + ("navajowhite1" . "255 222 173") + ("navajowhite2" . "238 207 161") + ("navajowhite3" . "205 179 139") + ("navajowhite4" . "139 121 94") + ("lemonchiffon1" . "255 250 205") + ("lemonchiffon2" . "238 233 191") + ("lemonchiffon3" . "205 201 165") + ("lemonchiffon4" . "139 137 112") + ("cornsilk1" . "255 248 220") + ("cornsilk2" . "238 232 205") + ("cornsilk3" . "205 200 177") + ("cornsilk4" . "139 136 120") + ("ivory1" . "255 255 240") + ("ivory2" . "238 238 224") + ("ivory3" . "205 205 193") + ("ivory4" . "139 139 131") + ("honeydew1" . "240 255 240") + ("honeydew2" . "224 238 224") + ("honeydew3" . "193 205 193") + ("honeydew4" . "131 139 131") + ("lavenderblush1" . "255 240 245") + ("lavenderblush2" . "238 224 229") + ("lavenderblush3" . "205 193 197") + ("lavenderblush4" . "139 131 134") + ("mistyrose1" . "255 228 225") + ("mistyrose2" . "238 213 210") + ("mistyrose3" . "205 183 181") + ("mistyrose4" . "139 125 123") + ("azure1" . "240 255 255") + ("azure2" . "224 238 238") + ("azure3" . "193 205 205") + ("azure4" . "131 139 139") + ("slateblue1" . "131 111 255") + ("slateblue2" . "122 103 238") + ("slateblue3" . "105 89 205") + ("slateblue4" . "71 60 139") + ("royalblue1" . "72 118 255") + ("royalblue2" . "67 110 238") + ("royalblue3" . "58 95 205") + ("royalblue4" . "39 64 139") + ("blue1" . "0 0 255") + ("blue2" . "0 0 238") + ("blue3" . "0 0 205") + ("blue4" . "0 0 139") + ("dodgerblue1" . "30 144 255") + ("dodgerblue2" . "28 134 238") + ("dodgerblue3" . "24 116 205") + ("dodgerblue4" . "16 78 139") + ("steelblue1" . "99 184 255") + ("steelblue2" . "92 172 238") + ("steelblue3" . "79 148 205") + ("steelblue4" . "54 100 139") + ("deepskyblue1" . "0 191 255") + ("deepskyblue2" . "0 178 238") + ("deepskyblue3" . "0 154 205") + ("deepskyblue4" . "0 104 139") + ("skyblue1" . "135 206 255") + ("skyblue2" . "126 192 238") + ("skyblue3" . "108 166 205") + ("skyblue4" . "74 112 139") + ("lightskyblue1" . "176 226 255") + ("lightskyblue2" . "164 211 238") + ("lightskyblue3" . "141 182 205") + ("lightskyblue4" . "96 123 139") + ("lightsteelblue1" . "202 225 255") + ("lightsteelblue2" . "188 210 238") + ("lightsteelblue3" . "162 181 205") + ("lightsteelblue4" . "110 123 139") + ("lightblue1" . "191 239 255") + ("lightblue2" . "178 223 238") + ("lightblue3" . "154 192 205") + ("lightblue4" . "104 131 139") + ("lightcyan1" . "224 255 255") + ("lightcyan2" . "209 238 238") + ("lightcyan3" . "180 205 205") + ("lightcyan4" . "122 139 139") + ("paleturquoise1" . "187 255 255") + ("paleturquoise2" . "174 238 238") + ("paleturquoise3" . "150 205 205") + ("paleturquoise4" . "102 139 139") + ("cadetblue1" . "152 245 255") + ("cadetblue2" . "142 229 238") + ("cadetblue3" . "122 197 205") + ("cadetblue4" . "83 134 139") + ("turquoise1" . "0 245 255") + ("turquoise2" . "0 229 238") + ("turquoise3" . "0 197 205") + ("turquoise4" . "0 134 139") + ("cyan1" . "0 255 255") + ("cyan2" . "0 238 238") + ("cyan3" . "0 205 205") + ("cyan4" . "0 139 139") + ("aquamarine1" . "127 255 212") + ("aquamarine2" . "118 238 198") + ("aquamarine3" . "102 205 170") + ("aquamarine4" . "69 139 116") + ("darkseagreen1" . "193 255 193") + ("darkseagreen2" . "180 238 180") + ("darkseagreen3" . "155 205 155") + ("darkseagreen4" . "105 139 105") + ("seagreen1" . "84 255 159") + ("seagreen2" . "78 238 148") + ("seagreen3" . "67 205 128") + ("seagreen4" . "46 139 87") + ("palegreen1" . "154 255 154") + ("palegreen2" . "144 238 144") + ("palegreen3" . "124 205 124") + ("palegreen4" . "84 139 84") + ("springgreen1" . "0 255 127") + ("springgreen2" . "0 238 118") + ("springgreen3" . "0 205 102") + ("springgreen4" . "0 139 69") + ("green1" . "0 255 0") + ("green2" . "0 238 0") + ("green3" . "0 205 0") + ("green4" . "0 139 0") + ("chartreuse1" . "127 255 0") + ("chartreuse2" . "118 238 0") + ("chartreuse3" . "102 205 0") + ("chartreuse4" . "69 139 0") + ("olivedrab1" . "192 255 62") + ("olivedrab2" . "179 238 58") + ("olivedrab3" . "154 205 50") + ("olivedrab4" . "105 139 34") + ("darkolivegreen1" . "202 255 112") + ("darkolivegreen2" . "188 238 104") + ("darkolivegreen3" . "162 205 90") + ("darkolivegreen4" . "110 139 61") + ("khaki1" . "255 246 143") + ("khaki2" . "238 230 133") + ("khaki3" . "205 198 115") + ("khaki4" . "139 134 78") + ("lightgoldenrod1" . "255 236 139") + ("lightgoldenrod2" . "238 220 130") + ("lightgoldenrod3" . "205 190 112") + ("lightgoldenrod4" . "139 129 76") + ("lightyellow1" . "255 255 224") + ("lightyellow2" . "238 238 209") + ("lightyellow3" . "205 205 180") + ("lightyellow4" . "139 139 122") + ("yellow1" . "255 255 0") + ("yellow2" . "238 238 0") + ("yellow3" . "205 205 0") + ("yellow4" . "139 139 0") + ("gold1" . "255 215 0") + ("gold2" . "238 201 0") + ("gold3" . "205 173 0") + ("gold4" . "139 117 0") + ("goldenrod1" . "255 193 37") + ("goldenrod2" . "238 180 34") + ("goldenrod3" . "205 155 29") + ("goldenrod4" . "139 105 20") + ("darkgoldenrod1" . "255 185 15") + ("darkgoldenrod2" . "238 173 14") + ("darkgoldenrod3" . "205 149 12") + ("darkgoldenrod4" . "139 101 8") + ("rosybrown1" . "255 193 193") + ("rosybrown2" . "238 180 180") + ("rosybrown3" . "205 155 155") + ("rosybrown4" . "139 105 105") + ("indianred1" . "255 106 106") + ("indianred2" . "238 99 99") + ("indianred3" . "205 85 85") + ("indianred4" . "139 58 58") + ("sienna1" . "255 130 71") + ("sienna2" . "238 121 66") + ("sienna3" . "205 104 57") + ("sienna4" . "139 71 38") + ("burlywood1" . "255 211 155") + ("burlywood2" . "238 197 145") + ("burlywood3" . "205 170 125") + ("burlywood4" . "139 115 85") + ("wheat1" . "255 231 186") + ("wheat2" . "238 216 174") + ("wheat3" . "205 186 150") + ("wheat4" . "139 126 102") + ("tan1" . "255 165 79") + ("tan2" . "238 154 73") + ("tan3" . "205 133 63") + ("tan4" . "139 90 43") + ("chocolate1" . "255 127 36") + ("chocolate2" . "238 118 33") + ("chocolate3" . "205 102 29") + ("chocolate4" . "139 69 19") + ("firebrick1" . "255 48 48") + ("firebrick2" . "238 44 44") + ("firebrick3" . "205 38 38") + ("firebrick4" . "139 26 26") + ("brown1" . "255 64 64") + ("brown2" . "238 59 59") + ("brown3" . "205 51 51") + ("brown4" . "139 35 35") + ("salmon1" . "255 140 105") + ("salmon2" . "238 130 98") + ("salmon3" . "205 112 84") + ("salmon4" . "139 76 57") + ("lightsalmon1" . "255 160 122") + ("lightsalmon2" . "238 149 114") + ("lightsalmon3" . "205 129 98") + ("lightsalmon4" . "139 87 66") + ("orange1" . "255 165 0") + ("orange2" . "238 154 0") + ("orange3" . "205 133 0") + ("orange4" . "139 90 0") + ("darkorange1" . "255 127 0") + ("darkorange2" . "238 118 0") + ("darkorange3" . "205 102 0") + ("darkorange4" . "139 69 0") + ("coral1" . "255 114 86") + ("coral2" . "238 106 80") + ("coral3" . "205 91 69") + ("coral4" . "139 62 47") + ("tomato1" . "255 99 71") + ("tomato2" . "238 92 66") + ("tomato3" . "205 79 57") + ("tomato4" . "139 54 38") + ("orangered1" . "255 69 0") + ("orangered2" . "238 64 0") + ("orangered3" . "205 55 0") + ("orangered4" . "139 37 0") + ("red1" . "255 0 0") + ("red2" . "238 0 0") + ("red3" . "205 0 0") + ("red4" . "139 0 0") + ("deeppink1" . "255 20 147") + ("deeppink2" . "238 18 137") + ("deeppink3" . "205 16 118") + ("deeppink4" . "139 10 80") + ("hotpink1" . "255 110 180") + ("hotpink2" . "238 106 167") + ("hotpink3" . "205 96 144") + ("hotpink4" . "139 58 98") + ("pink1" . "255 181 197") + ("pink2" . "238 169 184") + ("pink3" . "205 145 158") + ("pink4" . "139 99 108") + ("lightpink1" . "255 174 185") + ("lightpink2" . "238 162 173") + ("lightpink3" . "205 140 149") + ("lightpink4" . "139 95 101") + ("palevioletred1" . "255 130 171") + ("palevioletred2" . "238 121 159") + ("palevioletred3" . "205 104 137") + ("palevioletred4" . "139 71 93") + ("maroon1" . "255 52 179") + ("maroon2" . "238 48 167") + ("maroon3" . "205 41 144") + ("maroon4" . "139 28 98") + ("violetred1" . "255 62 150") + ("violetred2" . "238 58 140") + ("violetred3" . "205 50 120") + ("violetred4" . "139 34 82") + ("magenta1" . "255 0 255") + ("magenta2" . "238 0 238") + ("magenta3" . "205 0 205") + ("magenta4" . "139 0 139") + ("orchid1" . "255 131 250") + ("orchid2" . "238 122 233") + ("orchid3" . "205 105 201") + ("orchid4" . "139 71 137") + ("plum1" . "255 187 255") + ("plum2" . "238 174 238") + ("plum3" . "205 150 205") + ("plum4" . "139 102 139") + ("mediumorchid1" . "224 102 255") + ("mediumorchid2" . "209 95 238") + ("mediumorchid3" . "180 82 205") + ("mediumorchid4" . "122 55 139") + ("darkorchid1" . "191 62 255") + ("darkorchid2" . "178 58 238") + ("darkorchid3" . "154 50 205") + ("darkorchid4" . "104 34 139") + ("purple1" . "155 48 255") + ("purple2" . "145 44 238") + ("purple3" . "125 38 205") + ("purple4" . "85 26 139") + ("mediumpurple1" . "171 130 255") + ("mediumpurple2" . "159 121 238") + ("mediumpurple3" . "137 104 205") + ("mediumpurple4" . "93 71 139") + ("thistle1" . "255 225 255") + ("thistle2" . "238 210 238") + ("thistle3" . "205 181 205") + ("thistle4" . "139 123 139") + ("grey0" . "0 0 0") + ("grey1" . "3 3 3") + ("grey2" . "5 5 5") + ("grey3" . "8 8 8") + ("grey4" . "10 10 10") + ("grey5" . "13 13 13") + ("grey6" . "15 15 15") + ("grey7" . "18 18 18") + ("grey8" . "20 20 20") + ("grey9" . "23 23 23") + ("grey10" . "26 26 26") + ("grey11" . "28 28 28") + ("grey12" . "31 31 31") + ("grey13" . "33 33 33") + ("grey14" . "36 36 36") + ("grey15" . "38 38 38") + ("grey16" . "41 41 41") + ("grey17" . "43 43 43") + ("grey18" . "46 46 46") + ("grey19" . "48 48 48") + ("grey20" . "51 51 51") + ("grey21" . "54 54 54") + ("grey22" . "56 56 56") + ("grey23" . "59 59 59") + ("grey24" . "61 61 61") + ("grey25" . "64 64 64") + ("grey26" . "66 66 66") + ("grey27" . "69 69 69") + ("grey28" . "71 71 71") + ("grey29" . "74 74 74") + ("grey30" . "77 77 77") + ("grey31" . "79 79 79") + ("grey32" . "82 82 82") + ("grey33" . "84 84 84") + ("grey34" . "87 87 87") + ("grey35" . "89 89 89") + ("grey36" . "92 92 92") + ("grey37" . "94 94 94") + ("grey38" . "97 97 97") + ("grey39" . "99 99 99") + ("grey40" . "102 102 102") + ("grey41" . "105 105 105") + ("grey42" . "107 107 107") + ("grey43" . "110 110 110") + ("grey44" . "112 112 112") + ("grey45" . "115 115 115") + ("grey46" . "117 117 117") + ("grey47" . "120 120 120") + ("grey48" . "122 122 122") + ("grey49" . "125 125 125") + ("grey50" . "127 127 127") + ("grey51" . "130 130 130") + ("grey52" . "133 133 133") + ("grey53" . "135 135 135") + ("grey54" . "138 138 138") + ("grey55" . "140 140 140") + ("grey56" . "143 143 143") + ("grey57" . "145 145 145") + ("grey58" . "148 148 148") + ("grey59" . "150 150 150") + ("grey60" . "153 153 153") + ("grey61" . "156 156 156") + ("grey62" . "158 158 158") + ("grey63" . "161 161 161") + ("grey64" . "163 163 163") + ("grey65" . "166 166 166") + ("grey66" . "168 168 168") + ("grey67" . "171 171 171") + ("grey68" . "173 173 173") + ("grey69" . "176 176 176") + ("grey70" . "179 179 179") + ("grey71" . "181 181 181") + ("grey72" . "184 184 184") + ("grey73" . "186 186 186") + ("grey74" . "189 189 189") + ("grey75" . "191 191 191") + ("grey76" . "194 194 194") + ("grey77" . "196 196 196") + ("grey78" . "199 199 199") + ("grey79" . "201 201 201") + ("grey80" . "204 204 204") + ("grey81" . "207 207 207") + ("grey82" . "209 209 209") + ("grey83" . "212 212 212") + ("grey84" . "214 214 214") + ("grey85" . "217 217 217") + ("grey86" . "219 219 219") + ("grey87" . "222 222 222") + ("grey88" . "224 224 224") + ("grey89" . "227 227 227") + ("grey90" . "229 229 229") + ("grey91" . "232 232 232") + ("grey92" . "235 235 235") + ("grey93" . "237 237 237") + ("grey94" . "240 240 240") + ("grey95" . "242 242 242") + ("grey96" . "245 245 245") + ("grey97" . "247 247 247") + ("grey98" . "250 250 250") + ("grey99" . "252 252 252") + ("grey100" . "255 255 255") + ("darkgrey" . "169 169 169") + ("darkblue" . "0 0 139") + ("darkcyan" . "0 139 139") + ("darkmagenta" . "139 0 139") + ("darkred" . "139 0 0") + ("lightgreen" . "144 238 144"))) + + +(define (%convert-color str) + (let ((col (assoc str *skribe-rgb-alist*))) + (cond + (col + (let* ((p (open-input-string (cdr col))) + (r (read p)) + (g (read p)) + (b (read p))) + (values r g b))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 7)) + (values (string->number (substring str 1 3) 16) + (string->number (substring str 3 5) 16) + (string->number (substring str 5 7) 16))) + ((and (string? str) (eq? (string-ref str 0) #\#) (= (string-length str) 13)) + (values (string->number (substring str 1 5) 16) + (string->number (substring str 5 9) 16) + (string->number (substring str 9 13) 16))) + (else + (values 0 0 0))))) + +;;; +;;; SKRIBE-COLOR->RGB +;;; +(define (skribe-color->rgb spec) + (cond + ((string? spec) (%convert-color spec)) + ((integer? spec) + (values (bit-and #xff (bit-shift spec -16)) + (bit-and #xff (bit-shift spec -8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;;; +;;; SKRIBE-GET-USED-COLORS +;;; +(define (skribe-get-used-colors) + *used-colors*) + +;;; +;;; SKRIBE-USE-COLOR! +;;; +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) + +)
\ No newline at end of file diff --git a/skribe/src/stklos/configure.stk b/skribe/src/stklos/configure.stk new file mode 100644 index 0000000..ece7abc --- /dev/null +++ b/skribe/src/stklos/configure.stk @@ -0,0 +1,90 @@ +;;;; +;;;; configure.stk -- Skribe configuration options +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 10-Feb-2004 11:47 (eg) +;;;; Last file update: 17-Feb-2004 09:43 (eg) +;;;; + +(define-module SKRIBE-CONFIGURE-MODULE + (export skribe-configure skribe-enforce-configure) + + +(define %skribe-conf + `((:release ,(skribe-release)) + (:scheme ,(skribe-scheme)) + (:url ,(skribe-url)) + (:doc-dir ,(skribe-doc-dir)) + (:ext-dir ,(skribe-ext-dir)) + (:default-path ,(skribe-default-path)))) + +;;; +;;; SKRIBE-CONFIGURE +;;; +(define (skribe-configure . opt) + (let ((conf %skribe-conf)) + (cond + ((null? opt) + conf) + ((null? (cdr opt)) + (let ((cell (assq (car opt) conf))) + (if (pair? cell) + (cadr cell) + 'void))) + (else + (let loop ((opt opt)) + (cond + ((null? opt) + #t) + ((not (keyword? (car opt))) + #f) + ((or (null? (cdr opt)) (keyword? (cadr opt))) + #f) + (else + (let ((cell (assq (car opt) conf))) + (if (and (pair? cell) + (if (procedure? (cadr opt)) + ((cadr opt) (cadr cell)) + (equal? (cadr opt) (cadr cell)))) + (loop (cddr opt)) + #f))))))))) +;;; +;;; SKRIBE-ENFORCE-CONFIGURE ... +;;; +(define (skribe-enforce-configure . opt) + (let loop ((o opt)) + (when (pair? o) + (cond + ((or (not (keyword? (car o))) + (null? (cdr o))) + (skribe-error 'skribe-enforce-configure "Illegal enforcement" opt)) + ((skribe-configure (car o) (cadr o)) + (loop (cddr o))) + (else + (skribe-error 'skribe-enforce-configure + (format "Configuration mismatch: ~a" (car o)) + (if (procedure? (cadr o)) + (format "provided `~a'" + (skribe-configure (car o))) + (format "provided `~a', required `~a'" + (skribe-configure (car o)) + (cadr o))))))))) +)
\ No newline at end of file diff --git a/skribe/src/stklos/debug.stk b/skribe/src/stklos/debug.stk new file mode 100644 index 0000000..a9fefde --- /dev/null +++ b/skribe/src/stklos/debug.stk @@ -0,0 +1,161 @@ +;;;; +;;;; debug.stk -- Debug Facilities (stolen to Manuel Serrano) +;;;; +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 10-Aug-2003 20:45 (eg) +;;;; Last file update: 28-Oct-2004 13:16 (eg) +;;;; + + +(define-module SKRIBE-DEBUG-MODULE + (export debug-item skribe-debug set-skribe-debug! add-skribe-debug-symbol + no-debug-color) + +(define *skribe-debug* 0) +(define *skribe-debug-symbols* '()) +(define *skribe-debug-color* #t) +(define *skribe-debug-item* #f) +(define *debug-port* (current-error-port)) +(define *debug-depth* 0) +(define *debug-margin* "") +(define *skribe-margin-debug-level* 0) + + +(define (set-skribe-debug! val) + (set! *skribe-debug* val)) + +(define (add-skribe-debug-symbol s) + (set! *skribe-debug-symbols* (cons s *skribe-debug-symbols*))) + + +(define (no-debug-color) + (set! *skribe-debug-color* #f)) + +(define (skribe-debug) + *skribe-debug*) + +;; +;; debug-port +;; +; (define (debug-port . o) +; (cond +; ((null? o) +; *debug-port*) +; ((output-port? (car o)) +; (set! *debug-port* o) +; o) +; (else +; (error 'debug-port "Illegal debug port" (car o))))) +; + +;;; +;;; debug-color +;;; +(define (debug-color col . o) + (with-output-to-string + (if (and *skribe-debug-color* + (equal? (getenv "TERM") "xterm") + (interactive-port? *debug-port*)) + (lambda () + (format #t "[0m[1;~Am" (+ 31 col)) + (for-each display o) + (display "[0m")) + (lambda () + (for-each display o))))) + +;;; +;;; debug-bold +;;; +(define (debug-bold . o) + (apply debug-color -30 o)) + +;;; +;;; debug-item +;;; +(define (debug-item . args) + (when (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (display *debug-margin* *debug-port*) + (display (debug-color (- *debug-depth* 1) "- ") *debug-port*) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*))) + +;;(define-macro (debug-item . args) +;; `()) + +;;; +;;; %with-debug-margin +;;; +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+ *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (- *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;;; +;;; %with-debug +;; +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (begin + (display *debug-margin* *debug-port*) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl)) + *debug-port*) + (newline *debug-port*) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk)) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +(define-macro (with-debug level label . body) + `((in-module SKRIBE-DEBUG-MODULE %with-debug) ,level ,label (lambda () ,@body))) + +;;(define-macro (with-debug level label . body) +;; `(begin ,@body)) + +) + +#| +Example: + +(with-debug 0 'foo1.1 + (debug-item 'foo2.1) + (debug-item 'foo2.2) + (with-debug 0 'foo2.3 + (debug-item 'foo3.1) + (with-debug 0 'foo3.2 + (debug-item 'foo4.1) + (debug-item 'foo4.2)) + (debug-item 'foo3.3)) + (debug-item 'foo2.4)) +|# diff --git a/skribe/src/stklos/engine.stk b/skribe/src/stklos/engine.stk new file mode 100644 index 0000000..a13ed0f --- /dev/null +++ b/skribe/src/stklos/engine.stk @@ -0,0 +1,242 @@ +;;;; +;;;; engines.stk -- Skribe Engines Stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 24-Jul-2003 20:33 (eg) +;;;; Last file update: 28-Oct-2004 21:21 (eg) +;;;; + +(define-module SKRIBE-ENGINE-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-EVAL-MODULE) + + (export default-engine default-engine-set! + make-engine copy-engine find-engine + engine-custom engine-custom-set! + engine-format? engine-add-writer! + processor-get-engine + push-default-engine pop-default-engine) +) + +;;; Module definition is split here because this file is read by the documentation +;;; Should be changed. +(select-module SKRIBE-ENGINE-MODULE) + +(define *engines* '()) +(define *default-engine* #f) +(define *default-engines* '()) + + +(define (default-engine) + *default-engine*) + + +(define (default-engine-set! e) + (unless (engine? e) + (skribe-error 'default-engine-set! "bad engine ~S" e)) + (set! *default-engine* e) + (set! *default-engines* (cons e *default-engines*)) + e) + + +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + + +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + + +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + ((engine? *skribe-engine*) *skribe-engine*) + (else (find-engine *skribe-engine*))))) + (if (not (engine? e)) + (skribe-error 'engine-format? "No engine" e) + (string=? fmt (engine-format e))))) + +;;; +;;; MAKE-ENGINE +;;; +(define (make-engine ident :key (version 'unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (make <engine> :ident ident :version version :format format + :filter filter :delegate delegate + :symbol-table symbol-table + :custom custom :info info))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + + +;;; +;;; COPY-ENGINE +;;; +(define (copy-engine ident e :key (version 'unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((new (shallow-clone e))) + (slot-set! new 'ident ident) + (slot-set! new 'version version) + (slot-set! new 'filter (or filter (slot-ref e 'filter))) + (slot-set! new 'delegate (or delegate (slot-ref e 'delegate))) + (slot-set! new 'symbol-table (or symbol-table (slot-ref e 'symbol-table))) + (slot-set! new 'customs (or custom (slot-ref e 'customs))) + + (set! *engines* (cons new *engines*)) + new)) + + +;;; +;;; FIND-ENGINE +;;; +(define (%find-loaded-engine id version) + (let Loop ((es *engines*)) + (cond + ((null? es) #f) + ((eq? (slot-ref (car es) 'ident) id) + (cond + ((eq? version 'unspecified) (car es)) + ((eq? version (slot-ref (car es) 'version)) (car es)) + (else (Loop (cdr es))))) + (else (loop (cdr es)))))) + + +(define (find-engine id :key (version 'unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + + (or (%find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and c (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (%find-loaded-engine id version)) + #f))))) + +;;; +;;; ENGINE-CUSTOM +;;; +(define (engine-custom e id) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (cadr c) + 'unspecified))) + + +;;; +;;; ENGINE-CUSTOM-SET! +;;; +(define (engine-custom-set! e id val) + (let* ((customs (slot-ref e 'customs)) + (c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (slot-set! e 'customs (cons (list id val) customs))))) + + +;;; +;;; ENGINE-ADD-WRITER! +;;; +(define (engine-add-writer! e ident pred upred opt before action after class valid) + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error ident "Illegal procedure" proc)) + ((not (equal? (%procedure-arity proc) arity)) + (skribe-error ident + (format #f "Illegal ~S procedure" name) + proc)))) + + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + + ;; + ;; Engine-add-writer! starts here + ;; + (unless (is-a? e <engine>) + (skribe-error ident "Illegal engine" e)) + + ;; check the options + (unless (or (eq? opt 'all) (list? opt)) + (skribe-error ident "Illegal options" opt)) + + ;; check the correctness of the predicate + (check-procedure "predicate" pred 2) + + ;; check the correctness of the validation proc + (when valid + (check-procedure "validate" valid 2)) + + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + + ;; create a new writer and bind it + (let ((n (make <writer> + :ident (if (symbol? ident) ident 'all) + :class class :pred pred :upred upred :options opt + :before before :action action :after after + :validate valid))) + (slot-set! e 'writers (cons n (slot-ref e 'writers))) + n)) + +;;;; ====================================================================== +;;;; +;;;; I N I T S +;;;; +;;;; ====================================================================== + +;; A base engine must pre-exist before anything is loaded. In +;; particular, this dummy base engine is used to load the actual +;; definition of base. + +(make-engine 'base :version 'bootstrap) + + +(select-module STklos) diff --git a/skribe/src/stklos/eval.stk b/skribe/src/stklos/eval.stk new file mode 100644 index 0000000..3acace9 --- /dev/null +++ b/skribe/src/stklos/eval.stk @@ -0,0 +1,149 @@ +;;;; +;;;; eval.stk -- Skribe Evaluator +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 27-Jul-2003 09:15 (eg) +;;;; Last file update: 28-Oct-2004 15:05 (eg) +;;;; + + +;; FIXME; On peut implémenter maintenant skribe-warning/node + + +(define-module SKRIBE-EVAL-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-VERIFY-MODULE + SKRIBE-RESOLVE-MODULE SKRIBE-OUTPUT-MODULE) + (export skribe-eval skribe-eval-port skribe-load skribe-load-options + skribe-include) + + +(define *skribe-loaded* '()) ;; List of already loaded files +(define *skribe-load-options* '()) + +(define (%evaluate expr) + (with-handler + (lambda (c) + (flush-output-port (current-error-port)) + (raise c)) + (eval expr (find-module 'STklos)))) + +;;; +;;; SKRIBE-EVAL +;;; +(define (skribe-eval a e :key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;;; +;;; SKRIBE-EVAL-PORT +;;; +(define (skribe-eval-port port engine :key (env '())) + (with-debug 2 'skribe-eval-port + (debug-item "engine=" engine) + (let ((e (if (symbol? engine) (find-engine engine) engine))) + (debug-item "e=" e) + (if (not (is-a? e <engine>)) + (skribe-error 'skribe-eval-port "Cannot find engine" engine) + (let loop ((exp (read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (unless (eof-object? exp) + (skribe-eval (%evaluate exp) e :env env) + (loop (read port)))))))) + +;;; +;;; SKRIBE-LOAD +;;; +(define *skribe-load-options* '()) + +(define (skribe-load-options) + *skribe-load-options*) + +(define (skribe-load file :rest opt :key engine path) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + + (let* ((ei (cond + ((not engine) *skribe-engine*) + ((engine? engine) engine) + ((not (symbol? engine)) (skribe-error 'skribe-load + "Illegal engine" engine)) + (else engine))) + (path (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else path))) + (filep (find-path file path))) + + (set! *skribe-load-options* opt) + + (unless (and (string? filep) (file-exists? filep)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + *skribe-path*)) + + ;; Load this file if not already done + (unless (member filep *skribe-loaded*) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [loading file: ~S ~S]\n" filep opt)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [loading file: ~S]\n" filep))) + ;; Load it + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))) + (set! *skribe-loaded* (cons filep *skribe-loaded*)))))) + +;;; +;;; SKRIBE-INCLUDE +;;; +(define (skribe-include file :optional (path (skribe-path))) + (unless (every string? path) + (skribe-error 'skribe-include "Illegal path" path)) + + (let ((path (find-path file path))) + (unless (and (string? path) (file-exists? path)) + (skribe-error 'skribe-load + (format "Cannot find ~S in path" file) + path)) + (when (> *skribe-verbose* 0) + (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path + (lambda () + (let Loop ((exp (read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (Loop (read (current-input-port)) + (cons (%evaluate exp) res)))))))) +)
\ No newline at end of file diff --git a/skribe/src/stklos/lib.stk b/skribe/src/stklos/lib.stk new file mode 100644 index 0000000..3c3b9f0 --- /dev/null +++ b/skribe/src/stklos/lib.stk @@ -0,0 +1,317 @@ +;;;; +;;;; lib.stk -- Utilities +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 11-Aug-2003 20:29 (eg) +;;;; Last file update: 27-Oct-2004 12:41 (eg) +;;;; + +;;; +;;; NEW +;;; +(define (maybe-copy obj) + (if (pair-mutable? obj) + obj + (copy-tree obj))) + +(define-macro (new class . parameters) + `(make ,(string->symbol (format "<~a>" class)) + ,@(apply append (map (lambda (x) + `(,(make-keyword (car x)) (maybe-copy ,(cadr x)))) + parameters)))) + +;;; +;;; DEFINE-MARKUP +;;; +(define-macro (define-markup bindings . body) + ;; This is just a STklos extended lambda. Nothing to do + `(define ,bindings ,@body)) + + +;;; +;;; DEFINE-SIMPLE-MARKUP +;;; +(define-macro (define-simple-markup markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-SIMPLE-CONTAINER +;;; +(define-macro (define-simple-container markup) + `(define-markup (,markup :rest opts :key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + + +;;; +;;; DEFINE-PROCESSOR-MARKUP +;;; +(define-macro (define-processor-markup proc) + `(define-markup (,proc #!rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + + +;;; +;;; SKRIBE-EVAL-LOCATION ... +;;; +(define (skribe-eval-location) + (format (current-error-port) + "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n") + #f) + +;;; +;;; SKRIBE-ERROR +;;; +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (markup? obj) (markup-markup obj) obj))) + (if (location? l) + (error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape) + (error "~a: ~a ~s " proc msg shape)))) + +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error proc msg obj))) + + +;;; +;;; SKRIBE-TYPE-ERROR +;;; +(define (skribe-type-error proc msg obj etype) + (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f)) + + + +;;; FIXME: Peut-être virée maintenant +(define (skribe-line-error file line proc msg obj) + (error (format "%a:%a: ~a:~a ~S" file line proc msg obj))) + + +;;; +;;; SKRIBE-WARNING & SKRIBE-WARNING/AST +;;; +(define (%skribe-warn level file line lst) + (let ((port (current-error-port))) + (format port "**** WARNING:\n") + (when (and file line) (format port "~a: ~a: " file line)) + (for-each (lambda (x) (format port "~a " x)) lst) + (newline port))) + + +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (%skribe-warn level #f #f obj))) + + +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (ast-loc ast))) + (if (location? l) + (%skribe-warn level (location-file l) (location-pos l) obj) + (%skribe-warn level #f #f obj))))) + +;;; +;;; SKRIBE-MESSAGE +;;; +(define (skribe-message fmt . obj) + (when (> *skribe-verbose* 0) + (apply format (current-error-port) fmt obj))) + +;;; +;;; FILE-PREFIX / FILE-SUFFIX +;;; +(define (file-prefix fn) + (if fn + (let ((match (regexp-match "(.*)\\.([^/]*$)" fn))) + (if match + (cadr match) + fn)) + "./SKRIBE-OUTPUT")) + +(define (file-suffix s) + ;; Not completely correct, but sufficient here + (let* ((basename (regexp-replace "^(.*)/(.*)$" s "\\2")) + (split (string-split basename "."))) + (if (> (length split) 1) + (car (reverse! split)) + ""))) + + +;;; +;;; KEY-GET +;;; +;;; We need to redefine the standard key-get to be more permissive. In +;;; STklos key-get accepts a list which is formed only of keywords. In +;;; Skribe, parameter lists are of the form +;;; (:title "..." :option "...." body1 body2 body3) +;;; So is we find an element which is not a keyword, we skip it (unless it +;;; follows a keyword of course). Since the compiler of extended lambda +;;; uses the function key-get, it will now accept Skribe markups +(define (key-get lst key :optional (default #f default?)) + (define (not-found) + (if default? + default + (error 'key-get "value ~S not found in list ~S" key lst))) + (let Loop ((l lst)) + (cond + ((null? l) + (not-found)) + ((not (pair? l)) + (error 'key-get "bad list ~S" lst)) + ((keyword? (car l)) + (if (null? (cdr l)) + (error 'key-get "bad keyword list ~S" lst) + (if (eq? (car l) key) + (cadr l) + (Loop (cddr l))))) + (else + (Loop (cdr l)))))) + + +;;; +;;; UNSPECIFIED? +;;; +(define (unspecified? obj) + (eq? obj 'unspecified)) + +;;;; ====================================================================== +;;;; +;;;; A C C E S S O R S +;;;; +;;;; ====================================================================== + +;; SKRIBE-PATH +(define (skribe-path) *skribe-path*) + +(define (skribe-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;; SKRIBE-IMAGE-PATH +(define (skribe-image-path) *skribe-image-path*) + +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;; SKRIBE-BIB-PATH +(define (skribe-bib-path) *skribe-bib-path*) + +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;; SKRBE-SOURCE-PATH +(define (skribe-source-path) *skribe-source-path*) + +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) + +;;;; ====================================================================== +;;;; +;;;; Compatibility with Bigloo +;;;; +;;;; ====================================================================== + +(define (substring=? s1 s2 len) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (let Loop ((i 0)) + (cond + ((= i len) #t) + ((= i l1) #f) + ((= i l2) #f) + ((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1))) + (else #f))))) + +(define (directory->list str) + (map basename (glob (string-append str "/*") (string-append "/.*")))) + +(define-macro (printf . args) `(format #t ,@args)) +(define fprintf format) + +(define (symbol-append . l) + (string->symbol (apply string-append (map symbol->string l)))) + + +(define (make-list n . fill) + (let ((fill (if (null? fill) (void) (car fill)))) + (let Loop ((i n) (res '())) + (if (zero? i) + res + (Loop (- i 1) (cons fill res)))))) + + +(define string-capitalize string-titlecase) +(define prefix file-prefix) +(define suffix file-suffix) +(define system->string exec) +(define any? any) +(define every? every) +(define cons* list*) +(define find-file/path find-path) +(define process-input-port process-input) +(define process-output-port process-output) +(define process-error-port process-error) + +;;; +;;; h a s h t a b l e s +;;; +(define make-hashtable (lambda () (make-hash-table equal?))) +(define hashtable? hash-table?) +(define hashtable-get (lambda (h k) (hash-table-get h k #f))) +(define hashtable-put! hash-table-put!) +(define hashtable-update! hash-table-update!) +(define hashtable->list (lambda (h) + (map cdr (hash-table->list h)))) + +(define find-runtime-type (lambda (obj) obj)) + +(define-macro (unwind-protect expr1 expr2) + ;; This is no completely correct. + `(dynamic-wind + (lambda () #f) + (lambda () ,expr1) + (lambda () ,expr2))) diff --git a/skribe/src/stklos/lisp-lex.l b/skribe/src/stklos/lisp-lex.l new file mode 100644 index 0000000..efad24b --- /dev/null +++ b/skribe/src/stklos/lisp-lex.l @@ -0,0 +1,91 @@ +;;;; -*- Scheme -*- +;;;; +;;;; lisp-lex.l -- SILex input for the Lisp Languages +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 5-Jan-2004 18:24 (eg) +;;;; + +space [ \n\9] +letter [#?!_:a-zA-Z\-] +digit [0-9] + + +%% +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +\;.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) +\[|\] (if *bracket-highlight* + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis +[ \n\9\(\)]+ (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) +[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if *class-highlight* + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + *the-keys*))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/skribe/src/stklos/lisp.stk b/skribe/src/stklos/lisp.stk new file mode 100644 index 0000000..9bfe75a --- /dev/null +++ b/skribe/src/stklos/lisp.stk @@ -0,0 +1,294 @@ +;;;; +;;;; lisp.stk -- Lisp Family Fontification +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 16-Oct-2003 22:17 (eg) +;;;; Last file update: 28-Oct-2004 21:14 (eg) +;;;; + +(require "lex-rt") ;; to avoid module problems + +(define-module SKRIBE-LISP-MODULE + (export skribe scheme stklos bigloo lisp) + (import SKRIBE-SOURCE-MODULE) + +(include "lisp-lex.stk") ;; SILex generated + +(define *bracket-highlight* #f) +(define *class-highlight* #f) +(define *the-keys* #f) + +(define *lisp-keys* #f) +(define *scheme-keys* #f) +(define *skribe-keys* #f) +(define *stklos-keys* #f) +(define *lisp-keys* #f) + + +;;; +;;; DEFINITION-SEARCH +;;; +(define (definition-search inp tab test) + (let Loop ((exp (%read inp))) + (unless (eof-object? exp) + (if (test exp) + (let ((start (and (%epair? exp) (%epair-line exp))) + (stop (port-current-line inp))) + (source-read-lines (port-file-name inp) start stop tab)) + (Loop (%read inp)))))) + + +(define (lisp-family-fontifier s) + (let ((lex (lisp-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + +;;;; ====================================================================== +;;;; +;;;; LISP +;;;; +;;;; ====================================================================== +(define (lisp-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (and (eq? def fun) exp)) + ((defvar ?var . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define (init-lisp-keys) + (unless *lisp-keys* + (set! *lisp-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(setq if let let* letrec cond case else progn lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(defun defclass defmacro))))) + *lisp-keys*) + +(define (lisp-fontifier s) + (fluid-let ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SCHEME +;;;; +;;;; ====================================================================== +(define (scheme-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-scheme-keys) + (unless *scheme-keys* + (set! *scheme-keys* + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(set! if let let* letrec quote cond case else begin do lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(define define-syntax))))) + *scheme-keys*) + + +(define (scheme-fontifier s) + (fluid-let ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;;;; ====================================================================== +;;;; +;;;; STKLOS +;;;; +;;;; ====================================================================== +(define (stklos-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-generic define-method define-macro) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-module) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-stklos-keys) + (unless *stklos-keys* + (init-scheme-keys) + (set! *stklos-keys* (append *scheme-keys* + ;; Markups + (map (lambda (x) (cons x '&source-key)) + '(select-module import export)) + ;; Key + (map (lambda (x) (cons x '&source-keyword)) + '(case-lambda dotimes match-case match-lambda)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-generic define-class + define-macro define-method define-module)) + ;; error + (map (lambda (x) (cons x '&source-error)) + '(error call/cc))))) + *stklos-keys*) + + +(define (stklos-fontifier s) + (fluid-let ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define stklos + (new language + (name "stklos") + (fontifier stklos-fontifier) + (extractor stklos-extractor))) + +;;;; ====================================================================== +;;;; +;;;; SKRIBE +;;;; +;;;; ====================================================================== +(define (skribe-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + ((define (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + ((markup-output (quote ?mk) . ?-) + (and (eq? mk def) exp)) + (else + #f))))) + + +(define (init-skribe-keys) + (unless *skribe-keys* + (init-stklos-keys) + (set! *skribe-keys* (append *stklos-keys* + ;; Markups + (map (lambda (x) (cons x '&source-markup)) + '(bold it emph tt color ref index underline + roman figure center pre flush hrule + linebreak image kbd code var samp + sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font + document chapter section subsection + subsubsection paragraph p handle resolve + processor abstract margin toc + table-of-contents current-document + current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-markup))))) + *skribe-keys*) + + +(define (skribe-fontifier s) + (fluid-let ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;;;; ====================================================================== +;;;; +;;;; BIGLOO +;;;; +;;;; ====================================================================== +(define (bigloo-extractor iport def tab) + (definition-search + iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (and (eq? def fun) exp)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (and (eq? var def) exp)) + (else + #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) + +) diff --git a/skribe/src/stklos/main.stk b/skribe/src/stklos/main.stk new file mode 100644 index 0000000..4905423 --- /dev/null +++ b/skribe/src/stklos/main.stk @@ -0,0 +1,264 @@ +;;;; +;;;; skribe.stk -- Skribe Main +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 24-Jul-2003 20:33 (eg) +;;;; Last file update: 6-Mar-2004 16:13 (eg) +;;;; + +;; FIXME: These are horrible hacks +;(DESCRIBE 1 (current-error-port)) ; to make compiler happy +(set! *compiler-options* '()) ;HORREUR pour éviter les warnings du compilo + + +(include "../common/configure.scm") +(include "../common/param.scm") + +(include "vars.stk") +(include "reader.stk") +(include "configure.stk") +(include "types.stk") +(include "debug.stk") +(include "lib.stk") +(include "../common/lib.scm") +(include "resolve.stk") +(include "writer.stk") +(include "verify.stk") +(include "output.stk") +(include "prog.stk") +(include "eval.stk") +(include "runtime.stk") +(include "engine.stk") +(include "biblio.stk") +(include "source.stk") +(include "lisp.stk") +(include "xml.stk") +(include "c.stk") +(include "color.stk") +(include "../common/sui.scm") + +(import SKRIBE-EVAL-MODULE + SKRIBE-CONFIGURE-MODULE + SKRIBE-RUNTIME-MODULE + SKRIBE-ENGINE-MODULE + SKRIBE-EVAL-MODULE + SKRIBE-WRITER-MODULE + SKRIBE-VERIFY-MODULE + SKRIBE-OUTPUT-MODULE + SKRIBE-BIBLIO-MODULE + SKRIBE-PROG-MODULE + SKRIBE-RESOLVE-MODULE + SKRIBE-SOURCE-MODULE + SKRIBE-LISP-MODULE + SKRIBE-XML-MODULE + SKRIBE-C-MODULE + SKRIBE-DEBUG-MODULE + SKRIBE-COLOR-MODULE) + +(include "../common/index.scm") +(include "../common/api.scm") + + +;;; KLUDGE for allowing redefinition of Skribe INCLUDE +(remove-expander! 'include) + + +;;;; ====================================================================== +;;;; +;;;; P A R S E - A R G S +;;;; +;;;; ====================================================================== +(define (parse-args args) + + (define (version) + (format #t "skribe v~A\n" (skribe-release))) + + (define (query) + (version) + (for-each (lambda (x) + (let ((s (keyword->string (car x)))) + (printf " ~a: ~a\n" s (cadr x)))) + (skribe-configure))) + + ;; + ;; parse-args starts here + ;; + (let ((paths '()) + (engine #f)) + (parse-arguments args + "Usage: skribe [options] [input]" + "General options:" + (("target" :alternate "t" :arg target + :help "sets the output format to <target>") + (set! engine (string->symbol target))) + (("I" :arg path :help "adds <path> to Skribe path") + (set! paths (cons path paths))) + (("B" :arg path :help "adds <path> to bibliography path") + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("S" :arg path :help "adds <path> to source path") + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("P" :arg path :help "adds <path> to image path") + (skribe-image-path-set! (cons path (skribe-image-path)))) + (("split-chapters" :alternate "C" :arg chapter + :help "emit chapter's sections in separate files") + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("preload" :arg file :help "preload <file>") + (set! *skribe-preload* (cons file *skribe-preload*))) + (("use-variant" :alternate "u" :arg variant + :help "use <variant> output format") + (set! *skribe-variants* (cons variant *skribe-variants*))) + (("base" :alternate "b" :arg base + :help "base prefix to remove from hyperlinks") + (set! *skribe-ref-base* base)) + (("rc-dir" :arg dir :alternate "d" :help "set the RC directory to <dir>") + (set! *skribe-rc-directory* dir)) + + "File options:" + (("no-init-file" :help "Dont load rc Skribe file") + (set! *load-rc* #f)) + (("output" :alternate "o" :arg file :help "set the output to <file>") + (set! *skribe-dest* file) + (let* ((s (file-suffix file)) + (c (assoc s *skribe-auto-mode-alist*))) + (when (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + + "Misc:" + (("help" :alternate "h" :help "provides help for the command") + (arg-usage (current-error-port)) + (exit 0)) + (("options" :help "display the skribe options and exit") + (arg-usage (current-output-port) #t) + (exit 0)) + (("version" :alternate "V" :help "displays the version of Skribe") + (version) + (exit 0)) + (("query" :alternate "q" + :help "displays informations about Skribe conf.") + (query) + (exit 0)) + (("verbose" :alternate "v" :arg level + :help "sets the verbosity to <level>. Use -v0 for crystal silence") + (let ((val (string->number level))) + (when (integer? val) + (set! *skribe-verbose* val)))) + (("warning" :alternate "w" :arg level + :help "sets the verbosity to <level>. Use -w0 for crystal silence") + (let ((val (string->number level))) + (when (integer? val) + (set! *skribe-warning* val)))) + (("debug" :alternate "g" :arg level :help "sets the debug <level>") + (let ((val (string->number level))) + (if (integer? val) + (set-skribe-debug! val) + (begin + ;; Use the symbol for debug + (set-skribe-debug! 1) + (add-skribe-debug-symbol (string->symbol level)))))) + (("no-color" :help "disable coloring for output") + (no-debug-color)) + (("custom" :alternate "c" :arg key=val :help "Preset custom value") + (let ((args (string-split key=val "="))) + (if (and (list args) (= (length args) 2)) + (let ((key (car args)) + (val (cadr args))) + (set! *skribe-precustom* (cons (cons (string->symbol key) val) + *skribe-precustom*))) + (error 'parse-arguments "Bad custom ~S" key=val)))) + (("eval" :alternate "e" :arg expr :help "evaluate expression <expr>") + (with-input-from-string expr + (lambda () (eval (read))))) + (else + (set! *skribe-src* other-arguments))) + + ;; we have to configure Skribe path according to the environment variable + (skribe-path-set! (append (let ((path (getenv "SKRIBEPATH"))) + (if path + (string-split path ":") + '())) + (reverse! paths) + (skribe-default-path))) + ;; Final initializations + (when engine + (set! *skribe-engine* engine)))) + +;;;; ====================================================================== +;;;; +;;;; L O A D - R C +;;;; +;;;; ====================================================================== +(define (load-rc) + (when *load-rc* + (let ((file (make-path *skribe-rc-directory* *skribe-rc-file*))) + (when (and file (file-exists? file)) + (load file))))) + + + +;;;; ====================================================================== +;;;; +;;;; S K R I B E +;;;; +;;;; ====================================================================== +(define (doskribe) + (let ((e (find-engine *skribe-engine*))) + (if (and (engine? e) (pair? *skribe-precustom*)) + (for-each (lambda (cv) + (engine-custom-set! e (car cv) (cdr cv))) + *skribe-precustom*)) + (if (pair? *skribe-src*) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) + *skribe-src*) + (skribe-eval-port (current-input-port) *skribe-engine*)))) + + +;;;; ====================================================================== +;;;; +;;;; M A I N +;;;; +;;;; ====================================================================== +(define (main args) + ;; Load the user rc file + (load-rc) + + ;; Parse command line + (parse-args args) + + ;; Load the base file to bootstrap the system as well as the files + ;; that are in the *skribe-preload* variable + (skribe-load "base.skr" :engine 'base) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) *skribe-preload*) + + ;; Load the specified variants + (for-each (lambda (x) (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) + (reverse! *skribe-variants*)) + +;; (if (string? *skribe-dest*) +;; (with-handler (lambda (kind loc msg) +;; (remove-file *skribe-dest*) +;; (error loc msg)) +;; (with-output-to-file *skribe-dest* doskribe)) +;; (doskribe)) +(if (string? *skribe-dest*) + (with-output-to-file *skribe-dest* doskribe) + (doskribe)) + + 0) diff --git a/skribe/src/stklos/output.stk b/skribe/src/stklos/output.stk new file mode 100644 index 0000000..3c00323 --- /dev/null +++ b/skribe/src/stklos/output.stk @@ -0,0 +1,158 @@ +;;;; +;;;; output.stk -- Skribe Output Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 18:42 (eg) +;;;; Last file update: 5-Mar-2004 10:32 (eg) +;;;; + +(define-module SKRIBE-OUTPUT-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-WRITER-MODULE) + (export output) + + +(define-generic out) + +(define (%out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" n " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (engine-ident e)) + (debug-item "w=" (writer-ident w)) + + (when (writer? w) + (invoke (slot-ref w 'before) n e) + (invoke (slot-ref w 'action) n e) + (invoke (slot-ref w 'after) n e)))) + + + +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (null? writer) + (out node e) + (cond + ((is-a? (car writer) <writer>) + (%out/writer node e (car writer))) + ((not (car writer)) + (skribe-error 'output + (format "Illegal ~A user writer" (engine-ident e)) + (if (markup? node) (markup-markup node) node))) + (else + (skribe-error 'output "Illegal user writer" (car writer))))))) + + +;;; +;;; OUT implementations +;;; +(define-method out (node e) + #f) + + +(define-method out ((node <pair>) e) + (let Loop ((n* node)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (skribe-error 'out "Illegal argument" n*))))) + + +(define-method out ((node <string>) e) + (let ((f (slot-ref e 'filter))) + (if (procedure? f) + (display (f node)) + (display node)))) + + +(define-method out ((node <number>) e) + (out (number->string node) e)) + + +(define-method out ((n <processor>) e) + (let ((combinator (slot-ref n 'combinator)) + (engine (slot-ref n 'engine)) + (body (slot-ref n 'body)) + (procedure (slot-ref n 'procedure))) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + + +(define-method out ((n <command>) e) + (let* ((fmt (slot-ref n 'fmt)) + (body (slot-ref n 'body)) + (lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (skribe-error '! "Too few arguments provided" n))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (skribe-error '! "Too few arguments provided" n)))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0))))))) + + +(define-method out ((n <handle>) e) + 'unspecified) + + +(define-method out ((n <unresolved>) e) + (skribe-error 'output "Orphan unresolved" n)) + + +(define-method out ((node <markup>) e) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (%out/writer node e w) + (output (slot-ref node 'body) e)))) +) diff --git a/skribe/src/stklos/prog.stk b/skribe/src/stklos/prog.stk new file mode 100644 index 0000000..6301ece --- /dev/null +++ b/skribe/src/stklos/prog.stk @@ -0,0 +1,219 @@ +;;;; +;;;; prog.stk -- All the stuff for the prog markup +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 31-Aug-2003 23:42 (eg) +;;;; Last file update: 22-Oct-2003 19:35 (eg) +;;;; + +(define-module SKRIBE-PROG-MODULE + (export make-prog-body resolve-line) + +;;; ====================================================================== +;;; +;;; COMPATIBILITY +;;; +;;; ====================================================================== +(define pregexp-match regexp-match) +(define pregexp-replace regexp-replace) +(define pregexp-quote regexp-quote) + + +(define (node-body-set! b v) + (slot-set! b 'body v)) + +;;; +;;; FIXME: Tout le module peut se factoriser +;;; définir en bigloo node-body-set + + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (number->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (receive (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((node? line) + (receive (m l) + (extract-mark (node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((= r2 l) + (if (= r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+ r2 1) + (+ r2 1) + (if (= r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+ r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (number->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (number->string (+ (if (integer? ldigit) + (max lnum (expt 10 (- ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (receive (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) + +)
\ No newline at end of file diff --git a/skribe/src/stklos/reader.stk b/skribe/src/stklos/reader.stk new file mode 100644 index 0000000..bd38562 --- /dev/null +++ b/skribe/src/stklos/reader.stk @@ -0,0 +1,136 @@ +;;;; +;;;; reader.stk -- Reader hook for the open bracket +;;;; +;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@unice.fr] +;;;; Creation date: 6-Dec-2001 22:59 (eg) +;;;; Last file update: 28-Feb-2004 10:22 (eg) +;;;; + +;; Examples of ISO-2022-JP (here for cut'n paste tests, since my japanese +;; is *very* limited ;-). +;; +;; "Japan" $BF|K\(B +;; "China and Chinese music" $BCf9q$HCf9q$N2;3Z(B + + +;; +;; This function is a hook for the standard reader. After defining, +;; %read-bracket, the reader calls it when it encounters an open +;; bracket + + +(define (%read-bracket in) + + (define (read-japanese in) + ;; This function reads an ISO-2022-JP sequence. Susch s sequence is coded + ;; as "^[$B......^[(B" . When entering in this function the current + ;; character is 'B' (the opening sequence one). Function reads until the + ;; end of the sequence and return it as a string + (read-char in) ;; to skip the starting #\B + (let ((res (open-output-string))) + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + ((char=? c #\escape) + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\() + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (read-char in) + (format "\033$B~A\033(B" (get-output-string res))) + (begin + (format res "\033~A" next1) + (Loop next2))))) + (begin + (display #\escape res) + (Loop next1))))) + (else (display (read-char in) res) + (Loop (peek-char in))))))) + ;; + ;; Body of %read-bracket starts here + ;; + (let ((out (open-output-string)) + (res '()) + (in-string? #f)) + + (read-char in) ; skip open bracket + + (let Loop ((c (peek-char in))) + (cond + ((eof-object? c) ;; EOF + (error '%read-bracket "EOF encountered")) + + ((char=? c #\escape) ;; ISO-2022-JP string? + (read-char in) + (let ((next1 (peek-char in))) + (if (char=? next1 #\$) + (begin + (read-char in) + (let ((next2 (peek-char in))) + (if (char=? next2 #\B) + (begin + (set! res + (append! res + (list (get-output-string out) + (list 'unquote + (list 'jp + (read-japanese in)))))) + (set! out (open-output-string))) + (format out "\033~A" next1)))) + (display #\escape out))) + (Loop (peek-char in))) + + ((char=? c #\\) ;; Quote char + (read-char in) + (display (read-char in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\,)) ;; Comma + (read-char in) + (let ((next (peek-char in))) + (if (char=? next #\() + (begin + (set! res (append! res (list (get-output-string out) + (list 'unquote + (read in))))) + (set! out (open-output-string))) + (display #\, out)) + (Loop (peek-char in)))) + + ((and (not in-string?) (char=? c #\[)) ;; Open bracket + (display (%read-bracket in) out) + (Loop (peek-char in))) + + ((and (not in-string?) (char=? c #\])) ;; Close bracket + (read-char in) + (let ((str (get-output-string out))) + (list 'quasiquote + (append! res (if (string=? str "") '() (list str)))))) + + (else (when (char=? c #\") (set! in-string? (not in-string?))) + (display (read-char in) out) + (Loop (peek-char in))))))) + diff --git a/skribe/src/stklos/resolve.stk b/skribe/src/stklos/resolve.stk new file mode 100644 index 0000000..91dc965 --- /dev/null +++ b/skribe/src/stklos/resolve.stk @@ -0,0 +1,255 @@ +;;;; +;;;; resolve.stk -- Skribe Resolve Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 18:39 (eg) +;;;; Last file update: 17-Feb-2004 14:43 (eg) +;;;; + +(define-module SKRIBE-RESOLVE-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-RUNTIME-MODULE) + (export resolve! resolve-search-parent resolve-children resolve-children* + find1 resolve-counter resolve-parent resolve-ident) + +(define *unresolved* #f) +(define-generic do-resolve!) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE! +;;;; +;;;; This function iterates over an ast until all unresolved references +;;;; are resolved. +;;;; +;;;; ====================================================================== +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + (fluid-let ((*unresolved* #f)) + (let Loop ((ast ast)) + (set! *unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if *unresolved* + (Loop ast) + ast)))))) + +;;;; ====================================================================== +;;;; +;;;; D O - R E S O L V E ! +;;;; +;;;; ====================================================================== + +(define-method do-resolve! (ast engine env) + ast) + + +(define-method do-resolve! ((ast <pair>) engine env) + (let Loop ((n* ast)) + (cond + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (Loop (cdr n*))) + ((not (null? n*)) + (error 'do-resolve "Illegal argument" n*)) + (else + ast)))) + + +(define-method do-resolve! ((node <node>) engine env) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve<body> + (debug-item "body=" body) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options)))) + (slot-set! node 'body (do-resolve! body engine env)) + node))) + + + +(define-method do-resolve! ((node <container>) engine env0) + (let ((body (slot-ref node 'body)) + (options (slot-ref node 'options)) + (env (slot-ref node 'env)) + (parent (slot-ref node 'parent))) + (with-debug 5 'do-resolve<container> + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" body) + (debug-item "env0=" env0) + (debug-item "env=" env) + (when (eq? parent 'unspecified) + (let ((p (assq 'parent env0))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (when (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))) + (let ((e `((parent ,node) ,@env ,@env0))) + (slot-set! node 'body (do-resolve! body engine e))))) + node))) + + +(define-method do-resolve! ((node <document>) engine env0) + (next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (slot-ref engine 'customs))) + node) + + +(define-method do-resolve! ((node <unresolved>) engine env) + (with-debug 5 'do-resolve<unresolved> + (debug-item "node=" node) + (let ((p (assq 'parent env))) + (slot-set! node 'parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + + (let* ((proc (slot-ref node 'proc)) + (res (resolve! (proc node engine env) engine env)) + (loc (ast-loc node))) + (when (ast? res) + (ast-loc-set! res loc)) + (debug-item "res=" res) + (set! *unresolved* #t) + res))) + + +(define-method do-resolve! ((node <handle>) engine env) + node) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (is-a? n <ast>)) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (slot-ref n 'parent) 'unspecified) + (skribe-error 'resolve-parent "Orphan node" n)) + (else + (slot-ref n 'parent))))) + + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-SEARCH-PARENT +;;;; +;;;; ====================================================================== +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" n) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" p " " + (if (is-a? p 'markup) (slot-ref p 'markup) "???")) + (cond + ((pred p) p) + ((is-a? p <unresolved>) p) + ((not p) #f) + (else (resolve-search-parent p e pred)))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-COUNTER +;;;; +;;;; ====================================================================== +;;FIXME: factoriser +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;;;; ====================================================================== +;;;; +;;;; RESOLVE-IDENT +;;;; +;;;; ====================================================================== +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) + +) diff --git a/skribe/src/stklos/runtime.stk b/skribe/src/stklos/runtime.stk new file mode 100644 index 0000000..58d0d45 --- /dev/null +++ b/skribe/src/stklos/runtime.stk @@ -0,0 +1,456 @@ +;;;; +;;;; runtime.stk -- Skribe runtime system +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 18:47 (eg) +;;;; Last file update: 15-Nov-2004 14:03 (eg) +;;;; + +(define-module SKRIBE-RUNTIME-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-VERIFY-MODULE SKRIBE-RESOLVE-MODULE + SKRIBE-OUTPUT-MODULE SKRIBE-EVAL-MODULE) + + (export ;; Utilities + strip-ref-base ast->file-location string-canonicalize + + ;; Markup functions + markup-option markup-option-add! markup-output + + ;; Container functions + container-env-get + + ;; Images + convert-image + + ;; String writing + make-string-replace + + ;; AST + ast->string + ) + +;;;; ====================================================================== +;;;; +;;;; U T I L I T I E S +;;;; +;;;; ====================================================================== +(define skribe-load 'function-defined-below) + + +;;FIXME: Remonter cette fonction +(define (strip-ref-base file) + (if (not (string? *skribe-ref-base*)) + file + (let ((l (string-length *skribe-ref-base*))) + (cond + ((not (> (string-length file) (+ l 2))) + file) + ((not (substring=? file *skribe-ref-base* l)) + file) + ((not (char=? (string-ref file l) (file-separator))) + file) + (else + (substring file (+ l 1) (string-length file))))))) + + +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format "~a:~a:" (location-file l) (location-line l)) + ""))) + +;; FIXME: Remonter cette fonction +(define (string-canonicalize old) + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((= r l) + (cond + ((= w 0) + "") + ((char-whitespace? (string-ref new (- w 1))) + (substring new 0 (- w 1))) + ((= w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+ r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+ r 1) (+ w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+ r 1) (+ w 1) #f)))))) + + +;;;; ====================================================================== +;;;; +;;;; M A R K U P S F U N C T I O N S +;;;; +;;;; ====================================================================== +;;; (define (markup-output markup +;; :optional (engine #f) +;; :key (predicate #f) +;; (options '()) +;; (before #f) +;; (action #f) +;; (after #f)) +;; (let ((e (or engine (use-engine)))) +;; (cond +;; ((not (is-a? e <engine>)) +;; (skribe-error 'markup-writer "illegal engine" e)) +;; ((and (not before) +;; (not action) +;; (not after)) +;; (%find-markup-output e markup)) +;; (else +;; (let ((mp (if (procedure? predicate) +;; (lambda (n e) (and (is-markup? n markup) (predicate n e))) +;; (lambda (n e) (is-markup? n markup))))) +;; (engine-output e markup mp options +;; (or before (slot-ref e 'default-before)) +;; (or action (slot-ref e 'default-action)) +;; (or after (slot-ref e 'default-after)))))))) + +(define (markup-option m opt) + (if (markup? m) + (let ((c (assq opt (slot-ref m 'options)))) + (and (pair? c) (pair? (cdr c)) + (cadr c))) + (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + + +(define (markup-option-add! m opt val) + (if (markup? m) + (slot-set! m 'options (cons (list opt val) + (slot-ref m 'options))) + (skribe-type-error 'markup-option "Illegal markup: " m "markup"))) + +;;;; ====================================================================== +;;;; +;;;; C O N T A I N E R S +;;;; +;;;; ====================================================================== +(define (container-env-get m key) + (let ((c (assq key (slot-ref m 'env)))) + (and (pair? c) (cadr c)))) + + +;;;; ====================================================================== +;;;; +;;;; I M A G E S +;;;; +;;;; ====================================================================== +(define (builtin-convert-image from fmt dir) + (let* ((s (suffix from)) + (f (string-append (prefix (basename from)) "." fmt)) + (to (string-append dir "/" f))) ;; FIXME: + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append "fig2dev -L " fmt " " from " > " to) + (string-append "convert " from " " to)))) + (cond + ((> *skribe-verbose* 1) + (format (current-error-port) " [converting image: ~S (~S)]" from c)) + ((> *skribe-verbose* 0) + (format (current-error-port) " [converting image: ~S]" from))) + (and (zero? (system c)) + to)))))) + +(define (convert-image file formats) + (let ((path (find-path file (skribe-image-path)))) + (if (not path) + (skribe-error 'convert-image + (format "Can't find `~a' image file in path: " file) + (skribe-image-path)) + (let ((suf (suffix file))) + (if (member suf formats) + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + #f))) + (if dir + (let ((dest (basename path))) + (copy-file path (make-path dir dest)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + +;;;; ====================================================================== +;;;; +;;;; S T R I N G - W R I T I N G +;;;; +;;;; ====================================================================== + +;; +;; (define (%make-html-replace) +;; ;; Ad-hoc version for HTML, a little bit faster than the +;; ;; make-general-string-replace define later (particularily if there +;; ;; is nothing to replace since, it does not allocate a new string +;; (let ((specials (string->regexp "&|\"|<|>"))) +;; (lambda (str) +;; (if (regexp-match specials str) +;; (begin +;; (let ((out (open-output-string))) +;; (dotimes (i (string-length str)) +;; (let ((ch (string-ref str i))) +;; (case ch +;; ((#\") (display """ out)) +;; ((#\&) (display "&" out)) +;; ((#\<) (display "<" out)) +;; ((#\>) (display ">" out)) +;; (else (write-char ch out))))) +;; (get-output-string out))) +;; str)))) + + +(define (%make-general-string-replace lst) + ;; The general version + (lambda (str) + (let ((out (open-output-string))) + (dotimes (i (string-length str)) + (let* ((ch (string-ref str i)) + (res (assq ch lst))) + (display (if res (cadr res) ch) out))) + (get-output-string out)))) + + +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2)))))) + (cond + ((equal? l '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) + string->html) + (else + (%make-general-string-replace lst))))) + + + + +;;;; ====================================================================== +;;;; +;;;; O P T I O N S +;;;; +;;;; ====================================================================== + +;;NEW ;; +;;NEW ;; GET-OPTION +;;NEW ;; +;;NEW (define (get-option obj key) +;;NEW ;; This function either searches inside an a-list or a markup. +;;NEW (cond +;;NEW ((pair? obj) (let ((c (assq key obj))) +;;NEW (and (pair? c) (pair? (cdr c)) (cadr c)))) +;;NEW ((markup? obj) (get-option (slot-ref obj 'option*) key)) +;;NEW (else #f))) +;;NEW +;;NEW ;; +;;NEW ;; BIND-OPTION! +;;NEW ;; +;;NEW (define (bind-option! obj key value) +;;NEW (slot-set! obj 'option* (cons (list key value) +;;NEW (slot-ref obj 'option*)))) +;;NEW +;;NEW +;;NEW ;; +;;NEW ;; GET-ENV +;;NEW ;; +;;NEW (define (get-env obj key) +;;NEW ;; This function either searches inside an a-list or a container +;;NEW (cond +;;NEW ((pair? obj) (let ((c (assq key obj))) +;;NEW (and (pair? c) (cadr c)))) +;;NEW ((container? obj) (get-env (slot-ref obj 'env) key)) +;;NEW (else #f))) +;;NEW + + + + +;;;; ====================================================================== +;;;; +;;;; A S T +;;;; +;;;; ====================================================================== + +(define-generic ast->string) + + +(define-method ast->string ((ast <top>)) "") +(define-method ast->string ((ast <string>)) ast) +(define-method ast->string ((ast <number>)) (number->string ast)) + +(define-method ast->string ((ast <pair>)) + (let ((out (open-output-string))) + (let Loop ((lst ast)) + (cond + ((null? lst) + (get-output-string out)) + (else + (display (ast->string (car lst)) out) + (unless (null? (cdr lst)) + (display #\space out)) + (Loop (cdr lst))))))) + +(define-method ast->string ((ast <node>)) + (ast->string (slot-ref ast 'body))) + + +;;NEW ;; +;;NEW ;; AST-PARENT +;;NEW ;; +;;NEW (define (ast-parent n) +;;NEW (slot-ref n 'parent)) +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-PARENT +;;NEW ;; +;;NEW (define (markup-parent m) +;;NEW (let ((p (slot-ref m 'parent))) +;;NEW (if (eq? p 'unspecified) +;;NEW (skribe-error 'markup-parent "Unresolved parent reference" m) +;;NEW p))) +;;NEW +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-DOCUMENT +;;NEW ;; +;;NEW (define (markup-document m) +;;NEW (let Loop ((p m) +;;NEW (l #f)) +;;NEW (cond +;;NEW ((is-markup? p 'document) p) +;;NEW ((or (eq? p 'unspecified) (not p)) l) +;;NEW (else (Loop (slot-ref p 'parent) p))))) +;;NEW +;;NEW ;; +;;NEW ;; MARKUP-CHAPTER +;;NEW ;; +;;NEW (define (markup-chapter m) +;;NEW (let loop ((p m) +;;NEW (l #f)) +;;NEW (cond +;;NEW ((is-markup? p 'chapter) p) +;;NEW ((or (eq? p 'unspecified) (not p)) l) +;;NEW (else (loop (slot-ref p 'parent) p))))) +;;NEW +;;NEW +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; H A N D L E S +;;NEW ;;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (handle-body h) +;;NEW (slot-ref h 'body)) +;;NEW +;;NEW +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; F I N D +;;NEW ;;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (find pred obj) +;;NEW (with-debug 4 'find +;;NEW (debug-item "obj=" obj) +;;NEW (let loop ((obj (if (is-a? obj <container>) (container-body obj) obj))) +;;NEW (cond +;;NEW ((pair? obj) +;;NEW (apply append (map (lambda (o) (loop o)) obj))) +;;NEW ((is-a? obj <container>) +;;NEW (debug-item "loop=" obj " " (slot-ref obj 'ident)) +;;NEW (if (pred obj) +;;NEW (list (cons obj (loop (container-body obj)))) +;;NEW '())) +;;NEW (else +;;NEW (if (pred obj) +;;NEW (list obj) +;;NEW '())))))) +;;NEW + +;;NEW ;;;; ====================================================================== +;;NEW ;;;; +;;NEW ;;;; M A R K U P A R G U M E N T P A R S I N G +;;NEW ;;; +;;NEW ;;;; ====================================================================== +;;NEW (define (the-body opt) +;;NEW ;; Filter out the options +;;NEW (let loop ((opt* opt) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-body "Illegal body" opt)) +;;NEW ((keyword? (car opt*)) +;;NEW (if (null? (cdr opt*)) +;;NEW (skribe-error 'the-body "Illegal option" (car opt*)) +;;NEW (loop (cddr opt*) res))) +;;NEW (else +;;NEW (loop (cdr opt*) (cons (car opt*) res)))))) +;;NEW +;;NEW +;;NEW +;;NEW (define (the-options opt+ . out) +;;NEW ;; Returns an list made of options.The OUT argument contains +;;NEW ;; keywords that are filtered out. +;;NEW (let loop ((opt* opt+) +;;NEW (res '())) +;;NEW (cond +;;NEW ((null? opt*) +;;NEW (reverse! res)) +;;NEW ((not (pair? opt*)) +;;NEW (skribe-error 'the-options "Illegal options" opt*)) +;;NEW ((keyword? (car opt*)) +;;NEW (cond +;;NEW ((null? (cdr opt*)) +;;NEW (skribe-error 'the-options "Illegal option" (car opt*))) +;;NEW ((memq (car opt*) out) +;;NEW (loop (cdr opt*) res)) +;;NEW (else +;;NEW (loop (cdr opt*) +;;NEW (cons (list (car opt*) (cadr opt*)) res))))) +;;NEW (else +;;NEW (loop (cdr opt*) res))))) +;;NEW + + +) diff --git a/skribe/src/stklos/source.stk b/skribe/src/stklos/source.stk new file mode 100644 index 0000000..a3102c1 --- /dev/null +++ b/skribe/src/stklos/source.stk @@ -0,0 +1,191 @@ +;;;; +;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 3-Sep-2003 12:22 (eg) +;;;; Last file update: 27-Oct-2004 20:09 (eg) +;;;; + + + +(define-module SKRIBE-SOURCE-MODULE + (export source-read-lines source-read-definition source-fontify) + + +;; Temporary solution +(define (language-extractor lang) + (slot-ref lang 'extractor)) + +(define (language-fontifier lang) + (slot-ref lang 'fontifier)) + + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+ l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+ l 1) #t (read-line) r)) + (else + (loop (+ l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((= i len) + (let ((nlen (- col 1))) + (if (= len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((= i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (* (/ (+ col tabl) + tabl) + tabl))) + (liip (+ i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+ i 1) (+ j 1) (+ col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+ i 1) + (* (/ (+ col tabl) tabl) tabl))) + (else + (loop (+ i 1) (+ col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-path file (skribe-source-path)))) + (cond + ((not (language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + (slot-ref lang 'name))) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (> *skribe-verbose* 0) + (format (current-error-port) " [source file: ~S]\n" p)) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((= i l) + (if (= i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+ i 1) + (+ i 1) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #\cr) + (< (+ i 1) l) + (char=? (string-ref str (+ i 1)) #\Newline)) + (loop (+ i 2) + (+ i 2) + (if (= i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+ i 1) j r)))))) + +) diff --git a/skribe/src/stklos/types.stk b/skribe/src/stklos/types.stk new file mode 100644 index 0000000..fb16230 --- /dev/null +++ b/skribe/src/stklos/types.stk @@ -0,0 +1,294 @@ +;;;; +;;;; types.stk -- Definition of Skribe classes +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 12-Aug-2003 22:18 (eg) +;;;; Last file update: 28-Oct-2004 16:18 (eg) +;;;; + + +(define *node-table* (make-hash-table equal?)) + ; Used to stores the nodes of an AST. + ; It permits to retrieve a node from its + ; identifier. + + +;;;; ====================================================================== +;;;; +;;;; <AST> +;;;; +;;;; ====================================================================== +;;FIXME: set! location in <ast> +(define-class <ast> () + ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) + (loc :init-form #f))) + +(define (ast? obj) (is-a? obj <ast>)) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) + +;;;; ====================================================================== +;;;; +;;;; <COMMAND> +;;;; +;;;; ====================================================================== +(define-class <command> (<ast>) + ((fmt :init-keyword :fmt) + (body :init-keyword :body))) + +(define (command? obj) (is-a? obj <command>)) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;;; ====================================================================== +;;;; +;;;; <UNRESOLVED> +;;;; +;;;; ====================================================================== +(define-class <unresolved> (<ast>) + ((proc :init-keyword :proc))) + +(define (unresolved? obj) (is-a? obj <unresolved>)) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;;; ====================================================================== +;;;; +;;;; <HANDLE> +;;;; +;;;; ====================================================================== +(define-class <handle> (<ast>) + ((ast :init-keyword :ast :init-form #f :getter handle-ast))) + +(define (handle? obj) (is-a? obj <handle>)) +(define (handle-ast obj) (slot-ref obj 'ast)) + + +;;;; ====================================================================== +;;;; +;;;; <NODE> +;;;; +;;;; ====================================================================== +(define-class <node> (<ast>) + ((required-options :init-keyword :required-options :init-form '()) + (options :init-keyword :options :init-form '()) + (body :init-keyword :body :init-form #f + :getter node-body))) + +(define (node? obj) (is-a? obj <node>)) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + + +;;;; ====================================================================== +;;;; +;;;; <PROCESSOR> +;;;; +;;;; ====================================================================== +(define-class <processor> (<node>) + ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-form 'unspecified) + (procedure :init-keyword :procedure :init-form (lambda (n e) n)))) + +(define (processor? obj) (is-a? obj <processor>)) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + +;;;; ====================================================================== +;;;; +;;;; <MARKUP> +;;;; +;;;; ====================================================================== +(define-class <markup> (<node>) + ((ident :init-keyword :ident :getter markup-ident :init-form #f) + (class :init-keyword :class :getter markup-class :init-form #f) + (markup :init-keyword :markup :getter markup-markup))) + + +(define (bind-markup! node) + (hash-table-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + + +(define-method initialize ((self <markup>) initargs) + (next-method) + (bind-markup! self)) + + +(define (markup? obj) (is-a? obj <markup>)) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) + + +(define (is-markup? obj markup) + (and (is-a? obj <markup>) + (eq? (slot-ref obj 'markup) markup))) + + + +(define (find-markups ident) + (hash-table-get *node-table* ident #f)) + + +(define-method write-object ((obj <markup>) port) + (format port "#[~A (~A/~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; <CONTAINER> +;;;; +;;;; ====================================================================== +(define-class <container> (<markup>) + ((env :init-keyword :env :init-form '()))) + +(define (container? obj) (is-a? obj <container>)) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + + + +;;;; ====================================================================== +;;;; +;;;; <DOCUMENT> +;;;; +;;;; ====================================================================== +(define-class <document> (<container>) + ()) + +(define (document? obj) (is-a? obj <document>)) +(define (document-ident obj) (slot-ref obj 'ident)) +(define (document-body obj) (slot-ref obj 'body)) +(define document-options markup-options) +(define document-env container-env) + + +;;;; ====================================================================== +;;;; +;;;; <ENGINE> +;;;; +;;;; ====================================================================== +(define-class <engine> () + ((ident :init-keyword :ident :init-form '???) + (format :init-keyword :format :init-form "raw") + (info :init-keyword :info :init-form '()) + (version :init-keyword :version :init-form 'unspecified) + (delegate :init-keyword :delegate :init-form #f) + (writers :init-keyword :writers :init-form '()) + (filter :init-keyword :filter :init-form #f) + (customs :init-keyword :custom :init-form '()) + (symbol-table :init-keyword :symbol-table :init-form '()))) + + + +(define (engine? obj) + (is-a? obj <engine>)) + +(define (engine-ident obj) ;; Define it here since the doc searches it + (slot-ref obj 'ident)) + +(define (engine-format obj) ;; Define it here since the doc searches it + (slot-ref obj 'format)) + +(define (engine-customs obj) ;; Define it here since the doc searches it + (slot-ref obj 'customs)) + +(define (engine-filter obj) ;; Define it here since the doc searches it + (slot-ref obj 'filter)) + +(define (engine-symbol-table obj) ;; Define it here since the doc searches it + (slot-ref obj 'symbol-table)) + + +;;;; ====================================================================== +;;;; +;;;; <WRITER> +;;;; +;;;; ====================================================================== +(define-class <writer> () + ((ident :init-keyword :ident :init-form '??? :getter writer-ident) + (class :init-keyword :class :initform 'unspecified + :getter writer-class) + (pred :init-keyword :pred :init-form 'unspecified) + (upred :init-keyword :upred :init-form 'unspecified) + (options :init-keyword :options :init-form '() :getter writer-options) + (verified? :init-keyword :verified? :init-form #f) + (validate :init-keyword :validate :init-form #f) + (before :init-keyword :before :init-form #f :getter writer-before) + (action :init-keyword :action :init-form #f :getter writer-action) + (after :init-keyword :after :init-form #f :getter writer-after))) + +(define (writer? obj) + (is-a? obj <writer>)) + +(define-method write-object ((obj <writer>) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; <LANGUAGE> +;;;; +;;;; ====================================================================== +(define-class <language> () + ((name :init-keyword :name :init-form #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier) + (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))) + +(define (language? obj) + (is-a? obj <language>)) + + +;;;; ====================================================================== +;;;; +;;;; <LOCATION> +;;;; +;;;; ====================================================================== +(define-class <location> () + ((file :init-keyword :file :getter location-file) + (pos :init-keyword :pos :getter location-pos) + (line :init-keyword :line :getter location-line))) + +(define (location? obj) + (is-a? obj <location>)) + +(define (ast-location obj) + (let ((loc (slot-ref obj 'loc))) + (if (location? loc) + (let* ((fname (location-file loc)) + (line (location-line loc)) + (pwd (getcwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (> lenf len)) + (substring fname len (+ 1 (string-length fname))) + fname))) + (format "~a, line ~a" file line)) + "no source location"))) diff --git a/skribe/src/stklos/vars.stk b/skribe/src/stklos/vars.stk new file mode 100644 index 0000000..1c875f8 --- /dev/null +++ b/skribe/src/stklos/vars.stk @@ -0,0 +1,82 @@ +;;;; +;;;; vars.stk -- Skribe Globals +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 11-Aug-2003 16:18 (eg) +;;;; Last file update: 26-Feb-2004 20:36 (eg) +;;;; + + +;;; +;;; Switches +;;; +(define *skribe-verbose* 0) +(define *skribe-warning* 5) +(define *load-rc* #t) + +;;; +;;; PATH variables +;;; +(define *skribe-path* #f) +(define *skribe-bib-path* '(".")) +(define *skribe-source-path* '(".")) +(define *skribe-image-path* '(".")) + + +(define *skribe-rc-directory* + (make-path (getenv "HOME") ".skribe")) + + +;;; +;;; In and out ports +;;; +(define *skribe-src* '()) +(define *skribe-dest* #f) + +;;; +;;; Engine +;;; +(define *skribe-engine* 'html) ;; Use HTML by default + +;;; +;;; Misc +;;; +(define *skribe-chapter-split* '()) +(define *skribe-ref-base* #f) +(define *skribe-convert-image* #f) ;; i.e. use the Skribe standard converter +(define *skribe-variants* '()) + + + + +;;; Forward definitions (to avoid warnings when compiling Skribe) +;;; This is a KLUDGE. +(define mark #f) +(define ref #f) +;;(define invoke 3) +(define lookup-markup-writer #f) + +(define-module SKRIBE-ENGINE-MODULE + (define find-engine #f)) + +(define-module SKRIBE-OUTPUT-MODULE) + +(define-module SKRIBE-RUNTIME-MODULE) diff --git a/skribe/src/stklos/verify.stk b/skribe/src/stklos/verify.stk new file mode 100644 index 0000000..da9b132 --- /dev/null +++ b/skribe/src/stklos/verify.stk @@ -0,0 +1,157 @@ +;;;; +;;;; verify.stk -- Skribe Verification Stage +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 13-Aug-2003 11:57 (eg) +;;;; Last file update: 27-Oct-2004 16:35 (eg) +;;;; + +(define-module SKRIBE-VERIFY-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-WRITER-MODULE + SKRIBE-RUNTIME-MODULE) + (export verify) + + +(define-generic verify) + +;;; +;;; CHECK-REQUIRED-OPTIONS +;;; +(define (check-required-options markup writer engine) + (let ((required-options (slot-ref markup 'required-options)) + (ident (slot-ref writer 'ident)) + (options (slot-ref writer 'options)) + (verified? (slot-ref writer 'verified?))) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (engine-ident engine) + (format "Option unsupported: ~a, supported options: ~a" o options) + markup))) + required-options) + (slot-set! writer 'verified? #t))))) + +;;; +;;; CHECK-OPTIONS +;;; +(define (check-options lopts markup engine) + + ;; Only keywords are checked, symbols are voluntary left unchecked. */ + (with-debug 6 'check-options + (debug-item "markup=" (markup-markup markup)) + (debug-item "options=" (slot-ref markup 'options)) + (debug-item "lopts=" lopts) + (for-each + (lambda (o2) + (for-each + (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o lopts))) + (skribe-warning/ast + 3 + markup + 'verify + (format "Engine ~a does not support markup ~a option `~a' -- ~a" + (engine-ident engine) + (markup-markup markup) + o + (markup-option markup o))))) + o2)) + (slot-ref markup 'options)))) + + +;;; ====================================================================== +;;; +;;; V E R I F Y +;;; +;;; ====================================================================== + +;;; TOP +(define-method verify ((obj <top>) e) + obj) + +;;; PAIR +(define-method verify ((obj <pair>) e) + (for-each (lambda (x) (verify x e)) obj) + obj) + +;;; PROCESSOR +(define-method verify ((obj <processor>) e) + (let ((combinator (slot-ref obj 'combinator)) + (engine (slot-ref obj 'engine)) + (body (slot-ref obj 'body))) + (verify body (processor-get-engine combinator engine e)) + obj)) + +;;; NODE +(define-method verify ((node <node>) e) + ;; Verify body + (verify (slot-ref node 'body) e) + ;; Verify options + (for-each (lambda (o) (verify (cadr o) e)) + (slot-ref node 'options)) + node) + +;;; MARKUP +(define-method verify ((node <markup>) e) + (with-debug 5 'verify::<markup> + (debug-item "node=" (markup-markup node)) + (debug-item "options=" (slot-ref node 'options)) + (debug-item "e=" (engine-ident e)) + + (next-method) + + (let ((w (lookup-markup-writer node e))) + (when (writer? w) + (check-required-options node w e) + (when (pair? (writer-options w)) + (check-options (slot-ref w 'options) node e)) + (let ((validate (slot-ref w 'validate))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format "Node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)))))))) + node)) + + +;;; DOCUMENT +(define-method verify ((node <document>) e) + (next-method) + + ;; verify the engine customs + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (slot-ref e 'customs)) + + node) + + +) + diff --git a/skribe/src/stklos/writer.stk b/skribe/src/stklos/writer.stk new file mode 100644 index 0000000..2b0f91c --- /dev/null +++ b/skribe/src/stklos/writer.stk @@ -0,0 +1,211 @@ +;;;; +;;;; writer.stk -- Skribe Writer Stuff +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 15-Sep-2003 22:21 (eg) +;;;; Last file update: 4-Mar-2004 10:48 (eg) +;;;; + + +(define-module SKRIBE-WRITER-MODULE + (import SKRIBE-DEBUG-MODULE SKRIBE-ENGINE-MODULE SKRIBE-OUTPUT-MODULE) + (export invoke markup-writer markup-writer-get markup-writer-get* + lookup-markup-writer copy-markup-writer) + +;;;; ====================================================================== +;;;; +;;;; INVOKE +;;;; +;;;; ====================================================================== +(define (invoke proc node e) + (with-debug 5 'invoke + (debug-item "e=" (engine-ident e)) + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))) + + +;;;; ====================================================================== +;;;; +;;;; LOOKUP-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (lookup-markup-writer node e) + (let ((writers (slot-ref e 'writers)) + (delegate (slot-ref e 'delegate))) + (let Loop ((w* writers)) + (cond + ((pair? w*) + (let ((pred (slot-ref (car w*) 'pred))) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;;;; ====================================================================== +;;;; +;;;; MAKE-WRITER-PREDICATE +;;;; +;;;; ====================================================================== +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (eq? (%procedure-arity predicate) 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (markup-writer markup :optional engine + :key (predicate #f) (class #f) (options '()) + (validate #f) + (before #f) (action 'unspecified) (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action 'unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action 'unspecified) + (lambda (n e) (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET +;;;; +;;;; ====================================================================== +(define (markup-writer-get markup :optional engine :key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer-get "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer-get "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (slot-ref e 'writers))) + (cond + ((pair? w*) + (if (and (eq? (writer-ident (car w*)) markup) + (equal? (writer-class (car w*)) class) + (or (unspecified? pred) + (eq? (slot-ref (car w*) 'upred) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate))) + (else + #f)))))))) + +;;;; ====================================================================== +;;;; +;;;; MARKUP-WRITER-GET* +;;;; +;;;; ====================================================================== + +;; Finds all writers that matches MARKUP with optional CLASS attribute. + +(define (markup-writer-get* markup #!optional engine #!key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (slot-ref e 'writers)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (slot-ref (car w*) 'ident) markup) + (equal? (slot-ref (car w*) 'class) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (slot-ref e 'delegate)) + (liip (slot-ref e 'delegate) res)) + (else + (reverse! res))))))))) + +;;; ====================================================================== +;;;; +;;;; COPY-MARKUP-WRITER +;;;; +;;;; ====================================================================== +(define (copy-markup-writer markup old-engine :optional new-engine + :key (predicate 'unspecified) + (class 'unspecified) + (options 'unspecified) + (validate 'unspecified) + (before 'unspecified) + (action 'unspecified) + (after 'unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) (slot-ref old 'pred) predicate) + :class (if (unspecified? class) (slot-ref old 'class) class) + :options (if (unspecified? options) (slot-ref old 'options) options) + :validate (if (unspecified? validate) (slot-ref old 'validate) validate) + :before (if (unspecified? before) (slot-ref old 'before) before) + :action (if (unspecified? action) (slot-ref old 'action) action) + :after (if (unspecified? after) (slot-ref old 'after) after)))) + +) diff --git a/skribe/src/stklos/xml-lex.l b/skribe/src/stklos/xml-lex.l new file mode 100644 index 0000000..5d9a8d9 --- /dev/null +++ b/skribe/src/stklos/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 21-Dec-2003 22:38 (eg) +;;;; + +space [ \n\9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +'[^']*' (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +<!--(.|\n)*--> (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<<EOF>> 'eof +<<ERROR>> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + +
\ No newline at end of file diff --git a/skribe/src/stklos/xml.stk b/skribe/src/stklos/xml.stk new file mode 100644 index 0000000..47dd46f --- /dev/null +++ b/skribe/src/stklos/xml.stk @@ -0,0 +1,52 @@ +;;;; +;;;; xml.stk -- XML Fontification stuff +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 16-Oct-2003 22:33 (eg) +;;;; Last file update: 28-Dec-2003 17:33 (eg) +;;;; + + +(require "lex-rt") ;; to avoid module problems + + +(define-module SKRIBE-XML-MODULE + (export xml) + (import SKRIBE-SOURCE-MODULE) + +(include "xml-lex.stk") ;; SILex generated + +(define (xml-fontifier s) + (let ((lex (xml-lex (open-input-string s)))) + (let Loop ((token (lexer-next-token lex)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (Loop (lexer-next-token lex) + (cons token res)))))) + + +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) +) diff --git a/skribe/tools/Makefile b/skribe/tools/Makefile new file mode 100644 index 0000000..200db45 --- /dev/null +++ b/skribe/tools/Makefile @@ -0,0 +1,60 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/tools/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Wed Jul 30 16:23:07 2003 */ +#* Last change : Tue Oct 26 19:36:26 2004 (eg) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Skribe Tools general makefile */ +#*=====================================================================*/ +include ../etc/Makefile.config + +TOOLS= skribebibtex + +#*---------------------------------------------------------------------*/ +#* all */ +#*---------------------------------------------------------------------*/ +.PHONY: all + +all: + for p in $(TOOLS); do \ + (cd $$p/$(SYSTEM) && $(MAKE)) || exit -1; \ + done + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ for p in $(TOOLS); do \ + (cd $$p/bigloo && $(MAKE) pop); \ + (cd $$p/stklos && $(MAKE) pop); \ + done + @ echo tools/Makefile + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall + +install: + @ for p in $(TOOLS); do \ + (cd $$p/$(SYSTEM) && $(MAKE) install) || exit -1; \ + done +uninstall: + @ for p in $(TOOLS); do \ + (cd $$p/$(SYSTEM) && $(MAKE) uninstall) || exit -1; \ + done + +#*---------------------------------------------------------------------*/ +#* clean */ +#*---------------------------------------------------------------------*/ +.PHONY: clean + +clean: + for p in $(TOOLS); do \ + (cd $$p/$(SYSTEM) && $(MAKE) clean); \ + done + diff --git a/skribe/tools/skribebibtex/bigloo/Makefile b/skribe/tools/skribebibtex/bigloo/Makefile new file mode 100644 index 0000000..c2a4cc1 --- /dev/null +++ b/skribe/tools/skribebibtex/bigloo/Makefile @@ -0,0 +1,70 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/tools/skribebibtex/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Thu Dec 20 10:42:25 2001 */ +#* Last change : Tue Oct 26 19:34:00 2004 (eg) */ +#* Copyright : 2001-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to compile the bibtex->Skribe translator */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* Standard configuration */ +#*---------------------------------------------------------------------*/ +include ../../../etc/bigloo/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Binary */ +#*---------------------------------------------------------------------*/ +TARGETNAME = skribebibtex + +#*---------------------------------------------------------------------*/ +#* Objects */ +#*---------------------------------------------------------------------*/ +_BGL_OBJECTS = skribebibtex main +_C_OBJECTS = +_JAVA_OBJECTS = + +_OBJECTS = $(_BGL_OBJECTS) $(_C_OBJECTS) +OBJECTS = $(_OBJECTS:%=o/%.o) + +_CLASSES = $(_BGL_OBJECTS) $(_JAVA_OBJECTS) +CLASSES = $(_OBJECTS:%=o/class_s/bigloo/skribe/$(TARGETNAME)/%.class) + +_BGL_SOURCES = $(_BGL_OBJECTS:%=%.scm) +_C_SOURCES = $(_C_OBJECTS:%=%.c) +_JAVA_SOURCES = $(_JAVA_OBJECTS:%=%.java) + +SOURCES = $(_BGL_SOURCES) $(_C_SOURCES) $(_JAVA_SOURCES) +INCLUDES = + +#*---------------------------------------------------------------------*/ +#* Sources */ +#*---------------------------------------------------------------------*/ +POPULATION = $(SOURCES) $(INCLUDES) Makefile + +#*---------------------------------------------------------------------*/ +#* all, c & jvm */ +#*---------------------------------------------------------------------*/ +all: bin-$(TARGET) +c: bin-c +jvm: bin-jvm + +#*---------------------------------------------------------------------*/ +#* Standard Skribe Makefile */ +#*---------------------------------------------------------------------*/ +include ../../../etc/bigloo/Makefile.tpl + +#*---------------------------------------------------------------------*/ +#* pop: */ +#*---------------------------------------------------------------------*/ +pop: + @ echo $(POPULATION:%=tools/$(TARGETNAME)/bigloo/%) + +#*---------------------------------------------------------------------*/ +#* clean */ +#*---------------------------------------------------------------------*/ +clean: stdclean + + diff --git a/skribe/tools/skribebibtex/bigloo/main.scm b/skribe/tools/skribebibtex/bigloo/main.scm new file mode 100644 index 0000000..3ff89de --- /dev/null +++ b/skribe/tools/skribebibtex/bigloo/main.scm @@ -0,0 +1,44 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/tools/skribebibtex/main.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 12 14:57:58 2001 */ +;* Last change : Fri Oct 24 12:00:23 2003 (serrano) */ +;* Copyright : 2001-03 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The entry point of the bibtex->skribe translator */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module main + (import skribebibtex) + (main main)) + +;*---------------------------------------------------------------------*/ +;* main ... */ +;*---------------------------------------------------------------------*/ +(define (main argv) + (define (usage args-parse-usage) + (print "usage: skribebibtex [options] [input]") + (newline) + (args-parse-usage #f)) + (let ((stage 'scr) + (dest #f) + (in #f)) + (args-parse (cdr argv) + ((("-h" "--help") (help "This help message")) + (usage args-parse-usage) + (exit 0)) + ((("--options") (help "Display the options and exit")) + (args-parse-usage #t) + (exit 0)) + (("-o" ?out (help "Set the destination file")) + (set! dest out)) + (else + (set! in else))) + (if (string? dest) + (with-output-to-file dest (lambda () (skribebibtex in))) + (skribebibtex in)))) + diff --git a/skribe/tools/skribebibtex/bigloo/skribebibtex.scm b/skribe/tools/skribebibtex/bigloo/skribebibtex.scm new file mode 100644 index 0000000..b581537 --- /dev/null +++ b/skribe/tools/skribebibtex/bigloo/skribebibtex.scm @@ -0,0 +1,385 @@ +;*=====================================================================*/ +;* .../skribe/tools/skribebibtex/bigloo/skribebibtex.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 12 14:57:58 2001 */ +;* Last change : Sun Apr 10 09:10:02 2005 (serrano) */ +;* Copyright : 2001-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The bibtex->skribe translator */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribebibtex + (export (skribebibtex in))) + +;*---------------------------------------------------------------------*/ +;* skribebibtex ... */ +;*---------------------------------------------------------------------*/ +(define (skribebibtex in) + (let* ((port (if (string? in) + (let ((p (open-input-file in))) + (if (not (input-port? p)) + (error "skribebibtext" + "Can't read input file" + in) + p)) + (current-input-port))) + (sexp (parse-bibtex port))) + (for-each (lambda (e) + (match-case e + ((?kind ?ident . ?fields) + (display* "(" + (string-downcase (symbol->string kind)) + " \"" ident "\"") + (for-each (lambda (f) + (display* "\n (" (car f) " ") + (write (cdr f)) + (display ")")) + fields) + (print ")\n")))) + sexp))) + +;*---------------------------------------------------------------------*/ +;* *bibtex-string-table* ... */ +;*---------------------------------------------------------------------*/ +(define *bibtex-string-table* #unspecified) + +;*---------------------------------------------------------------------*/ +;* make-bibtex-hashtable ... */ +;*---------------------------------------------------------------------*/ +(define (make-bibtex-hashtable) + (let ((table (make-hashtable))) + (for-each (lambda (k) + (let ((cp (string-capitalize k))) + (hashtable-put! table k cp) + (hashtable-put! table cp cp))) + '("jan" "feb" "mar" "apr" "may" "jun" "jul" + "aug" "sep" "oct" "nov" "dec")) + table)) + +;*---------------------------------------------------------------------*/ +;* parse-bibtex ... */ +;*---------------------------------------------------------------------*/ +(define (parse-bibtex port::input-port) + (set! *bibtex-string-table* (make-bibtex-hashtable)) + (cond-expand + (bigloo2.6 + (try (read/lalrp bibtex-parser bibtex-lexer port) + (lambda (escape proc mes obj) + (match-case obj + ((?token (?fname . ?pos) . ?val) + (error/location proc "bibtex parse error" token fname pos)) + (else + (notify-error proc mes obj) + (error proc mes obj)))))) + (else + (with-exception-handler + (lambda (e) + (if (&io-parse-error? e) + (let ((o (&error-obj e))) + (match-case o + ((?token (?fname . ?pos) . ?val) + (error/location (&error-proc e) + "bibtex parse error" + token + fname + pos)) + (else + (raise e)))) + (raise e))) + (lambda () + (read/lalrp bibtex-parser bibtex-lexer port)))))) + +;*---------------------------------------------------------------------*/ +;* the-coord ... */ +;*---------------------------------------------------------------------*/ +(define (the-coord port) + (cons (input-port-name port) (input-port-position port))) + +;*---------------------------------------------------------------------*/ +;* bibtex-lexer ... */ +;*---------------------------------------------------------------------*/ +(define bibtex-lexer + (regular-grammar ((blank (in " \t\n"))) + ;; separators + ((+ blank) + (list 'BLANK (the-coord (the-port)))) + ;; comments + ((: "%" (* all)) + (ignore)) + ;; egal sign + (#\= + (list 'EGAL (the-coord (the-port)))) + ;; sharp sign + ((: (* blank) #\# (* blank)) + (list 'SHARP (the-coord (the-port)))) + ;; open bracket + (#\{ + (list 'BRA-OPEN (the-coord (the-port)))) + ;; close bracket + (#\} + (list 'BRA-CLO (the-coord (the-port)))) + ;; comma + (#\, + (list 'COMMA (the-coord (the-port)))) + ;; double quote + ((: #\\ (in "\"\\_")) + (list 'CHAR (the-coord (the-port)) (the-character))) + ;; optional linebreak + ((: #\\ #\-) + (ignore)) + ;; special latin characters + ((or "{\\'e}" "\\'e") + (list 'CHAR (the-coord (the-port)) "é")) + ((or "{\\o}" "\\o") + (list 'CHAR (the-coord (the-port)) "ø")) + ((or "{\\~{n}}" "\\~{n}") + (list 'CHAR (the-coord (the-port)) "ñ")) + ((or "{\\~{N}}" "\\~{N}") + (list 'CHAR (the-coord (the-port)) "Ñ")) + ((or "{\\^{o}}" "\\^{o}") + (list 'CHAR (the-coord (the-port)) "ô")) + ((or "{\\^{O}}" "\\^{O}") + (list 'CHAR (the-coord (the-port)) "Ô")) + ((or "{\\\"{o}}" "\\\"{o}") + (list 'CHAR (the-coord (the-port)) "ö")) + ((or "{\\\"{O}}" "\\\"{O}") + (list 'CHAR (the-coord (the-port)) "Ö")) + ((or "{\\`e}" "\\`e") + (list 'CHAR (the-coord (the-port)) "è")) + ((or "{\\`a}" "\\`a") + (list 'CHAR (the-coord (the-port)) "à")) + ((or "{\\\"i}" "{\\\"{i}}" "\\\"i" "\\\"{i}") + (list 'CHAR (the-coord (the-port)) "ï")) + ((or "{\\\"u}" "\\\"u") + (list 'CHAR (the-coord (the-port)) "ü")) + ((or "{\\`u}" "\\`u") + (list 'CHAR (the-coord (the-port)) "ù")) + ;; latex commands + ((: #\\ alpha (+ (or alpha digit))) + (let ((s (the-substring 1 (the-length)))) + (cond + ((member s '("pi" "Pi" "lambda" "Lambda")) + (list 'IDENT (the-coord (the-port)) s)) + (else + (ignore))))) + ;; strings + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (list 'STRING + (the-coord (the-port)) + (the-substring 1 (-fx (the-length) 1)))) + ;; commands + ((: "@" (+ alpha)) + (let* ((str (string-upcase (the-substring 1 (the-length)))) + (sym (string->symbol str))) + (case sym + ((STRING) + (list 'BIBSTRING (the-coord (the-port)))) + (else + (list 'BIBITEM (the-coord (the-port)) sym))))) + ;; digit + ((+ digit) + (list 'NUMBER (the-coord (the-port)) (the-string))) + ;; ident + ((+ (or alpha digit (in ".:-&/?+*"))) + (list 'IDENT (the-coord (the-port)) (the-string))) + ;; default + (else + (let ((c (the-failure))) + (if (eof-object? c) + c + (list 'CHAR (the-coord (the-port)) c)))))) + +;*---------------------------------------------------------------------*/ +;* bibtex-parser ... */ +;*---------------------------------------------------------------------*/ +(define bibtex-parser + (lalr-grammar + ;; tokens + (CHAR IDENT STRING COMMA BRA-OPEN BRA-CLO SHARP BLANK NUMBER EGAL + BIBSTRING BIBITEM) + + ;; bibtex + (bibtex + (() + '()) + ((bibtex string-def) + bibtex) + ((bibtex bibtex-entry) + (cons bibtex-entry bibtex)) + ((bibtex BLANK) + bibtex)) + + ;; blank* + (blank* + (() '()) + ((blank* BLANK) '())) + + ;; string-def + (string-def + ((BIBSTRING BRA-OPEN blank* IDENT blank* EGAL blank* bibtex-entry-value BRA-CLO) + (bibtex-string-def! (cadr IDENT) bibtex-entry-value))) + + ;; bibtex-entry + (bibtex-entry + ((BIBITEM blank* BRA-OPEN blank* IDENT blank* COMMA + bibtex-entry-item* BRA-CLO) + (make-bibtex-entry (cadr BIBITEM) + (cadr IDENT) + bibtex-entry-item*))) + + ;; bibtex-entry-item* + (bibtex-entry-item* + ((blank*) + '()) + ((bibtex-entry-item) + (list bibtex-entry-item)) + ((bibtex-entry-item COMMA bibtex-entry-item*) + (cons bibtex-entry-item bibtex-entry-item*))) + + ;; bibtex-entry-item + (bibtex-entry-item + ((blank* IDENT blank* EGAL blank* bibtex-entry-value blank*) + (cons (cadr IDENT) bibtex-entry-value))) + + ;; bibtex-entry-value + (bibtex-entry-value + ((NUMBER) + (list (cadr NUMBER))) + ((bibtex-entry-value-string) + bibtex-entry-value-string) + ((BRA-OPEN bibtex-entry-value-block* BRA-CLO) + bibtex-entry-value-block*)) + + ;; bibtex-entry-value-string + (bibtex-entry-value-string + ((bibtex-entry-value-string-simple) + (list bibtex-entry-value-string-simple)) + ((bibtex-entry-value-string SHARP bibtex-entry-value-string-simple) + `(,@bibtex-entry-value-string ,bibtex-entry-value-string-simple))) + + ;; bibtex-entry-value-string-simple + (bibtex-entry-value-string-simple + ((STRING) + (cadr STRING)) + ((IDENT) + `(ref ,(cadr IDENT)))) + + ;; bibtex-entry-value-block* + (bibtex-entry-value-block* + (() + '()) + ((bibtex-entry-value-block* bibtex-entry-value-block) + (append bibtex-entry-value-block* bibtex-entry-value-block))) + + ;; bibtex-entry-value-block + (bibtex-entry-value-block + ((BRA-OPEN bibtex-entry-value-block* BRA-CLO) + bibtex-entry-value-block*) + ((COMMA) + (list ",")) + ((IDENT) + (list (cadr IDENT))) + ((BLANK) + (list " ")) + ((EGAL) + (list "=")) + ((CHAR) + (list (cadr CHAR))) + ((NUMBER) + (list (cadr NUMBER))) + ((STRING) + (list (string-append "\"" (cadr STRING) "\"")))))) + +;*---------------------------------------------------------------------*/ +;* bibtex-string-def! ... */ +;*---------------------------------------------------------------------*/ +(define (bibtex-string-def! ident value) + (define (->string value) + (if (string? value) + value + (match-case value + (((and ?s (? string?))) + s) + (((and ?n (? number?))) + (number->string n)) + (else + (apply string-append (map ->string value)))))) + (hashtable-put! *bibtex-string-table* ident (->string value))) + +;*---------------------------------------------------------------------*/ +;* make-bibtex-entry ... */ +;*---------------------------------------------------------------------*/ +(define (make-bibtex-entry kind ident value) + (define (parse-entry-value line) + (let ((name (car line)) + (val (cdr line))) + (let loop ((val (reverse val)) + (res "")) + (cond + ((null? val) + (cons name (untexify res))) + ((char? (car val)) + (loop (cdr val) (string-append (string (car val)) res))) + ((string? (car val)) + (loop (cdr val) (string-append (car val) res))) + (else + (match-case (car val) + ((ref ?ref) + (let ((h (hashtable-get *bibtex-string-table* ref))) + (loop (cdr val) + (if (string? h) + (string-append h res) + res)))) + (else + (loop (cdr val) res)))))))) + (let ((fields (map parse-entry-value value))) + `(,kind ,ident ,@fields))) + +;*---------------------------------------------------------------------*/ +;* untexify ... */ +;*---------------------------------------------------------------------*/ +(define (untexify val) + (define (untexify-math-string str) + (string-case str + ((+ (out #\_ #\^ #\space #\Newline #\tab)) + (let ((s (the-string))) + (string-append s (ignore)))) + ((+ (in "^_")) + (ignore)) + ((+ (in " \n\t")) + (string-append " " (ignore))) + (else + ""))) + (define (untexify-string str) + (let ((s (pregexp-replace* "C[$]\\^[$]_[+][+][$][$]" str "C++"))) + (string-case (pregexp-replace* "[{}]" s "") + ((+ (out #\\ #\$ #\space #\Newline #\tab #\~)) + (let ((s (the-string))) + (string-append s (ignore)))) + ((: #\\ (+ (or (: "c" (out #\h)) + (: "ch" (out #\a)) + (: "cha" (out #\r)) + (: "char" (out digit)) + (out #\\ #\space #\c)))) + (ignore)) + ((: #\\ "char" (+ digit)) + (string-append + (string + (integer->char + (string->integer + (the-substring 5 (the-length))))) + (ignore))) + ((: #\$ (* (out #\$)) #\$) + (let ((s (the-substring 1 (-fx (the-length) 1)))) + (string-append (untexify-math-string s) (ignore)))) + ((+ (in " \n\t~")) + (string-append " " (ignore))) + (else + "")))) + (if (string? val) + (untexify-string val) + (map untexify val))) diff --git a/skribe/tools/skribebibtex/stklos/Makefile b/skribe/tools/skribebibtex/stklos/Makefile new file mode 100644 index 0000000..3e31d88 --- /dev/null +++ b/skribe/tools/skribebibtex/stklos/Makefile @@ -0,0 +1,62 @@ +# +# Makefile for STklos skribebibtex +# +# Author: Erick Gallesio [eg@essi.fr] +# Creation date: 26-Oct-2004 18:40 (eg) +# Last file update: 8-Nov-2004 15:25 (eg) + +include ../../../etc/stklos/Makefile.skb +include ../../../etc/Makefile.config + +POPULATION = Makefile bibtex-lex.l bibtex-parser.y skribebibtex.stk main.stk +BINDIR = ../../../bin +TARGET = skribebibtex +EXE = $(BINDIR)/$(TARGET).stklos + +all: $(EXE) + +$(EXE): main.stk bibtex-lex.stk bibtex-parser.stk + stklos-compile -l -o $(EXE) main.stk + +bibtex-lex.stk: bibtex-lex.l + stklos-genlex bibtex-lex.l bibtex-lex.stk bibtex-lex + +bibtex-parser.stk: bibtex-parser.y + stklos -f bibtex-parser.y + +bibtex: bibtex-lex.stk + + +#====================================================================== +# install ... +#====================================================================== +install: $(INSTALL_BINDIR) + cp $(EXE) $(INSTALL_BINDIR)/$(TARGET).stklos \ + && chmod $(BMASK) $(INSTALL_BINDIR)/$(TARGET).stklos + rm -f $(INSTALL_BINDIR)/$(TARGET) + ln -s $(TARGET).stklos $(INSTALL_BINDIR)/$(TARGET) + +$(INSTALL_BINDIR): + mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) + + +#====================================================================== +# uninstall ... +#====================================================================== +uninstall: + rm $(INSTALL_BINDIR)/$(TARGET) + rm $(INSTALL_BINDIR)/$(TARGET).stklos + + +#====================================================================== +# pop ... +#====================================================================== +pop: + @echo $(POPULATION:%=tools/skribebibtex/stklos/%) + +#====================================================================== +# clean ... +#====================================================================== + +clean: + rm -f $(EXE) bibtex-lex.stk bibtex-parser.stk *~ diff --git a/skribe/tools/skribebibtex/stklos/bibtex-lex.l b/skribe/tools/skribebibtex/stklos/bibtex-lex.l new file mode 100644 index 0000000..03b4871 --- /dev/null +++ b/skribe/tools/skribebibtex/stklos/bibtex-lex.l @@ -0,0 +1,75 @@ +;;;; -*- Scheme -*- +;;;; bibtex-lex.l -- SILex input for BibTeX +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Oct-2004 17:47 (eg) +;;;; Last file update: 25-Oct-2004 20:16 (eg) +;;;; + + +space [ \n\9] +alpha [-+a-zA-ZàâäéèêëîïôöûüùÀÂÄÉÈÊËÎÏÔÖÛÜÙ./:()?!'&_~] + +%% + +;; Spaces +{space}+ (list 'BLANK) +;; Comment +\%.*$ (yycontinue) +;; equal sign += (list 'EQUAL) +;; Open Bracket +\{ (list 'LBRACKET) +;; Close Bracket +\} (list 'RBRACKET) +;; Comma +, (list 'COMMA) +;; Strings +\"[^\"]*\" (list 'STRING yytext) +;; Commands +@{alpha}+ (let* ((str (string-downcase + (substring yytext 1 + (string-length yytext)))) + (sym (string->symbol str))) + (case sym + ((string) (list 'BIBSTRING)) + (else (list 'BIBITEM sym)))) +;; Ident +{alpha}({alpha}|[0-9])* (list 'IDENT yytext) +;; Number +[0-9]+ (list 'NUMBER yytext) +;; Diacritic +\\['`^\"][aeiouAEIOU] (lex-char (string-ref yytext 1) + (string-ref yytext 2)) +\{\\['`^\"][aeiouAEIOU]\} (lex-char (string-ref yytext 2) + (string-ref yytext 3)) + +;; Unrecognized character +. (begin + (format (current-error-port) + "Skipping character ~S\n" yytext) + (yycontinue)) + +;;;; ====================================================================== +<<EOF>> '*eoi* +<<ERROR>> (error 'bibtex-lexer "Parse error" yytext) + + diff --git a/skribe/tools/skribebibtex/stklos/bibtex-parser.y b/skribe/tools/skribebibtex/stklos/bibtex-parser.y new file mode 100644 index 0000000..50236a9 --- /dev/null +++ b/skribe/tools/skribebibtex/stklos/bibtex-parser.y @@ -0,0 +1,117 @@ +;;;; -*- Scheme -*- +;;;; bibtex-parser.y -- SILex input for BibTeX +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Oct-2004 17:47 (eg) +;;;; Last file update: 22-Oct-2004 18:14 (eg) +;;;; + +(load "lalr") + +(define (main args) + ;; Build the parser + (lalr-parser + ;; Options + (output: parser "bibtex-parser.stk") + + ;; Terminal symbols + (CHAR BLANK IDENT STRING COMMA LBRACKET RBRACKET NUMBER EQUAL + BIBSTRING BIBITEM) + + ;; Rules + (S + () + (S string-def) + (S blank*) + (S bibtex-entry)) + + + (blank* + () + (blank* BLANK)) + + + (string-def + (BIBSTRING LBRACKET blank* IDENT blank* EQUAL blank* entry-value + blank* RBRACKET) + : (bibtex-string-def! (car $4) (car $8))) + + + (bibtex-entry + (BIBITEM LBRACKET blank* IDENT blank* COMMA blank* entry-item* RBRACKET) + : (make-bibentry $1 $4 $8)) + + + (entry-item* + (blank*) + : '() + (entry-item) + : (list $1) + (entry-item COMMA entry-item*) + : (cons $1 $3)) + + + (entry-item + (blank* IDENT blank* EQUAL blank* entry-value blank*) + : (cons (car $2) $6)) + + + (entry-value + (NUMBER) + : (list (car $1)) + (STRING) + : $1 + (IDENT) + : (bibtex-string-ref (car $1)) + (LBRACKET entry-value-block* RBRACKET) + : (list (apply string-append $2))) + + + (entry-value-block* + () + : '() + (entry-value-block* entry-value-block) + : (append $1 $2)) + + + (entry-value-block + (LBRACKET entry-value-block* RBRACKET) + : $2 + (COMMA) + : (list ",") + (IDENT) + : $1 + (BLANK) + : (list " ") + (EQUAL) + : (list "=") + (CHAR) + : $1 + (NUMBER) + : $1 + (STRING) + : $1) + ) + ;; Terminate + 0) + + +
\ No newline at end of file diff --git a/skribe/tools/skribebibtex/stklos/main.stk b/skribe/tools/skribebibtex/stklos/main.stk new file mode 100644 index 0000000..3225658 --- /dev/null +++ b/skribe/tools/skribebibtex/stklos/main.stk @@ -0,0 +1,118 @@ +;;;; +;;;; main.stk -- Skribebibtex Main +;;;; +;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 22-Oct-2004 10:29 (eg) +;;;; Last file update: 26-Oct-2004 21:52 (eg) +;;;; + +(define *bibtex-strings* (make-hash-table string=?)) +(define *debug* (getenv "DEBUG")) +(define *in* (current-input-port)) +(define *out* (current-output-port)) + + +(define (bibtex-string-def! str val) + (hash-table-put! *bibtex-strings* str val)) + + +(define (bibtex-string-ref str) + (list (hash-table-get *bibtex-strings* str str))) + + +(define (lex-char accent letter) + (list 'CHAR + (case accent + ((#\') (case letter + ((#\a) "á") ((#\e) "é") ((#\i) "í") ((#\o) "ó") ((#\u) "ú") + ((#\A) "Á") ((#\E) "É") ((#\I) "Í") ((#\O) "Ó") ((#\U) "ú") + (else "?"))) + ((#\`) (case letter + ((#\a) "à") ((#\e) "è") ((#\i) "ì") ((#\o) "ò") ((#\u) "ù") + ((#\A) "À") ((#\E) "È") ((#\I) "Ì") ((#\O) "Ò") ((#\U) "Ù") + (else "?"))) + ((#\^) (case letter + ((#\a) "â") ((#\e) "ê") ((#\i) "î") ((#\o) "ô") ((#\u) "û") + ((#\A) "Â") ((#\E) "Ê") ((#\I) "Î") ((#\O) "Ô") ((#\U) "Û") + (else "?"))) + ((#\") (case letter + ((#\a) "ä") ((#\e) "ë") ((#\i) "ï") ((#\o) "ö") ((#\u) "ü") + ((#\A) "Ä") ((#\E) "Ë") ((#\I) "Ï") ((#\O) "Ö") ((#\U) "Ü") + (else "?"))) + (else "?")))) + + +(define (make-bibentry kind key infos) + (define (pretty-string s) + (if (and (string? s) + (>= (string-length s) 2) + (eq? #\" (string-ref s 0)) + (eq? #\" (string-ref s (- (string-length s) 1)))) + (substring s 1 (- (string-length s) 1)) + s)) + (format *out* ";;;;\n(~A ~S\n" (car kind) (car key)) + (for-each (lambda (x) (format *out* " (~A ~S)\n" + (car x) + (pretty-string (cadr x)))) + infos) + (format *out* ")\n\n")) + + +;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- +(include "bibtex-lex.stk") +(include "bibtex-parser.stk") +;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- + +(define (bibtex2scheme in out) + (let* ((lex (bibtex-lex in)) + (scan (lambda () + (let ((tok (lexer-next-token lex))) + (when *debug* + (format (current-error-port) "token = ~S\n" tok)) + tok))) + (error (lambda (a b) (error 'bibtex-parser "~A~A" a b)))) + (parser scan error))) + + +(define (main args) + ;; Parse the program arguments + (parse-arguments args + "Usage: skribebibtex [options] [input]" + (("help" :alternate "h" :help "provide help for the command") + (arg-usage (current-error-port)) + (exit 0)) + (("options" :help "display the options and exit") + (arg-usage (current-output-port) #t) + (exit 0)) + (("output" :alternate "o" :arg file :help "set the output to <file>") + (let ((port (open-file file "w"))) + (if port + (set! *out* port) + (die (format "~A: bad output file ~S" 'skribebibtex file) 1)))) + (else + (cond + ((= (length other-arguments) 1) + (let* ((file (car other-arguments)) + (port (open-file file "r"))) + (if port + (set! *in* file) + (die (format "~A: bad input file ~S" 'skribebibtex file) 1))))))) + (bibtex2scheme *in* *out*)) |
