diff options
| -rw-r--r-- | Makefile | 131 | ||||
| -rwxr-xr-x | configure | 124 | ||||
| -rw-r--r-- | legacy/bigloo/Makefile (renamed from src/bigloo/Makefile) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/api.bgl (renamed from src/bigloo/api.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/api.sch (renamed from src/bigloo/api.sch) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/asm.scm (renamed from src/bigloo/asm.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/bib.bgl (renamed from src/bigloo/bib.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/c.scm (renamed from src/bigloo/c.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/color.scm (renamed from src/bigloo/color.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/configure.bgl (renamed from src/bigloo/configure.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/debug.sch (renamed from src/bigloo/debug.sch) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/debug.scm (renamed from src/bigloo/debug.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/engine.scm (renamed from src/bigloo/engine.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/eval.scm (renamed from src/bigloo/eval.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/evapi.scm (renamed from src/bigloo/evapi.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/index.bgl (renamed from src/bigloo/index.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/lib.bgl (renamed from src/bigloo/lib.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/lisp.scm (renamed from src/bigloo/lisp.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/main.scm (renamed from src/bigloo/main.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/new.sch (renamed from src/bigloo/new.sch) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/output.scm (renamed from src/bigloo/output.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/param.bgl (renamed from src/bigloo/param.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/parseargs.scm (renamed from src/bigloo/parseargs.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/prog.scm (renamed from src/bigloo/prog.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/read.scm (renamed from src/bigloo/read.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/resolve.scm (renamed from src/bigloo/resolve.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/source.scm (renamed from src/bigloo/source.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/sui.bgl (renamed from src/bigloo/sui.bgl) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/types.scm (renamed from src/bigloo/types.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/verify.scm (renamed from src/bigloo/verify.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/writer.scm (renamed from src/bigloo/writer.scm) | 0 | ||||
| -rw-r--r-- | legacy/bigloo/xml.scm (renamed from src/bigloo/xml.scm) | 0 | ||||
| -rw-r--r-- | legacy/stklos/Makefile.in (renamed from src/stklos/Makefile.in) | 0 | ||||
| -rw-r--r-- | legacy/stklos/biblio.stk (renamed from src/stklos/biblio.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/c-lex.l (renamed from src/stklos/c-lex.l) | 0 | ||||
| -rw-r--r-- | legacy/stklos/c.stk (renamed from src/stklos/c.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/color.stk (renamed from src/stklos/color.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/configure.stk (renamed from src/stklos/configure.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/debug.stk (renamed from src/stklos/debug.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/engine.stk (renamed from src/stklos/engine.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/eval.stk (renamed from src/stklos/eval.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/lib.stk (renamed from src/stklos/lib.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/lisp-lex.l (renamed from src/stklos/lisp-lex.l) | 0 | ||||
| -rw-r--r-- | legacy/stklos/lisp.stk (renamed from src/stklos/lisp.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/main.stk (renamed from src/stklos/main.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/output.stk (renamed from src/stklos/output.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/prog.stk (renamed from src/stklos/prog.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/reader.stk (renamed from src/stklos/reader.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/resolve.stk (renamed from src/stklos/resolve.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/runtime.stk (renamed from src/stklos/runtime.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/source.stk (renamed from src/stklos/source.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/types.stk (renamed from src/stklos/types.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/vars.stk (renamed from src/stklos/vars.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/verify.stk (renamed from src/stklos/verify.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/writer.stk (renamed from src/stklos/writer.stk) | 0 | ||||
| -rw-r--r-- | legacy/stklos/xml-lex.l (renamed from src/stklos/xml-lex.l) | 0 | ||||
| -rw-r--r-- | legacy/stklos/xml.stk (renamed from src/stklos/xml.stk) | 0 | ||||
| -rw-r--r-- | src/Makefile | 41 | ||||
| -rw-r--r-- | src/common/api.scm | 1249 | ||||
| -rw-r--r-- | src/common/bib.scm | 192 | ||||
| -rw-r--r-- | src/common/configure.scm | 8 | ||||
| -rw-r--r-- | src/common/configure.scm.in | 6 | ||||
| -rw-r--r-- | src/common/index.scm | 126 | ||||
| -rw-r--r-- | src/common/lib.scm | 238 | ||||
| -rw-r--r-- | src/common/param.scm | 69 | ||||
| -rw-r--r-- | src/common/sui.scm | 166 |
66 files changed, 0 insertions, 2350 deletions
diff --git a/Makefile b/Makefile deleted file mode 100644 index 918e91a..0000000 --- a/Makefile +++ /dev/null @@ -1,131 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Wed Jul 30 16:23:07 2003 */ -#* Last change : Fri May 21 16:37:53 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The general Skribe makefile */ -#*=====================================================================*/ -include etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* DIRECTORIES */ -#*---------------------------------------------------------------------*/ -DIRECTORIES = skr \ - doc \ - examples \ - src \ - emacs \ - etc \ - tools - -POPULATIONDIRS = $(DIRECTORIES) \ - contribs - -#*---------------------------------------------------------------------*/ -#* all */ -#*---------------------------------------------------------------------*/ -.PHONY: all - -all: - (cd src/$(SYSTEM) && $(MAKE)) - (cd tools && $(MAKE)) - (cd doc && $(MAKE)) - -#*---------------------------------------------------------------------*/ -#* install */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) install) || exit -1; \ - done - -uninstall: - for d in $(DIRECTORIES); do \ - (cd $$d && $(MAKE) uninstall) || exit -1; \ - done - -#*---------------------------------------------------------------------*/ -#* revision */ -#*---------------------------------------------------------------------*/ -.PHONY: revision populate skribe.prj - -revision: populate checkin - -populate: skribe.prj - prcs populate skribe `$(MAKE) pop` - -checkin: - prcs checkin -r$(SKRIBERELEASE).@ skribe - -checkout: - @ prcs checkout -r$(SKRIBERELEASE).@ skribe - -skribe.prj: - @ cat skribe.prj | sed -e s,"(Populate-Ignore ())","(Populate-Ignore (\"\\\\\\\\\\.o\\$$\" \"\\\\\\\\\\~$$\" \"\\\\\\\\\\.log\\$$\" \"\\\\\\\\\\.ps\\$$\" \"\\\\\\\\\\.aux\\$$\" \"\\\\\\\\\\.date_of_backup\\$$\" \"\\\\\\\\\\.so\\$$\" \"\\\\\\\\\\.a\\$$\" \"if_not_there\\$$\" \"if_mach\\$$\" \"threadlibs\\$$\"))", > skribe.dprj; $(RM) -f skribe.prj; mv skribe.dprj skribe.prj - -#*---------------------------------------------------------------------*/ -#* population */ -#* ------------------------------------------------------------- */ -#* The list of all files that have to be placed inside the */ -#* repository for revision. */ -#*---------------------------------------------------------------------*/ -.PHONY: subpop popfilelist - -subpop: - @ for d in $(POPULATIONDIRS); do \ - (cd $$d && $(MAKE) -s pop); \ - done - -pop: - @ echo Makefile INSTALL LICENSE README README.java - @ echo configure - @ (for p in `$(MAKE) -s subpop`; do \ - echo $$p; \ - done) | sort - -#*---------------------------------------------------------------------*/ -#* distrib */ -#*---------------------------------------------------------------------*/ -.PHONY: distrib distrib-jvm distrib-src - -distrib: - $(MAKE) distrib -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - (cd www && $(MAKE)) - -distrib-jvm: - $(MAKE) distrib-jvm -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -distrib-src: - $(MAKE) distrib-src -f etc/$(SYSTEM)/Makefile -I etc/$(SYSTEM) - -#*---------------------------------------------------------------------*/ -#* clean/distclean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean distclean - $(RM) -f etc/Makefile.config - -clean: - (cd src && $(MAKE) clean) - (cd doc && $(MAKE) clean) - (cd tools && $(MAKE) clean) - (cd etc && $(MAKE) clean) - -distclean: clean - (cd emacs && $(MAKE) distclean) - (cd etc && $(MAKE) distclean) - -#*---------------------------------------------------------------------*/ -#* devclean/devdistclean */ -#*---------------------------------------------------------------------*/ -.PHONY: devclean devdistclean - -devclean: clean - (cd www && $(MAKE) clean) - -devdistclean: devclean distclean - diff --git a/configure b/configure deleted file mode 100755 index 798d9d2..0000000 --- a/configure +++ /dev/null @@ -1,124 +0,0 @@ -#!/bin/sh -# -# This file is a simple trampoline to the real configure script which -# depends of the Scheme system used -# -# Known systems so far: -# - Bigloo (use --with-bigloo) -# - STklos (use --with-stklos) -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 29-Jul-2003 13:59 (eg) -# Last file update: 23-Sep-2004 17:14 (eg) - - -use_bigloo=0 -use_stklos=0 - -new_args="" -export new_args -prefix=/usr/local -export prefix - -for i in "$@"; do - case $i in - --with-bigloo) scheme=bigloo; use_bigloo=1;; - --with-stklos) scheme=stklos; use_stklos=1;; - --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; - new_args="$new_args $i";; - *) new_args="$new_args \"$i\"";; - esac -done - -#* for i in $* ;do */ -#* case $i in */ -#* --with-bigloo) scheme=bigloo; use_bigloo=1;; */ -#* --with-stklos) scheme=stklos; use_stklos=1;; */ -#* --prefix=*) prefix=`echo $i | sed 's/^[^=]*=//'`; */ -#* new_args="$new_args $i";; */ -#* *) new_args="$new_args $i";; */ -#* esac */ -#* done */ - - -case `expr $use_bigloo + $use_stklos` in - 0) echo "You must at least specify a Scheme system: "; - echo " --with-bigloo to use Bigloo" - echo " --with-stklos to use STklos" - exit 1;; - 1) ;; - *) echo "You must specify ONLY ONE Scheme system"; exit 1;; -esac - -if test $use_bigloo = 1 ;then - scheme=bigloo -fi - -if test $use_stklos = 1 ;then - scheme=stklos -fi - - - -# Common configuration -release="1.2d" -skribeurl="http://www.inria.fr/mimosa/fp/Skribe" -skribeextdir="$prefix/share/skribe/extensions" -skribedocdir=$prefix/doc/skribe-$release -skribeskrdir="'(\".\" \"$skribeextdir\" \"$prefix/share/skribe/$release/skr\" )" - -# etc/config -rm -f etc/config 2> /dev/null -echo "# Automatically generated file (don't edit)" > etc/config -echo "release=$release" >> etc/config -echo "skribeurl=$skribeurl" >> etc/config -echo "prefix=$prefix" >> etc/config - -# etc/skribe-config -cat etc/skribe-config.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_SKR_DIR@|$prefix/share/skribe/$release/skr|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - > etc/skribe-config -chmod a+x etc/skribe-config - -# emacs/skribe.el -cat emacs/skribe.el.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@PREFIX@|$prefix|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SYSTEM@|$scheme|" \ - | sed "s|@SKRIBE_DOCDIR@|$skribedocdir|" \ - > emacs/skribe.el - -# src/common/configure.scm -rm -f src/common/configure.scm 2> /dev/null -echo ";; Automatically generated file (don't edit)" > src/common/configure.scm -cat src/common/configure.scm.in \ - | sed "s|@SKRIBE_RELEASE@|$release|" \ - | sed "s|@SKRIBE_URL@|$skribeurl|" \ - | sed "s|@SKRIBE_DOC_DIR@|$skribedocdir|" \ - | sed "s|@SKRIBE_EXT_DIR@|$skribeextdir|" \ - | sed "s|@SKRIBE_SKR_PATH@|$skribeskrdir|" \ - | sed "s|@SKRIBE_SCHEME@|$scheme|" \ - >> src/common/configure.scm -echo "" >> src/common/configure.scm - -if test $use_bigloo = 1 ;then - # pass all the arguments to the Bigloo autoconf without the --with-bigloo - echo "Using Bigloo system" - eval "cd etc/bigloo; SKRIBERELEASE=$release ./configure --docdir=$skribedocdir $new_args" - exit 0 -fi - -# If we are here, it means that we use the STklos system -if test $use_stklos = 1 ;then - # pass all the arguments to the STklos autoconf without the --with-stklos - echo "Using STklos system" - eval "cd etc/stklos; ./configure $new_args" - exit 0 -fi - diff --git a/src/bigloo/Makefile b/legacy/bigloo/Makefile index 02d2b6a..02d2b6a 100644 --- a/src/bigloo/Makefile +++ b/legacy/bigloo/Makefile diff --git a/src/bigloo/api.bgl b/legacy/bigloo/api.bgl index 55493b0..55493b0 100644 --- a/src/bigloo/api.bgl +++ b/legacy/bigloo/api.bgl diff --git a/src/bigloo/api.sch b/legacy/bigloo/api.sch index 390b8fa..390b8fa 100644 --- a/src/bigloo/api.sch +++ b/legacy/bigloo/api.sch diff --git a/src/bigloo/asm.scm b/legacy/bigloo/asm.scm index 03196ac..03196ac 100644 --- a/src/bigloo/asm.scm +++ b/legacy/bigloo/asm.scm diff --git a/src/bigloo/bib.bgl b/legacy/bigloo/bib.bgl index 6b0f7dd..6b0f7dd 100644 --- a/src/bigloo/bib.bgl +++ b/legacy/bigloo/bib.bgl diff --git a/src/bigloo/c.scm b/legacy/bigloo/c.scm index 07290ce..07290ce 100644 --- a/src/bigloo/c.scm +++ b/legacy/bigloo/c.scm diff --git a/src/bigloo/color.scm b/legacy/bigloo/color.scm index e481d65..e481d65 100644 --- a/src/bigloo/color.scm +++ b/legacy/bigloo/color.scm diff --git a/src/bigloo/configure.bgl b/legacy/bigloo/configure.bgl index e100d8d..e100d8d 100644 --- a/src/bigloo/configure.bgl +++ b/legacy/bigloo/configure.bgl diff --git a/src/bigloo/debug.sch b/legacy/bigloo/debug.sch index 9b53c84..9b53c84 100644 --- a/src/bigloo/debug.sch +++ b/legacy/bigloo/debug.sch diff --git a/src/bigloo/debug.scm b/legacy/bigloo/debug.scm index 8f1691c..8f1691c 100644 --- a/src/bigloo/debug.scm +++ b/legacy/bigloo/debug.scm diff --git a/src/bigloo/engine.scm b/legacy/bigloo/engine.scm index bd8a027..bd8a027 100644 --- a/src/bigloo/engine.scm +++ b/legacy/bigloo/engine.scm diff --git a/src/bigloo/eval.scm b/legacy/bigloo/eval.scm index b5c6548..b5c6548 100644 --- a/src/bigloo/eval.scm +++ b/legacy/bigloo/eval.scm diff --git a/src/bigloo/evapi.scm b/legacy/bigloo/evapi.scm index 6f0d49e..6f0d49e 100644 --- a/src/bigloo/evapi.scm +++ b/legacy/bigloo/evapi.scm diff --git a/src/bigloo/index.bgl b/legacy/bigloo/index.bgl index 9697981..9697981 100644 --- a/src/bigloo/index.bgl +++ b/legacy/bigloo/index.bgl diff --git a/src/bigloo/lib.bgl b/legacy/bigloo/lib.bgl index 6dd6d37..6dd6d37 100644 --- a/src/bigloo/lib.bgl +++ b/legacy/bigloo/lib.bgl diff --git a/src/bigloo/lisp.scm b/legacy/bigloo/lisp.scm index 65a8227..65a8227 100644 --- a/src/bigloo/lisp.scm +++ b/legacy/bigloo/lisp.scm diff --git a/src/bigloo/main.scm b/legacy/bigloo/main.scm index 5b9e5e5..5b9e5e5 100644 --- a/src/bigloo/main.scm +++ b/legacy/bigloo/main.scm diff --git a/src/bigloo/new.sch b/legacy/bigloo/new.sch index 16bb7d5..16bb7d5 100644 --- a/src/bigloo/new.sch +++ b/legacy/bigloo/new.sch diff --git a/src/bigloo/output.scm b/legacy/bigloo/output.scm index 4bc6271..4bc6271 100644 --- a/src/bigloo/output.scm +++ b/legacy/bigloo/output.scm diff --git a/src/bigloo/param.bgl b/legacy/bigloo/param.bgl index 6ff6b42..6ff6b42 100644 --- a/src/bigloo/param.bgl +++ b/legacy/bigloo/param.bgl diff --git a/src/bigloo/parseargs.scm b/legacy/bigloo/parseargs.scm index 4ce58c4..4ce58c4 100644 --- a/src/bigloo/parseargs.scm +++ b/legacy/bigloo/parseargs.scm diff --git a/src/bigloo/prog.scm b/legacy/bigloo/prog.scm index baad0f0..baad0f0 100644 --- a/src/bigloo/prog.scm +++ b/legacy/bigloo/prog.scm diff --git a/src/bigloo/read.scm b/legacy/bigloo/read.scm index 91cd345..91cd345 100644 --- a/src/bigloo/read.scm +++ b/legacy/bigloo/read.scm diff --git a/src/bigloo/resolve.scm b/legacy/bigloo/resolve.scm index 8248a4f..8248a4f 100644 --- a/src/bigloo/resolve.scm +++ b/legacy/bigloo/resolve.scm diff --git a/src/bigloo/source.scm b/legacy/bigloo/source.scm index babadff..babadff 100644 --- a/src/bigloo/source.scm +++ b/legacy/bigloo/source.scm diff --git a/src/bigloo/sui.bgl b/legacy/bigloo/sui.bgl index 63c5477..63c5477 100644 --- a/src/bigloo/sui.bgl +++ b/legacy/bigloo/sui.bgl diff --git a/src/bigloo/types.scm b/legacy/bigloo/types.scm index b8babd4..b8babd4 100644 --- a/src/bigloo/types.scm +++ b/legacy/bigloo/types.scm diff --git a/src/bigloo/verify.scm b/legacy/bigloo/verify.scm index 602a951..602a951 100644 --- a/src/bigloo/verify.scm +++ b/legacy/bigloo/verify.scm diff --git a/src/bigloo/writer.scm b/legacy/bigloo/writer.scm index ce515bf..ce515bf 100644 --- a/src/bigloo/writer.scm +++ b/legacy/bigloo/writer.scm diff --git a/src/bigloo/xml.scm b/legacy/bigloo/xml.scm index d4c662e..d4c662e 100644 --- a/src/bigloo/xml.scm +++ b/legacy/bigloo/xml.scm diff --git a/src/stklos/Makefile.in b/legacy/stklos/Makefile.in index 80a26de..80a26de 100644 --- a/src/stklos/Makefile.in +++ b/legacy/stklos/Makefile.in diff --git a/src/stklos/biblio.stk b/legacy/stklos/biblio.stk index 5691588..5691588 100644 --- a/src/stklos/biblio.stk +++ b/legacy/stklos/biblio.stk diff --git a/src/stklos/c-lex.l b/legacy/stklos/c-lex.l index a5b337e..a5b337e 100644 --- a/src/stklos/c-lex.l +++ b/legacy/stklos/c-lex.l diff --git a/src/stklos/c.stk b/legacy/stklos/c.stk index 265c421..265c421 100644 --- a/src/stklos/c.stk +++ b/legacy/stklos/c.stk diff --git a/src/stklos/color.stk b/legacy/stklos/color.stk index 0cb829f..0cb829f 100644 --- a/src/stklos/color.stk +++ b/legacy/stklos/color.stk diff --git a/src/stklos/configure.stk b/legacy/stklos/configure.stk index ece7abc..ece7abc 100644 --- a/src/stklos/configure.stk +++ b/legacy/stklos/configure.stk diff --git a/src/stklos/debug.stk b/legacy/stklos/debug.stk index a9fefde..a9fefde 100644 --- a/src/stklos/debug.stk +++ b/legacy/stklos/debug.stk diff --git a/src/stklos/engine.stk b/legacy/stklos/engine.stk index a13ed0f..a13ed0f 100644 --- a/src/stklos/engine.stk +++ b/legacy/stklos/engine.stk diff --git a/src/stklos/eval.stk b/legacy/stklos/eval.stk index 3acace9..3acace9 100644 --- a/src/stklos/eval.stk +++ b/legacy/stklos/eval.stk diff --git a/src/stklos/lib.stk b/legacy/stklos/lib.stk index 3c3b9f0..3c3b9f0 100644 --- a/src/stklos/lib.stk +++ b/legacy/stklos/lib.stk diff --git a/src/stklos/lisp-lex.l b/legacy/stklos/lisp-lex.l index efad24b..efad24b 100644 --- a/src/stklos/lisp-lex.l +++ b/legacy/stklos/lisp-lex.l diff --git a/src/stklos/lisp.stk b/legacy/stklos/lisp.stk index 9bfe75a..9bfe75a 100644 --- a/src/stklos/lisp.stk +++ b/legacy/stklos/lisp.stk diff --git a/src/stklos/main.stk b/legacy/stklos/main.stk index 4905423..4905423 100644 --- a/src/stklos/main.stk +++ b/legacy/stklos/main.stk diff --git a/src/stklos/output.stk b/legacy/stklos/output.stk index 3c00323..3c00323 100644 --- a/src/stklos/output.stk +++ b/legacy/stklos/output.stk diff --git a/src/stklos/prog.stk b/legacy/stklos/prog.stk index 6301ece..6301ece 100644 --- a/src/stklos/prog.stk +++ b/legacy/stklos/prog.stk diff --git a/src/stklos/reader.stk b/legacy/stklos/reader.stk index bd38562..bd38562 100644 --- a/src/stklos/reader.stk +++ b/legacy/stklos/reader.stk diff --git a/src/stklos/resolve.stk b/legacy/stklos/resolve.stk index 91dc965..91dc965 100644 --- a/src/stklos/resolve.stk +++ b/legacy/stklos/resolve.stk diff --git a/src/stklos/runtime.stk b/legacy/stklos/runtime.stk index 58d0d45..58d0d45 100644 --- a/src/stklos/runtime.stk +++ b/legacy/stklos/runtime.stk diff --git a/src/stklos/source.stk b/legacy/stklos/source.stk index a3102c1..a3102c1 100644 --- a/src/stklos/source.stk +++ b/legacy/stklos/source.stk diff --git a/src/stklos/types.stk b/legacy/stklos/types.stk index fb16230..fb16230 100644 --- a/src/stklos/types.stk +++ b/legacy/stklos/types.stk diff --git a/src/stklos/vars.stk b/legacy/stklos/vars.stk index 1c875f8..1c875f8 100644 --- a/src/stklos/vars.stk +++ b/legacy/stklos/vars.stk diff --git a/src/stklos/verify.stk b/legacy/stklos/verify.stk index da9b132..da9b132 100644 --- a/src/stklos/verify.stk +++ b/legacy/stklos/verify.stk diff --git a/src/stklos/writer.stk b/legacy/stklos/writer.stk index 2b0f91c..2b0f91c 100644 --- a/src/stklos/writer.stk +++ b/legacy/stklos/writer.stk diff --git a/src/stklos/xml-lex.l b/legacy/stklos/xml-lex.l index 5d9a8d9..5d9a8d9 100644 --- a/src/stklos/xml-lex.l +++ b/legacy/stklos/xml-lex.l diff --git a/src/stklos/xml.stk b/legacy/stklos/xml.stk index 47dd46f..47dd46f 100644 --- a/src/stklos/xml.stk +++ b/legacy/stklos/xml.stk diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index 09e96d5..0000000 --- a/src/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:15:57 2003 */ -#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The meta Makefile for the sources */ -#*=====================================================================*/ -include ../etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo src/Makefile - @ (cd bigloo && $(MAKE) pop) - @ (cd stklos && $(MAKE) pop) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - (cd $(SYSTEM) && $(MAKE) install) - -uninstall: - (cd $(SYSTEM) && $(MAKE) uninstall) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - (cd $(SYSTEM) && $(MAKE) clean) - diff --git a/src/common/api.scm b/src/common/api.scm deleted file mode 100644 index eb657c7..0000000 --- a/src/common/api.scm +++ /dev/null @@ -1,1249 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/api.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:11:56 2003 */ -;* Last change : Mon Dec 20 10:38:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scribe API */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../bigloo/api.bgl@ */ -;* Documentation: */ -;* @path ../../doc/user/markup.skb@ */ -;* @path ../../doc/user/document.skb@ */ -;* @path ../../doc/user/sectioning.skb@ */ -;* @path ../../doc/user/toc.skb@ */ -;* @path ../../doc/user/ornament.skb@ */ -;* @path ../../doc/user/line.skb@ */ -;* @path ../../doc/user/font.skb@ */ -;* @path ../../doc/user/justify.skb@ */ -;* @path ../../doc/user/enumeration.skb@ */ -;* @path ../../doc/user/colframe.skb@ */ -;* @path ../../doc/user/figure.skb@ */ -;* @path ../../doc/user/image.skb@ */ -;* @path ../../doc/user/table.skb@ */ -;* @path ../../doc/user/footnote.skb@ */ -;* @path ../../doc/user/char.skb@ */ -;* @path ../../doc/user/links.skb@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* include ... */ -;*---------------------------------------------------------------------*/ -(define-markup (include file) - (if (not (string? file)) - (skribe-error 'include "Illegal file (string expected)" file) - (skribe-include file))) - -;*---------------------------------------------------------------------*/ -;* document ... */ -;*---------------------------------------------------------------------*/ -(define-markup (document #!rest - opts - #!key - (ident #f) (class "document") - (title #f) (html-title #f) (author #f) - (ending #f) (env '())) - (new document - (markup 'document) - (ident (or ident - (ast->string title) - (symbol->string (gensym 'document)))) - (class class) - (required-options '(:title :author :ending)) - (options (the-options opts :ident :class :env)) - (body (the-body opts)) - (env (append env - (list (list 'chapter-counter 0) (list 'chapter-env '()) - (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()) - (list 'figure-counter 0) (list 'figure-env '())))))) - -;*---------------------------------------------------------------------*/ -;* author ... */ -;*---------------------------------------------------------------------*/ -(define-markup (author #!rest - opts - #!key - (ident #f) (class "author") - name - (title #f) - (affiliation #f) - (email #f) - (url #f) - (address #f) - (phone #f) - (photo #f) - (align 'center)) - (if (not (memq align '(center left right))) - (skribe-error 'author "Illegal align value" align) - (new container - (markup 'author) - (ident (or ident (symbol->string (gensym 'author)))) - (class class) - (required-options '(:name :title :affiliation :email :url :address :phone :photo :align)) - (options `((:name ,name) - (:align ,align) - ,@(the-options opts :ident :class))) - (body #f)))) - -;*---------------------------------------------------------------------*/ -;* toc ... */ -;*---------------------------------------------------------------------*/ -(define-markup (toc #!rest - opts - #!key - (ident #f) (class "toc") - (chapter #t) (section #t) (subsection #f)) - (let ((body (the-body opts))) - (new container - (markup 'toc) - (ident (or ident (symbol->string (gensym 'toc)))) - (class class) - (required-options '()) - (options `((:chapter ,chapter) - (:section ,section) - (:subsection ,subsection) - ,@(the-options opts :ident :class))) - (body (cond - ((null? body) - (new unresolved - (proc (lambda (n e env) - (handle - (resolve-search-parent n env document?)))))) - ((null? (cdr body)) - (if (handle? (car body)) - (car body) - (skribe-error 'toc - "Illegal argument (handle expected)" - (if (markup? (car body)) - (markup-markup (car body)) - "???")))) - (else - (skribe-error 'toc "Illegal argument" body))))))) - -;*---------------------------------------------------------------------*/ -;* chapter ... ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:chapter@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:chapter@ */ -;*---------------------------------------------------------------------*/ -(define-markup (chapter #!rest - opts - #!key - (ident #f) (class "chapter") - title (html-title #f) (file #f) (toc #t) (number #t)) - (new container - (markup 'chapter) - (ident (or ident (symbol->string (gensym 'chapter)))) - (class class) - (required-options '(:title :file :toc :number)) - (options `((:toc ,toc) - (:number ,(and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n - env - 'chapter - number)))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'section-counter 0) (list 'section-env '()) - (list 'footnote-counter 0) (list 'footnote-env '()))))) - -;*---------------------------------------------------------------------*/ -;* section-number ... */ -;*---------------------------------------------------------------------*/ -(define (section-number number markup) - (and number - (new unresolved - (proc (lambda (n e env) - (resolve-counter n env markup number)))))) - -;*---------------------------------------------------------------------*/ -;* section ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:section@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:sectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (section #!rest - opts - #!key - (ident #f) (class "section") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'section) - (ident (or ident (symbol->string (gensym 'section)))) - (class class) - (required-options '(:title :toc :file :toc :number)) - (options `((:number ,(section-number number 'section)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (if file - (list (list 'subsection-counter 0) (list 'subsection-env '()) - (list 'footnote-counter 0) (list 'footnote-env '())) - (list (list 'subsection-counter 0) (list 'subsection-env '())))))) - -;*---------------------------------------------------------------------*/ -;* subsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsection #!rest - opts - #!key - (ident #f) (class "subsection") - title (file #f) (toc #t) (number #t)) - (new container - (markup 'subsection) - (ident (or ident (symbol->string (gensym 'subsection)))) - (class class) - (required-options '(:title :toc :file :number)) - (options `((:number ,(section-number number 'subsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)) - (env (list (list 'subsubsection-counter 0) (list 'subsubsection-env '()))))) - -;*---------------------------------------------------------------------*/ -;* subsubsection ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/sectioning.skb:subsubsection@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:subsubsectionr@ */ -;*---------------------------------------------------------------------*/ -(define-markup (subsubsection #!rest - opts - #!key - (ident #f) (class "subsubsection") - title (file #f) (toc #f) (number #t)) - (new container - (markup 'subsubsection) - (ident (or ident (symbol->string (gensym 'subsubsection)))) - (class class) - (required-options '(:title :toc :number :file)) - (options `((:number ,(section-number number 'subsubsection)) - (:toc ,toc) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* paragraph ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup paragraph) - -;*---------------------------------------------------------------------*/ -;* footnote ... */ -;*---------------------------------------------------------------------*/ -(define-markup (footnote #!rest opts - #!key (ident #f) (class "footnote") (label #t)) - ;; The `:label' option used to be called `:number'. - (new container - (markup 'footnote) - (ident (symbol->string (gensym 'footnote))) - (class class) - (required-options '()) - (options `((:label - ,(cond ((string? label) label) - ((number? label) label) - ((not label) label) - (else - (new unresolved - (proc (lambda (n e env) - (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* linebreak ... */ -;*---------------------------------------------------------------------*/ -(define-markup (linebreak #!rest opts #!key (ident #f) (class #f)) - (let ((ln (new markup - (ident (or ident (symbol->string (gensym 'linebreak)))) - (class class) - (markup 'linebreak))) - (num (the-body opts))) - (cond - ((null? num) - ln) - ((not (null? (cdr num))) - (skribe-error 'linebreak "Illegal arguments" num)) - ((not (and (integer? (car num)) (positive? (car num)))) - (skribe-error 'linebreak "Illegal argument" (car num))) - (else - (vector->list (make-vector (car num) ln)))))) - -;*---------------------------------------------------------------------*/ -;* hrule ... */ -;*---------------------------------------------------------------------*/ -(define-markup (hrule #!rest - opts - #!key - (ident #f) (class #f) - (width 100.) (height 1)) - (new markup - (markup 'hrule) - (ident (or ident (symbol->string (gensym 'hrule)))) - (class class) - (required-options '()) - (options `((:width ,width) - (:height ,height) - ,@(the-options opts :ident :class))) - (body #f))) - -;*---------------------------------------------------------------------*/ -;* color ... */ -;*---------------------------------------------------------------------*/ -(define-markup (color #!rest - opts - #!key - (ident #f) (class "color") - (bg #f) (fg #f) (width #f) (margin #f)) - (new container - (markup 'color) - (ident (or ident (symbol->string (gensym 'color)))) - (class class) - (required-options '(:bg :fg :width)) - (options `((:bg ,(if bg (skribe-use-color! bg) bg)) - (:fg ,(if fg (skribe-use-color! fg) fg)) - ,@(the-options opts :ident :class :bg :fg))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* frame ... */ -;*---------------------------------------------------------------------*/ -(define-markup (frame #!rest - opts - #!key - (ident #f) (class "frame") - (width #f) (margin 2) (border 1)) - (new container - (markup 'frame) - (ident (or ident (symbol->string (gensym 'frame)))) - (class class) - (required-options '(:width :border :margin)) - (options `((:margin ,margin) - (:border ,(cond - ((integer? border) border) - (border 1) - (else #f))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* font ... */ -;*---------------------------------------------------------------------*/ -(define-markup (font #!rest - opts - #!key - (ident #f) (class #f) - (size #f) (face #f)) - (new container - (markup 'font) - (ident (or ident (symbol->string (gensym 'font)))) - (class class) - (required-options '(:size)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* flush ... */ -;*---------------------------------------------------------------------*/ -(define-markup (flush #!rest - opts - #!key - (ident #f) (class #f) - side) - (case side - ((center left right) - (new container - (markup 'flush) - (ident (or ident (symbol->string (gensym 'flush)))) - (class class) - (required-options '(:side)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - (else - (skribe-error 'flush "Illegal side" side)))) - -;*---------------------------------------------------------------------*/ -;* center ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container center) - -;*---------------------------------------------------------------------*/ -;* pre ... */ -;*---------------------------------------------------------------------*/ -(define-simple-container pre) - -;*---------------------------------------------------------------------*/ -;* prog ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:prog@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:prog@ */ -;*---------------------------------------------------------------------*/ -(define-markup (prog #!rest - opts - #!key - (ident #f) (class "prog") - (line 1) (linedigit #f) (mark ";!")) - (if (not (or (string? mark) (eq? mark #f))) - (skribe-error 'prog "Illegal mark" mark) - (new container - (markup 'prog) - (ident (or ident (symbol->string (gensym 'prog)))) - (class class) - (required-options '(:line :mark)) - (options (the-options opts :ident :class :linedigit)) - (body (make-prog-body (the-body opts) line linedigit mark))))) - -;*---------------------------------------------------------------------*/ -;* source ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:source@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:source@ */ -;*---------------------------------------------------------------------*/ -(define-markup (source #!rest - opts - #!key - language - (file #f) (start #f) (stop #f) - (definition #f) (tab 8)) - (let ((body (the-body opts))) - (cond - ((and (not (null? body)) (or file start stop definition)) - (skribe-error 'source - "file, start/stop, and definition are exclusive with body" - body)) - ((and start stop definition) - (skribe-error 'source - "start/stop are exclusive with a definition" - body)) - ((and (or start stop definition) (not file)) - (skribe-error 'source - "start/stop and definition require a file specification" - file)) - ((and definition (not language)) - (skribe-error 'source - "definition requires a language specification" - definition)) - ((and file (not (string? file))) - (skribe-error 'source "Illegal file" file)) - ((and start (not (or (integer? start) (string? start)))) - (skribe-error 'source "Illegal start" start)) - ((and stop (not (or (integer? stop) (string? stop)))) - (skribe-error 'source "Illegal start" stop)) - ((and (integer? start) (integer? stop) (> start stop)) - (skribe-error 'source - "start line > stop line" - (format "~a/~a" start stop))) - ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) - ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) - (file - (let ((s (if (not definition) - (source-read-lines file start stop tab) - (source-read-definition file definition tab language)))) - (if language - (source-fontify s language) - s))) - (language - (source-fontify body language)) - (else - body)))) - -;*---------------------------------------------------------------------*/ -;* language ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/prgm.skb:language@ */ -;*---------------------------------------------------------------------*/ -(define-markup (language #!key name (fontifier #f) (extractor #f)) - (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") - (new language - (name name) - (fontifier fontifier) - (extractor extractor)))) - -;*---------------------------------------------------------------------*/ -;* figure ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/figure.skb:figure@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:figure@ */ -;*---------------------------------------------------------------------*/ -(define-markup (figure #!rest - opts - #!key - (ident #f) (class "figure") - (legend #f) (number #t) (multicolumns #f)) - (new container - (markup 'figure) - (ident (or ident - (let ((s (ast->string legend))) - (if (not (string=? s "")) - s - (symbol->string (gensym 'figure)))))) - (class class) - (required-options '(:legend :number :multicolumns)) - (options `((:number - ,(new unresolved - (proc (lambda (n e env) - (resolve-counter n env 'figure number))))) - ,@(the-options opts :ident :class))) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* parse-list-of ... */ -;* ------------------------------------------------------------- */ -;* The function table accepts two different prototypes. It */ -;* may receive its N elements in a list of N elements or in */ -;* a list of one element which is a list of N elements. This */ -;* gets rid of APPLY when calling container markup such as ITEMIZE */ -;* or TABLE. */ -;*---------------------------------------------------------------------*/ -(define (parse-list-of for markup lst) - (cond - ((null? lst) - '()) - ((and (pair? lst) - (or (pair? (car lst)) (null? (car lst))) - (null? (cdr lst))) - (parse-list-of for markup (car lst))) - (else - (let loop ((lst lst)) - (cond - ((null? lst) - '()) - ((pair? (car lst)) - (loop (car lst))) - (else - (let ((r (car lst))) - (if (not (is-markup? r markup)) - (skribe-warning 2 - for - (format "Illegal `~a' element, `~a' expected" - (if (markup? r) - (markup-markup r) - (find-runtime-type r)) - markup))) - (cons r (loop (cdr lst)))))))))) - -;*---------------------------------------------------------------------*/ -;* itemize ... */ -;*---------------------------------------------------------------------*/ -(define-markup (itemize #!rest opts #!key (ident #f) (class "itemize") symbol) - (new container - (markup 'itemize) - (ident (or ident (symbol->string (gensym 'itemize)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'itemize 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* enumerate ... */ -;*---------------------------------------------------------------------*/ -(define-markup (enumerate #!rest opts #!key (ident #f) (class "enumerate") symbol) - (new container - (markup 'enumerate) - (ident (or ident (symbol->string (gensym 'enumerate)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'enumerate 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* description ... */ -;*---------------------------------------------------------------------*/ -(define-markup (description #!rest opts #!key (ident #f) (class "description") symbol) - (new container - (markup 'description) - (ident (or ident (symbol->string (gensym 'description)))) - (class class) - (required-options '(:symbol)) - (options `((:symbol ,symbol) ,@(the-options opts :ident :class))) - (body (parse-list-of 'description 'item (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* item ... */ -;*---------------------------------------------------------------------*/ -(define-markup (item #!rest opts #!key (ident #f) (class #f) key) - (if (and key (not (or (string? key) - (number? key) - (markup? key) - (pair? key)))) - (skribe-type-error 'item "Illegal key:" key "node") - (new container - (markup 'item) - (ident (or ident (symbol->string (gensym 'item)))) - (class class) - (required-options '(:key)) - (options `((:key ,key) ,@(the-options opts :ident :class :key))) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* table */ -;*---------------------------------------------------------------------*/ -(define-markup (table #!rest - opts - #!key - (ident #f) (class #f) - (border #f) (width #f) - (frame 'none) (rules 'none) - (cellstyle 'collapse) (cellpadding #f) (cellspacing #f)) - (let ((frame (cond - ((string? frame) - (string->symbol frame)) - ((not frame) - #f) - (else - frame))) - (rules (cond - ((string? rules) - (string->symbol rules)) - ((not rules) - #f) - (else - rules))) - (frame-vals '(none above below hsides vsides lhs rhs box border)) - (rules-vals '(none rows cols all header)) - (cells-vals '(collapse separate))) - (cond - ((and frame (not (memq frame frame-vals))) - (skribe-error 'table - (format "frame should be one of \"~a\"" frame-vals) - frame)) - ((and rules (not (memq rules rules-vals))) - (skribe-error 'table - (format "rules should be one of \"~a\"" rules-vals) - rules)) - ((not (or (memq cellstyle cells-vals) - (string? cellstyle) - (number? cellstyle))) - (skribe-error 'table - (format "cellstyle should be one of \"~a\", or a number, or a string" cells-vals) - cellstyle)) - (else - (new container - (markup 'table) - (ident (or ident (symbol->string (gensym 'table)))) - (class class) - (required-options '(:width :frame :rules)) - (options `((:frame ,frame) - (:rules ,rules) - (:cellstyle ,cellstyle) - ,@(the-options opts :ident :class))) - (body (parse-list-of 'table 'tr (the-body opts)))))))) - -;*---------------------------------------------------------------------*/ -;* tr ... */ -;*---------------------------------------------------------------------*/ -(define-markup (tr #!rest opts #!key (ident #f) (class #f) (bg #f)) - (new container - (markup 'tr) - (ident (or ident (symbol->string (gensym 'tr)))) - (class class) - (required-options '()) - (options `(,@(if bg `((:bg ,(if bg (skribe-use-color! bg) bg))) '()) - ,@(the-options opts :ident :class :bg))) - (body (parse-list-of 'tr 'tc (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* tc... */ -;*---------------------------------------------------------------------*/ -(define-markup (tc m - #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (let ((align (if (string? align) - (string->symbol align) - align)) - (valign (if (string? valign) - (string->symbol valign) - valign))) - (cond - ((not (integer? colspan)) - (skribe-type-error 'tc "Illegal colspan, " colspan "integer")) - ((not (symbol? align)) - (skribe-type-error 'tc "Illegal align, " align "align")) - ((not (memq align '(#f center left right))) - (skribe-error - 'tc - "align should be one of 'left', `center', or `right'" - align)) - ((not (memq valign '(#f top middle center bottom))) - (skribe-error - 'tc - "valign should be one of 'top', `middle', `center', or `bottom'" - valign)) - (else - (new container - (markup 'tc) - (ident (or ident (symbol->string (gensym 'tc)))) - (class class) - (required-options '(:width :align :valign :colspan)) - (options `((markup ,m) - (:align ,align) - (:valign ,valign) - (:colspan ,colspan) - ,@(if bg - `((:bg ,(if bg (skribe-use-color! bg) bg))) - '()) - ,@(the-options opts :ident :class :bg :align :valign))) - (body (the-body opts))))))) - -;*---------------------------------------------------------------------*/ -;* th ... */ -;*---------------------------------------------------------------------*/ -(define-markup (th #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'th opts)) - -;*---------------------------------------------------------------------*/ -;* td ... */ -;*---------------------------------------------------------------------*/ -(define-markup (td #!rest - opts - #!key - (ident #f) (class #f) - (width #f) (align 'center) (valign #f) - (colspan 1) (bg #f)) - (apply tc 'td opts)) - -;*---------------------------------------------------------------------*/ -;* image ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/image.skb:image@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:image@ */ -;* latex: @ref ../../skr/latex.skr:image@ */ -;*---------------------------------------------------------------------*/ -(define-markup (image #!rest - opts - #!key - (ident #f) (class #f) - file (url #f) (width #f) (height #f) (zoom #f)) - (cond - ((not (or (string? file) (string? url))) - (skribe-error 'image "No file or url provided" file)) - ((and (string? file) (string? url)) - (skribe-error 'image "Both file and url provided" (list file url))) - (else - (new markup - (markup 'image) - (ident (or ident (symbol->string (gensym 'image)))) - (class class) - (required-options '(:file :url :width :height)) - (options (the-options opts :ident :class)) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* blockquote */ -;*---------------------------------------------------------------------*/ -(define-simple-markup blockquote) - -;*---------------------------------------------------------------------*/ -;* Ornaments ... */ -;*---------------------------------------------------------------------*/ -(define-simple-markup roman) -(define-simple-markup bold) -(define-simple-markup underline) -(define-simple-markup strike) -(define-simple-markup emph) -(define-simple-markup kbd) -(define-simple-markup it) -(define-simple-markup tt) -(define-simple-markup code) -(define-simple-markup var) -(define-simple-markup samp) -(define-simple-markup sf) -(define-simple-markup sc) -(define-simple-markup sub) -(define-simple-markup sup) - -;*---------------------------------------------------------------------*/ -;* char ... */ -;*---------------------------------------------------------------------*/ -(define-markup (char char) - (cond - ((char? char) - (string char)) - ((integer? char) - (string (integer->char char))) - ((and (string? char) (= (string-length char) 1)) - char) - (else - (skribe-error 'char "Illegal char" char)))) - -;*---------------------------------------------------------------------*/ -;* symbol ... */ -;*---------------------------------------------------------------------*/ -(define-markup (symbol symbol) - (let ((v (cond - ((symbol? symbol) - (symbol->string symbol)) - ((string? symbol) - symbol) - (else - (skribe-error 'symbol - "Illegal argument (symbol expected)" - symbol))))) - (new markup - (markup 'symbol) - (body v)))) - -;*---------------------------------------------------------------------*/ -;* ! ... */ -;*---------------------------------------------------------------------*/ -(define-markup (! format #!rest node) - (if (not (string? format)) - (skribe-type-error '! "Illegal format:" format "string") - (new command - (fmt format) - (body node)))) - -;*---------------------------------------------------------------------*/ -;* processor ... */ -;*---------------------------------------------------------------------*/ -(define-markup (processor #!rest opts - #!key (combinator #f) (engine #f) (procedure #f)) - (cond - ((and combinator (not (procedure? combinator))) - (skribe-error 'processor "Combinator not a procedure" combinator)) - ((and engine (not (engine? engine))) - (skribe-error 'processor "Illegal engine" engine)) - ((and procedure - (or (not (procedure? procedure)) - (not (correct-arity? procedure 2)))) - (skribe-error 'processor "Illegal procedure" procedure)) - (else - (new processor - (combinator combinator) - (engine engine) - (procedure (or procedure (lambda (n e) n))) - (body (the-body opts)))))) - -;*---------------------------------------------------------------------*/ -;* Processors ... */ -;*---------------------------------------------------------------------*/ -(define-processor-markup html-processor) -(define-processor-markup tex-processor) - -;*---------------------------------------------------------------------*/ -;* handle ... */ -;*---------------------------------------------------------------------*/ -(define-markup (handle #!rest opts - #!key (ident #f) (class "handle") value section) - (let ((body (the-body opts))) - (cond - (section - (error 'handle "Illegal handle `section' option" section) - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident section 'section n env))) - (new handle - (ast s))))))) - ((and (pair? body) - (null? (cdr body)) - (markup? (car body))) - (new handle - (ast (car body)))) - (else - (skribe-error 'handle "Illegal handle" opts))))) - -;*---------------------------------------------------------------------*/ -;* mailto ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mailto@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mailto@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mailto #!rest opts #!key (ident #f) (class "mailto") text) - (new markup - (markup 'mailto) - (ident (or ident (symbol->string (gensym 'ident)))) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (the-body opts)))) - -;*---------------------------------------------------------------------*/ -;* *mark-table* ... */ -;*---------------------------------------------------------------------*/ -(define *mark-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* mark ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:mark@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:mark@ */ -;*---------------------------------------------------------------------*/ -(define-markup (mark #!rest opts #!key (ident #f) (class "mark") (text #f)) - (let ((bd (the-body opts))) - (cond - ((and (pair? bd) (not (null? (cdr bd)))) - (skribe-error 'mark "Too many argument provided" bd)) - ((null? bd) - (skribe-error 'mark "Missing argument" '())) - ((not (string? (car bd))) - (skribe-type-error 'mark "Illegal ident:" (car bd) "string")) - (ident - (skribe-error 'mark "Illegal `ident:' option" ident)) - (else - (let* ((bs (ast->string bd)) - (n (new markup - (markup 'mark) - (ident bs) - (class class) - (options (the-options opts :ident :class :text)) - (body text)))) - (hashtable-put! *mark-table* bs n) - n))))) - -;*---------------------------------------------------------------------*/ -;* ref ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/links.skb:ref@ */ -;* writer: */ -;* html: @ref ../../skr/html.skr:ref@ */ -;* latex: @ref ../../skr/latex.skr:ref@ */ -;*---------------------------------------------------------------------*/ -(define-markup (ref #!rest - opts - #!key - (class #f) - (ident #f) - (text #f) - (chapter #f) - (section #f) - (subsection #f) - (subsubsection #f) - (bib #f) - (bib-table (default-bib-table)) - (url #f) - (figure #f) - (mark #f) - (handle #f) - (line #f) - (skribe #f) - (page #f)) - (define (unref ast text kind) - (let ((msg (format "Can't find `~a': " kind))) - (if (ast? ast) - (begin - (skribe-warning/ast 1 ast 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body (list text ": " (ast->file-location ast))))) - (begin - (skribe-warning 1 'ref msg text) - (new markup - (markup 'unref) - (ident (symbol->string 'unref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) ,@(the-options opts :ident :class))) - (body text)))))) - (define (skribe-ref skribe) - (let ((path (find-file/path skribe (skribe-path)))) - (if (not path) - (unref #f skribe 'sui-file) - (let* ((sui (load-sui path)) - (os (the-options opts :skribe :class :text)) - (u (sui-ref->url (dirname path) sui ident os))) - (if (not u) - (unref #f os 'sui-ref) - (ref :url u :text text :ident ident :class class)))))) - (define (handle-ref text) - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind handle) ,@(the-options opts :ident :class))) - (body text))) - (define (doref text kind) - (if (not (string? text)) - (skribe-type-error 'ref "Illegal reference" text "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (resolve-ident text kind n env))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind ,kind) - (mark ,text) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n text (or kind 'ident))))))))) - (define (mark-ref mark) - (if (not (string? mark)) - (skribe-type-error 'mark "Illegal mark, " mark "string") - (new unresolved - (proc (lambda (n e env) - (let ((s (hashtable-get *mark-table* mark))) - (if s - (new markup - (markup 'ref) - (ident (symbol->string 'ref)) - (class class) - (required-options '(:text)) - (options `((kind mark) - (mark ,mark) - ,@(the-options opts :ident :class))) - (body (new handle - (ast s)))) - (unref n mark 'mark)))))))) - (define (make-bib-ref v) - (let ((s (resolve-bib bib-table v))) - (if s - (let* ((n (new markup - (markup 'bib-ref) - (ident (symbol->string 'bib-ref)) - (class class) - (required-options '(:text)) - (options (the-options opts :ident :class)) - (body (new handle - (ast s))))) - (h (new handle (ast n))) - (o (markup-option s 'used))) - (markup-option-add! s 'used (if (pair? o) (cons h o) (list h))) - n) - (unref #f v 'bib)))) - (define (bib-ref text) - (if (pair? text) - (new markup - (markup 'bib-ref+) - (ident (symbol->string 'bib-ref+)) - (class class) - (options (the-options opts :ident :class)) - (body (map make-bib-ref text))) - (make-bib-ref text))) - (define (url-ref) - (new markup - (markup 'url-ref) - (ident (symbol->string 'url-ref)) - (class class) - (required-options '(:url :text)) - (options (the-options opts :ident :class)))) - (define (line-ref line) - (new unresolved - (proc (lambda (n e env) - (let ((l (resolve-line line))) - (if (pair? l) - (new markup - (markup 'line-ref) - (ident (symbol->string 'line-ref)) - (class class) - (options `((:text ,(markup-ident (car l))) - ,@(the-options opts :ident :class))) - (body (new handle - (ast (car l))))) - (unref n line 'line))))))) - (let ((b (the-body opts))) - (if (not (null? b)) - (skribe-warning 1 'ref "Arguments ignored " b)) - (cond - (skribe (skribe-ref skribe)) - (handle (handle-ref handle)) - (ident (doref ident #f)) - (chapter (doref chapter 'chapter)) - (section (doref section 'section)) - (subsection (doref subsection 'subsection)) - (subsubsection (doref subsubsection 'subsubsection)) - (figure (doref figure 'figure)) - (mark (mark-ref mark)) - (bib (bib-ref bib)) - (url (url-ref)) - (line (line-ref line)) - (else (skribe-error 'ref "Illegal reference" opts))))) - -;*---------------------------------------------------------------------*/ -;* resolve ... */ -;*---------------------------------------------------------------------*/ -(define-markup (resolve fun) - (new unresolved - (proc fun))) - -;*---------------------------------------------------------------------*/ -;* bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (bibliography #!rest files - #!key - (command #f) (bib-table (default-bib-table))) - (for-each (lambda (f) - (cond - ((string? f) - (bib-load! bib-table f command)) - ((pair? f) - (bib-add! bib-table f)) - (else - (skribe-error "bibliography" "Illegal entry" f)))) - (the-body files))) - -;*---------------------------------------------------------------------*/ -;* the-bibliography ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/bib.skb:the-bibliography@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-bibliography@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-bibliography #!rest opts - #!key - pred - (bib-table (default-bib-table)) - (sort bib-sort/authors) - (count 'partial)) - (if (not (memq count '(partial full))) - (skribe-error 'the-bibliography - "Cound must be either `partial' or `full'" - count) - (new unresolved - (proc (lambda (n e env) - (resolve-the-bib bib-table - (new handle (ast n)) - sort - pred - count - (the-options opts))))))) - -;*---------------------------------------------------------------------*/ -;* make-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:make-index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (make-index ident) - (make-index-table ident)) - -;*---------------------------------------------------------------------*/ -;* index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:index@ */ -;*---------------------------------------------------------------------*/ -(define-markup (index #!rest - opts - #!key - (ident #f) (class "index") - (note #f) (index #f) (shape #f) - (url #f)) - (let* ((entry-name (the-body opts)) - (ename (cond - ((string? entry-name) - entry-name) - ((and (pair? entry-name) (every string? entry-name)) - (apply string-append entry-name)) - (else - (skribe-error - 'index - "entry-name must be either a string or a list of strings" - entry-name)))) - (table (cond - ((not index) (default-index)) - ((index? index) index) - (else (skribe-type-error 'index - "Illegal index table, " - index - "index")))) - (m (mark (symbol->string (gensym)))) - (h (new handle (ast m))) - (new (new markup - (markup '&index-entry) - (ident (or ident (symbol->string (gensym 'index)))) - (class class) - (options `((name ,ename) ,@(the-options opts :ident :class))) - (body (if url - (ref :url url :text (or shape ename)) - (ref :handle h :text (or shape ename))))))) - ;; New is bound to a dummy option of the mark in order - ;; to make new options verified. - (markup-option-add! m 'to-verify new) - (hashtable-update! table - ename - (lambda (cur) (cons new cur)) - (list new)) - m)) - -;*---------------------------------------------------------------------*/ -;* the-index ... */ -;* ------------------------------------------------------------- */ -;* doc: */ -;* @ref ../../doc/user/index.skb:the-index@ */ -;* writer: */ -;* base: @ref ../../skr/base.skr:the-index@ */ -;* html: @ref ../../skr/html.skr:the-index-header@ */ -;*---------------------------------------------------------------------*/ -(define-markup (the-index #!rest - opts - #!key - (ident #f) - (class "the-index") - (split #f) - (char-offset 0) - (header-limit 50) - (column 1)) - (let ((bd (the-body opts))) - (cond - ((not (and (integer? char-offset) (>= char-offset 0))) - (skribe-error 'the-index "Illegal char offset" char-offset)) - ((not (integer? column)) - (skribe-error 'the-index "Illegal column number" column)) - ((not (every? index? bd)) - (skribe-error 'the-index - "Illegal indexes" - (filter (lambda (o) (not (index? o))) bd))) - (else - (new unresolved - (proc (lambda (n e env) - (resolve-the-index (ast-loc n) - ident class - bd - split - char-offset - header-limit - column)))))))) diff --git a/src/common/bib.scm b/src/common/bib.scm deleted file mode 100644 index b73c5f0..0000000 --- a/src/common/bib.scm +++ /dev/null @@ -1,192 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/bib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Wed Jan 14 08:02:45 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../bigloo/bib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* bib-load! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-load! table filename command) - (if (not (bib-table? table)) - (skribe-error 'bib-load "Illegal bibliography table" table) - ;; read the file - (let ((p (skribe-open-bib-file filename command))) - (if (not (input-port? p)) - (skribe-error 'bib-load "Can't open data base" filename) - (unwind-protect - (parse-bib table p) - (close-input-port p)))))) - -;*---------------------------------------------------------------------*/ -;* resolve-bib ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-bib table ident) - (if (not (bib-table? table)) - (skribe-error 'resolve-bib "Illegal bibliography table" table) - (let* ((i (cond - ((string? ident) ident) - ((symbol? ident) (symbol->string ident)) - (else (skribe-error 'resolve-bib "Illegal ident" ident)))) - (en (hashtable-get table i))) - (if (is-markup? en '&bib-entry) - en - #f)))) - -;*---------------------------------------------------------------------*/ -;* make-bib-entry ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-entry kind ident fields from) - (let* ((m (new markup - (markup '&bib-entry) - (ident ident) - (options `((kind ,kind) (from ,from))))) - (h (new handle - (ast m)))) - (for-each (lambda (f) - (if (and (pair? f) - (pair? (cdr f)) - (null? (cddr f)) - (symbol? (car f))) - (markup-option-add! m - (car f) - (new markup - (markup (symbol-append - '&bib-entry- - (car f))) - (parent h) - (body (cadr f)))) - (bib-parse-error f))) - fields) - m)) - -;*---------------------------------------------------------------------*/ -;* bib-sort/authors ... */ -;*---------------------------------------------------------------------*/ -(define (bib-sort/authors l) - (define (cmp i1 i2 def) - (cond - ((and (markup? i1) (markup? i2)) - (cmp (markup-body i1) (markup-body i2) def)) - ((markup? i1) - (cmp (markup-body i1) i2 def)) - ((markup? i2) - (cmp i1 (markup-body i2) def)) - ((and (string? i1) (string? i2)) - (if (string=? i1 i2) - (def) - (string<? 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/src/common/configure.scm b/src/common/configure.scm deleted file mode 100644 index 90e2339..0000000 --- a/src/common/configure.scm +++ /dev/null @@ -1,8 +0,0 @@ -;; Automatically generated file (don't edit) -(define (skribe-release) "1.2d") -(define (skribe-url) "http://www.inria.fr/mimosa/fp/Skribe") -(define (skribe-doc-dir) "/usr/local/doc/skribe-1.2d") -(define (skribe-ext-dir) "/usr/local/share/skribe/extensions") -(define (skribe-default-path) '("." "/usr/local/share/skribe/extensions" "/usr/local/share/skribe/1.2d/skr" )) -(define (skribe-scheme) "bigloo") - diff --git a/src/common/configure.scm.in b/src/common/configure.scm.in deleted file mode 100644 index 830ec4d..0000000 --- a/src/common/configure.scm.in +++ /dev/null @@ -1,6 +0,0 @@ -(define (skribe-release) "@SKRIBE_RELEASE@") -(define (skribe-url) "@SKRIBE_URL@") -(define (skribe-doc-dir) "@SKRIBE_DOC_DIR@") -(define (skribe-ext-dir) "@SKRIBE_EXT_DIR@") -(define (skribe-default-path) @SKRIBE_SKR_PATH@) -(define (skribe-scheme) "@SKRIBE_SCHEME@") diff --git a/src/common/index.scm b/src/common/index.scm deleted file mode 100644 index 65c271f..0000000 --- a/src/common/index.scm +++ /dev/null @@ -1,126 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/index.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 14:58:05 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../bigloo/index.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* index? ... */ -;*---------------------------------------------------------------------*/ -(define (index? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *index-table* ... */ -;*---------------------------------------------------------------------*/ -(define *index-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-index-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-index-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-index ... */ -;*---------------------------------------------------------------------*/ -(define (default-index) - (if (not *index-table*) - (set! *index-table* (make-index-table "default-index"))) - *index-table*) - -;*---------------------------------------------------------------------*/ -;* resolve-the-index ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) - ;; fetch the descriminating index name letter - (define (index-ref n) - (let ((name (markup-option n 'name))) - (if (>= char-offset (string-length name)) - (skribe-error 'the-index "char-offset out of bound" char-offset) - (string-ref name char-offset)))) - ;; sort a bucket of entries (the entries in a bucket share there name) - (define (sort-entries-bucket ie) - (sort ie - (lambda (i1 i2) - (or (not (markup-option i1 :note)) - (markup-option i2 :note))))) - ;; accumulate all the entries starting with the same letter - (define (letter-references refs) - (let ((letter (index-ref (car (car refs))))) - (let loop ((refs refs) - (acc '())) - (if (or (null? refs) - (not (char-ci=? letter (index-ref (car (car refs)))))) - (values (char-upcase letter) acc refs) - (loop (cdr refs) (cons (car refs) acc)))))) - ;; merge the buckets that comes from different index tables - (define (merge-buckets buckets) - (if (null? buckets) - '() - (let loop ((buckets buckets) - (res '())) - (cond - ((null? (cdr buckets)) - (reverse! (cons (car buckets) res))) - ((string=? (markup-option (car (car buckets)) 'name) - (markup-option (car (cadr buckets)) 'name)) - ;; we merge - (loop (cons (append (car buckets) (cadr buckets)) - (cddr buckets)) - res)) - (else - (loop (cdr buckets) - (cons (car buckets) res))))))) - (let* ((entries (apply append (map hashtable->list indexes))) - (sorted (map sort-entries-bucket - (merge-buckets - (sort entries - (lambda (e1 e2) - (string-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/src/common/lib.scm b/src/common/lib.scm deleted file mode 100644 index b0fa2d0..0000000 --- a/src/common/lib.scm +++ /dev/null @@ -1,238 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/lib.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Sep 10 11:57:54 2003 */ -;* Last change : Wed Oct 27 12:16:40 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Scheme independent lib part. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/lib.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* engine-custom-add! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-add! e id val) - (let ((old (engine-custom e id))) - (if (unspecified? old) - (engine-custom-set! e id (list val)) - (engine-custom-set! e id (cons val old))))) - -;*---------------------------------------------------------------------*/ -;* find-markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define (find-markup-ident ident) - (let ((r (find-markups ident))) - (if (or (pair? r) (null? r)) - r - '()))) - -;*---------------------------------------------------------------------*/ -;* container-search-down ... */ -;*---------------------------------------------------------------------*/ -(define (container-search-down pred obj) - (with-debug 4 'container-search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((container? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* search-down ... */ -;*---------------------------------------------------------------------*/ -(define (search-down pred obj) - (with-debug 4 'search-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj (markup-body obj))) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (let ((rest (loop (markup-body obj)))) - (if (pred obj) - (cons obj rest) - rest))) - ((pred obj) - (list obj)) - (else - '()))))) - -;*---------------------------------------------------------------------*/ -;* find-down ... */ -;*---------------------------------------------------------------------*/ -(define (find-down pred obj) - (with-debug 4 'find-down - (debug-item "obj=" (find-runtime-type obj)) - (let loop ((obj obj)) - (cond - ((pair? obj) - (apply append (map (lambda (o) (loop o)) obj))) - ((markup? obj) - (debug-item "loop=" (find-runtime-type obj) - " " (markup-ident obj)) - (if (pred obj) - (list (cons obj (loop (markup-body obj)))) - '())) - (else - (if (pred obj) - (list obj) - '())))))) - -;*---------------------------------------------------------------------*/ -;* find1-down ... */ -;*---------------------------------------------------------------------*/ -(define (find1-down pred obj) - (with-debug 4 'find1-down - (let loop ((obj obj) - (stack '())) - (debug-item "obj=" (find-runtime-type obj) - " " (if (markup? obj) (markup-markup obj) "???") - " " (if (markup? obj) (markup-ident obj) "")) - (cond - ((memq obj stack) - (skribe-error 'find1-down "Illegal cyclic object" obj)) - ((pair? obj) - (let liip ((obj obj)) - (cond - ((null? obj) - #f) - (else - (or (loop (car obj) (cons obj stack)) - (liip (cdr obj))))))) - ((pred obj) - obj) - ((markup? obj) - (loop (markup-body obj) (cons obj stack))) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* find-up ... */ -;*---------------------------------------------------------------------*/ -(define (find-up pred obj) - (let loop ((obj obj) - (res '())) - (cond - ((not (ast? obj)) - res) - ((pred obj) - (loop (ast-parent obj) (cons obj res))) - (else - (loop (ast-parent obj) (cons obj res)))))) - -;*---------------------------------------------------------------------*/ -;* find1-up ... */ -;*---------------------------------------------------------------------*/ -(define (find1-up pred obj) - (let loop ((obj obj)) - (cond - ((not (ast? obj)) - #f) - ((pred obj) - obj) - (else - (loop (ast-parent obj)))))) - -;*---------------------------------------------------------------------*/ -;* ast-document ... */ -;*---------------------------------------------------------------------*/ -(define (ast-document m) - (find1-up document? m)) - -;*---------------------------------------------------------------------*/ -;* ast-chapter ... */ -;*---------------------------------------------------------------------*/ -(define (ast-chapter m) - (find1-up (lambda (n) (is-markup? n 'chapter)) m)) - -;*---------------------------------------------------------------------*/ -;* ast-section ... */ -;*---------------------------------------------------------------------*/ -(define (ast-section m) - (find1-up (lambda (n) (is-markup? n 'section)) m)) - -;*---------------------------------------------------------------------*/ -;* the-body ... */ -;* ------------------------------------------------------------- */ -;* Filter out the options */ -;*---------------------------------------------------------------------*/ -(define (the-body opt+) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-body "Illegal body" opt*)) - ((keyword? (car opt*)) - (if (null? (cdr opt*)) - (skribe-error 'the-body "Illegal option" (car opt*)) - (loop (cddr opt*) res))) - (else - (loop (cdr opt*) (cons (car opt*) res)))))) - -;*---------------------------------------------------------------------*/ -;* the-options ... */ -;* ------------------------------------------------------------- */ -;* Returns an list made of options. The OUT argument contains */ -;* keywords that are filtered out. */ -;*---------------------------------------------------------------------*/ -(define (the-options opt+ . out) - (let loop ((opt* opt+) - (res '())) - (cond - ((null? opt*) - (reverse! res)) - ((not (pair? opt*)) - (skribe-error 'the-options "Illegal options" opt*)) - ((keyword? (car opt*)) - (cond - ((null? (cdr opt*)) - (skribe-error 'the-options "Illegal option" (car opt*))) - ((memq (car opt*) out) - (loop (cdr opt*) res)) - (else - (loop (cdr opt*) - (cons (list (car opt*) (cadr opt*)) res))))) - (else - (loop (cdr opt*) res))))) - -;*---------------------------------------------------------------------*/ -;* list-split ... */ -;*---------------------------------------------------------------------*/ -(define (list-split l num . fill) - (let loop ((l l) - (i 0) - (acc '()) - (res '())) - (cond - ((null? l) - (reverse! (cons (if (or (null? fill) (= i num)) - (reverse! acc) - (append! (reverse! acc) - (make-list (- num i) (car fill)))) - res))) - ((= i num) - (loop l - 0 - '() - (cons (reverse! acc) res))) - (else - (loop (cdr l) - (+ i 1) - (cons (car l) acc) - res))))) - diff --git a/src/common/param.scm b/src/common/param.scm deleted file mode 100644 index ba8d489..0000000 --- a/src/common/param.scm +++ /dev/null @@ -1,69 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/param.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 30 09:06:53 2003 */ -;* Last change : Thu Oct 28 21:51:49 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Common Skribe parameters */ -;* Implementation: @label param@ */ -;* bigloo: @path ../bigloo/param.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-file* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-file* "skriberc") - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-mode-alist* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) - -;*---------------------------------------------------------------------*/ -;* *skribe-auto-load-alist* ... */ -;* ------------------------------------------------------------- */ -;* Autoload engines. */ -;*---------------------------------------------------------------------*/ -(define *skribe-auto-load-alist* - '((base . "base.skr") - (html . "html.skr") - (sui . "html.skr") - (latex . "latex.skr") - (context . "context.skr") - (xml . "xml.skr"))) - -;*---------------------------------------------------------------------*/ -;* *skribe-preload* ... */ -;* ------------------------------------------------------------- */ -;* The list of skribe files (e.g. styles) to be loaded at boot-time */ -;*---------------------------------------------------------------------*/ -(define *skribe-preload* - '("skribe.skr")) - -;*---------------------------------------------------------------------*/ -;* *skribe-precustom* ... */ -;* ------------------------------------------------------------- */ -;* The list of pair <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/src/common/sui.scm b/src/common/sui.scm deleted file mode 100644 index eb6134b..0000000 --- a/src/common/sui.scm +++ /dev/null @@ -1,166 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/common/sui.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Dec 31 11:44:33 2003 */ -;* Last change : Tue Feb 17 11:35:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Url Indexes */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../bigloo/sui.bgl@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* *sui-table* ... */ -;*---------------------------------------------------------------------*/ -(define *sui-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* load-sui ... */ -;* ------------------------------------------------------------- */ -;* Returns a SUI sexp if already loaded. Load it otherwise. */ -;* Raise an error if the file cannot be open. */ -;*---------------------------------------------------------------------*/ -(define (load-sui path) - (let ((sexp (hashtable-get *sui-table* path))) - (or sexp - (begin - (when (> *skribe-verbose* 0) - (fprintf (current-error-port) " [loading sui: ~a]\n" path)) - (let ((p (open-input-file path))) - (if (not (input-port? p)) - (skribe-error 'load-sui - "Can't find `Skribe Url Index' file" - path) - (unwind-protect - (let ((sexp (read p))) - (match-case sexp - ((sui (? string?) . ?-) - (hashtable-put! *sui-table* path sexp)) - (else - (skribe-error 'load-sui - "Illegal `Skribe Url Index' file" - path))) - sexp) - (close-input-port p)))))))) - -;*---------------------------------------------------------------------*/ -;* sui-ref->url ... */ -;*---------------------------------------------------------------------*/ -(define (sui-ref->url dir sui ident opts) - (let ((refs (sui-find-ref sui ident opts))) - (and (pair? refs) - (let ((base (sui-file sui)) - (file (car (car refs))) - (mark (cdr (car refs)))) - (format "~a/~a#~a" dir (or file base) mark))))) - -;*---------------------------------------------------------------------*/ -;* sui-title ... */ -;*---------------------------------------------------------------------*/ -(define (sui-title sexp) - (match-case sexp - ((sui (and ?title (? string?)) . ?-) - title) - (else - (skribe-error 'sui-title "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-file ... */ -;*---------------------------------------------------------------------*/ -(define (sui-file sexp) - (sui-key sexp :file)) - -;*---------------------------------------------------------------------*/ -;* sui-key ... */ -;*---------------------------------------------------------------------*/ -(define (sui-key sexp key) - (match-case sexp - ((sui ?- . ?rest) - (let loop ((rest rest)) - (and (pair? rest) - (if (eq? (car rest) key) - (and (pair? (cdr rest)) - (cadr rest)) - (loop (cdr rest)))))) - (else - (skribe-error 'sui-key "Illegal `sui' format" sexp)))) - -;*---------------------------------------------------------------------*/ -;* sui-find-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-find-ref sui ident opts) - (let ((ident (assq :ident opts)) - (mark (assq :mark opts)) - (class (let ((c (assq :class opts))) - (and (pair? c) (cadr c)))) - (chapter (assq :chapter opts)) - (section (assq :section opts)) - (subsection (assq :subsection opts)) - (subsubsection (assq :subsubsection opts))) - (match-case sui - ((sui (? string?) . ?refs) - (cond - (mark (sui-search-ref 'marks refs (cadr mark) class)) - (chapter (sui-search-ref 'chapters refs (cadr chapter) class)) - (section (sui-search-ref 'sections refs (cadr section) class)) - (subsection (sui-search-ref 'subsections refs (cadr subsection) class)) - (subsubsection (sui-search-ref 'subsubsections refs (cadr subsubsection) class)) - (ident (sui-search-all-refs sui ident class)) - (else '()))) - (else - (skribe-error 'sui-find-ref "Illegal `sui' format" sui))))) - -;*---------------------------------------------------------------------*/ -;* sui-search-all-refs ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-all-refs sui id refs) - '()) - -;*---------------------------------------------------------------------*/ -;* sui-search-ref ... */ -;*---------------------------------------------------------------------*/ -(define (sui-search-ref kind refs val class) - (define (find-ref refs val class) - (map (lambda (r) - (let ((f (memq :file r)) - (c (memq :mark r))) - (cons (and (pair? f) (cadr f)) (and (pair? c) (cadr c))))) - (filter (if class - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val) - (let ((c (memq :class m))) - (and (pair? c) - (eq? (cadr c) class))))) - (lambda (m) - (and (pair? m) - (string? (car m)) - (string=? (car m) val)))) - refs))) - (let loop ((refs refs)) - (if (pair? refs) - (if (and (pair? (car refs)) (eq? (caar refs) kind)) - (find-ref (cdar refs) val class) - (loop (cdr refs))) - '()))) - -;*---------------------------------------------------------------------*/ -;* sui-filter ... */ -;*---------------------------------------------------------------------*/ -(define (sui-filter sui pred1 pred2) - (match-case sui - ((sui (? string?) . ?refs) - (let loop ((refs refs) - (res '())) - (if (pair? refs) - (if (and (pred1 (car refs))) - (loop (cdr refs) - (cons (filter pred2 (cdar refs)) res)) - (loop (cdr refs) res)) - (reverse! res)))) - (else - (skribe-error 'sui-filter "Illegal `sui' format" sui)))) |