diff options
Diffstat (limited to 'src')
99 files changed, 3109 insertions, 13833 deletions
diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index 09e96d5..0000000 --- a/src/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Sat Oct 25 08:15:57 2003 */ -#* Last change : Mon Jan 5 09:55:27 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The meta Makefile for the sources */ -#*=====================================================================*/ -include ../etc/Makefile.config - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo src/Makefile - @ (cd bigloo && $(MAKE) pop) - @ (cd stklos && $(MAKE) pop) - -#*---------------------------------------------------------------------*/ -#* Install/Uinstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall - -install: - (cd $(SYSTEM) && $(MAKE) install) - -uninstall: - (cd $(SYSTEM) && $(MAKE) uninstall) - -#*---------------------------------------------------------------------*/ -#* clean */ -#*---------------------------------------------------------------------*/ -.PHONY: clean - -clean: - (cd $(SYSTEM) && $(MAKE) clean) - diff --git a/src/Makefile.am b/src/Makefile.am new file mode 100644 index 0000000..1d3db1f --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = guile diff --git a/src/bigloo/Makefile b/src/bigloo/Makefile deleted file mode 100644 index 02d2b6a..0000000 --- a/src/bigloo/Makefile +++ /dev/null @@ -1,271 +0,0 @@ -#*=====================================================================*/ -#* serrano/prgm/project/skribe/src/bigloo/Makefile */ -#* ------------------------------------------------------------- */ -#* Author : Manuel Serrano */ -#* Creation : Mon Jul 21 18:21:11 2003 */ -#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ -#* Copyright : 2003-04 Manuel Serrano */ -#* ------------------------------------------------------------- */ -#* The Makefile to build the Bigloo API */ -#*=====================================================================*/ - -#*---------------------------------------------------------------------*/ -#* General inclusion */ -#*---------------------------------------------------------------------*/ -include ../../etc/bigloo/Makefile.skb - -#*---------------------------------------------------------------------*/ -#* Compilers and tools */ -#*---------------------------------------------------------------------*/ -BSKBFLAGS = -I $(SRCDIR)/bigloo - -#*---------------------------------------------------------------------*/ -#* Targets ... */ -#*---------------------------------------------------------------------*/ -PROJECT = skribe -CTARGET = $(SKRIBEBINDIR)/skribe.bigloo -JVMTARGET = $(SKRIBEBINDIR)/skribe.zip - -PBASE = bigloo.$(PROJECT) -ODIR = o -CLASSDIR = class_s/bigloo/$(PROJECT) -OBJDIR = obj/bigloo/$(PROJECT) - -#*---------------------------------------------------------------------*/ -#* Objects */ -#*---------------------------------------------------------------------*/ -SRCDIR = .. -SKRIBECOMMON = param api bib index lib sui -SKRIBEBGL = types parseargs main eval evapi \ - output resolve verify debug read prog source \ - lisp xml c asm engine writer color -SKRIBEINCLUDE = api new debug - -MODULES = $(SKRIBEBGL:%=%.scm) \ - $(SKRIBECOMMON:%=%.bgl) \ - configure.bgl -INCLUDES = $(SKRIBEINCLUDE:%=%.sch) -SOURCES = $(MODULES) \ - $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ - $(SRCDIR)/common/configure.scm \ - $(INCLUDES) -OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure -COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) -JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) - -#*---------------------------------------------------------------------*/ -#* Population */ -#*---------------------------------------------------------------------*/ -POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile -POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in - -#*---------------------------------------------------------------------*/ -#* Suffixes */ -#*---------------------------------------------------------------------*/ -.SUFFIXES: -.SUFFIXES: .scm .bgl .class .o .obj - -#*---------------------------------------------------------------------*/ -#* All */ -#*---------------------------------------------------------------------*/ -.PHONY: c jvm dotnet - -all: $(TARGET) - -c: $(CTARGET) -jvm: $(JVMTARGET) -dotnet: - echo "Not implemented yet" - -#*--- c ---------------------------------------------------------------*/ -$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) - $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) - -#*--- jvm -------------------------------------------------------------*/ -$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) - $(RM) -f $(JVMTARGET) - (cd $(ODIR)/class_s && \ - $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) - -$(SKRIBEBINDIR): - mkdir -p $(SKRIBEBINDIR) - -#*---------------------------------------------------------------------*/ -#* pop */ -#*---------------------------------------------------------------------*/ -.PHONY: pop - -pop: - @ echo $(POPULATIONSCM:%=src/common/%) - @ echo $(POPULATIONBGL:%=src/bigloo/%) - -#*---------------------------------------------------------------------*/ -#* ude */ -#*---------------------------------------------------------------------*/ -.PHONY: ude .etags .afile - -ude: - @ $(MAKE) -f Makefile .afile .etags dep - -.afile: - @ $(AFILE) -o .afile $(MODULES) - -.jfile: - @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) - -.etags: - @ $(BTAGS) -o .etags $(SOURCES) - -dep: - @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ - head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) - @ $(BDEPEND) -search-path ../common \ - -search-path ../bigloo \ - -strict-obj-dir $(ODIR) \ - -strict-class-dir $(CLASSDIR) \ - -fno-mco $(SOURCES) >> /tmp/Makefile.aux - @ mv /tmp/Makefile.aux Makefile - -getbinary: - @ echo $(PROJECT) - -getsources: - @ echo $(SOURCES) - -#*---------------------------------------------------------------------*/ -#* The implicit rules */ -#*---------------------------------------------------------------------*/ -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ - $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ - -$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm - $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ - $(SRCDIR)/bigloo/$*.scm -o $@ - -$(OBJDIR)/%.obj: src/%.scm - $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ - -#*---------------------------------------------------------------------*/ -#* Ad hoc rules */ -#*---------------------------------------------------------------------*/ -$(ODIR): - mkdir -p $(ODIR) - -$(CLASSDIR): - mkdir -p $(CLASSDIR) - -$(OBJDIR): - mkdir -p $(OBJDIR) - - -#*---------------------------------------------------------------------*/ -#* install/uninstall */ -#*---------------------------------------------------------------------*/ -.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm - -install: - $(MAKE) install-$(TARGET) - -uninstall: - $(MAKE) uninstall-$(TARGET) - -install-c: $(DESTDIR)$(INSTALL_BINDIR) - cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ - && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe - -uninstall-c: - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo - $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe - -install-jvm: $(DESTDIR)$(INSTALL_FILDIR) - cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) - -uninstall-jvm: - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip - $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip - -$(DESTDIR)$(INSTALL_BINDIR): - mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) - -$(DESTDIR)$(INSTALL_FILDIR): - mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) - -#*---------------------------------------------------------------------*/ -#* Clean */ -#*---------------------------------------------------------------------*/ -clean: - $(RM) -f .afile - $(RM) -f .jfile - $(RM) -rf $(ODIR) - $(RM) -f $(CTARGET) - $(RM) -f $(JVMTARGET) - -#*---------------------------------------------------------------------*/ -#* Cleanall */ -#*---------------------------------------------------------------------*/ -cleanall: clean - -#*---------------------------------------------------------------------*/ -#* Manual dependency */ -#*---------------------------------------------------------------------*/ -o/eval.o o/class/bigloo/skribe/eval.class: \ - $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm - -#bdepend start (don't edit) -#*---------------------------------------------------------------------*/ -#* Dependencies ... */ -#*---------------------------------------------------------------------*/ -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch -o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch -o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch -o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch -o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch -o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch -o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch -o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch -o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch -o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch -o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch -o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch -o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ - ../bigloo/api.sch -o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch - -#bdepend stop diff --git a/src/bigloo/api.bgl b/src/bigloo/api.bgl deleted file mode 100644 index 55493b0..0000000 --- a/src/bigloo/api.bgl +++ /dev/null @@ -1,117 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:21:34 2003 */ -;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo header for the API. */ -;* ------------------------------------------------------------- */ -;* Implementation: @label api@ */ -;* bigloo: @path ../common/api.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_api - - (include "new.sch" - "api.sch") - - (import skribe_param - skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_bib - skribe_index - skribe_prog - skribe_source - skribe_engine - skribe_color - skribe_sui) - - (export (include string) - - (document::%markup . opts) - (author::%markup . opts) - (toc::%markup . opts) - - (chapter::%markup . opts) - (section::%markup . opts) - (subsection::%markup . opts) - (subsubsection::%markup . opts) - (paragraph::%markup . opts) - - (footnote::%markup . opts) - - (linebreak . opts) - (hrule::%markup . opts) - - (color::%markup . opts) - (frame::%markup . opts) - (font::%markup . opts) - - (flush::%markup . opts) - (center::%markup . opts) - (pre::%markup . opts) - (prog::%markup . opts) - (source::obj . opts) - (language::obj . opts) - - (itemize::%markup . opts) - (enumerate::%markup . opts) - (description::%markup . opts) - (item::%markup . opts) - - (figure::%markup . opts) - - (table::%markup . opts) - (tr::%markup . opts) - (td::%markup . opts) - (th::%markup . opts) - - (image::%markup . opts) - - (blockquote::%markup . opts) - - (roman::%markup . opts) - (bold::%markup . opts) - (underline::%markup . opts) - (strike::%markup . opts) - (emph::%markup . opts) - (kbd::%markup . opts) - (it::%markup . opts) - (tt::%markup . opts) - (code::%markup . opts) - (var::%markup . opts) - (samp::%markup . opts) - (sf::%markup . opts) - (sc::%markup . opts) - (sub::%markup . opts) - (sup::%markup . opts) - - (mailto::%markup . opts) - (mark::%markup . opts) - - (handle . obj) - (ref::%ast . obj) - (resolve::%ast ::procedure) - - (bibliography . files) - (the-bibliography . opts) - - (make-index ::bstring) - (index . args) - (the-index . args) - - (char::bstring char) - (symbol::%markup symbol) - (!::%command string . args) - - (processor::%processor . opts) - - (html-processor::%processor . opts) - (tex-processor::%processor . opts))) diff --git a/src/bigloo/api.sch b/src/bigloo/api.sch deleted file mode 100644 index 390b8fa..0000000 --- a/src/bigloo/api.sch +++ /dev/null @@ -1,91 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/api.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Jul 21 18:15:25 2003 */ -;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo macros for the API implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* define-pervasive-macro ... */ -;*---------------------------------------------------------------------*/ -(define-macro (define-pervasive-macro proto . body) - `(begin - (eval '(define-macro ,proto ,@body)) - (define-macro ,proto ,@body))) - -;*---------------------------------------------------------------------*/ -;* define-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-markup proto . body) - (define (s2k symbol) - (string->keyword (string-append ":" (symbol->string symbol)))) - (if (not (pair? proto)) - (error 'define-markup "Illegal markup definition" proto) - (let* ((id (car proto)) - (args (cdr proto)) - (dargs (dsssl-formals->scheme-formals args error))) - `(begin - ,(if (and (memq #!key args) - (memq '&skribe-eval-location args)) - `(define-expander ,id - (lambda (x e) - (append - (cons ',id (map (lambda (x) (e x e)) (cdr x))) - (list :&skribe-eval-location - '(skribe-eval-location))))) - #unspecified) - (define ,(cons id dargs) - ,(make-dsssl-function-prelude proto - args `(begin ,@body) - error s2k)))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-markup markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new markup - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-simple-container ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-simple-container markup) - `(define-markup (,markup #!rest opts #!key ident class loc) - (new container - (markup ',markup) - (ident (or ident (symbol->string (gensym ',markup)))) - (loc loc) - (class class) - (required-options '()) - (options (the-options opts :ident :class :loc)) - (body (the-body opts))))) - -;*---------------------------------------------------------------------*/ -;* define-processor-markup ... */ -;*---------------------------------------------------------------------*/ -(define-pervasive-macro (define-processor-markup proc) - `(define-markup (,proc #!rest opts) - (new processor - (engine (find-engine ',proc)) - (body (the-body opts)) - (options (the-options opts))))) - -;*---------------------------------------------------------------------*/ -;* new (at runtime) */ -;*---------------------------------------------------------------------*/ -(eval '(define-macro (new id . inits) - (cons (symbol-append 'new- id) - (map (lambda (i) - (list 'list (list 'quote (car i)) (cadr i))) - inits)))) diff --git a/src/bigloo/asm.scm b/src/bigloo/asm.scm deleted file mode 100644 index 03196ac..0000000 --- a/src/bigloo/asm.scm +++ /dev/null @@ -1,99 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* ASM fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_asm - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export asm)) - -;*---------------------------------------------------------------------*/ -;* asm ... */ -;*---------------------------------------------------------------------*/ -(define asm - (new language - (name "asm") - (fontifier asm-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* asm-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (asm-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: "#" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((: (* (in #\tab #\space)) - (+ (out #\: #\Space #\Tab #\Newline)) #\:) - ;; labels - (let ((c (new markup - (markup '&source-define) - (body (the-string))))) - (cons c (ignore)))) - ((or (in "<>=!/\\+*-([])") - #\/ - (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(asm)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/src/bigloo/bib.bgl b/src/bigloo/bib.bgl deleted file mode 100644 index 6b0f7dd..0000000 --- a/src/bigloo/bib.bgl +++ /dev/null @@ -1,161 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Dec 7 06:12:29 2001 */ -;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ -;* Copyright : 2001-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe Bibliography */ -;* ------------------------------------------------------------- */ -;* Implementation: @label bib@ */ -;* bigloo: @path ../common/bib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_bib - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_read) - - (export (bib-table?::bool ::obj) - (make-bib-table ::bstring) - (default-bib-table) - (bib-load! ::obj ::bstring ::obj) - (bib-add! ::obj . entries) - (resolve-bib ::obj ::obj) - (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) - (bib-sort/authors::pair-nil ::pair-nil) - (bib-sort/idents::pair-nil ::pair-nil) - (bib-sort/dates::pair-nil ::pair-nil))) - -;*---------------------------------------------------------------------*/ -;* bib-table? ... */ -;*---------------------------------------------------------------------*/ -(define (bib-table? obj) - (hashtable? obj)) - -;*---------------------------------------------------------------------*/ -;* *bib-table* ... */ -;*---------------------------------------------------------------------*/ -(define *bib-table* #f) - -;*---------------------------------------------------------------------*/ -;* make-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (make-bib-table ident) - (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* default-bib-table ... */ -;*---------------------------------------------------------------------*/ -(define (default-bib-table) - (if (not *bib-table*) - (set! *bib-table* (make-bib-table "default-bib-table"))) - *bib-table*) - -;*---------------------------------------------------------------------*/ -;* bib-parse-error ... */ -;*---------------------------------------------------------------------*/ -(define (bib-parse-error entry) - (if (epair? entry) - (match-case (cer entry) - ((at ?fname ?pos ?-) - (error/location "parse-biblio" - "bibliography syntax error" - entry - fname - pos)) - (else - (error 'bib-parse "bibliography syntax error" entry))) - (error 'bib-parse "bibliography syntax error" entry))) - -;*---------------------------------------------------------------------*/ -;* bib-duplicate ... */ -;*---------------------------------------------------------------------*/ -(define (bib-duplicate ident from old) - (let ((ofrom (markup-option old 'from))) - (skribe-warning 2 - 'bib - (format "Duplicated bibliographic entry ~a'.\n" ident) - (if ofrom - (format " Using version of `~a'.\n" ofrom) - "") - (if from - (format " Ignoring version of `~a'." from) - " Ignoring redefinition.")))) - -;*---------------------------------------------------------------------*/ -;* parse-bib ... */ -;*---------------------------------------------------------------------*/ -(define (parse-bib table port) - (if (not (bib-table? table)) - (skribe-error 'parse-bib "Illegal bibliography table" table) - (let ((from (input-port-name port))) - (let loop ((entry (skribe-read port))) - (if (not (eof-object? entry)) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident from old) - (hashtable-put! table - ident - (make-bib-entry kind - ident - fds - from)))) - (loop (skribe-read port))) - (else - (bib-parse-error entry)))))))) - -;*---------------------------------------------------------------------*/ -;* bib-add! ... */ -;*---------------------------------------------------------------------*/ -(define (bib-add! table . entries) - (if (not (bib-table? table)) - (skribe-error 'bib-add! "Illegal bibliography table" table) - (for-each (lambda (entry) - (match-case entry - (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) - (let* ((ident (symbol->string ident)) - (old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) - (let ((old (hashtable-get table ident))) - (if old - (bib-duplicate ident #f old) - (hashtable-put! table - ident - (make-bib-entry kind - ident fs #f))))) - (else - (bib-parse-error entry)))) - entries))) - - - diff --git a/src/bigloo/c.scm b/src/bigloo/c.scm deleted file mode 100644 index 07290ce..0000000 --- a/src/bigloo/c.scm +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/c.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Thu May 27 10:11:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* C fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_c - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export C)) - -;*---------------------------------------------------------------------*/ -;* C stamps */ -;*---------------------------------------------------------------------*/ -(define *keyword* (gensym)) -(define *cpp* (gensym)) - -;*---------------------------------------------------------------------*/ -;* C keywords */ -;*---------------------------------------------------------------------*/ -(for-each (lambda (symbol) - (putprop! symbol *keyword* #t)) - '(for class template while return try catch break continue - do if else typedef struct union goto switch case - static extern default finally throw)) -(let ((sharp (string->symbol "#"))) - (for-each (lambda (symbol) - (putprop! (symbol-append sharp symbol) *cpp* #t)) - '(include define if ifdef ifdef else endif))) - -;*---------------------------------------------------------------------*/ -;* C ... */ -;*---------------------------------------------------------------------*/ -(define C - (new language - (name "C") - (fontifier c-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* c-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (c-fontifier s) - (let ((g (regular-grammar () - ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) - (+ #\*) "/") - ;; bold comments - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-line-comment) - (body s)))) - str) - (ignore)))) - ((: "//" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\Newline #\Space)) - ;; separators - (let ((str (the-string))) - (cons str (ignore)))) - ((in "{}") - ;; brackets - (let ((str (the-string))) - (let ((c (new markup - (markup '&source-bracket) - (body (the-string))))) - (cons c (ignore))))) - ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) - ;; keywords - (let* ((string (the-string)) - (symbol (the-symbol))) - (cond - ((getprop symbol *keyword*) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((getprop symbol *cpp*) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons string (ignore)))))) - ((in "<>=!/\\+*-([])") - ;; regular text - (let ((s (the-string))) - (cons s (ignore)))) - ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (body s)))) - str) - (ignore)))) - ((+ (or #\; #\" #\# #\tab)) - (let ((str (the-string))) - (cons str (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(C)" "Unexpected character" c))))))) - (read/rp g (open-input-string s)))) - diff --git a/src/bigloo/color.scm b/src/bigloo/color.scm deleted file mode 100644 index e481d65..0000000 --- a/src/bigloo/color.scm +++ /dev/null @@ -1,702 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/color.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Apr 10 13:46:50 2002 */ -;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ -;* Copyright : 2002-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Tex color manager */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_color - (import skribe_configure) - (export (skribe-color->rgb ::obj) - (skribe-get-used-colors) - (skribe-use-color! color))) - -;*---------------------------------------------------------------------*/ -;* *skribe-rgb-string* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-rgb-string* - "255 250 250 snow -248 248 255 ghostwhite -245 245 245 whitesmoke -220 220 220 gainsboro -255 250 240 floralwhite -253 245 230 oldlace -250 240 230 linen -250 235 215 antiquewhite -255 239 213 papayawhip -255 235 205 blanchedalmond -255 228 196 bisque -255 218 185 peachpuff -255 222 173 navajowhite -255 228 181 moccasin -255 248 220 cornsilk -255 255 240 ivory -255 250 205 lemonchiffon -255 245 238 seashell -240 255 240 honeydew -245 255 250 mintcream -240 255 255 azure -240 248 255 aliceblue -230 230 250 lavender -255 240 245 lavenderblush -255 228 225 mistyrose -255 255 255 white -0 0 0 black -47 79 79 darkslategrey -105 105 105 dimgrey -112 128 144 slategrey -119 136 153 lightslategrey -190 190 190 grey -211 211 211 lightgrey -25 25 112 midnightblue -0 0 128 navy -0 0 128 navyblue -100 149 237 cornflowerblue -72 61 139 darkslateblue -106 90 205 slateblue -123 104 238 mediumslateblue -132 112 255 lightslateblue -0 0 205 mediumblue -65 105 225 royalblue -0 0 255 blue -30 144 255 dodgerblue -0 191 255 deepskyblue -135 206 235 skyblue -135 206 250 lightskyblue -70 130 180 steelblue -176 196 222 lightsteelblue -173 216 230 lightblue -176 224 230 powderblue -175 238 238 paleturquoise -0 206 209 darkturquoise -72 209 204 mediumturquoise -64 224 208 turquoise -0 255 255 cyan -224 255 255 lightcyan -95 158 160 cadetblue -102 205 170 mediumaquamarine -127 255 212 aquamarine -0 100 0 darkgreen -85 107 47 darkolivegreen -143 188 143 darkseagreen -46 139 87 seagreen -60 179 113 mediumseagreen -32 178 170 lightseagreen -152 251 152 palegreen -0 255 127 springgreen -124 252 0 lawngreen -0 255 0 green -127 255 0 chartreuse -0 250 154 mediumspringgreen -173 255 47 greenyellow -50 205 50 limegreen -154 205 50 yellowgreen -34 139 34 forestgreen -107 142 35 olivedrab -189 183 107 darkkhaki -240 230 140 khaki -238 232 170 palegoldenrod -250 250 210 lightgoldenrodyellow -255 255 224 lightyellow -255 255 0 yellow -255 215 0 gold -238 221 130 lightgoldenrod -218 165 32 goldenrod -184 134 11 darkgoldenrod -188 143 143 rosybrown -205 92 92 indianred -139 69 19 saddlebrown -160 82 45 sienna -205 133 63 peru -222 184 135 burlywood -245 245 220 beige -245 222 179 wheat -244 164 96 sandybrown -210 180 140 tan -210 105 30 chocolate -178 34 34 firebrick -165 42 42 brown -233 150 122 darksalmon -250 128 114 salmon -255 160 122 lightsalmon -255 165 0 orange -255 140 0 darkorange -255 127 80 coral -240 128 128 lightcoral -255 99 71 tomato -255 69 0 orangered -255 0 0 red -255 105 180 hotpink -255 20 147 deeppink -255 192 203 pink -255 182 193 lightpink -219 112 147 palevioletred -176 48 96 maroon -199 21 133 mediumvioletred -208 32 144 violetred -255 0 255 magenta -238 130 238 violet -221 160 221 plum -218 112 214 orchid -186 85 211 mediumorchid -153 50 204 darkorchid -148 0 211 darkviolet -138 43 226 blueviolet -160 32 240 purple -147 112 219 mediumpurple -216 191 216 thistle -255 250 250 snow1 -238 233 233 snow2 -205 201 201 snow3 -139 137 137 snow4 -255 245 238 seashell1 -238 229 222 seashell2 -205 197 191 seashell3 -139 134 130 seashell4 -255 239 219 antiquewhite1 -238 223 204 antiquewhite2 -205 192 176 antiquewhite3 -139 131 120 antiquewhite4 -255 228 196 bisque1 -238 213 183 bisque2 -205 183 158 bisque3 -139 125 107 bisque4 -255 218 185 peachpuff1 -238 203 173 peachpuff2 -205 175 149 peachpuff3 -139 119 101 peachpuff4 -255 222 173 navajowhite1 -238 207 161 navajowhite2 -205 179 139 navajowhite3 -139 121 94 navajowhite4 -255 250 205 lemonchiffon1 -238 233 191 lemonchiffon2 -205 201 165 lemonchiffon3 -139 137 112 lemonchiffon4 -255 248 220 cornsilk1 -238 232 205 cornsilk2 -205 200 177 cornsilk3 -139 136 120 cornsilk4 -255 255 240 ivory1 -238 238 224 ivory2 -205 205 193 ivory3 -139 139 131 ivory4 -240 255 240 honeydew1 -224 238 224 honeydew2 -193 205 193 honeydew3 -131 139 131 honeydew4 -255 240 245 lavenderblush1 -238 224 229 lavenderblush2 -205 193 197 lavenderblush3 -139 131 134 lavenderblush4 -255 228 225 mistyrose1 -238 213 210 mistyrose2 -205 183 181 mistyrose3 -139 125 123 mistyrose4 -240 255 255 azure1 -224 238 238 azure2 -193 205 205 azure3 -131 139 139 azure4 -131 111 255 slateblue1 -122 103 238 slateblue2 -105 89 205 slateblue3 -71 60 139 slateblue4 -72 118 255 royalblue1 -67 110 238 royalblue2 -58 95 205 royalblue3 -39 64 139 royalblue4 -0 0 255 blue1 -0 0 238 blue2 -0 0 205 blue3 -0 0 139 blue4 -30 144 255 dodgerblue1 -28 134 238 dodgerblue2 -24 116 205 dodgerblue3 -16 78 139 dodgerblue4 -99 184 255 steelblue1 -92 172 238 steelblue2 -79 148 205 steelblue3 -54 100 139 steelblue4 -0 191 255 deepskyblue1 -0 178 238 deepskyblue2 -0 154 205 deepskyblue3 -0 104 139 deepskyblue4 -135 206 255 skyblue1 -126 192 238 skyblue2 -108 166 205 skyblue3 -74 112 139 skyblue4 -176 226 255 lightskyblue1 -164 211 238 lightskyblue2 -141 182 205 lightskyblue3 -96 123 139 lightskyblue4 -202 225 255 lightsteelblue1 -188 210 238 lightsteelblue2 -162 181 205 lightsteelblue3 -110 123 139 lightsteelblue4 -191 239 255 lightblue1 -178 223 238 lightblue2 -154 192 205 lightblue3 -104 131 139 lightblue4 -224 255 255 lightcyan1 -209 238 238 lightcyan2 -180 205 205 lightcyan3 -122 139 139 lightcyan4 -187 255 255 paleturquoise1 -174 238 238 paleturquoise2 -150 205 205 paleturquoise3 -102 139 139 paleturquoise4 -152 245 255 cadetblue1 -142 229 238 cadetblue2 -122 197 205 cadetblue3 -83 134 139 cadetblue4 -0 245 255 turquoise1 -0 229 238 turquoise2 -0 197 205 turquoise3 -0 134 139 turquoise4 -0 255 255 cyan1 -0 238 238 cyan2 -0 205 205 cyan3 -0 139 139 cyan4 -127 255 212 aquamarine1 -118 238 198 aquamarine2 -102 205 170 aquamarine3 -69 139 116 aquamarine4 -193 255 193 darkseagreen1 -180 238 180 darkseagreen2 -155 205 155 darkseagreen3 -105 139 105 darkseagreen4 -84 255 159 seagreen1 -78 238 148 seagreen2 -67 205 128 seagreen3 -46 139 87 seagreen4 -154 255 154 palegreen1 -144 238 144 palegreen2 -124 205 124 palegreen3 -84 139 84 palegreen4 -0 255 127 springgreen1 -0 238 118 springgreen2 -0 205 102 springgreen3 -0 139 69 springgreen4 -0 255 0 green1 -0 238 0 green2 -0 205 0 green3 -0 139 0 green4 -127 255 0 chartreuse1 -118 238 0 chartreuse2 -102 205 0 chartreuse3 -69 139 0 chartreuse4 -192 255 62 olivedrab1 -179 238 58 olivedrab2 -154 205 50 olivedrab3 -105 139 34 olivedrab4 -202 255 112 darkolivegreen1 -188 238 104 darkolivegreen2 -162 205 90 darkolivegreen3 -110 139 61 darkolivegreen4 -255 246 143 khaki1 -238 230 133 khaki2 -205 198 115 khaki3 -139 134 78 khaki4 -255 236 139 lightgoldenrod1 -238 220 130 lightgoldenrod2 -205 190 112 lightgoldenrod3 -139 129 76 lightgoldenrod4 -255 255 224 lightyellow1 -238 238 209 lightyellow2 -205 205 180 lightyellow3 -139 139 122 lightyellow4 -255 255 0 yellow1 -238 238 0 yellow2 -205 205 0 yellow3 -139 139 0 yellow4 -255 215 0 gold1 -238 201 0 gold2 -205 173 0 gold3 -139 117 0 gold4 -255 193 37 goldenrod1 -238 180 34 goldenrod2 -205 155 29 goldenrod3 -139 105 20 goldenrod4 -255 185 15 darkgoldenrod1 -238 173 14 darkgoldenrod2 -205 149 12 darkgoldenrod3 -139 101 8 darkgoldenrod4 -255 193 193 rosybrown1 -238 180 180 rosybrown2 -205 155 155 rosybrown3 -139 105 105 rosybrown4 -255 106 106 indianred1 -238 99 99 indianred2 -205 85 85 indianred3 -139 58 58 indianred4 -255 130 71 sienna1 -238 121 66 sienna2 -205 104 57 sienna3 -139 71 38 sienna4 -255 211 155 burlywood1 -238 197 145 burlywood2 -205 170 125 burlywood3 -139 115 85 burlywood4 -255 231 186 wheat1 -238 216 174 wheat2 -205 186 150 wheat3 -139 126 102 wheat4 -255 165 79 tan1 -238 154 73 tan2 -205 133 63 tan3 -139 90 43 tan4 -255 127 36 chocolate1 -238 118 33 chocolate2 -205 102 29 chocolate3 -139 69 19 chocolate4 -255 48 48 firebrick1 -238 44 44 firebrick2 -205 38 38 firebrick3 -139 26 26 firebrick4 -255 64 64 brown1 -238 59 59 brown2 -205 51 51 brown3 -139 35 35 brown4 -255 140 105 salmon1 -238 130 98 salmon2 -205 112 84 salmon3 -139 76 57 salmon4 -255 160 122 lightsalmon1 -238 149 114 lightsalmon2 -205 129 98 lightsalmon3 -139 87 66 lightsalmon4 -255 165 0 orange1 -238 154 0 orange2 -205 133 0 orange3 -139 90 0 orange4 -255 127 0 darkorange1 -238 118 0 darkorange2 -205 102 0 darkorange3 -139 69 0 darkorange4 -255 114 86 coral1 -238 106 80 coral2 -205 91 69 coral3 -139 62 47 coral4 -255 99 71 tomato1 -238 92 66 tomato2 -205 79 57 tomato3 -139 54 38 tomato4 -255 69 0 orangered1 -238 64 0 orangered2 -205 55 0 orangered3 -139 37 0 orangered4 -255 0 0 red1 -238 0 0 red2 -205 0 0 red3 -139 0 0 red4 -255 20 147 deeppink1 -238 18 137 deeppink2 -205 16 118 deeppink3 -139 10 80 deeppink4 -255 110 180 hotpink1 -238 106 167 hotpink2 -205 96 144 hotpink3 -139 58 98 hotpink4 -255 181 197 pink1 -238 169 184 pink2 -205 145 158 pink3 -139 99 108 pink4 -255 174 185 lightpink1 -238 162 173 lightpink2 -205 140 149 lightpink3 -139 95 101 lightpink4 -255 130 171 palevioletred1 -238 121 159 palevioletred2 -205 104 137 palevioletred3 -139 71 93 palevioletred4 -255 52 179 maroon1 -238 48 167 maroon2 -205 41 144 maroon3 -139 28 98 maroon4 -255 62 150 violetred1 -238 58 140 violetred2 -205 50 120 violetred3 -139 34 82 violetred4 -255 0 255 magenta1 -238 0 238 magenta2 -205 0 205 magenta3 -139 0 139 magenta4 -255 131 250 orchid1 -238 122 233 orchid2 -205 105 201 orchid3 -139 71 137 orchid4 -255 187 255 plum1 -238 174 238 plum2 -205 150 205 plum3 -139 102 139 plum4 -224 102 255 mediumorchid1 -209 95 238 mediumorchid2 -180 82 205 mediumorchid3 -122 55 139 mediumorchid4 -191 62 255 darkorchid1 -178 58 238 darkorchid2 -154 50 205 darkorchid3 -104 34 139 darkorchid4 -155 48 255 purple1 -145 44 238 purple2 -125 38 205 purple3 -85 26 139 purple4 -171 130 255 mediumpurple1 -159 121 238 mediumpurple2 -137 104 205 mediumpurple3 -93 71 139 mediumpurple4 -255 225 255 thistle1 -238 210 238 thistle2 -205 181 205 thistle3 -139 123 139 thistle4 -0 0 0 grey0 -3 3 3 grey1 -5 5 5 grey2 -8 8 8 grey3 -10 10 10 grey4 -13 13 13 grey5 -15 15 15 grey6 -18 18 18 grey7 -20 20 20 grey8 -23 23 23 grey9 -26 26 26 grey10 -28 28 28 grey11 -31 31 31 grey12 -33 33 33 grey13 -36 36 36 grey14 -38 38 38 grey15 -41 41 41 grey16 -43 43 43 grey17 -46 46 46 grey18 -48 48 48 grey19 -51 51 51 grey20 -54 54 54 grey21 -56 56 56 grey22 -59 59 59 grey23 -61 61 61 grey24 -64 64 64 grey25 -66 66 66 grey26 -69 69 69 grey27 -71 71 71 grey28 -74 74 74 grey29 -77 77 77 grey30 -79 79 79 grey31 -82 82 82 grey32 -84 84 84 grey33 -87 87 87 grey34 -89 89 89 grey35 -92 92 92 grey36 -94 94 94 grey37 -97 97 97 grey38 -99 99 99 grey39 -102 102 102 grey40 -105 105 105 grey41 -107 107 107 grey42 -110 110 110 grey43 -112 112 112 grey44 -115 115 115 grey45 -117 117 117 grey46 -120 120 120 grey47 -122 122 122 grey48 -125 125 125 grey49 -127 127 127 grey50 -130 130 130 grey51 -133 133 133 grey52 -135 135 135 grey53 -138 138 138 grey54 -140 140 140 grey55 -143 143 143 grey56 -145 145 145 grey57 -148 148 148 grey58 -150 150 150 grey59 -153 153 153 grey60 -156 156 156 grey61 -158 158 158 grey62 -161 161 161 grey63 -163 163 163 grey64 -166 166 166 grey65 -168 168 168 grey66 -171 171 171 grey67 -173 173 173 grey68 -176 176 176 grey69 -179 179 179 grey70 -181 181 181 grey71 -184 184 184 grey72 -186 186 186 grey73 -189 189 189 grey74 -191 191 191 grey75 -194 194 194 grey76 -196 196 196 grey77 -199 199 199 grey78 -201 201 201 grey79 -204 204 204 grey80 -207 207 207 grey81 -209 209 209 grey82 -212 212 212 grey83 -214 214 214 grey84 -217 217 217 grey85 -219 219 219 grey86 -222 222 222 grey87 -224 224 224 grey88 -227 227 227 grey89 -229 229 229 grey90 -232 232 232 grey91 -235 235 235 grey92 -237 237 237 grey93 -240 240 240 grey94 -242 242 242 grey95 -245 245 245 grey96 -247 247 247 grey97 -250 250 250 grey98 -252 252 252 grey99 -255 255 255 grey100 -169 169 169 darkgrey -0 0 139 darkblue -0 139 139 darkcyan -139 0 139 darkmagenta -139 0 0 darkred -144 238 144 lightgreen") - -;*---------------------------------------------------------------------*/ -;* *rgb-port* ... */ -;*---------------------------------------------------------------------*/ -(define *rgb-port* #unspecified) - -;*---------------------------------------------------------------------*/ -;* same-color? ... */ -;*---------------------------------------------------------------------*/ -(define (same-color? s1 s2) - (define (skip-rgb s) - (let ((l (string-length s))) - (let loop ((i 0)) - (if (=fx i l) - l - (let ((c (string-ref s i))) - (if (or (char-numeric? c) (char-whitespace? c)) - (loop (+fx i 1)) - i)))))) - (let ((l1 (string-length s1)) - (l2 (string-length s2))) - (if (>fx l1 l2) - (let ((lc (skip-rgb s1))) - (and (=fx (-fx l1 lc) l2) - (let loop ((i1 (-fx l1 l2)) - (i2 0)) - (cond - ((=fx i1 l1) - #t) - ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) - (loop (+fx i1 1) (+fx i2 1))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* rgb-grep ... */ -;*---------------------------------------------------------------------*/ -(define (rgb-grep symbol) - (let ((parser (regular-grammar () - ((bol (: #\! (* all))) - (ignore)) - ((+ #\Newline) - (ignore)) - ((: (* (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ digit) - (+ (in #\space #\tab)) - (+ all)) - (let ((s (the-string))) - (if (same-color? s symbol) - (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) - (values (string->number (cadr m)) - (string->number (caddr m)) - (string->number (cadddr m)))) - (ignore)))) - (else - (values 0 0 0))))) - ;; initialization the port reading rgb.txt file - (with-input-from-string *skribe-rgb-string* - (lambda () - (read/rp parser (current-input-port)))))) - -;*---------------------------------------------------------------------*/ -;* *color-parser* ... */ -;*---------------------------------------------------------------------*/ -(define *color-parser* - (regular-grammar ((blank* (* blank)) - (blank+ (+ blank))) - - ;; rgb color - ((: #\# (+ xdigit)) - (let ((val (the-substring 1 (the-length)))) - (cond - ((=fx (string-length val) 6) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 2 4) 16) - (string->integer (substring val 4 6) 16))) - ((=fx (string-length val) 12) - (values (string->integer (substring val 0 2) 16) - (string->integer (substring val 4 6) 16) - (string->integer (substring val 8 10) 16))) - (else - (values 0 0 0))))) - - ;; symbolic names - ((+ (out #\Newline)) - (let ((name (the-string))) - (cond - ((string-ci=? name "none") - (values 0 0 0)) - ((string-ci=? name "black") - (values 0 0 0)) - ((string-ci=? name "white") - (values #xff #xff #xff)) - (else - (rgb-grep name))))) - - ;; error - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* skribe-color->rgb ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-color->rgb spec) - (cond - ((string? spec) - (with-input-from-string spec - (lambda () - (read/rp *color-parser* (current-input-port))))) - ((fixnum? spec) - (values (bit-and #xff (bit-rsh spec 16)) - (bit-and #xff (bit-rsh spec 8)) - (bit-and #xff spec))) - (else - (values 0 0 0)))) - -;*---------------------------------------------------------------------*/ -;* *used-colors* ... */ -;*---------------------------------------------------------------------*/ -(define *used-colors* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-get-used-colors ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-get-used-colors) - *used-colors*) - -;*---------------------------------------------------------------------*/ -;* skribe-use-color! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-use-color! color) - (set! *used-colors* (cons color *used-colors*)) - color) diff --git a/src/bigloo/configure.bgl b/src/bigloo/configure.bgl deleted file mode 100644 index e100d8d..0000000 --- a/src/bigloo/configure.bgl +++ /dev/null @@ -1,90 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:42:21 2003 */ -;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The general configuration options. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_configure - (export (skribe-release) - (skribe-url) - (skribe-doc-dir) - (skribe-ext-dir) - (skribe-default-path) - (skribe-scheme) - - (skribe-configure . opt) - (skribe-enforce-configure . opt))) - -;*---------------------------------------------------------------------*/ -;* skribe-configuration ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configuration) - `((:release ,(skribe-release)) - (:scheme ,(skribe-scheme)) - (:url ,(skribe-url)) - (:doc-dir ,(skribe-doc-dir)) - (:ext-dir ,(skribe-ext-dir)) - (:default-path ,(skribe-default-path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-configure . opt) - (let ((conf (skribe-configuration))) - (cond - ((null? opt) - conf) - ((null? (cdr opt)) - (let ((cell (assq (car opt) conf))) - (if (pair? cell) - (cadr cell) - 'void))) - (else - (let loop ((opt opt)) - (cond - ((null? opt) - #t) - ((not (keyword? (car opt))) - #f) - ((or (null? (cdr opt)) (keyword? (cadr opt))) - #f) - (else - (let ((cell (assq (car opt) conf))) - (if (and (pair? cell) - (if (procedure? (cadr opt)) - ((cadr opt) (cadr cell)) - (equal? (cadr opt) (cadr cell)))) - (loop (cddr opt)) - #f))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-enforce-configure ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-enforce-configure . opt) - (let loop ((o opt)) - (when (pair? o) - (cond - ((or (not (keyword? (car o))) - (null? (cdr o))) - (error 'skribe-enforce-configure - "Illegal enforcement" - opt)) - ((skribe-configure (car o) (cadr o)) - (loop (cddr o))) - (else - (error 'skribe-enforce-configure - (format "Configuration mismatch: ~a" (car o)) - (if (procedure? (cadr o)) - (format "provided `~a'" - (skribe-configure (car o))) - (format "provided `~a', required `~a'" - (skribe-configure (car o)) - (cadr o))))))))) diff --git a/src/bigloo/debug.sch b/src/bigloo/debug.sch deleted file mode 100644 index 9b53c84..0000000 --- a/src/bigloo/debug.sch +++ /dev/null @@ -1,54 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Thu May 29 06:46:33 2003 */ -;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* directives */ -;*---------------------------------------------------------------------*/ -(directives - (import skribe_debug)) - -;*---------------------------------------------------------------------*/ -;* when-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (when-debug level . exp) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(if (>= *skribe-debug* ,level) (begin ,@exp)) - #unspecified)) - -;*---------------------------------------------------------------------*/ -;* with-debug ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-debug level lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* with-push-trace ... */ -;*---------------------------------------------------------------------*/ -(define-macro (with-push-trace lbl . arg*) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - (let ((r (gensym))) - `(let () - (c-push-trace ,lbl) - (let ((,r ,@arg*)) - (c-pop-trace) - ,r))) - `(begin ,@arg*))) - -;*---------------------------------------------------------------------*/ -;* debug-item ... */ -;*---------------------------------------------------------------------*/ -(define-expander debug-item - (lambda (x e) - (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) - `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) - #unspecified))) diff --git a/src/bigloo/debug.scm b/src/bigloo/debug.scm deleted file mode 100644 index 8f1691c..0000000 --- a/src/bigloo/debug.scm +++ /dev/null @@ -1,188 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jun 11 10:01:47 2003 */ -;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Simple debug facilities */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_debug - - (export *skribe-debug* - *skribe-debug-symbols* - *skribe-debug-color* - - (skribe-debug::int) - (debug-port::output-port . ::obj) - (debug-margin::bstring) - (debug-color::bstring ::int . ::obj) - (debug-bold::bstring . ::obj) - (debug-string ::obj) - (debug-item . ::obj) - - (%with-debug ::obj ::obj ::procedure))) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-symbols* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-symbols* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-color* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-color* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-debug-item* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-debug-item* #f) - -;*---------------------------------------------------------------------*/ -;* *debug-port* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-port* (current-error-port)) - -;*---------------------------------------------------------------------*/ -;* *debug-depth* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-depth* 0) - -;*---------------------------------------------------------------------*/ -;* *debug-margin* ... */ -;*---------------------------------------------------------------------*/ -(define *debug-margin* "") - -;*---------------------------------------------------------------------*/ -;* *skribe-margin-debug-level* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-margin-debug-level* 0) - -;*---------------------------------------------------------------------*/ -;* skribe-debug ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-debug) - *skribe-debug*) - -;*---------------------------------------------------------------------*/ -;* debug-port ... */ -;*---------------------------------------------------------------------*/ -(define (debug-port . o) - (cond - ((null? o) - *debug-port*) - ((output-port? (car o)) - (set! *debug-port* o) - o) - (else - (error 'debug-port "Illegal debug port" (car o))))) - -;*---------------------------------------------------------------------*/ -;* debug-margin ... */ -;*---------------------------------------------------------------------*/ -(define (debug-margin) - *debug-margin*) - -;*---------------------------------------------------------------------*/ -;* debug-color ... */ -;*---------------------------------------------------------------------*/ -(define (debug-color col::int . o) - (with-output-to-string - (if *skribe-debug-color* - (lambda () - (display* "[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/src/bigloo/engine.scm b/src/bigloo/engine.scm deleted file mode 100644 index bd8a027..0000000 --- a/src/bigloo/engine.scm +++ /dev/null @@ -1,262 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 08:01:30 2003 */ -;* Last change : Fri May 21 16:12:32 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe engines */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_engine - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output) - - (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) - (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) - (find-engine ::symbol #!key version) - - (default-engine::obj) - (default-engine-set! ::%engine) - (push-default-engine ::%engine) - (pop-default-engine) - - (processor-get-engine ::obj ::obj ::%engine) - - (engine-format? ::bstring . e) - - (engine-custom::obj ::%engine ::symbol) - (engine-custom-set! ::%engine ::symbol ::obj) - - (engine-add-writer! ::%engine ::obj ::procedure ::obj - ::obj ::obj ::obj ::obj ::obj ::obj))) - -;*---------------------------------------------------------------------*/ -;* *engines* ... */ -;*---------------------------------------------------------------------*/ -(define *engines* '()) - -;*---------------------------------------------------------------------*/ -;* *default-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *default-engine* #f) -(define *default-engines* '()) - -;*---------------------------------------------------------------------*/ -;* default-engine-set! ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine-set! e) - (if (not (engine? e)) - (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) - (begin - (set! *default-engine* e) - (set! *default-engines* (cons *default-engine* *default-engines*)) - e))) - -;*---------------------------------------------------------------------*/ -;* default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (default-engine) - *default-engine*) - -;*---------------------------------------------------------------------*/ -;* push-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (push-default-engine e) - (set! *default-engines* (cons e *default-engines*)) - (default-engine-set! e)) - -;*---------------------------------------------------------------------*/ -;* pop-default-engine ... */ -;*---------------------------------------------------------------------*/ -(define (pop-default-engine) - (if (null? *default-engines*) - (skribe-error 'pop-default-engine "Empty engine stack" '()) - (begin - (set! *default-engines* (cdr *default-engines*)) - (if (pair? *default-engines*) - (default-engine-set! (car *default-engines*)) - (set! *default-engine* #f))))) - -;*---------------------------------------------------------------------*/ -;* processor-get-engine ... */ -;*---------------------------------------------------------------------*/ -(define (processor-get-engine combinator newe olde) - (cond - ((procedure? combinator) - (combinator newe olde)) - ((engine? newe) - newe) - (else - olde))) - -;*---------------------------------------------------------------------*/ -;* engine-format? ... */ -;*---------------------------------------------------------------------*/ -(define (engine-format? fmt . e) - (let ((e (cond - ((pair? e) (car e)) - ((%engine? *skribe-engine*) *skribe-engine*) - (else (find-engine *skribe-engine*))))) - (if (not (%engine? e)) - (skribe-error 'engine-format? "No engine" e) - (string=? fmt (%engine-format e))))) - -;*---------------------------------------------------------------------*/ -;* make-engine ... */ -;*---------------------------------------------------------------------*/ -(define (make-engine ident - #!key - (version #unspecified) - (format "raw") - (filter #f) - (delegate #f) - (symbol-table '()) - (custom '()) - (info '())) - (let ((e (instantiate::%engine - (ident ident) - (version version) - (format format) - (filter filter) - (delegate delegate) - (symbol-table symbol-table) - (customs custom) - (info info)))) - ;; store the engine in the global table - (set! *engines* (cons e *engines*)) - ;; return it - e)) - -;*---------------------------------------------------------------------*/ -;* copy-engine ... */ -;*---------------------------------------------------------------------*/ -(define (copy-engine ident - e - #!key - (version #unspecified) - (filter #f) - (delegate #f) - (symbol-table #f) - (custom #f)) - (let ((e (duplicate::%engine e - (ident ident) - (version version) - (filter (or filter (%engine-filter e))) - (delegate (or delegate (%engine-delegate e))) - (symbol-table (or symbol-table (%engine-symbol-table e))) - (customs (or custom (%engine-customs e)))))) - (set! *engines* (cons e *engines*)) - e)) - -;*---------------------------------------------------------------------*/ -;* find-loaded-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-loaded-engine id version) - (let loop ((es *engines*)) - (cond - ((null? es) - #f) - ((eq? (%engine-ident (car es)) id) - (cond - ((eq? version #unspecified) - (car es)) - ((eq? version (%engine-version (car es))) - (car es)) - (else - (loop (cdr es))))) - (else - (loop (cdr es)))))) - -;*---------------------------------------------------------------------*/ -;* find-engine ... */ -;*---------------------------------------------------------------------*/ -(define (find-engine id #!key (version #unspecified)) - (with-debug 5 'find-engine - (debug-item "id=" id " version=" version) - (or (find-loaded-engine id version) - (let ((c (assq id *skribe-auto-load-alist*))) - (debug-item "c=" c) - (if (and (pair? c) (string? (cdr c))) - (begin - (skribe-load (cdr c) :engine 'base) - (find-loaded-engine id version)) - #f))))) - -;*---------------------------------------------------------------------*/ -;* engine-custom ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom e id) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (cadr c) - #unspecified)))) - -;*---------------------------------------------------------------------*/ -;* engine-custom-set! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-custom-set! e id val) - (with-access::%engine e (customs) - (let ((c (assq id customs))) - (if (pair? c) - (set-car! (cdr c) val) - (set! customs (cons (list id val) customs)))))) - -;*---------------------------------------------------------------------*/ -;* engine-add-writer! ... */ -;*---------------------------------------------------------------------*/ -(define (engine-add-writer! e id pred upred opt before action after class va) - ;; check the arity of a procedure - (define (check-procedure name proc arity) - (cond - ((not (procedure? proc)) - (skribe-error id "Illegal procedure" proc)) - ((not (correct-arity? proc arity)) - (skribe-error id - (string-append "Illegal `" name "'procedure") - proc)))) - (define (check-output name proc) - (and proc (or (string? proc) (check-procedure name proc 2)))) - ;; check the engine - (if (not (engine? e)) - (skribe-error id "Illegal engine" e)) - ;; check the options - (if (not (or (eq? opt 'all) (list? opt))) - (skribe-error id "Illegal options" opt)) - ;; check the correctness of the predicate and the validator - (check-procedure "predicate" pred 2) - (when va (check-procedure "validate" va 2)) - ;; check the correctness of the three actions - (check-output "before" before) - (check-output "action" action) - (check-output "after" after) - ;; create a new writer... - (let ((n (instantiate::%writer - (ident (if (symbol? id) id 'all)) - (class class) - (pred pred) - (upred upred) - (options opt) - (before before) - (action action) - (after after) - (validate va)))) - ;; ...and bind it - (with-access::%engine e (writers) - (set! writers (cons n writers)) - n))) diff --git a/src/bigloo/eval.scm b/src/bigloo/eval.scm deleted file mode 100644 index b5c6548..0000000 --- a/src/bigloo/eval.scm +++ /dev/null @@ -1,335 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed May 18 15:52:01 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe evaluator */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_eval - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_param - skribe_types - skribe_resolve - skribe_verify - skribe_output - skribe_read - skribe_lib - skribe_engine) - - (export (skribe-eval-location) - (skribe-error ::obj ::obj ::obj) - (skribe-type-error ::obj ::obj ::obj ::bstring) - (skribe-warning ::int . obj) - (skribe-warning/ast ::int ::%ast . obj) - (skribe-message ::bstring . obj) - (skribe-load ::bstring #!rest opt #!key engine path) - (skribe-load-options) - (skribe-include ::bstring . rest) - (skribe-open-bib-file ::bstring ::obj) - (skribe-eval-port ::input-port ::obj #!key env) - (skribe-eval ::obj ::%engine #!key env) - (skribe-path::pair-nil) - (skribe-path-set! ::obj) - (skribe-image-path::pair-nil) - (skribe-image-path-set! ::obj) - (skribe-bib-path::pair-nil) - (skribe-bib-path-set! ::obj) - (skribe-source-path::pair-nil) - (skribe-source-path-set! ::obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-location ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-location) - (evmeaning-location)) - -;*---------------------------------------------------------------------*/ -;* skribe-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-error proc msg obj) - (if (ast? obj) - (skribe-ast-error proc msg obj) - (error/evloc proc msg obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-type-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-type-error proc msg obj etype) - (let ((ty (if (%markup? obj) - (format "~a#~a" (markup-markup obj) (markup-ident obj)) - (find-runtime-type obj)))) - (skribe-error proc - (bigloo-type-error-msg msg etype ty) - obj))) - -;*---------------------------------------------------------------------*/ -;* skribe-ast-error ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-ast-error proc msg obj) - (let ((l (ast-loc obj)) - (shape (if (%markup? obj) - (%markup-markup obj) - (find-runtime-type obj)))) - (if (location? l) - (error/location proc msg shape (location-file l) (location-pos l)) - (error/evloc proc msg shape)))) - -;*---------------------------------------------------------------------*/ -;* error/evloc ... */ -;*---------------------------------------------------------------------*/ -(define (error/evloc proc msg obj) - (let ((l (evmeaning-location))) - (if (location? l) - (error/location proc msg obj (location-file l) (location-pos l)) - ((begin error) proc msg obj)))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning level . obj) - (if (>= *skribe-warning* level) - (let ((l (evmeaning-location))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply warning obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-warning/ast ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-warning/ast level ast . obj) - (if (>= *skribe-warning* level) - (let ((l (%ast-loc ast))) - (if (location? l) - (apply warning/location (location-file l) (location-pos l) obj) - (apply skribe-warning level obj))))) - -;*---------------------------------------------------------------------*/ -;* skribe-message ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-message fmt . obj) - (if (> *skribe-verbose* 0) - (apply fprintf (current-error-port) fmt obj))) - -;*---------------------------------------------------------------------*/ -;* *skribe-loaded* ... */ -;* ------------------------------------------------------------- */ -;* This hash table stores the list of loaded files in order */ -;* to avoid one file to be loaded twice. */ -;*---------------------------------------------------------------------*/ -(define *skribe-loaded* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* *skribe-load-options* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-load-options* '()) - -;*---------------------------------------------------------------------*/ -;* skribe-load ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load file #!rest opt #!key engine path) - (with-debug 4 'skribe-load - (debug-item " engine=" engine) - (debug-item " path=" path) - (debug-item " opt" opt) - (let* ((ei (cond - ((not engine) - *skribe-engine*) - ((engine? engine) - engine) - ((not (symbol? engine)) - (skribe-error 'skribe-load "Illegal engine" engine)) - (else - engine))) - (path (cond - ((not path) - (skribe-path)) - ((string? path) - (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else - path))) - (filep (find-file/path file path))) - (set! *skribe-load-options* opt) - (if (and (string? filep) (file-exists? filep)) - (if (not (hashtable-get *skribe-loaded* filep)) - (begin - (hashtable-put! *skribe-loaded* filep #t) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [loading file: " filep " " opt "]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [loading file: " filep "]"))) - (with-input-from-file filep - (lambda () - (skribe-eval-port (current-input-port) ei))))) - (skribe-error 'skribe-load - (format "Can't find file `~a' in path" file) - path))))) - -;*---------------------------------------------------------------------*/ -;* skribe-load-options ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-load-options) - *skribe-load-options*) - -;*---------------------------------------------------------------------*/ -;* evaluate ... */ -;*---------------------------------------------------------------------*/ -(define (evaluate exp) - (try (eval exp) - (lambda (a p m o) - (evmeaning-notify-error p m o) - (flush-output-port (current-error-port))))) - -;*---------------------------------------------------------------------*/ -;* skribe-include ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-include file . rest) - (let* ((path (cond - ((or (null? rest) (null? (cdr rest))) - (skribe-path)) - ((not (every? string? (cdr rest))) - (skribe-error 'skribe-include "Illegal path" (cdr rest))) - (else - (cdr rest)))) - (filep (find-file/path file (if (null? path) (skribe-path) path)))) - (if (and (string? filep) (file-exists? filep)) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [including file: " filep "]")) - (with-input-from-file filep - (lambda () - (let loop ((exp (skribe-read (current-input-port))) - (res '())) - (if (eof-object? exp) - (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (loop (skribe-read (current-input-port)) - (cons (evaluate exp) res))))))) - (skribe-error 'skribe-include - (format "Can't find file `~a 'in path" file) - path)))) - -;*---------------------------------------------------------------------*/ -;* skribe-open-bib-file ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-open-bib-file file command) - (let ((filep (find-file/path file *skribe-bib-path*))) - (if (string? filep) - (begin - (if (>fx *skribe-verbose* 0) - (fprint (current-error-port) " [loading bib: " filep "]")) - (open-input-file (if (string? command) - (string-append "| " - (format command filep)) - filep))) - (begin - (skribe-warning 1 - 'bibliography - "Can't find bibliography -- " file) - #f)))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval-port ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval-port port ei #!key (env '())) - (with-debug 2 'skribe-eval-port - (debug-item "ei=" ei) - (let ((e (if (symbol? ei) (find-engine ei) ei))) - (debug-item "e=" e) - (if (not (%engine? e)) - (skribe-error 'find-engine "Can't find engine" ei) - (let loop ((exp (skribe-read port))) - (with-debug 10 'skribe-eval-port - (debug-item "exp=" exp)) - (if (not (eof-object? exp)) - (begin - (skribe-eval (evaluate exp) e :env env) - (loop (skribe-read port))))))))) - -;*---------------------------------------------------------------------*/ -;* skribe-eval ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-eval a e #!key (env '())) - (with-debug 2 'skribe-eval - (debug-item "a=" a " e=" (%engine-ident e)) - (let ((a2 (resolve! a e env))) - (debug-item "resolved a=" a) - (let ((a3 (verify a2 e))) - (debug-item "verified a=" a3) - (output a3 e))))) - -;*---------------------------------------------------------------------*/ -;* skribe-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path) - *skribe-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-path-set! "Illegal path" path) - (set! *skribe-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path) - *skribe-image-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-image-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-image-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-image-path-set! "Illegal path" path) - (set! *skribe-image-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path) - *skribe-bib-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-bib-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-bib-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-bib-path-set! "Illegal path" path) - (set! *skribe-bib-path* path))) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path) - *skribe-source-path*) - -;*---------------------------------------------------------------------*/ -;* skribe-source-path-set! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-source-path-set! path) - (if (not (and (list? path) (every? string? path))) - (skribe-error 'skribe-source-path-set! "Illegal path" path) - (set! *skribe-source-path* path))) diff --git a/src/bigloo/evapi.scm b/src/bigloo/evapi.scm deleted file mode 100644 index 6f0d49e..0000000 --- a/src/bigloo/evapi.scm +++ /dev/null @@ -1,39 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 18:57:09 2003 */ -;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Bigloo eval declarations */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_evapi - (import skribe_types - skribe_lib - skribe_api - skribe_engine - skribe_writer - skribe_output - skribe_eval - skribe_read - skribe_resolve - skribe_param - skribe_source - skribe_index - skribe_configure - skribe_lisp - skribe_xml - skribe_c - skribe_asm - skribe_bib - skribe_color - skribe_sui - skribe_debug) - (eval (export-all))) - - diff --git a/src/bigloo/index.bgl b/src/bigloo/index.bgl deleted file mode 100644 index 9697981..0000000 --- a/src/bigloo/index.bgl +++ /dev/null @@ -1,32 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sun Aug 24 08:01:45 2003 */ -;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe indexes Bigloo module declaration */ -;* ------------------------------------------------------------- */ -;* Implementation: @label index@ */ -;* bigloo: @path ../common/index.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_index - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (index?::bool ::obj) - (default-index) - (make-index-table ::bstring) - (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) - diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl deleted file mode 100644 index 6dd6d37..0000000 --- a/src/bigloo/lib.bgl +++ /dev/null @@ -1,340 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe runtime (i.e., the style user functions). */ -;* ------------------------------------------------------------- */ -;* Implementation: @label lib@ */ -;* bigloo: @path ../common/lib.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lib - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_output - skribe_engine) - - (export (markup-option ::%markup ::obj) - (markup-option-add! ::%markup ::obj ::obj) - (markup-class ::%markup) - - (container-env-get ::%container ::symbol) - (container-search-down::pair-nil ::procedure ::%container) - (search-down::pair-nil ::procedure ::obj) - - (find-markup-ident::pair-nil ::bstring) - - (find-down::pair-nil ::procedure ::obj) - (find1-down::obj ::procedure ::obj) - (find-up::pair-nil ::procedure ::obj) - (find1-up::obj ::procedure ::obj) - - (ast-document ::%ast) - (ast-chapter ::%ast) - (ast-section ::%ast) - - (the-body ::pair-nil) - (the-options ::pair-nil . rest) - - (list-split::pair-nil ::pair-nil ::int . ::obj) - - (generic ast->string::bstring ::obj) - - (strip-ref-base ::bstring) - (ast->file-location ::%ast) - - (convert-image ::bstring ::pair-nil) - - (make-string-replace ::pair-nil) - (string-canonicalize::bstring ::bstring) - (inline unspecified?::bool ::obj))) - -;*---------------------------------------------------------------------*/ -;* markup-option ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option m opt) - (if (%markup? m) - (with-access::%markup m (options) - (let ((c (assq opt options))) - (and (pair? c) (pair? (cdr c)) (cadr c)))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-option-add! ... */ -;*---------------------------------------------------------------------*/ -(define (markup-option-add! m opt val) - (if (%markup? m) - (with-access::%markup m (options) - (set! options (cons (list opt val) options))) - (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) - -;*---------------------------------------------------------------------*/ -;* markup-class ... */ -;*---------------------------------------------------------------------*/ -(define (markup-class m) - (%markup-class m)) - -;*---------------------------------------------------------------------*/ -;* container-env-get ... */ -;*---------------------------------------------------------------------*/ -(define (container-env-get m key) - (with-access::%container m (env) - (let ((c (assq key env))) - (and (pair? c) (cadr c))))) - -;*---------------------------------------------------------------------*/ -;* strip-ref-base ... */ -;*---------------------------------------------------------------------*/ -(define (strip-ref-base file) - (if (not (string? *skribe-ref-base*)) - file - (let ((l (string-length *skribe-ref-base*))) - (cond - ((not (>fx (string-length file) (+fx l 2))) - file) - ((not (substring=? file *skribe-ref-base* l)) - file) - ((not (char=? (string-ref file l) (file-separator))) - file) - (else - (substring file (+fx l 1) (string-length file))))))) - -;*---------------------------------------------------------------------*/ -;* ast->file-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast->file-location ast) - (let ((l (ast-loc ast))) - (if (location? l) - (format "~a:~a" (location-file l) (location-pos l)) - ""))) - -;*---------------------------------------------------------------------*/ -;* builtin-convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (builtin-convert-image from fmt dir) - (let* ((s (suffix from)) - (f (string-append (prefix (basename from)) "." fmt)) - (to (make-file-name dir f))) - (cond - ((string=? s fmt) - to) - ((file-exists? to) - to) - (else - (let ((c (if (string=? s "fig") - (string-append "fig2dev -L " fmt " " from " > " to) - (string-append "convert " from " " to)))) - (cond - ((>fx *skribe-verbose* 1) - (fprint (current-error-port) - " [converting image: " from " (" c ")]")) - ((>fx *skribe-verbose* 0) - (fprint (current-error-port) - " [converting image: " from "]"))) - (if (=fx (system c) 0) to #f)))))) - -;*---------------------------------------------------------------------*/ -;* convert-image ... */ -;*---------------------------------------------------------------------*/ -(define (convert-image file formats) - (let ((path (find-file/path file (skribe-image-path)))) - (if (not (string? path)) - (skribe-error 'image - (format "Can't find `~a' image file in path: " file) - (skribe-image-path)) - (let ((suf (suffix file))) - (if (member suf formats) - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - #f))) - (if dir - (let ((dest (basename path))) - (copy-file path (make-file-name dir dest)) - dest) - path)) - (let loop ((fmts formats)) - (if (null? fmts) - #f - (let* ((dir (if (string? *skribe-dest*) - (dirname *skribe-dest*) - ".")) - (p (builtin-convert-image path (car fmts) dir))) - (if (string? p) - p - (loop (cdr fmts))))))))))) - -;*---------------------------------------------------------------------*/ -;* html-string ... */ -;*---------------------------------------------------------------------*/ -(define (html-string str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (if (=fx nlen len) - str - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let ((c (string-ref-ur str r))) - (case c - ((#\<) - (blit-string! "<" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\>) - (blit-string! ">" 0 res w 4) - (loop (+fx r 1) (+fx w 4))) - ((#\&) - (blit-string! "&" 0 res w 5) - (loop (+fx r 1) (+fx w 5))) - ((#\") - (blit-string! """ 0 res w 6) - (loop (+fx r 1) (+fx w 6))) - (else - (string-set! res w c) - (loop (+fx r 1) (+fx w 1))))))))) - (case (string-ref-ur str r) - ((#\< #\>) - (loop (+fx r 1) (+fx nlen 3))) - ((#\&) - (loop (+fx r 1) (+fx nlen 4))) - ((#\") - (loop (+fx r 1) (+fx nlen 5))) - (else - (loop (+fx r 1) nlen))))))) - -;*---------------------------------------------------------------------*/ -;* make-generic-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-generic-string-replace lst) - (lambda (str) - (let ((len (string-length str))) - (let loop ((r 0) - (nlen len)) - (if (=fx r len) - (let ((res (make-string nlen))) - (let loop ((r 0) - (w 0)) - (if (=fx w nlen) - res - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (let ((pl (string-length (cadr p)))) - (blit-string! (cadr p) 0 res w pl) - (loop (+fx r 1) (+fx w pl))) - (begin - (string-set! res w c) - (loop (+fx r 1) (+fx w 1)))))))) - (let* ((c (string-ref-ur str r)) - (p (assq c lst))) - (if (pair? p) - (loop (+fx r 1) - (+fx nlen (-fx (string-length (cadr p)) 1))) - (loop (+fx r 1) - nlen)))))))) - -;*---------------------------------------------------------------------*/ -;* make-string-replace ... */ -;*---------------------------------------------------------------------*/ -(define (make-string-replace lst) - (let ((l (sort lst (lambda (r1 r2) (char<? (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/src/bigloo/lisp.scm b/src/bigloo/lisp.scm deleted file mode 100644 index 65a8227..0000000 --- a/src/bigloo/lisp.scm +++ /dev/null @@ -1,530 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Aug 29 08:14:59 2003 */ -;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Handling of lispish source files. */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_lisp - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export bigloo - scheme - lisp - skribe)) - -;*---------------------------------------------------------------------*/ -;* keys ... */ -;*---------------------------------------------------------------------*/ -(define *the-key* #f) -(define *bracket-highlight* #t) -(define *bigloo-key* #f) -(define *scheme-key* #f) -(define *lisp-key* #f) -(define *skribe-key* #f) - -;*---------------------------------------------------------------------*/ -;* init-bigloo-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-bigloo-fontifier!) - (if (not *bigloo-key*) - (begin - (set! *bigloo-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'symbol)) - '(set! if let cond case quote begin letrec let* - lambda export extern class generic inline - static import foreign type with-access instantiate - duplicate labels - match-case match-lambda - syntax-rules pragma widen! shrink! - wide-class profile profile/gc - regular-grammar lalr-grammar apply)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'define)) - '(define define-inline define-struct define-macro - define-generic define-method define-syntax - define-expander)) - ;; error - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'error)) - '(bind-exit unwind-protect call/cc error warning)) - ;; module - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'module)) - '(module import export library)) - ;; thread - (for-each (lambda (symbol) - (putprop! symbol *bigloo-key* 'thread)) - '(make-thread thread-start! thread-yield! - thread-await! thread-await*! - thread-sleep! thread-join! - thread-terminate! thread-suspend! - thread-resume! thread-yield! - thread-specific thread-specific-set! - thread-name thread-name-set! - scheduler-react! scheduler-start! - broadcast! scheduler-broadcast! - current-thread thread? - current-scheduler scheduler? make-scheduler - make-input-signal make-output-signal - make-connect-signal make-process-signal - make-accept-signal make-timer-signal - thread-get-values! thread-get-values*!))))) - -;*---------------------------------------------------------------------*/ -;* init-lisp-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-lisp-fontifier!) - (if (not *lisp-key*) - (begin - (set! *lisp-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'symbol)) - '(setq if let cond case else progn letrec let* - lambda labels try unwind-protect apply funcall)) - ;; defun - (for-each (lambda (symbol) - (putprop! symbol *lisp-key* 'define)) - '(define defun defvar defmacro))))) - -;*---------------------------------------------------------------------*/ -;* init-skribe-fontifier! ... */ -;*---------------------------------------------------------------------*/ -(define (init-skribe-fontifier!) - (if (not *skribe-key*) - (begin - (set! *skribe-key* (gensym)) - ;; language keywords - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'symbol)) - '(set! bold it emph tt color ref index underline - figure center pre flush hrule linebreak - image kbd code var samp sc sf sup sub - itemize description enumerate item - table tr td th item prgm author - prgm hook font lambda)) - ;; define - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'define)) - '(define define-markup)) - ;; markup - (for-each (lambda (symbol) - (putprop! symbol *skribe-key* 'markup)) - '(document chapter section subsection subsubsection - paragraph p handle resolve processor - abstract margin toc table-of-contents - current-document current-chapter current-section - document-sections* section-number - footnote print-index include skribe-load - slide))))) - -;*---------------------------------------------------------------------*/ -;* bigloo ... */ -;*---------------------------------------------------------------------*/ -(define bigloo - (new language - (name "bigloo") - (fontifier bigloo-fontifier) - (extractor bigloo-extractor))) - -;*---------------------------------------------------------------------*/ -;* scheme ... */ -;*---------------------------------------------------------------------*/ -(define scheme - (new language - (name "scheme") - (fontifier scheme-fontifier) - (extractor scheme-extractor))) - -;*---------------------------------------------------------------------*/ -;* lisp ... */ -;*---------------------------------------------------------------------*/ -(define lisp - (new language - (name "lisp") - (fontifier lisp-fontifier) - (extractor lisp-extractor))) - -;*---------------------------------------------------------------------*/ -;* bigloo-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-fontifier s) - (init-bigloo-fontifier!) - (set! *the-key* *bigloo-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* bigloo-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (bigloo-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-inline define-generic - define-method define-macro define-expander) - (?fun . ?-) . ?-) - (eq? def fun)) - (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* skribe ... */ -;*---------------------------------------------------------------------*/ -(define skribe - (new language - (name "skribe") - (fontifier skribe-fontifier) - (extractor skribe-extractor))) - -;*---------------------------------------------------------------------*/ -;* skribe-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-fontifier s) - (init-skribe-fontifier!) - (set! *the-key* *skribe-key*) - (set! *bracket-highlight* #t) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* skribe-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro define-markup) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - ((markup-output (quote ?mk) . ?-) - (eq? mk def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* scheme-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-fontifier s) s) - -;*---------------------------------------------------------------------*/ -;* scheme-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (scheme-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or define define-macro) (?fun . ?-) . ?-) - (eq? def fun)) - ((define (and (? symbol?) ?var) . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* lisp-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-fontifier s) - (init-lisp-fontifier!) - (set! *the-key* *lisp-key*) - (set! *bracket-highlight* #f) - (fontify-lisp (open-input-string s))) - -;*---------------------------------------------------------------------*/ -;* lisp-extractor ... */ -;*---------------------------------------------------------------------*/ -(define (lisp-extractor iport def tab) - (definition-search iport - tab - (lambda (exp) - (match-case exp - (((or defun defmacro) ?fun ?- . ?-) - (eq? def fun)) - ((defvar ?var . ?-) - (eq? var def)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* definition-search ... */ -;* ------------------------------------------------------------- */ -;* This function seeks a Bigloo definition. If it finds it, it */ -;* returns two values the starting char number of the definition */ -;* and the stop char. */ -;*---------------------------------------------------------------------*/ -(define (definition-search ip tab semipred) - (cond-expand - (bigloo2.6 - (define (reader-current-line-number) - (let* ((port (open-input-string "(9)")) - (exp (read port #t))) - (close-input-port port) - (line-number exp))) - (define (line-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos ?line) - line)))) - (reader-reset!) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (line-number exp)) - (e (reader-current-line-number))) - (source-read-lines (input-port-name ip) b e tab))))))) - (else - (define (char-number expr) - (and (epair? expr) - (match-case (cer expr) - ((at ?- ?pos) - pos)))) - (let loop ((exp (read ip #t))) - (if (not (eof-object? exp)) - (let ((v (semipred exp))) - (if (not v) - (loop (read ip #t)) - (let* ((b (char-number exp)) - (e (input-port-position ip))) - (source-read-chars (input-port-name ip) - b - e - tab))))))))) - - -;*---------------------------------------------------------------------*/ -;* fontify-lisp ... */ -;*---------------------------------------------------------------------*/ -(define (fontify-lisp port::input-port) - (let ((g (regular-grammar () - ((: ";;" (* all)) - ;; italic comments - (let ((c (new markup - (markup '&source-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";*" (* all)) - ;; bold comments - (let ((c (new markup - (markup '&source-line-comment) - (body (the-string))))) - (cons c (ignore)))) - ((: ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-string))) - (cons str (ignore)))) - ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) - ;; plain comments - (let ((str (the-substring 1 (the-length)))) - (cons str (ignore)))) - ((+ #\Space) - ;; separators - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - (#\( - ;; open parenthesis - (let ((str (highlight (the-string)))) - (pupush-highlight) - (cons str (ignore)))) - (#\) - ;; close parenthesis - (let ((str (highlight (the-string) -1))) - (cons str (ignore)))) - ((+ (in "[]")) - ;; brackets - (let ((s (the-string))) - (if *bracket-highlight* - (let ((c (new markup - (markup '&source-bracket) - (body s)))) - (cons c (ignore))) - (cons s (ignore))))) - ((+ #\Tab) - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((: #\( (+ (out "; \t()[]:\"\n"))) - ;; keywords - (let* ((string (the-substring 1 (the-length))) - (symbol (string->symbol string)) - (key (getprop symbol *the-key*))) - (cons - "(" - (case key - ((symbol) - (let ((c (new markup - (markup '&source-keyword) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((define) - (let ((c (new markup - (markup '&source-define) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-define) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((error) - (let ((c (new markup - (markup '&source-error) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((module) - (let ((c (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body string)))) - (push-highlight (lambda (e) - (new markup - (markup '&source-module) - (ident (symbol->string (gensym))) - (body e))) - 1) - (cons c (ignore)))) - ((markup) - (let ((c (new markup - (markup '&source-markup) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - ((thread) - (let ((c (new markup - (markup '&source-thread) - (ident (symbol->string (gensym))) - (body string)))) - (cons c (ignore)))) - (else - (cons (highlight string 1) (ignore))))))) - ((+ (out "; \t()[]:\"\n")) - (let ((string (the-string))) - (cons (highlight string 1) (ignore)))) - ((+ #\Newline) - ;; newline - (let ((str (the-string))) - (cons (highlight str) (ignore)))) - ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") - (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) - ;; strings - (let ((str (split-string-newline (the-string)))) - (append (map (lambda (s) - (if (eq? s 'eol) - "\n" - (new markup - (markup '&source-string) - (ident (symbol->string (gensym))) - (body s)))) - str) - (ignore)))) - ((: "::" (+ (out ";\n \t()[]:\""))) - ;; type annotations - (let ((c (new markup - (markup '&source-type) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) - ;; keywords annotations - (let ((c (new markup - (markup '&source-key) - (ident (symbol->string (gensym))) - (body (the-string))))) - (cons c (ignore)))) - ((+ (or #\: #\; #\")) - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - ((: #\# #\\ (+ (out " \n\t"))) - ;; characters - (let ((str (the-string))) - (cons (highlight str 1) (ignore)))) - (else - (let ((c (the-failure))) - (if (eof-object? c) - '() - (error "source(lisp)" "Unexpected character" c))))))) - (reset-highlight!) - (read/rp g port))) - -;*---------------------------------------------------------------------*/ -;* *highlight* ... */ -;*---------------------------------------------------------------------*/ -(define *highlight* '()) - -;*---------------------------------------------------------------------*/ -;* reset-highlight! ... */ -;*---------------------------------------------------------------------*/ -(define (reset-highlight!) - (set! *highlight* '())) - -;*---------------------------------------------------------------------*/ -;* push-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (push-highlight col pv) - (set! *highlight* (cons (cons col pv) *highlight*))) - -;*---------------------------------------------------------------------*/ -;* pupush-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pupush-highlight) - (if (pair? *highlight*) - (let ((c (car *highlight*))) - (set-cdr! c 100000)))) - -;*---------------------------------------------------------------------*/ -;* pop-highlight ... */ -;*---------------------------------------------------------------------*/ -(define (pop-highlight pv) - (case pv - ((-1) - (set! *highlight* (cdr *highlight*))) - ((0) - 'nop) - (else - (let ((c (car *highlight*))) - (if (>fx (cdr c) 1) - (set-cdr! c (-fx (cdr c) 1)) - (set! *highlight* (cdr *highlight*))))))) - -;*---------------------------------------------------------------------*/ -;* highlight ... */ -;*---------------------------------------------------------------------*/ -(define (highlight exp . pop) - (if (pair? *highlight*) - (let* ((c (car *highlight*)) - (r (if (>fx (cdr c) 0) - ((car c) exp) - exp))) - (if (pair? pop) (pop-highlight (car pop))) - r) - exp)) - - diff --git a/src/bigloo/main.scm b/src/bigloo/main.scm deleted file mode 100644 index 5b9e5e5..0000000 --- a/src/bigloo/main.scm +++ /dev/null @@ -1,96 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/main.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:51:49 2003 */ -;* Last change : Wed May 18 15:45:27 2005 (serrano) */ -;* Copyright : 2003-05 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe main entry point */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_main - - (include "debug.sch") - - (import skribe_types - skribe_parse-args - skribe_param - skribe_lib - skribe_eval - skribe_read - skribe_engine - skribe_evapi) - - (main main)) - -;*---------------------------------------------------------------------*/ -;* main ... */ -;*---------------------------------------------------------------------*/ -(define (main args) - (with-debug 2 'main - (debug-item "parse env variables...") - (parse-env-variables) - - (debug-item "load rc file...") - (load-rc) - - (debug-item "parse command line...") - (parse-args args) - - (debug-item "load base...") - (skribe-load "base.skr" :engine 'base) - - (debug-item "preload... (" *skribe-engine* ")") - (for-each (lambda (f) - (skribe-load f :engine *skribe-engine*)) - *skribe-preload*) - - ;; Load the specified variants - (debug-item "variant... (" *skribe-variants* ")") - (for-each (lambda (x) - (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) - (reverse! *skribe-variants*)) - - (debug-item "body..." *skribe-engine*) - (if (string? *skribe-dest*) - (cond-expand - (bigloo2.6 - (try (with-output-to-file *skribe-dest* doskribe) - (lambda (e a b c) - (delete-file *skribe-dest*) - (let ((s (with-output-to-string - (lambda () (write c))))) - (notify-error a b s)) - (exit -1)))) - (else - (with-exception-handler - (lambda (e) - (if (&warning? e) - (raise e) - (begin - (delete-file *skribe-dest*) - (if (&error? e) - (error-notify e) - (raise e)) - (exit 1)))) - (lambda () - (with-output-to-file *skribe-dest* doskribe))))) - (doskribe)))) - -;*---------------------------------------------------------------------*/ -;* doskribe ... */ -;*---------------------------------------------------------------------*/ -(define (doskribe) - (let ((e (find-engine *skribe-engine*))) - (if (and (engine? e) (pair? *skribe-precustom*)) - (for-each (lambda (cv) - (engine-custom-set! e (car cv) (cdr cv))) - *skribe-precustom*)) - (if (pair? *skribe-src*) - (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) - *skribe-src*) - (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/src/bigloo/output.scm b/src/bigloo/output.scm deleted file mode 100644 index 4bc6271..0000000 --- a/src/bigloo/output.scm +++ /dev/null @@ -1,167 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/output.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Jul 23 12:48:11 2003 */ -;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe engine */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_output - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (output ::obj ::%engine . w))) - -;*---------------------------------------------------------------------*/ -;* output ... */ -;*---------------------------------------------------------------------*/ -(define (output node e . writer) - (with-debug 3 'output - (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) - (debug-item "writer=" writer) - (if (pair? writer) - (cond - ((%writer? (car writer)) - (out/writer node e (car writer))) - ((not (car writer)) - (skribe-error 'output - (format "Illegal `~a' user writer" (%engine-ident e)) - (if (markup? node) (%markup-markup node) node))) - (else - (skribe-error 'output "Illegal user writer" (car writer)))) - (out node e)))) - -;*---------------------------------------------------------------------*/ -;* out/writer ... */ -;*---------------------------------------------------------------------*/ -(define (out/writer n e w) - (with-debug 5 'out/writer - (debug-item "n=" (find-runtime-type n) - " " (if (markup? n) (markup-markup n) "")) - (debug-item "e=" (%engine-ident e)) - (debug-item "w=" (%writer-ident w)) - (if (%writer? w) - (with-access::%writer w (before action after) - (invoke before n e) - (invoke action n e) - (invoke after n e))))) - -;*---------------------------------------------------------------------*/ -;* out ... */ -;*---------------------------------------------------------------------*/ -(define-generic (out node e::%engine) - (cond - ((pair? node) - (out* node e)) - ((string? node) - (let ((f (%engine-filter e))) - (if (procedure? f) - (display (f node)) - (display node)))) - ((number? node) - (display node)) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* out ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (out n::%processor e::%engine) - (with-access::%processor n (combinator engine body procedure) - (let ((newe (processor-get-engine combinator engine e))) - (out (procedure body newe) newe)))) - -;*---------------------------------------------------------------------*/ -;* out ::%command ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%command e::%engine) - (with-access::%command node (fmt body) - (let ((lb (length body)) - (lf (string-length fmt))) - (define (loops i n) - (if (= i lf) - (begin - (if (> n 0) - (if (<= n lb) - (output (list-ref body (- n 1)) e) - (skribe-error '! - "Too few arguments provided" - node))) - lf) - (let ((c (string-ref fmt i))) - (cond - ((char=? c #\$) - (display "$") - (+ 1 i)) - ((not (char-numeric? c)) - (cond - ((= n 0) - i) - ((<= n lb) - (output (list-ref body (- n 1)) e) - i) - (else - (skribe-error '! - "Too few arguments provided" - node)))) - (else - (loops (+ i 1) - (+ (- (char->integer c) - (char->integer #\0)) - (* 10 n)))))))) - (let loop ((i 0)) - (cond - ((= i lf) - #f) - ((not (char=? (string-ref fmt i) #\$)) - (display (string-ref fmt i)) - (loop (+ i 1))) - (else - (loop (loops (+ i 1) 0)))))))) - -;*---------------------------------------------------------------------*/ -;* out ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%handle e::%engine) - #unspecified) - -;*---------------------------------------------------------------------*/ -;* out ::%unresolved ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%unresolved e::%engine) - (error 'output "Orphan unresolved" node)) - -;*---------------------------------------------------------------------*/ -;* out ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (out node::%markup e::%engine) - (let ((w (lookup-markup-writer node e))) - (if (writer? w) - (out/writer node e w) - (output (%markup-body node) e)))) - -;*---------------------------------------------------------------------*/ -;* out* ... */ -;*---------------------------------------------------------------------*/ -(define (out* n+ e) - (let loop ((n* n+)) - (cond - ((pair? n*) - (out (car n*) e) - (loop (cdr n*))) - ((not (null? n*)) - (error 'output "Illegal argument" n*))))) - - diff --git a/src/bigloo/param.bgl b/src/bigloo/param.bgl deleted file mode 100644 index 6ff6b42..0000000 --- a/src/bigloo/param.bgl +++ /dev/null @@ -1,134 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Sat Jul 26 14:03:15 2003 */ -;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe parameters */ -;* ------------------------------------------------------------- */ -;* Implementation: @label param@ */ -;* bigloo: @path ../common/param.scm@ */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_param - - (import skribe_configure) - - (export *skribe-verbose* - *skribe-warning* - *skribe-path* - *skribe-bib-path* - *skribe-source-path* - *skribe-image-path* - *load-rc* - - *skribe-src* - *skribe-dest* - *skribe-engine* - *skribe-variants* - *skribe-chapter-split* - - *skribe-ref-base* - - *skribe-rc-directory* - *skribe-rc-file* - *skribe-auto-mode-alist* - *skribe-auto-load-alist* - *skribe-preload* - *skribe-precustom* - - *skribebib-auto-mode-alist*)) - -;*---------------------------------------------------------------------*/ -;* *skribe-verbose* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-verbose* 0) - -;*---------------------------------------------------------------------*/ -;* *skribe-warning* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-warning* 5) - -;*---------------------------------------------------------------------*/ -;* *skribe-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-path* (skribe-default-path)) - -;*---------------------------------------------------------------------*/ -;* *skribe-bib-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-bib-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-source-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-source-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *skribe-image-path* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-image-path* '(".")) - -;*---------------------------------------------------------------------*/ -;* *load-rc* ... */ -;*---------------------------------------------------------------------*/ -(define *load-rc* #t) - -;*---------------------------------------------------------------------*/ -;* *skribe-src* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-src* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-dest* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-dest* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-engine* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-engine* 'html) - -;*---------------------------------------------------------------------*/ -;* *skribe-variants* */ -;*---------------------------------------------------------------------*/ -(define *skribe-variants* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-chapter-split* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-chapter-split* '()) - -;*---------------------------------------------------------------------*/ -;* *skribe-ref-base* ... */ -;*---------------------------------------------------------------------*/ -(define *skribe-ref-base* #f) - -;*---------------------------------------------------------------------*/ -;* *skribe-rc-directory* ... */ -;* ------------------------------------------------------------- */ -;* The "runtime command" file directory. */ -;*---------------------------------------------------------------------*/ -(define *skribe-rc-directory* - (let ((home (getenv "HOME")) - (host (hostname))) - (let loop ((host (if (not (string? host)) (getenv "HOST") host))) - (if (string? host) - (let ((home/host (string-append home "/.skribe" host))) - (if (and (file-exists? home/host) (directory? home/host)) - home/host - (if (string=? (suffix host) "") - (let ((home/def (make-file-name home ".skribe"))) - (cond - ((and (file-exists? home/def) - (directory? home/def)) - home/def) - (else - home))) - (loop (prefix host))))))))) - diff --git a/src/bigloo/parseargs.scm b/src/bigloo/parseargs.scm deleted file mode 100644 index 4ce58c4..0000000 --- a/src/bigloo/parseargs.scm +++ /dev/null @@ -1,186 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:52:53 2003 */ -;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Argument parsing */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_parse-args - - (include "debug.sch") - - (import skribe_configure - skribe_param - skribe_read - skribe_types - skribe_eval) - - (export (parse-env-variables) - (parse-args ::pair) - (load-rc))) - -;*---------------------------------------------------------------------*/ -;* parse-env-variables ... */ -;*---------------------------------------------------------------------*/ -(define (parse-env-variables) - (let ((e (getenv "SKRIBEPATH"))) - (if (string? e) - (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) - -;*---------------------------------------------------------------------*/ -;* parse-args ... */ -;*---------------------------------------------------------------------*/ -(define (parse-args args) - (define (usage args-parse-usage) - (print "usage: skribe [options] [input]") - (newline) - (args-parse-usage #f) - (newline) - (print "Rc file:") - (newline) - (print " *skribe-rc* (searched in \".\" then $HOME)") - (newline) - (print "Target formats:") - (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) - (newline) - (print "Shell Variables:") - (newline) - (for-each (lambda (var) - (print " - " (car var) " " (cdr var))) - '(("SKRIBEPATH" . "Skribe input path (all files)")))) - (define (version) - (print "skribe v" (skribe-release))) - (define (query) - (version) - (newline) - (for-each (lambda (x) - (let ((s (keyword->string (car x)))) - (printf " ~a: ~a\n" - (substring s 1 (string-length s)) - (cadr x)))) - (skribe-configure))) - (let ((np '()) - (engine #f)) - (args-parse (cdr args) - ((("-h" "--help") (help "This message")) - (usage args-parse-usage) - (exit 0)) - (("--options" (help "Display the skribe options and exit")) - (args-parse-usage #t) - (exit 0)) - (("--version" (help "The version of Skribe")) - (version) - (exit 0)) - ((("-q" "--query") (help "Display informations about the Skribe configuration")) - (query) - (exit 0)) - ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) - (let ((l (string-length key=val))) - (let loop ((i 0)) - (cond - ((= i l) - (skribe-error 'skribe "Illegal option" key=val)) - ((char=? (string-ref key=val i) #\=) - (let ((key (substring key=val 0 i)) - (val (substring key=val (+ i 1) l))) - (set! *skribe-precustom* - (cons (cons (string->symbol key) val) - *skribe-precustom*)))) - (else - (loop (+ i 1))))))) - (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) - (set! *skribe-verbose* (string->integer level)))) - (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) - (if (string=? level "") - (set! *skribe-warning* (+fx 1 *skribe-warning*)) - (set! *skribe-warning* (string->integer level)))) - (("-g?level" (help "Increase or set debug level")) - (if (string=? level "") - (set! *skribe-debug* (+fx 1 *skribe-debug*)) - (let ((l (string->integer level))) - (if (= l 0) - (begin - (set! *skribe-debug* 1) - (set! *skribe-debug-symbols* - (cons (string->symbol level) - *skribe-debug-symbols*))) - (set! *skribe-debug* l))))) - (("--no-color" (help "Disable coloring for debug")) - (set! *skribe-debug-color* #f)) - ((("-t" "--target") ?e (help "The output target format")) - (set! engine (string->symbol e))) - (("-I" ?path (help "Add <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/src/bigloo/prog.scm b/src/bigloo/prog.scm deleted file mode 100644 index baad0f0..0000000 --- a/src/bigloo/prog.scm +++ /dev/null @@ -1,196 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Wed Aug 27 09:14:28 2003 */ -;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ -;* Copyright : 2003 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe prog bigloo implementation */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_prog - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api) - - (export (make-prog-body ::obj ::obj ::obj ::obj) - (resolve-line ::bstring))) - -;*---------------------------------------------------------------------*/ -;* *lines* ... */ -;*---------------------------------------------------------------------*/ -(define *lines* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* make-line-mark ... */ -;*---------------------------------------------------------------------*/ -(define (make-line-mark m lnum b) - (let* ((ls (integer->string lnum)) - (n (list (mark ls) b))) - (hashtable-put! *lines* m n) - n)) - -;*---------------------------------------------------------------------*/ -;* resolve-line ... */ -;*---------------------------------------------------------------------*/ -(define (resolve-line id) - (hashtable-get *lines* id)) - -;*---------------------------------------------------------------------*/ -;* extract-string-mark ... */ -;*---------------------------------------------------------------------*/ -(define (extract-string-mark line mark regexp) - (let ((m (pregexp-match regexp line))) - (if (pair? m) - (values (substring (car m) - (string-length mark) - (string-length (car m))) - (pregexp-replace regexp line "")) - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* extract-mark ... */ -;* ------------------------------------------------------------- */ -;* Extract the prog mark from a line. */ -;*---------------------------------------------------------------------*/ -(define (extract-mark line mark regexp) - (cond - ((not regexp) - (values #f line)) - ((string? line) - (extract-string-mark line mark regexp)) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - (values #f line) - (multiple-value-bind (m l) - (extract-mark (car ls) mark regexp) - (if (not m) - (loop (cdr ls) (cons l res)) - (values m (append (reverse! res) (cons l (cdr ls))))))))) - ((%node? line) - (multiple-value-bind (m l) - (extract-mark (%node-body line) mark regexp) - (if (not m) - (values #f line) - (begin - (%node-body-set! line l) - (values m line))))) - (else - (values #f line)))) - -;*---------------------------------------------------------------------*/ -;* split-line ... */ -;*---------------------------------------------------------------------*/ -(define (split-line line) - (cond - ((string? line) - (let ((l (string-length line))) - (let loop ((r1 0) - (r2 0) - (res '())) - (cond - ((=fx r2 l) - (if (=fx r1 r2) - (reverse! res) - (reverse! (cons (substring line r1 r2) res)))) - ((char=? (string-ref line r2) #\Newline) - (loop (+fx r2 1) - (+fx r2 1) - (if (=fx r1 r2) - (cons 'eol res) - (cons* 'eol (substring line r1 r2) res)))) - (else - (loop r1 - (+fx r2 1) - res)))))) - ((pair? line) - (let loop ((ls line) - (res '())) - (if (null? ls) - res - (loop (cdr ls) (append res (split-line (car ls))))))) - (else - (list line)))) - -;*---------------------------------------------------------------------*/ -;* flat-lines ... */ -;*---------------------------------------------------------------------*/ -(define (flat-lines lines) - (apply append (map split-line lines))) - -;*---------------------------------------------------------------------*/ -;* collect-lines ... */ -;*---------------------------------------------------------------------*/ -(define (collect-lines lines) - (let loop ((lines (flat-lines lines)) - (res '()) - (tmp '())) - (cond - ((null? lines) - (reverse! (cons (reverse! tmp) res))) - ((eq? (car lines) 'eol) - (cond - ((null? (cdr lines)) - (reverse! (cons (reverse! tmp) res))) - ((and (null? res) (null? tmp)) - (loop (cdr lines) - res - '())) - (else - (loop (cdr lines) - (cons (reverse! tmp) res) - '())))) - (else - (loop (cdr lines) - res - (cons (car lines) tmp)))))) - -;*---------------------------------------------------------------------*/ -;* make-prog-body ... */ -;*---------------------------------------------------------------------*/ -(define (make-prog-body src lnum-init ldigit mark) - (define (int->str i rl) - (let* ((s (integer->string i)) - (l (string-length s))) - (if (= l rl) - s - (string-append (make-string (- rl l) #\space) s)))) - (let* ((regexp (and mark - (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" - (pregexp-quote mark)))) - (src (cond - ((not (pair? src)) (list src)) - ((and (pair? (car src)) (null? (cdr src))) (car src)) - (else src))) - (lines (collect-lines src)) - (lnum (if (integer? lnum-init) lnum-init 1)) - (s (integer->string (+fx (if (integer? ldigit) - (max lnum (expt 10 (-fx ldigit 1))) - lnum) - (length lines)))) - (cs (string-length s))) - (let loop ((lines lines) - (lnum lnum) - (res '())) - (if (null? lines) - (reverse! res) - (multiple-value-bind (m l) - (extract-mark (car lines) mark regexp) - (let ((n (new markup - (markup '&prog-line) - (ident (and lnum-init (int->str lnum cs))) - (body (if m (make-line-mark m lnum l) l))))) - (loop (cdr lines) - (+ lnum 1) - (cons n res)))))))) diff --git a/src/bigloo/read.scm b/src/bigloo/read.scm deleted file mode 100644 index 91cd345..0000000 --- a/src/bigloo/read.scm +++ /dev/null @@ -1,482 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/read.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Dec 27 11:16:00 1994 */ -;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ -;* ------------------------------------------------------------- */ -;* Skribe's reader */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* Le module */ -;*---------------------------------------------------------------------*/ -(module skribe_read - (export (skribe-read . port))) - -;*---------------------------------------------------------------------*/ -;* Global counteurs ... */ -;*---------------------------------------------------------------------*/ -(define *par-open* 0) - -;*---------------------------------------------------------------------*/ -;* Parenthesis mismatch (or unclosing) errors. */ -;*---------------------------------------------------------------------*/ -(define *list-error-level* 20) -(define *list-errors* (make-vector *list-error-level* #unspecified)) -(define *vector-errors* (make-vector *list-error-level* #unspecified)) - -;*---------------------------------------------------------------------*/ -;* Control variables. */ -;*---------------------------------------------------------------------*/ -(define *end-of-list* (cons 0 0)) -(define *dotted-mark* (cons 1 1)) - -;*---------------------------------------------------------------------*/ -;* skribe-reader-reset! ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-reader-reset!) - (set! *par-open* 0)) - -;*---------------------------------------------------------------------*/ -;* read-error ... */ -;*---------------------------------------------------------------------*/ -(define (read-error msg obj port) - (let* ((obj-loc (if (epair? obj) - (match-case (cer obj) - ((at ?fname ?pos ?-) - pos) - (else - #f)) - #f)) - (loc (if (number? obj-loc) - obj-loc - (cond - ((>fx *par-open* 0) - (let ((open-key (-fx *par-open* 1))) - (if (<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/src/bigloo/resolve.scm b/src/bigloo/resolve.scm deleted file mode 100644 index 8248a4f..0000000 --- a/src/bigloo/resolve.scm +++ /dev/null @@ -1,283 +0,0 @@ -;*=====================================================================*/ -;* 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)) - (let ((e `((parent ,node) ,@env ,@env0))) - (set! body (do-resolve! body engine e)) - 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 (proc node 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/src/bigloo/source.scm b/src/bigloo/source.scm deleted file mode 100644 index babadff..0000000 --- a/src/bigloo/source.scm +++ /dev/null @@ -1,238 +0,0 @@ -;*=====================================================================*/ -;* 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/src/bigloo/sui.bgl b/src/bigloo/sui.bgl deleted file mode 100644 index 63c5477..0000000 --- a/src/bigloo/sui.bgl +++ /dev/null @@ -1,34 +0,0 @@ -;*=====================================================================*/ -;* 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/src/bigloo/types.scm b/src/bigloo/types.scm deleted file mode 100644 index b8babd4..0000000 --- a/src/bigloo/types.scm +++ /dev/null @@ -1,685 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/types.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Jul 22 16:40:42 2003 */ -;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The definition of the Skribe classes */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_types - - (export (abstract-class %ast - (parent (default #unspecified)) - (loc (default (evmeaning-location)))) - - (class %command::%ast - (fmt::bstring read-only) - (body (default #f))) - - (class %unresolved::%ast - (proc::procedure read-only)) - - (class %handle::%ast - (ast (default #f))) - - (abstract-class %node::%ast - (required-options::pair-nil read-only (default '())) - (options::pair-nil (default '())) - (body (default #f))) - - (class %processor::%node - (combinator (default (lambda (e1 e2) e1))) - (procedure::procedure (default (lambda (n e) n))) - engine) - - (class %markup::%node - (markup-init) - (ident (default #f)) - (class (default #f)) - (markup::symbol read-only)) - - (class %container::%markup - (env::pair-nil (default '()))) - - (class %document::%container) - - (class %engine - (ident::symbol read-only) - (format::bstring (default "raw")) - (info::pair-nil (default '())) - (version::obj read-only (default #unspecified)) - (delegate read-only (default #f)) - (writers::pair-nil (default '())) - (filter::obj (default #f)) - (customs::pair-nil (default '())) - (symbol-table::pair-nil (default '()))) - - (class %writer - (ident::symbol read-only) - (class read-only) - (pred::procedure read-only) - (upred read-only) - (options::obj read-only) - (verified?::bool (default #f)) - (validate (default #f)) - (before read-only) - (action read-only) - (after read-only)) - - (class %language - (name::bstring read-only) - (fontifier read-only (default #f)) - (extractor read-only (default #f))) - - (markup-init ::%markup) - (find-markups ::bstring) - - (inline ast?::bool ::obj) - (inline ast-parent::obj ::%ast) - (inline ast-loc::obj ::%ast) - (inline ast-loc-set!::obj ::%ast ::obj) - (ast-location::bstring ::%ast) - - (new-command . inits) - (inline command?::bool ::obj) - (inline command-fmt::bstring ::%command) - (inline command-body::obj ::%command) - - (new-unresolved . inits) - (inline unresolved?::bool ::obj) - (inline unresolved-proc::procedure ::%unresolved) - - (new-handle . inits) - (inline handle?::bool ::obj) - (inline handle-ast::obj ::%handle) - - (inline node?::bool ::obj) - (inline node-body::obj ::%node) - (inline node-options::pair-nil ::%node) - (inline node-loc::obj ::%node) - - (new-processor . inits) - (inline processor?::bool ::obj) - (inline processor-combinator::obj ::%processor) - (inline processor-engine::obj ::%processor) - - (new-markup . inits) - (inline markup?::bool ::obj) - (inline is-markup?::bool ::obj ::symbol) - (inline markup-markup::obj ::%markup) - (inline markup-ident::obj ::%markup) - (inline markup-body::obj ::%markup) - (inline markup-options::pair-nil ::%markup) - - (new-container . inits) - (inline container?::bool ::obj) - (inline container-ident::obj ::%container) - (inline container-body::obj ::%container) - (inline container-options::pair-nil ::%container) - - (new-document . inits) - (inline document?::bool ::obj) - (inline document-ident::bool ::%document) - (inline document-body::bool ::%document) - (inline document-options::pair-nil ::%document) - (inline document-env::pair-nil ::%document) - - (inline engine?::bool ::obj) - (inline engine-ident::obj ::obj) - (inline engine-format::obj ::obj) - (inline engine-customs::pair-nil ::obj) - (inline engine-filter::obj ::obj) - (inline engine-symbol-table::pair-nil ::%engine) - - (inline writer?::bool ::obj) - (inline writer-before::obj ::%writer) - (inline writer-action::obj ::%writer) - (inline writer-after::obj ::%writer) - (inline writer-options::obj ::%writer) - - (inline language?::bool ::obj) - (inline language-name::obj ::obj) - (inline language-fontifier::obj ::obj) - (inline language-extractor::obj ::obj) - - (new-language . inits) - - (location?::bool ::obj) - (location-file::bstring ::pair) - (location-pos::int ::pair))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate ... */ -;*---------------------------------------------------------------------*/ -(define-macro (skribe-instantiate type values . slots) - `(begin - (skribe-instantiate-check-values ',type ,values ',slots) - (,(symbol-append 'instantiate::% type) - ,@(map (lambda (slot) - (let ((id (if (pair? slot) (car slot) slot)) - (def (if (pair? slot) (cadr slot) #f))) - `(,id (new-get-value ',id ,values ,def)))) - slots)))) - -;*---------------------------------------------------------------------*/ -;* skribe-instantiate-check-values ... */ -;*---------------------------------------------------------------------*/ -(define (skribe-instantiate-check-values id values slots) - (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) - (when (pair? bs) - (for-each (lambda (b) - (error (symbol-append '|new | id) - "Illegal field" - b)) - bs)))) - -;*---------------------------------------------------------------------*/ -;* object-print ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-print obj::%ast port print-slot::procedure) - (let* ((class (object-class obj)) - (class-name (class-name class))) - (display "#|" port) - (display class-name port) - (display #\| port))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%ast ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%ast . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a>" - (find-runtime-type n))) - -;*---------------------------------------------------------------------*/ -;* object-display ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-display n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a>" - (find-runtime-type n) - (markup-markup n))) - -;*---------------------------------------------------------------------*/ -;* object-write ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (object-write n::%markup . port) - (fprintf (if (pair? port) (car port) (current-output-port)) - "<#~a:~a:~a>" - (find-runtime-type n) - (markup-markup n) - (find-runtime-type (markup-body n)))) - -;*---------------------------------------------------------------------*/ -;* *node-table* */ -;* ------------------------------------------------------------- */ -;* A private hashtable that stores all the nodes of an ast. It */ -;* is used for retreiving a node from its identifier. */ -;*---------------------------------------------------------------------*/ -(define *node-table* (make-hashtable)) - -;*---------------------------------------------------------------------*/ -;* ast? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast? obj) - (%ast? obj)) - -;*---------------------------------------------------------------------*/ -;* ast-parent ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-parent obj) - (%ast-parent obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc obj) - (%ast-loc obj)) - -;*---------------------------------------------------------------------*/ -;* ast-loc-set! ... */ -;*---------------------------------------------------------------------*/ -(define-inline (ast-loc-set! obj loc) - (%ast-loc-set! obj loc)) - -;*---------------------------------------------------------------------*/ -;* ast-location ... */ -;*---------------------------------------------------------------------*/ -(define (ast-location obj) - (with-access::%ast obj (loc) - (if (location? loc) - (let* ((fname (location-file loc)) - (char (location-pos loc)) - (pwd (pwd)) - (len (string-length pwd)) - (lenf (string-length fname)) - (file (if (and (substring=? pwd fname len) - (and (>fx lenf len))) - (substring fname len (+fx 1 (string-length fname))) - fname))) - (format "~a, char ~a" file char)) - "no source location"))) - -;*---------------------------------------------------------------------*/ -;* new-command ... */ -;*---------------------------------------------------------------------*/ -(define (new-command . init) - (skribe-instantiate command init - (parent #unspecified) - (loc #f) - fmt - (body #f))) - -;*---------------------------------------------------------------------*/ -;* command? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command? obj) - (%command? obj)) - -;*---------------------------------------------------------------------*/ -;* command-fmt ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-fmt cmd) - (%command-fmt cmd)) - -;*---------------------------------------------------------------------*/ -;* command-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (command-body cmd) - (%command-body cmd)) - -;*---------------------------------------------------------------------*/ -;* new-unresolved ... */ -;*---------------------------------------------------------------------*/ -(define (new-unresolved . init) - (skribe-instantiate unresolved init - (parent #unspecified) - loc - proc)) - -;*---------------------------------------------------------------------*/ -;* unresolved? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved? obj) - (%unresolved? obj)) - -;*---------------------------------------------------------------------*/ -;* unresolved-proc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (unresolved-proc unr) - (%unresolved-proc unr)) - -;*---------------------------------------------------------------------*/ -;* new-handle ... */ -;*---------------------------------------------------------------------*/ -(define (new-handle . init) - (skribe-instantiate handle init - (parent #unspecified) - loc - (ast #f))) - -;*---------------------------------------------------------------------*/ -;* handle? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle? obj) - (%handle? obj)) - -;*---------------------------------------------------------------------*/ -;* handle-ast ... */ -;*---------------------------------------------------------------------*/ -(define-inline (handle-ast obj) - (%handle-ast obj)) - -;*---------------------------------------------------------------------*/ -;* node? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node? obj) - (%node? obj)) - -;*---------------------------------------------------------------------*/ -;* node-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-body obj) - (%node-body obj)) - -;*---------------------------------------------------------------------*/ -;* node-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-options obj) - (%node-options obj)) - -;*---------------------------------------------------------------------*/ -;* node-loc ... */ -;*---------------------------------------------------------------------*/ -(define-inline (node-loc obj) - (%node-loc obj)) - -;*---------------------------------------------------------------------*/ -;* new-processor ... */ -;*---------------------------------------------------------------------*/ -(define (new-processor . init) - (skribe-instantiate processor init - (parent #unspecified) - loc - (combinator (lambda (e1 e2) e1)) - engine - (body #f))) - -;*---------------------------------------------------------------------*/ -;* processor? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor? obj) - (%processor? obj)) - -;*---------------------------------------------------------------------*/ -;* processor-combinator ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-combinator proc) - (%processor-combinator proc)) - -;*---------------------------------------------------------------------*/ -;* processor-engine ... */ -;*---------------------------------------------------------------------*/ -(define-inline (processor-engine proc) - (%processor-engine proc)) - -;*---------------------------------------------------------------------*/ -;* new-markup ... */ -;*---------------------------------------------------------------------*/ -(define (new-markup . init) - (skribe-instantiate markup init - (parent #unspecified) - (loc #f) - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()))) - -;*---------------------------------------------------------------------*/ -;* markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup? obj) - (%markup? obj)) - -;*---------------------------------------------------------------------*/ -;* is-markup? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (is-markup? obj markup) - (and (markup? obj) (eq? (markup-markup obj) markup))) - -;*---------------------------------------------------------------------*/ -;* markup-init ... */ -;* ------------------------------------------------------------- */ -;* The markup constructor simply stores in the markup table the */ -;* news markups. */ -;*---------------------------------------------------------------------*/ -(define (markup-init markup) - (bind-markup! markup)) - -;*---------------------------------------------------------------------*/ -;* bind-markup! ... */ -;*---------------------------------------------------------------------*/ -(define (bind-markup! node) - (hashtable-update! *node-table* - (markup-ident node) - (lambda (cur) (cons node cur)) - (list node))) - -;*---------------------------------------------------------------------*/ -;* find-markups ... */ -;*---------------------------------------------------------------------*/ -(define (find-markups ident) - (hashtable-get *node-table* ident)) - -;*---------------------------------------------------------------------*/ -;* markup-markup ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-markup obj) - (%markup-markup obj)) - -;*---------------------------------------------------------------------*/ -;* markup-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-ident obj) - (%markup-ident obj)) - -;*---------------------------------------------------------------------*/ -;* markup-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-body obj) - (%markup-body obj)) - -;*---------------------------------------------------------------------*/ -;* markup-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (markup-options obj) - (%markup-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-container ... */ -;*---------------------------------------------------------------------*/ -(define (new-container . init) - (skribe-instantiate container init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* container? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container? obj) - (%container? obj)) - -;*---------------------------------------------------------------------*/ -;* container-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-ident obj) - (%container-ident obj)) - -;*---------------------------------------------------------------------*/ -;* container-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-body obj) - (%container-body obj)) - -;*---------------------------------------------------------------------*/ -;* container-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (container-options obj) - (%container-options obj)) - -;*---------------------------------------------------------------------*/ -;* new-document ... */ -;*---------------------------------------------------------------------*/ -(define (new-document . init) - (skribe-instantiate document init - (parent #unspecified) - loc - markup - ident - (class #f) - (body #f) - (options '()) - (required-options '()) - (env '()))) - -;*---------------------------------------------------------------------*/ -;* document? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document? obj) - (%document? obj)) - -;*---------------------------------------------------------------------*/ -;* document-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-options doc) - (%document-options doc)) - -;*---------------------------------------------------------------------*/ -;* document-env ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-env doc) - (%document-env doc)) - -;*---------------------------------------------------------------------*/ -;* document-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-ident doc) - (%document-ident doc)) - -;*---------------------------------------------------------------------*/ -;* document-body ... */ -;*---------------------------------------------------------------------*/ -(define-inline (document-body doc) - (%document-body doc)) - -;*---------------------------------------------------------------------*/ -;* engine? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine? obj) - (%engine? obj)) - -;*---------------------------------------------------------------------*/ -;* engine-ident ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-ident obj) - (%engine-ident obj)) - -;*---------------------------------------------------------------------*/ -;* engine-format ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-format obj) - (%engine-format obj)) - -;*---------------------------------------------------------------------*/ -;* engine-customs ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-customs obj) - (%engine-customs obj)) - -;*---------------------------------------------------------------------*/ -;* engine-filter ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-filter obj) - (%engine-filter obj)) - -;*---------------------------------------------------------------------*/ -;* engine-symbol-table ... */ -;*---------------------------------------------------------------------*/ -(define-inline (engine-symbol-table obj) - (%engine-symbol-table obj)) - -;*---------------------------------------------------------------------*/ -;* writer? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer? obj) - (%writer? obj)) - -;*---------------------------------------------------------------------*/ -;* writer-before ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-before obj) - (%writer-before obj)) - -;*---------------------------------------------------------------------*/ -;* writer-action ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-action obj) - (%writer-action obj)) - -;*---------------------------------------------------------------------*/ -;* writer-after ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-after obj) - (%writer-after obj)) - -;*---------------------------------------------------------------------*/ -;* writer-options ... */ -;*---------------------------------------------------------------------*/ -(define-inline (writer-options obj) - (%writer-options obj)) - -;*---------------------------------------------------------------------*/ -;* language? ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language? obj) - (%language? obj)) - -;*---------------------------------------------------------------------*/ -;* language-name ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-name lg) - (%language-name lg)) - -;*---------------------------------------------------------------------*/ -;* language-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-fontifier lg) - (%language-fontifier lg)) - -;*---------------------------------------------------------------------*/ -;* language-extractor ... */ -;*---------------------------------------------------------------------*/ -(define-inline (language-extractor lg) - (%language-extractor lg)) - -;*---------------------------------------------------------------------*/ -;* new-get-value ... */ -;*---------------------------------------------------------------------*/ -(define (new-get-value key init def) - (let ((c (assq key init))) - (match-case c - ((?- ?v) - v) - (else - def)))) - -;*---------------------------------------------------------------------*/ -;* new-language ... */ -;*---------------------------------------------------------------------*/ -(define (new-language . init) - (skribe-instantiate language init name fontifier extractor)) - -;*---------------------------------------------------------------------*/ -;* location? ... */ -;*---------------------------------------------------------------------*/ -(define (location? o) - (match-case o - ((at ?- ?-) - #t) - (else - #f))) - -;*---------------------------------------------------------------------*/ -;* location-file ... */ -;*---------------------------------------------------------------------*/ -(define (location-file o) - (match-case o - ((at ?fname ?-) - fname) - (else - (error 'location-file "Illegal location" o)))) - -;*---------------------------------------------------------------------*/ -;* location-pos ... */ -;*---------------------------------------------------------------------*/ -(define (location-pos o) - (match-case o - ((at ?- ?loc) - loc) - (else - (error 'location-pos "Illegal location" o)))) diff --git a/src/bigloo/verify.scm b/src/bigloo/verify.scm deleted file mode 100644 index 602a951..0000000 --- a/src/bigloo/verify.scm +++ /dev/null @@ -1,143 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Fri Jul 25 09:54:55 2003 */ -;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* The Skribe verification stage */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_verify - - (include "debug.sch") - - (import skribe_types - skribe_lib - skribe_engine - skribe_writer - skribe_eval) - - (export (generic verify ::obj ::%engine))) - -;*---------------------------------------------------------------------*/ -;* check-required-options ... */ -;*---------------------------------------------------------------------*/ -(define (check-required-options n::%markup w::%writer e::%engine) - (with-access::%markup n (required-options) - (with-access::%writer w (ident options verified?) - (or verified? - (eq? options 'all) - (begin - (for-each (lambda (o) - (if (not (memq o options)) - (skribe-error (%engine-ident e) - (format "Option unsupported: ~a, supported options: ~a" o options) - n))) - required-options) - (set! verified? #t)))))) - -;*---------------------------------------------------------------------*/ -;* check-options ... */ -;* ------------------------------------------------------------- */ -;* Only keywords are checked, symbols are voluntary left unchecked. */ -;*---------------------------------------------------------------------*/ -(define (check-options eo*::pair-nil m::%markup e::%engine) - (with-debug 6 'check-options - (debug-item "markup=" (%markup-markup m)) - (debug-item "options=" (%markup-options m)) - (debug-item "eo*=" eo*) - (for-each (lambda (o2) - (for-each (lambda (o) - (if (and (keyword? o) - (not (eq? o :&skribe-eval-location)) - (not (memq o eo*))) - (skribe-warning/ast - 3 - m - 'verify - (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" - (%engine-ident e) - (%markup-markup m) - o - (markup-option m o))))) - o2)) - (%markup-options m)))) - -;*---------------------------------------------------------------------*/ -;* verify :: ... */ -;*---------------------------------------------------------------------*/ -(define-generic (verify node e) - (if (pair? node) - (for-each (lambda (n) (verify n e)) node)) - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%processor ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify n::%processor e) - (with-access::%processor n (combinator engine body) - (verify body (processor-get-engine combinator engine e)) - n)) - -;*---------------------------------------------------------------------*/ -;* verify ::%node ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%node e) - (with-access::%node node (body options) - (verify body e) - (for-each (lambda (o) (verify (cadr o) e)) options) - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%markup ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%markup e) - (with-debug 5 'verify::%markup - (debug-item "node=" (%markup-markup node)) - (debug-item "options=" (%markup-options node)) - (debug-item "e=" (%engine-ident e)) - (call-next-method) - (let ((w (lookup-markup-writer node e))) - (if (%writer? w) - (begin - (check-required-options node w e) - (if (pair? (%writer-options w)) - (check-options (%writer-options w) node e)) - (let ((validate (%writer-validate w))) - (when (procedure? validate) - (unless (validate node e) - (skribe-warning - 1 - node - (format "Node `~a' forbidden here by ~a engine" - (markup-markup node) - (engine-ident e)) - node))))))) - ;; return the node - node)) - -;*---------------------------------------------------------------------*/ -;* verify ::%document ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%document e) - (call-next-method) - ;; verify the engine custom - (for-each (lambda (c) - (let ((i (car c)) - (a (cadr c))) - (set-car! (cdr c) (verify a e)))) - (%engine-customs e)) - ;; return the node - node) - -;*---------------------------------------------------------------------*/ -;* verify ::%handle ... */ -;*---------------------------------------------------------------------*/ -(define-method (verify node::%handle e) - node) - diff --git a/src/bigloo/writer.scm b/src/bigloo/writer.scm deleted file mode 100644 index ce515bf..0000000 --- a/src/bigloo/writer.scm +++ /dev/null @@ -1,232 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Tue Sep 9 06:19:57 2003 */ -;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* Skribe writer management */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_writer - - (option (set! dsssl-symbol->keyword - (lambda (s) - (string->keyword - (string-append ":" (symbol->string s)))))) - - (include "debug.sch") - - (import skribe_types - skribe_eval - skribe_param - skribe_engine - skribe_output - skribe_lib) - - (export (invoke proc node e) - - (lookup-markup-writer ::%markup ::%engine) - - (markup-writer ::obj #!optional e #!key p class opt va bef aft act) - (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) - (markup-writer-get ::obj #!optional e #!key class pred) - (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) - -;*---------------------------------------------------------------------*/ -;* invoke ... */ -;*---------------------------------------------------------------------*/ -(define (invoke proc node e) - (let ((id (if (markup? node) - (string->symbol - (format "~a#~a" - (%engine-ident e) - (%markup-markup node))) - (%engine-ident e)))) - (with-push-trace id - (with-debug 5 'invoke - (debug-item "e=" (%engine-ident e)) - (debug-item "node=" (find-runtime-type node) - " " (if (markup? node) (%markup-markup node) "")) - (if (string? proc) - (display proc) - (if (procedure? proc) - (proc node e))))))) - -;*---------------------------------------------------------------------*/ -;* lookup-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (lookup-markup-writer node e) - (with-access::%engine e (writers delegate) - (let loop ((w* writers)) - (cond - ((pair? w*) - (with-access::%writer (car w*) (pred) - (if (pred node e) - (car w*) - (loop (cdr w*))))) - ((engine? delegate) - (lookup-markup-writer node delegate)) - (else - #f))))) - -;*---------------------------------------------------------------------*/ -;* make-writer-predicate ... */ -;*---------------------------------------------------------------------*/ -(define (make-writer-predicate markup predicate class) - (let* ((t1 (if (symbol? markup) - (lambda (n e) (is-markup? n markup)) - (lambda (n e) #t))) - (t2 (if class - (lambda (n e) - (and (t1 n e) (equal? (%markup-class n) class))) - t1))) - (if predicate - (cond - ((not (procedure? predicate)) - (skribe-error 'markup-writer - "Illegal predicate (procedure expected)" - predicate)) - ((not (correct-arity? predicate 2)) - (skribe-error 'markup-writer - "Illegal predicate arity (2 arguments expected)" - predicate)) - (else - (lambda (n e) - (and (t2 n e) (predicate n e))))) - t2))) - -;*---------------------------------------------------------------------*/ -;* markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (markup-writer markup - #!optional - engine - #!key - (predicate #f) - (class #f) - (options '()) - (validate #f) - (before #f) - (action #unspecified) - (after #f)) - (let ((e (or engine (default-engine)))) - (cond - ((and (not (symbol? markup)) (not (eq? markup #t))) - (skribe-error 'markup-writer "Illegal markup" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - ((and (not predicate) - (not class) - (null? options) - (not before) - (eq? action #unspecified) - (not after)) - (skribe-error 'markup-writer "Illegal writer" markup)) - (else - (let ((m (make-writer-predicate markup predicate class)) - (ac (if (eq? action #unspecified) - (lambda (n e) - (output (markup-body n) e)) - action))) - (engine-add-writer! e markup m predicate - options before ac after class validate)))))) - -;*---------------------------------------------------------------------*/ -;* copy-markup-writer ... */ -;*---------------------------------------------------------------------*/ -(define (copy-markup-writer markup old-engine - #!optional new-engine - #!key - (predicate #unspecified) - (class #unspecified) - (options #unspecified) - (validate #unspecified) - (before #unspecified) - (action #unspecified) - (after #unspecified)) - (let ((old (markup-writer-get markup old-engine)) - (new-engine (or new-engine old-engine))) - (markup-writer markup new-engine - :pred (if (unspecified? predicate) - (%writer-pred old) - predicate) - :class (if (unspecified? class) - (%writer-class old) - class) - :options (if (unspecified? options) - (%writer-options old) - options) - :validate (if (unspecified? validate) - (%writer-validate old) - validate) - :before (if (unspecified? before) - (%writer-before old) - before) - :action (if (unspecified? action) - (%writer-action old) - action) - :after (if (unspecified? after) - (%writer-after old) after)))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get ... */ -;* ------------------------------------------------------------- */ -;* Finds the writer that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e)) - (let loop ((w* (%engine-writers e))) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class) - (or (eq? pred #unspecified) - (eq? (%writer-upred (car w*)) pred))) - (car w*) - (loop (cdr w*)))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e))) - (else - #f)))))))) - -;*---------------------------------------------------------------------*/ -;* markup-writer-get* ... */ -;* ------------------------------------------------------------- */ -;* Finds alll writers that matches MARKUP with optional CLASS */ -;* attribute. */ -;*---------------------------------------------------------------------*/ -(define (markup-writer-get* markup #!optional engine #!key (class #f)) - (let ((e (or engine (default-engine)))) - (cond - ((not (symbol? markup)) - (skribe-error 'markup-writer "Illegal symbol" markup)) - ((not (engine? e)) - (skribe-error 'markup-writer "Illegal engine" e)) - (else - (let liip ((e e) - (res '())) - (let loop ((w* (%engine-writers e)) - (res res)) - (cond - ((pair? w*) - (if (and (eq? (%writer-ident (car w*)) markup) - (equal? (%writer-class (car w*)) class)) - (loop (cdr w*) (cons (car w*) res)) - (loop (cdr w*) res))) - ((engine? (%engine-delegate e)) - (liip (%engine-delegate e) res)) - (else - (reverse! res))))))))) diff --git a/src/bigloo/xml.scm b/src/bigloo/xml.scm deleted file mode 100644 index d4c662e..0000000 --- a/src/bigloo/xml.scm +++ /dev/null @@ -1,92 +0,0 @@ -;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ -;* ------------------------------------------------------------- */ -;* Author : Manuel Serrano */ -;* Creation : Mon Sep 1 12:08:39 2003 */ -;* Last change : Mon May 17 10:14:24 2004 (serrano) */ -;* Copyright : 2003-04 Manuel Serrano */ -;* ------------------------------------------------------------- */ -;* XML fontification */ -;*=====================================================================*/ - -;*---------------------------------------------------------------------*/ -;* The module */ -;*---------------------------------------------------------------------*/ -(module skribe_xml - - (include "new.sch") - - (import skribe_types - skribe_lib - skribe_resolve - skribe_eval - skribe_api - skribe_param - skribe_source) - - (export xml)) - -;*---------------------------------------------------------------------*/ -;* xml ... */ -;*---------------------------------------------------------------------*/ -(define xml - (new language - (name "xml") - (fontifier xml-fontifier) - (extractor #f))) - -;*---------------------------------------------------------------------*/ -;* xml-fontifier ... */ -;*---------------------------------------------------------------------*/ -(define (xml-fontifier s) - (let ((g (regular-grammar () - ((: #\; (in "<!--") (* (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/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)))) diff --git a/src/guile/Makefile.am b/src/guile/Makefile.am new file mode 100644 index 0000000..afe4667 --- /dev/null +++ b/src/guile/Makefile.am @@ -0,0 +1,4 @@ +SUBDIRS = skribilo + +bin_SCRIPTS = skribilo.scm +EXTRA_DIST = README diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am new file mode 100644 index 0000000..c86f2f3 --- /dev/null +++ b/src/guile/skribilo/Makefile.am @@ -0,0 +1,9 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm + +SUBDIRS = reader engine package skribe coloring diff --git a/src/guile/skribilo/Makefile.in b/src/guile/skribilo/Makefile.in index 80a26de..add7d0e 100644 --- a/src/guile/skribilo/Makefile.in +++ b/src/guile/skribilo/Makefile.in @@ -1,110 +1,463 @@ -# -# Makefile.in -- Skribe Src Makefile -# -# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -# -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# +# Makefile.in generated by automake 1.9.6 from Makefile.am. +# @configure_input@ + +# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, +# 2003, 2004, 2005 Free Software Foundation, Inc. +# This Makefile.in is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + # This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -# USA. -# -# Author: Erick Gallesio [eg@essi.fr] -# Creation date: 10-Aug-2003 20:26 (eg) -# Last file update: 6-Mar-2004 16:00 (eg) -# -include ../../etc/stklos/Makefile.skb +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. -prefix=@PREFIX@ +@SET_MAKE@ -SKR = $(wildcard ../../skr/*.skr) +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ +pkgdatadir = $(datadir)/@PACKAGE@ +pkglibdir = $(libdir)/@PACKAGE@ +pkgincludedir = $(includedir)/@PACKAGE@ +top_builddir = ../../.. +am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd +INSTALL = @INSTALL@ +install_sh_DATA = $(install_sh) -c -m 644 +install_sh_PROGRAM = $(install_sh) -c +install_sh_SCRIPT = $(install_sh) -c +INSTALL_HEADER = $(INSTALL_DATA) +transform = $(program_transform_name) +NORMAL_INSTALL = : +PRE_INSTALL = : +POST_INSTALL = : +NORMAL_UNINSTALL = : +PRE_UNINSTALL = : +POST_UNINSTALL = : +subdir = src/guile/skribilo +DIST_COMMON = $(dist_guilemodule_DATA) $(srcdir)/Makefile.am \ + $(srcdir)/Makefile.in $(srcdir)/config.scm.in +ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 +am__aclocal_m4_deps = $(top_srcdir)/configure.ac +am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ + $(ACLOCAL_M4) +mkinstalldirs = $(install_sh) -d +CONFIG_CLEAN_FILES = config.scm +SOURCES = +DIST_SOURCES = +RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \ + html-recursive info-recursive install-data-recursive \ + install-exec-recursive install-info-recursive \ + install-recursive installcheck-recursive installdirs-recursive \ + pdf-recursive ps-recursive uninstall-info-recursive \ + uninstall-recursive +am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; +am__vpath_adj = case $$p in \ + $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ + *) f=$$p;; \ + esac; +am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; +am__installdirs = "$(DESTDIR)$(guilemoduledir)" +dist_guilemoduleDATA_INSTALL = $(INSTALL_DATA) +DATA = $(dist_guilemodule_DATA) +ETAGS = etags +CTAGS = ctags +DIST_SUBDIRS = $(SUBDIRS) +DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) +ACLOCAL = @ACLOCAL@ +AMTAR = @AMTAR@ +AUTOCONF = @AUTOCONF@ +AUTOHEADER = @AUTOHEADER@ +AUTOMAKE = @AUTOMAKE@ +AWK = @AWK@ +CYGPATH_W = @CYGPATH_W@ +DEFS = @DEFS@ +ECHO_C = @ECHO_C@ +ECHO_N = @ECHO_N@ +ECHO_T = @ECHO_T@ +GUILE = @GUILE@ +GUILE_CONFIG = @GUILE_CONFIG@ +GUILE_SITE = @GUILE_SITE@ +GUILE_TOOLS = @GUILE_TOOLS@ +HAVE_LOUT_FALSE = @HAVE_LOUT_FALSE@ +HAVE_LOUT_TRUE = @HAVE_LOUT_TRUE@ +INSTALL_DATA = @INSTALL_DATA@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_SCRIPT = @INSTALL_SCRIPT@ +INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ +LIBOBJS = @LIBOBJS@ +LIBS = @LIBS@ +LOUT = @LOUT@ +LTLIBOBJS = @LTLIBOBJS@ +MAKEINFO = @MAKEINFO@ +PACKAGE = @PACKAGE@ +PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ +PACKAGE_NAME = @PACKAGE_NAME@ +PACKAGE_STRING = @PACKAGE_STRING@ +PACKAGE_TARNAME = @PACKAGE_TARNAME@ +PACKAGE_VERSION = @PACKAGE_VERSION@ +PATH_SEPARATOR = @PATH_SEPARATOR@ +SET_MAKE = @SET_MAKE@ +SHELL = @SHELL@ +SKRIBILO_DOC_DIR = @SKRIBILO_DOC_DIR@ +SKRIBILO_EXT_DIR = @SKRIBILO_EXT_DIR@ +SKRIBILO_SKR_PATH = @SKRIBILO_SKR_PATH@ +STRIP = @STRIP@ +VERSION = @VERSION@ +ac_ct_STRIP = @ac_ct_STRIP@ +am__leading_dot = @am__leading_dot@ +am__tar = @am__tar@ +am__untar = @am__untar@ +bindir = @bindir@ +build_alias = @build_alias@ +datadir = @datadir@ +exec_prefix = @exec_prefix@ +host_alias = @host_alias@ +includedir = @includedir@ +infodir = @infodir@ +install_sh = @install_sh@ +libdir = @libdir@ +libexecdir = @libexecdir@ +localstatedir = @localstatedir@ +mandir = @mandir@ +mkdir_p = @mkdir_p@ +oldincludedir = @oldincludedir@ +prefix = @prefix@ +program_transform_name = @program_transform_name@ +sbindir = @sbindir@ +sharedstatedir = @sharedstatedir@ +sysconfdir = @sysconfdir@ +target_alias = @target_alias@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = biblio.scm color.scm config.scm \ + debug.scm engine.scm evaluator.scm \ + lib.scm module.scm output.scm prog.scm \ + reader.scm resolve.scm runtime.scm \ + source.scm types.scm vars.scm verify.scm \ + writer.scm -DEPS= ../common/configure.scm ../common/param.scm ../common/api.scm \ - ../common/index.scm ../common/bib.scm ../common/lib.scm +SUBDIRS = reader engine package skribe coloring +all: all-recursive -SRCS= biblio.stk c.stk color.stk configure.stk debug.stk engine.stk \ - eval.stk lib.stk lisp.stk main.stk output.stk prog.stk reader.stk \ - resolve.stk runtime.stk source.stk types.stk vars.stk \ - verify.stk writer.stk xml.stk +.SUFFIXES: +$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) + @for dep in $?; do \ + case '$(am__configure_deps)' in \ + *$$dep*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \ + && exit 0; \ + exit 1;; \ + esac; \ + done; \ + echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/guile/skribilo/Makefile'; \ + cd $(top_srcdir) && \ + $(AUTOMAKE) --gnu src/guile/skribilo/Makefile +.PRECIOUS: Makefile +Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status + @case '$?' in \ + *config.status*) \ + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ + *) \ + echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ + esac; -LEXFILES = c-lex.l lisp-lex.l xml-lex.l +$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh -LEXSRCS = c-lex.stk lisp-lex.stk xml-lex.stk +$(top_srcdir)/configure: $(am__configure_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +$(ACLOCAL_M4): $(am__aclocal_m4_deps) + cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh +config.scm: $(top_builddir)/config.status $(srcdir)/config.scm.in + cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ +uninstall-info-am: +install-dist_guilemoduleDATA: $(dist_guilemodule_DATA) + @$(NORMAL_INSTALL) + test -z "$(guilemoduledir)" || $(mkdir_p) "$(DESTDIR)$(guilemoduledir)" + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ + f=$(am__strip_dir) \ + echo " $(dist_guilemoduleDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + $(dist_guilemoduleDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -BINDIR=../../bin +uninstall-dist_guilemoduleDATA: + @$(NORMAL_UNINSTALL) + @list='$(dist_guilemodule_DATA)'; for p in $$list; do \ + f=$(am__strip_dir) \ + echo " rm -f '$(DESTDIR)$(guilemoduledir)/$$f'"; \ + rm -f "$(DESTDIR)$(guilemoduledir)/$$f"; \ + done -EXE= $(BINDIR)/skribe.stklos +# This directory's subdirectories are mostly independent; you can cd +# into them and run `make' without going through this Makefile. +# To change the values of `make' variables: instead of editing Makefiles, +# (1) if the variable is set in `config.status', edit `config.status' +# (which will cause the Makefiles to be regenerated when you run `make'); +# (2) otherwise, pass the desired values on the `make' command line. +$(RECURSIVE_TARGETS): + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + target=`echo $@ | sed s/-recursive//`; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + dot_seen=yes; \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done; \ + if test "$$dot_seen" = "no"; then \ + $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ + fi; test -z "$$fail" -PRCS_FILES = Makefile.in $(SRCS) $(LEXFILES) +mostlyclean-recursive clean-recursive distclean-recursive \ +maintainer-clean-recursive: + @failcom='exit 1'; \ + for f in x $$MAKEFLAGS; do \ + case $$f in \ + *=* | --[!k]*);; \ + *k*) failcom='fail=yes';; \ + esac; \ + done; \ + dot_seen=no; \ + case "$@" in \ + distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ + *) list='$(SUBDIRS)' ;; \ + esac; \ + rev=''; for subdir in $$list; do \ + if test "$$subdir" = "."; then :; else \ + rev="$$subdir $$rev"; \ + fi; \ + done; \ + rev="$$rev ."; \ + target=`echo $@ | sed s/-recursive//`; \ + for subdir in $$rev; do \ + echo "Making $$target in $$subdir"; \ + if test "$$subdir" = "."; then \ + local_target="$$target-am"; \ + else \ + local_target="$$target"; \ + fi; \ + (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ + || eval $$failcom; \ + done && test -z "$$fail" +tags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \ + done +ctags-recursive: + list='$(SUBDIRS)'; for subdir in $$list; do \ + test "$$subdir" = . || (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \ + done -SFLAGS= +ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + mkid -fID $$unique +tags: TAGS -all: $(EXE) +TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ + include_option=--etags-include; \ + empty_fix=.; \ + else \ + include_option=--include; \ + empty_fix=; \ + fi; \ + list='$(SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test ! -f $$subdir/TAGS || \ + tags="$$tags $$include_option=$$here/$$subdir/TAGS"; \ + fi; \ + done; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ + test -n "$$unique" || unique=$$empty_fix; \ + $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ + $$tags $$unique; \ + fi +ctags: CTAGS +CTAGS: ctags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ + $(TAGS_FILES) $(LISP) + tags=; \ + here=`pwd`; \ + list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ + unique=`for i in $$list; do \ + if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ + done | \ + $(AWK) ' { files[$$0] = 1; } \ + END { for (i in files) print i; }'`; \ + test -z "$(CTAGS_ARGS)$$tags$$unique" \ + || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ + $$tags $$unique -Makefile: Makefile.in - (cd ../../etc/stklos; autoconf; configure) +GTAGS: + here=`$(am__cd) $(top_builddir) && pwd` \ + && cd $(top_srcdir) \ + && gtags -i $(GTAGS_ARGS) $$here -$(EXE): $(DEPS) $(BINDIR) $(LEXSRCS) $(SRCS) - stklos-compile $(SFLAGS) -o $(EXE) main.stk && \ - chmod $(BMASK) $(EXE) +distclean-tags: + -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags -# -# Lex files -# -lisp-lex.stk: lisp-lex.l - stklos-genlex lisp-lex.l lisp-lex.stk lisp-lex +distdir: $(DISTFILES) + @srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \ + topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \ + list='$(DISTFILES)'; for file in $$list; do \ + case $$file in \ + $(srcdir)/*) file=`echo "$$file" | sed "s|^$$srcdirstrip/||"`;; \ + $(top_srcdir)/*) file=`echo "$$file" | sed "s|^$$topsrcdirstrip/|$(top_builddir)/|"`;; \ + esac; \ + if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ + dir=`echo "$$file" | sed -e 's,/[^/]*$$,,'`; \ + if test "$$dir" != "$$file" && test "$$dir" != "."; then \ + dir="/$$dir"; \ + $(mkdir_p) "$(distdir)$$dir"; \ + else \ + dir=''; \ + fi; \ + if test -d $$d/$$file; then \ + if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ + cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ + fi; \ + cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ + else \ + test -f $(distdir)/$$file \ + || cp -p $$d/$$file $(distdir)/$$file \ + || exit 1; \ + fi; \ + done + list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ + if test "$$subdir" = .; then :; else \ + test -d "$(distdir)/$$subdir" \ + || $(mkdir_p) "$(distdir)/$$subdir" \ + || exit 1; \ + distdir=`$(am__cd) $(distdir) && pwd`; \ + top_distdir=`$(am__cd) $(top_distdir) && pwd`; \ + (cd $$subdir && \ + $(MAKE) $(AM_MAKEFLAGS) \ + top_distdir="$$top_distdir" \ + distdir="$$distdir/$$subdir" \ + distdir) \ + || exit 1; \ + fi; \ + done +check-am: all-am +check: check-recursive +all-am: Makefile $(DATA) +installdirs: installdirs-recursive +installdirs-am: + for dir in "$(DESTDIR)$(guilemoduledir)"; do \ + test -z "$$dir" || $(mkdir_p) "$$dir"; \ + done +install: install-recursive +install-exec: install-exec-recursive +install-data: install-data-recursive +uninstall: uninstall-recursive -xml-lex.stk: xml-lex.l - stklos-genlex xml-lex.l xml-lex.stk xml-lex +install-am: all-am + @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am -c-lex.stk: c-lex.l - stklos-genlex c-lex.l c-lex.stk c-lex +installcheck: installcheck-recursive +install-strip: + $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ + install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ + `test -z '$(STRIP)' || \ + echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install +mostlyclean-generic: +clean-generic: -install: $(INSTALL_BINDIR) - cp $(EXE) $(INSTALL_BINDIR)/skribe.stklos \ - && chmod $(BMASK) $(INSTALL_BINDIR)/skribe.stklos - rm -f $(INSTALL_BINDIR)/skribe - ln -s skribe.stklos $(INSTALL_BINDIR)/skribe +distclean-generic: + -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -uninstall: - rm $(INSTALL_BINDIR)/skribe - rm $(INSTALL_BINDIR)/skribe.stklos +maintainer-clean-generic: + @echo "This command is intended for maintainers to use" + @echo "it deletes files that may require special tools to rebuild." +clean: clean-recursive -$(BINDIR): - mkdir -p $(BINDIR) && chmod a+rx $(BINDIR) +clean-am: clean-generic mostlyclean-am -$(INSTALL_BINDIR): - mkdir -p $(INSTALL_BINDIR) && chmod a+rx $(INSTALL_BINDIR) +distclean: distclean-recursive + -rm -f Makefile +distclean-am: clean-am distclean-generic distclean-tags -## -## Services -## -tags: TAGS +dvi: dvi-recursive + +dvi-am: + +html: html-recursive + +info: info-recursive + +info-am: + +install-data-am: install-dist_guilemoduleDATA + +install-exec-am: + +install-info: install-info-recursive + +install-man: + +installcheck-am: + +maintainer-clean: maintainer-clean-recursive + -rm -f Makefile +maintainer-clean-am: distclean-am maintainer-clean-generic + +mostlyclean: mostlyclean-recursive + +mostlyclean-am: mostlyclean-generic + +pdf: pdf-recursive + +pdf-am: + +ps: ps-recursive -TAGS: $(SRCS) - etags -l scheme $(SRCS) +ps-am: -pop: - @echo $(PRCS_FILES:%=src/stklos/%) +uninstall-am: uninstall-dist_guilemoduleDATA uninstall-info-am -links: - ln -s $(DEPS) . - ln -s $(SKR) . +uninstall-info: uninstall-info-recursive -clean: - /bin/rm -f skribe $(EXE) *~ TAGS *.scm *.skr +.PHONY: $(RECURSIVE_TARGETS) CTAGS GTAGS all all-am check check-am \ + clean clean-generic clean-recursive ctags ctags-recursive \ + distclean distclean-generic distclean-recursive distclean-tags \ + distdir dvi dvi-am html html-am info info-am install \ + install-am install-data install-data-am \ + install-dist_guilemoduleDATA install-exec install-exec-am \ + install-info install-info-am install-man install-strip \ + installcheck installcheck-am installdirs installdirs-am \ + maintainer-clean maintainer-clean-generic \ + maintainer-clean-recursive mostlyclean mostlyclean-generic \ + mostlyclean-recursive pdf pdf-am ps ps-am tags tags-recursive \ + uninstall uninstall-am uninstall-dist_guilemoduleDATA \ + uninstall-info-am -distclean: clean - /bin/rm -f Makefile - /bin/rm -f ../common/configure.scm +# Tell versions [3.59,3.63) of GNU make to not export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am new file mode 100644 index 0000000..d518553 --- /dev/null +++ b/src/guile/skribilo/coloring/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = c.scm lisp.scm xml.scm diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm index 53cf670..ad02431 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,46 +1,46 @@ ;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; +;;;; lisp.scm -- Lisp Family Fontification +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 16-Oct-2003 22:17 (eg) ;;;; Last file update: 28-Oct-2004 21:14 (eg) ;;;; -(require "lex-rt") ;; to avoid module problems +(define-module (skribilo coloring lisp) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo runtime) + :export (skribe scheme stklos bigloo lisp)) -(define-module (skribilo lisp) - :export (skribe scheme stklos bigloo lisp) - :import (skribe source)) -(include "lisp-lex.stk") ;; SILex generated - -(define *bracket-highlight* #f) -(define *class-highlight* #f) -(define *the-keys* #f) +(define *bracket-highlight* (make-fluid)) +(define *class-highlight* (make-fluid)) +(define *the-keys* (make-fluid)) -(define *lisp-keys* #f) -(define *scheme-keys* #f) -(define *skribe-keys* #f) -(define *stklos-keys* #f) -(define *lisp-keys* #f) +(define *lisp-keys* (make-fluid)) +(define *scheme-keys* (make-fluid)) +(define *skribe-keys* (make-fluid)) +(define *stklos-keys* (make-fluid)) +(define *lisp-keys* (make-fluid)) ;;; @@ -57,17 +57,17 @@ (define (lisp-family-fontifier s) - (let ((lex (lisp-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) + (let ((lisp-input (open-input-string s))) + (let loop ((token (read lisp-input)) (res '())) - (if (eq? token 'eof) + (if (eof-object? token) (reverse! res) - (Loop (lexer-next-token lex) + (loop (read lisp-input) (cons token res)))))) ;;;; ====================================================================== ;;;; -;;;; LISP +;;;; LISP ;;;; ;;;; ====================================================================== (define (lisp-extractor iport def tab) @@ -77,17 +77,17 @@ (lambda (exp) (match-case exp (((or defun defmacro) ?fun ?- . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) ((defvar ?var . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-lisp-keys) (unless *lisp-keys* (set! *lisp-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(setq if let let* letrec cond case else progn lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -95,9 +95,9 @@ *lisp-keys*) (define (lisp-fontifier s) - (fluid-let ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) @@ -109,7 +109,7 @@ ;;;; ====================================================================== ;;;; -;;;; SCHEME +;;;; SCHEME ;;;; ;;;; ====================================================================== (define (scheme-extractor iport def tab) @@ -130,7 +130,7 @@ (unless *scheme-keys* (set! *scheme-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(set! if let let* letrec quote cond case else begin do lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -139,11 +139,11 @@ (define (scheme-fontifier s) - (fluid-let ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) - + (define scheme (new language @@ -153,7 +153,7 @@ ;;;; ====================================================================== ;;;; -;;;; STKLOS +;;;; STKLOS ;;;; ;;;; ====================================================================== (define (stklos-extractor iport def tab) @@ -164,11 +164,11 @@ (match-case exp (((or define define-generic define-method define-macro) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-module) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-stklos-keys) @@ -192,9 +192,9 @@ (define (stklos-fontifier s) - (fluid-let ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -206,7 +206,7 @@ ;;;; ====================================================================== ;;;; -;;;; SKRIBE +;;;; SKRIBE ;;;; ;;;; ====================================================================== (define (skribe-extractor iport def tab) @@ -250,12 +250,12 @@ (map (lambda (x) (cons x '&source-define)) '(define-markup))))) *skribe-keys*) - + (define (skribe-fontifier s) - (fluid-let ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -267,7 +267,7 @@ ;;;; ====================================================================== ;;;; -;;;; BIGLOO +;;;; BIGLOO ;;;; ;;;; ====================================================================== (define (bigloo-extractor iport def tab) @@ -279,15 +279,14 @@ (((or define define-inline define-generic define-method define-macro define-expander) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define bigloo (new language (name "bigloo") (fontifier scheme-fontifier) (extractor bigloo-extractor))) - diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm index d71e98c..e3db36f 100644 --- a/src/guile/skribilo/coloring/xml.scm +++ b/src/guile/skribilo/coloring/xml.scm @@ -1,53 +1,82 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:33 (eg) -;;;; Last file update: 28-Dec-2003 17:33 (eg) -;;;; - - -;(require "lex-rt") ;; to avoid module problems - - -(define-module (skribilo xml) - :export (xml)) - -(use-modules (skribilo source)) - -(include "xml-lex.stk") ;; SILex generated - -(define (xml-fontifier s) - (let ((lex (xml-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (Loop (lexer-next-token lex) - (cons token res)))))) +;;; xml.scm -- XML syntax highlighting. +;;; +;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +(define-module (skribilo coloring xml) + :export (xml) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (ice-9 rdelim) + :use-module (ice-9 regex)) + + +(define %comment-rx (make-regexp "<!--(.|\\n)*-->" regexp/extended)) + +(define (xml-fontifier str) + (let loop ((start 0) + (result '())) + (if (>= start (string-length str)) + (reverse! result) + (case (string-ref str start) + ((#\") + (let ((end (string-index str start #\"))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML string" + (string-drop str start)) + (loop end + (cons (new markup + (markup '&source-string) + (body (substring str start end))) + result))))) + ((#\<) + (let ((end (string-index str #\> start))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML tag" + (string-drop str start)) + (let ((comment? (regexp-exec %comment-rx + (substring str start end)))) + (loop end + (cons (if comment? + (new markup + (markup '&source-comment) + (body (substring str start end))) + (new markup + (markup '&source-module) + (body (substring str start end)))) + result)))))) + + (else + (loop (+ 1 start) + (if (or (null? result) + (not (string? (car result)))) + (cons (string (string-ref str start)) result) + (cons (string-append (car result) + (string (string-ref str start))) + (cdr result))))))))) + + (define xml (new language (name "xml") (fontifier xml-fontifier) (extractor #f))) +;;; xml.scm ends here diff --git a/src/guile/skribilo/config.scm.in b/src/guile/skribilo/config.scm.in index a5e3b7c..51e7a93 100644 --- a/src/guile/skribilo/config.scm.in +++ b/src/guile/skribilo/config.scm.in @@ -3,7 +3,7 @@ (define-module (skribilo config)) -(define-public (skribilo-release) "1.3") +(define-public (skribilo-release) "1.2") (define-public (skribilo-url) "http://www.laas.fr/~lcourtes/") (define-public (skribilo-doc-directory) "@SKRIBILO_DOC_DIR@") (define-public (skribilo-extension-directory) "@SKRIBILO_EXT_DIR@") diff --git a/src/guile/skribilo/engine/Makefile.am b/src/guile/skribilo/engine/Makefile.am new file mode 100644 index 0000000..7b6ec2c --- /dev/null +++ b/src/guile/skribilo/engine/Makefile.am @@ -0,0 +1,5 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/engine +dist_guilemodule_DATA = base.scm context.scm html.scm html4.scm \ + latex-simple.scm latex.scm \ + lout.scm \ + xml.scm diff --git a/src/guile/skribilo/engine/html.scm b/src/guile/skribilo/engine/html.scm index 3ad7da6..6e0dc85 100644 --- a/src/guile/skribilo/engine/html.scm +++ b/src/guile/skribilo/engine/html.scm @@ -82,7 +82,7 @@ ;*---------------------------------------------------------------------*/ ;* html-engine ... */ ;*---------------------------------------------------------------------*/ -(define html-engine +(define-public html-engine ;; setup the html engine (default-engine-set! (make-engine 'html diff --git a/src/guile/skribilo/engine/latex.scm b/src/guile/skribilo/engine/latex.scm index 8bd0ae3..2a59b4f 100644 --- a/src/guile/skribilo/engine/latex.scm +++ b/src/guile/skribilo/engine/latex.scm @@ -16,6 +16,8 @@ ;* @ref ../../doc/user/latexe.skb:ref@ */ ;*=====================================================================*/ +(define-skribe-module (skribilo engine latex)) + ;*---------------------------------------------------------------------*/ ;* latex-verbatim-encoding ... */ ;*---------------------------------------------------------------------*/ diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b675e8a..36df9f9 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -384,10 +384,10 @@ " @PageMark @Tag\n" "}\n\n" - "# @SkribeLeaders is used in `toc'\n" + "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" - "def @SkribeLeaders { " - ,leader " |" ,leader-space " @SkribeLeaders }\n\n")))) + "def @SkribiloLeaders { " + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -397,7 +397,8 @@ (author (markup-option doc :author)) (date-line (engine-custom engine 'date-line)) (cover-sheet? (engine-custom engine 'cover-sheet?)) - (multi-column? (> 1 (engine-custom engine 'column-number)))) + (multi-column? (> (engine-custom engine 'column-number) 1))) + (if multi-column? ;; In single-column document, `@FullWidth' yields a blank page. (display "\n@FullWidth {")) @@ -1205,7 +1206,7 @@ (entry-proc node engine) (display " &1rt @OneCol { ") - (printf " @SkribeLeaders & @PageOf { ~a }" + (printf " @SkribiloLeaders & @PageOf { ~a }" (lout-tagify (markup-ident node))) (display " &0io } }") @@ -2876,93 +2877,93 @@ ;*---------------------------------------------------------------------*/ ;* Slides */ ;* */ -;* At some point, this should move to `slide.skr'. */ -;*---------------------------------------------------------------------*/ -; (skribe-load "slide.skr") - -; (markup-writer 'slide -; ;; FIXME: In `slide.skr', `:ident' is systematically generated. -; :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) - -; :validate (lambda (n e) -; (eq? (engine-custom e 'document-type) 'slides)) - -; :before (lambda (n e) -; (display "\n@Overhead\n") -; (display " @Title { ") -; (output (markup-option n :title) e) -; (display " }\n") -; (if (markup-ident n) -; (begin -; (display " @Tag { ") -; (display (lout-tagify (markup-ident n))) -; (display " }\n"))) -; (if (markup-option n :number) -; (begin -; (display " @BypassNumber { ") -; (output (markup-option n :number) e) -; (display " }\n"))) -; (display "@Begin\n") - -; ;; `doc' documents produce their PDF outline right after -; ;; `@Text @Begin'; other types of documents must produce it -; ;; as part of their first chapter. -; (lout-output-pdf-meta-info (ast-document n) e)) - -; :after "@End @Overhead\n") - -; (markup-writer 'slide-vspace -; :options '(:unit) -; :validate (lambda (n e) -; (and (pair? (markup-body n)) -; (number? (car (markup-body n))))) -; :action (lambda (n e) -; (printf "\n//~a~a # slide-vspace\n" -; (car (markup-body n)) -; (case (markup-option n :unit) -; ((cm) "c") -; ((point points pt) "p") -; ((inch inches) "i") -; (else -; (skribe-error 'lout -; "Unknown vspace unit" -; (markup-option n :unit))))))) - -; (markup-writer 'slide-pause -; ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. -; ;; << /Type /Action -; ;; << /S /Trans -; ;; entry in the trans dict -; ;; << /Type /Trans /S /Dissolve >> -; :action (lambda (n e) -; (let ((filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark " -; [ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) -; (display (lout-embedded-postscript-code -; (filter pdfmark)))))) - -; ;; For movies, see -; ;; http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . -; (markup-writer 'slide-embed -; :options '(:alt :geometry :rgeometry :geometry-opt :command) -; ;; FIXME: `pdfmark'. -; ;; << /Type /Action /S /Launch -; :action (lambda (n e) -; (let ((command (markup-option n :command)) -; (filter (make-string-replace lout-verbatim-encoding)) -; (pdfmark "[ /Rect [ 0 ysize xsize 0 ] -; /Name /Comment -; /Contents (This is an embedded application) -; /ANN pdfmark - -; [ /Type /Action -; /S /Launch -; /F (~a) -; /OBJ pdfmark")) -; (display (string-append -; "4c @Wide 3c @High " -; (lout-embedded-postscript-code -; (filter (format #f pdfmark command)))))))) +;* At some point, we might want to move this to `slide.scm'. */ +;*---------------------------------------------------------------------*/ + +(use-modules (skribilo packages slide)) + +(markup-writer 'slide + :options '(:title :number :toc :ident) ;; '(:bg :vspace :image) + + :validate (lambda (n e) + (eq? (engine-custom e 'document-type) 'slides)) + + :before (lambda (n e) + (display "\n@Overhead\n") + (display " @Title { ") + (output (markup-option n :title) e) + (display " }\n") + (if (markup-ident n) + (begin + (display " @Tag { ") + (display (lout-tagify (markup-ident n))) + (display " }\n"))) + (if (markup-option n :number) + (begin + (display " @BypassNumber { ") + (output (markup-option n :number) e) + (display " }\n"))) + (display "@Begin\n") + + ;; `doc' documents produce their PDF outline right after + ;; `@Text @Begin'; other types of documents must produce it + ;; as part of their first chapter. + (lout-output-pdf-meta-info (ast-document n) e)) + + :after "@End @Overhead\n") + +(markup-writer 'slide-vspace + :options '(:unit) + :validate (lambda (n e) + (and (pair? (markup-body n)) + (number? (car (markup-body n))))) + :action (lambda (n e) + (printf "\n//~a~a # slide-vspace\n" + (car (markup-body n)) + (case (markup-option n :unit) + ((cm) "c") + ((point points pt) "p") + ((inch inches) "i") + (else + (skribe-error 'lout + "Unknown vspace unit" + (markup-option n :unit))))))) + +(markup-writer 'slide-pause + ;; FIXME: Use a `pdfmark' custom action and a PDF transition action. + ;; << /Type /Action + ;; << /S /Trans + ;; entry in the trans dict + ;; << /Type /Trans /S /Dissolve >> + :action (lambda (n e) + (let ((filter (make-string-replace lout-verbatim-encoding)) + (pdfmark " +[ {ThisPage} << /Trans << /S /Wipe /Dm /V /D 3 /M /O >> >> /PUT pdfmark")) + (display (lout-embedded-postscript-code + (filter pdfmark)))))) + +For movies, see +http://www.tug.org/tex-archive/macros/latex/contrib/movie15/movie15.sty . +(markup-writer 'slide-embed + :options '(:alt :geometry :rgeometry :geometry-opt :command) + ;; FIXME: `pdfmark'. + ;; << /Type /Action /S /Launch + :action (lambda (n e) + (let ((command (markup-option n :command)) + (filter (make-string-replace lout-verbatim-encoding)) + (pdfmark "[ /Rect [ 0 ysize xsize 0 ] + /Name /Comment + /Contents (This is an embedded application) + /ANN pdfmark + +[ /Type /Action + /S /Launch + /F (~a) + /OBJ pdfmark")) + (display (string-append + "4c @Wide 3c @High " + (lout-embedded-postscript-code + (filter (format #f pdfmark command)))))))) ;*---------------------------------------------------------------------*/ ;* Restore the base engine */ diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 703186c..def3280 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -39,8 +39,11 @@ (skribilo types) (skribilo lib) (skribilo vars) + (ice-9 optargs) - (oop goops)) + (oop goops) + (srfi srfi-13) + (srfi srfi-1)) @@ -49,8 +52,21 @@ (define *skribe-loaded* '()) ;; List of already loaded files (define *skribe-load-options* '()) +;;; +;;; %EVALUATE +;;; (define (%evaluate expr) - (eval expr (current-module))) + (let ((result (eval expr (current-module)))) + (if (or (ast? result) (markup? result)) + (let ((file (source-property expr 'filename)) + (line (source-property expr 'line)) + (column (source-property expr 'column))) + (format #t "~%~%*** source props for `~a': ~a~%~%" + result (source-properties expr)) + (slot-set! result 'loc + (make <location> + :file file :line line :pos column)))) + result)) @@ -74,6 +90,8 @@ (reader %default-reader)) (with-debug 2 'skribe-eval-port (debug-item "engine=" engine) + (debug-item "reader=" reader) + (let ((e (if (symbol? engine) (find-engine engine) engine))) (debug-item "e=" e) (if (not (is-a? e <engine>)) @@ -104,22 +122,31 @@ ((engine? engine) engine) ((not (symbol? engine)) (skribe-error 'skribe-load - "Illegal engine" engine)) + "illegal engine" engine)) (else engine))) - (path (cond - ((not path) (skribe-path)) - ((string? path) (list path)) - ((not (and (list? path) (every? string? path))) - (skribe-error 'skribe-load "Illegal path" path)) - (else path))) - (filep (search-path path file))) + (path (append (cond + ((not path) (skribe-path)) + ((string? path) (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "illegal path" path)) + (else path)) + %load-path)) + (filep (or (search-path path file) + (search-path (append path %load-path) file) + (search-path (append path %load-path) + (let ((dot (string-rindex file #\.))) + (if dot + (string-append + (string-take file dot) + ".scm") + file)))))) (set! *skribe-load-options* opt) (unless (and (string? filep) (file-exists? filep)) (skribe-error 'skribe-load (string-append "cannot find `" file "' in path") - (skribe-path))) + path)) ;; Load this file if not already done (unless (member filep *skribe-loaded*) @@ -139,22 +166,23 @@ ;;; (define* (skribe-include file #:optional (path (skribe-path))) (unless (every string? path) - (skribe-error 'skribe-include "Illegal path" path)) + (skribe-error 'skribe-include "illegal path" path)) (let ((path (search-path path file))) (unless (and (string? path) (file-exists? path)) (skribe-error 'skribe-load - (format "Cannot find ~S in path" file) + (format #t "cannot find ~S in path" file) path)) (when (> *skribe-verbose* 0) (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path (lambda () - (let Loop ((exp (read (current-input-port))) + (let Loop ((exp (%default-reader (current-input-port))) (res '())) (if (eof-object? exp) (if (and (pair? res) (null? (cdr res))) - (car res) - (reverse! res)) - (Loop (read (current-input-port)) + (car res) + (reverse! res)) + (Loop (%default-reader (current-input-port)) (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index 8667f7e..2961fc6 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -1,5 +1,5 @@ ;;; -;;; lib.stk -- Utilities +;;; lib.scm -- Utilities ;;; ;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;; @@ -18,11 +18,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -;;; -;;; Author: Erick Gallesio [eg@essi.fr] -;;; Creation date: 11-Aug-2003 20:29 (eg) -;;; Last file update: 27-Oct-2004 12:41 (eg) -;;; (read-set! keywords 'prefix) @@ -59,7 +54,9 @@ hashtable->list skribe-read - find-runtime-type) + find-runtime-type + + date) :export-syntax (new define-markup define-simple-markup define-simple-container define-processor-markup @@ -73,6 +70,8 @@ :use-module (skribilo vars) :use-module (srfi srfi-1) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) ;; date + :use-module (oop goops) :use-module (ice-9 optargs)) @@ -81,11 +80,20 @@ ;;; ;;; NEW ;;; + +(define %types-module (resolve-module '(skribilo types))) + (define-macro (new class . parameters) - `(make ,(string->symbol (format #f "<~a>" class)) - ,@(apply append (map (lambda (x) - `(,(symbol->keyword (car x)) ,(cadr x))) - parameters)))) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo types)' in order to make use of `new'. + (let* ((class-name (symbol-append '< class '>)) + (actual-class (module-ref %types-module class-name))) + `(let ((make ,make) + (,class-name ,actual-class)) + (make ,class-name + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))))) ;;; ;;; DEFINE-MARKUP @@ -99,12 +107,23 @@ (let loop ((args args) (result '()) (rest-arg #f)) - (if (null? args) - (if rest-arg (append (reverse result) rest-arg) (reverse result)) - (let ((is-rest-arg? (eq? (car args) #:rest))) - (loop (if is-rest-arg? (cddr args) (cdr args)) - (if is-rest-arg? result (cons (car args) result)) - (if is-rest-arg? (list (car args) (cadr args)) rest-arg)))))) + (cond ((null? args) + (if rest-arg + (append (reverse result) rest-arg) + (reverse result))) + + ((list? args) + (let ((is-rest-arg? (eq? (car args) #:rest))) + (loop (if is-rest-arg? (cddr args) (cdr args)) + (if is-rest-arg? result (cons (car args) result)) + (if is-rest-arg? + (list (car args) (cadr args)) + rest-arg)))) + + ((pair? args) + (loop '() + (cons (car args) result) + (list #:rest (cdr args))))))) (let ((name (car bindings)) (opts (cdr bindings))) @@ -376,3 +395,9 @@ (define-macro (when condition . exprs) `(if ,condition (begin ,@exprs))) + +(define (date) + (s19:date->string (s19:current-date) "~c")) + + +;;; lib.scm ends here diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 1a8f622..bb0c5ad 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -42,7 +42,6 @@ '((srfi srfi-1) ;; lists (srfi srfi-13) ;; strings ;(srfi srfi-19) ;; date and time - (oop goops) ;; `make' (ice-9 optargs) ;; `define*' (ice-9 and-let-star) ;; `and-let*' (ice-9 receive) ;; `receive' @@ -60,9 +59,13 @@ (skribilo output) (skribilo evaluator) (skribilo color) - (skribilo debug))) + (skribilo debug) + (skribilo source) ;; `source-read-lines', `source-fontify', etc. + (skribilo coloring lisp) ;; `skribe', `scheme', `lisp' + (skribilo coloring xml) ;; `xml' + )) -(define *skribe-core-modules* +(define %skribe-core-modules '("utils" "api" "bib" "index" "param" "sui")) (define-macro (define-skribe-module name . options) @@ -81,7 +84,7 @@ ,(string->symbol mod)))) (and (not (equal? m name)) m))) - *skribe-core-modules*))))) + %skribe-core-modules))))) ;; Make it available to the top-level module. @@ -106,7 +109,7 @@ execution of Skribilo/Skribe code." (map (lambda (mod) `(skribilo skribe ,(string->symbol mod))) - *skribe-core-modules*))) + %skribe-core-modules))) (set-module-name! the-module '(skribilo-user)) the-module)) @@ -152,7 +155,7 @@ hierarchy and in @code{(run-time-module)}." (module-use! (run-time-module) (resolve-module `(skribilo skribe ,(string->symbol mod))))) - *skribe-core-modules*)) + %skribe-core-modules)) ;;; module.scm ends here diff --git a/src/guile/skribilo/package/Makefile.am b/src/guile/skribilo/package/Makefile.am new file mode 100644 index 0000000..6e047d3 --- /dev/null +++ b/src/guile/skribilo/package/Makefile.am @@ -0,0 +1,4 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/package +dist_guilemodule_DATA = acmproc.scm french.scm jfp.scm letter.scm \ + lncs.scm scribe.scm sigplan.scm skribe.scm \ + slide.scm web-article.scm web-book.scm diff --git a/src/guile/skribilo/package/acmproc.scm b/src/guile/skribilo/package/acmproc.scm new file mode 100644 index 0000000..4accc7c --- /dev/null +++ b/src/guile/skribilo/package/acmproc.scm @@ -0,0 +1,155 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/acmproc.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Thu Jun 2 10:55:39 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[letterpaper]{acmproc}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\numberofauthors{~a}\n\\author{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "\\alignauthor\n") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\CopyrightYear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\crdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key (class "abstract") postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :class class :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/bigloo/new.sch b/src/guile/skribilo/package/french.scm index 16bb7d5..bd095db 100644 --- a/src/bigloo/new.sch +++ b/src/guile/skribilo/package/french.scm @@ -1,17 +1,21 @@ ;*=====================================================================*/ -;* serrano/prgm/project/skribe/src/bigloo/new.sch */ +;* serrano/prgm/project/skribe/skr/letter.skr */ ;* ------------------------------------------------------------- */ ;* Author : Manuel Serrano */ -;* Creation : Sun Aug 17 11:58:30 2003 */ -;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Tue Oct 28 14:33:43 2003 (serrano) */ ;* Copyright : 2003 Manuel Serrano */ ;* ------------------------------------------------------------- */ -;* The new facility */ +;* French Skribe style */ ;*=====================================================================*/ +(define-skribe-module (skribilo package french)) + ;*---------------------------------------------------------------------*/ -;* new ... */ +;* LaTeX configuration */ ;*---------------------------------------------------------------------*/ -(define-macro (new id . inits) - `(,(symbol-append 'instantiate::% id) ,@inits)) - +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'usepackage + (string-append (engine-custom le 'usepackage) + "\\usepackage[french]{babel} +\\usepackage{a4}"))) diff --git a/src/guile/skribilo/package/jfp.scm b/src/guile/skribilo/package/jfp.scm new file mode 100644 index 0000000..108b938 --- /dev/null +++ b/src/guile/skribilo/package/jfp.scm @@ -0,0 +1,319 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/jfp.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Mon Oct 11 15:44:08 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for JFP articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package jfp)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{jfp}") + (engine-custom-set! le 'hyperref #f) + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-subauthor) + (let* ((d (ast-document n)) + (sa (and (is-markup? d 'document) + (markup-option d :head-author)))) + (if sa + (begin + (display "[") + (output sa e) + (display "]"))))) + (define (&latex-author-1 n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author") + (&latex-subauthor) + (display "{\n") + (output (car n) e) + (for-each (lambda (a) + (display "\\and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (&latex-author-1 body)) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (&latex-author-n body)) + (else + (skribe-error 'author + "Illegal `jfp' author" + body)))))) + ;; title + (markup-writer '&latex-title le + :before (lambda (n e) + (let* ((d (ast-document n)) + (st (and (is-markup? d 'document) + (markup-option d :head-title)))) + (if st + (begin + (display "\\title[") + (output st e) + (display "]{")) + (display "\\title{")))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (aff (markup-option n :affiliation)) + (addr (markup-option n :address)) + (email (markup-option n :email))) + (if name + (begin + (output name e) + (display "\\\\\n"))) + (if aff + (begin + (output aff e) + (display "\\\\\n"))) + (if addr + (begin + (if (pair? addr) + (for-each (lambda (a) + (output a e) + (display "\\\\\n")) + addr) + (begin + (output addr e) + (display "\\\\\n"))))) + (if email + (begin + (display "\\email{") + (output email e) + (display "}\\\\\n"))))))) + ;; bib-ref + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :before "(" + :action (lambda (n e) + (let ((be (handle-ast (markup-body n)))) + (if (is-markup? be '&bib-entry) + (let ((a (markup-option be 'author)) + (y (markup-option be 'year))) + (cond + ((and (is-markup? a '&bib-entry-author) + (is-markup? y '&bib-entry-year)) + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e) + (display ", ") + (output y e))))) + ((is-markup? y '&bib-entry-year) + (skribe-error 'bib-ref + "Missing `name' entry" + (markup-ident be))) + (else + (let ((ba (markup-body a))) + (if (not (string? ba)) + (output ba e) + (let* ((s1 (pregexp-replace* " and " + ba + " \\& ")) + (s2 (pregexp-replace* ", [^ ]+" + s1 + ""))) + (output s2 e))))))) + (skribe-error 'bib-ref + "Illegal bib-ref" + (markup-ident be))))) + :after ")") + ;; bib-ref/text + (markup-writer 'bib-ref le + :options '(:bib :text :key) + :predicate (lambda (n e) + (markup-option n :key)) + :action (lambda (n e) + (output (markup-option n :key) e))) + ;; &the-bibliography + (markup-writer '&the-bibliography le + :before (lambda (n e) + (display "{% +\\sloppy +\\sfcode`\\.=1000\\relax +\\newdimen\\bibindent +\\bibindent=0em +\\begin{list}{}{% + \\settowidth\\labelwidth{[]}% + \\leftmargin\\labelwidth + \\advance\\leftmargin\\labelsep + \\advance\\leftmargin\\bibindent + \\itemindent -\\bibindent + \\listparindent \\itemindent + }%\n")) + :after (lambda (n e) + (display "\n\\end{list}}\n"))) + ;; bib-entry + (markup-writer '&bib-entry le + :options '(:title) + :action (lambda (n e) + (output n e (markup-writer-get '&bib-entry-body e))) + :after "\n") + ;; %bib-entry-title + (markup-writer '&bib-entry-title le + :action (lambda (n e) + (output (markup-body n) e))) + ;; %bib-entry-body + (markup-writer '&bib-entry-body le + :action (lambda (n e) + (define (output-fields descr) + (display "\\item[") + (let loop ((descr descr) + (pending #f) + (armed #f) + (first #t)) + (cond + ((null? descr) + 'done) + ((pair? (car descr)) + (if (eq? (caar descr) 'or) + (let ((o1 (cadr (car descr)))) + (if (markup-option n o1) + (loop (cons o1 (cdr descr)) + pending + #t + #f) + (let ((o2 (caddr (car descr)))) + (loop (cons o2 (cdr descr)) + pending + armed + #f)))) + (let ((o (markup-option n (cadr (car descr))))) + (if o + (begin + (if (and pending armed) + (output pending e)) + (output (caar descr) e) + (output o e) + (if (pair? (cddr (car descr))) + (output (caddr (car descr)) e)) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f))))) + ((symbol? (car descr)) + (let ((o (markup-option n (car descr)))) + (if o + (begin + (if (and armed pending) + (output pending e)) + (output o e) + (if first + (display "]")) + (loop (cdr descr) #f #t #f)) + (loop (cdr descr) pending armed #f)))) + ((null? (cdr descr)) + (output (car descr) e)) + ((string? (car descr)) + (loop (cdr descr) + (if pending pending (car descr)) + armed + #f)) + (else + (skribe-error 'output-bib-fields + "Illegal description" + (car descr)))))) + (output-fields + (case (markup-option n 'kind) + ((techreport) + `(author (" (" year ")") " " (or title url) ". " + number ", " institution ", " + address ", " month ", " + ("pp. " pages) ".")) + ((article) + `(author (" (" year ")") " " (or title url) ". " + journal ", " volume ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((inproceedings) + `(author (" (" year ")") " " (or title url) ". " + book(or title url) ", " series ", " ("(" number ")") ", " + address ", " month ", " + ("pp. " pages) ".")) + ((book) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")) + ((phdthesis) + '(author (" (" year ")") " " (or title url) ". " type ", " + school ", " address + ", " month ".")) + ((misc) + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ".")) + (else + '(author (" (" year ")") " " (or title url) ". " + publisher ", " address + ", " month ", " ("pp. " pages) ".")))))) + ;; abstract + (markup-writer 'jfp-abstract le + :options '(postscript) + :before "\\begin{abstract}\n" + :after "\\end{abstract}\n")) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-jfp-abstract he + :action (lambda (n e) + (let* ((bg (engine-custom e 'abstract-background)) + (exp (p (if bg + (center (color :bg bg :width 90. + (it (markup-body n)))) + (it (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (new markup + (markup 'jfp-abstract) + (body (p (the-body opt)))) + (let ((a (new markup + (markup '&html-jfp-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (section :title "References" :class "references" + :number (not (engine-format? "latex")) + (font :size -1 (the-bibliography))))) + diff --git a/src/guile/skribilo/package/letter.scm b/src/guile/skribilo/package/letter.scm new file mode 100644 index 0000000..1c39301 --- /dev/null +++ b/src/guile/skribilo/package/letter.scm @@ -0,0 +1,148 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/letter.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Thu Sep 23 20:00:42 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for letters */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package letter)) + +;*---------------------------------------------------------------------*/ +;* document */ +;*---------------------------------------------------------------------*/ +(define %letter-document document) + +(define-markup (document #!rest opt + #!key (ident #f) (class "letter") + where date author + &skribe-eval-location) + (let* ((ubody (the-body opt)) + (body (list (new markup + (markup '&letter-where) + (loc &skribe-eval-location) + (options `((:where ,where) + (:date ,date) + (:author ,author)))) + ubody))) + (apply %letter-document + :author #f :title #f + (append (apply append + (the-options opt :where :date :author :title)) + body)))) + +;*---------------------------------------------------------------------*/ +;* LaTeX configuration */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass[12pt]{letter}\n") + (engine-custom-set! le 'maketitle #f) + ;; &letter-where + (markup-writer '&letter-where le + :before "\\begin{raggedright}\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (output n e) + (when hd + (display "\\hfill ") + (output hd e) + (set! hd #f)) + (display "\\\\\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "\\end{raggedright}\n\\vspace{1cm}\n\n")) + +;*---------------------------------------------------------------------*/ +;* HTML configuration */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + ;; &letter-where + (markup-writer '&letter-where he + :before "<table width=\"100%\">\n" + :action (lambda (n e) + (let* ((w (markup-option n :where)) + (d (markup-option n :date)) + (a (markup-option n :author)) + (hd (if (and w d) + (list w ", " d) + (or w d))) + (ne (copy-engine 'author e))) + ;; author + (markup-writer 'author ne + :options '(:name :title :affiliation :email :url :address :phone :photo :align :header) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone))) + (define (row n) + (display "<tr><td align='left'>") + (output n e) + (when hd + (display "</td><td align='right'>") + (output hd e) + (set! hd #f)) + (display "</td></tr>\n")) + ;; name + (if name (row name)) + ;; title + (if title (row title)) + ;; affiliation + (if affiliation (row affiliation)) + ;; address + (if (pair? address) + (for-each row address)) + ;; telephone + (if phone (row phone)) + ;; email + (if email (row email)) + ;; url + (if url (row url))))) + ;; emit the author + (if a + (output a ne) + (output hd e)))) + :after "</table>\n<hr>\n\n")) + + diff --git a/src/guile/skribilo/package/lncs.scm b/src/guile/skribilo/package/lncs.scm new file mode 100644 index 0000000..2f027d0 --- /dev/null +++ b/src/guile/skribilo/package/lncs.scm @@ -0,0 +1,149 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/lncs.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Fri Jan 16 07:04:51 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for LNCS articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package lncs)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le 'documentclass "\\documentclass{llncs}") + ;; &latex-author + (markup-writer '&latex-author le + :action (lambda (n e) + (define (&latex-inst-body n) + (let ((affiliation (markup-option n :affiliation)) + (address (markup-option n :address))) + (when affiliation (output affiliation e) (display ", ")) + (when address + (for-each (lambda (a) (output a e) (display " ")) + address) + (newline)))) + (define (&latex-inst-n i) + (display "\\institute{\n") + (&latex-inst-body (car i)) + (for-each (lambda (n) + (display "\\and\n") + (&latex-inst-body n)) + (cdr i)) + (display "}\n")) + (define (&latex-author-1 n) + (display "\\author{\n") + (output n e) + (display "}\n")) + (define (&latex-author-n n) + (display "\\author{\n") + (output (car n) e) + (for-each (lambda (a) + (display " and ") + (output a e)) + (cdr n)) + (display "}\n")) + (let ((body (markup-body n))) + (cond + ((is-markup? body 'author) + (markup-option-add! n 'inst 1) + (&latex-author-1 body) + (&latex-inst-n (list body))) + ((and (list? body) + (every? (lambda (b) (is-markup? b 'author)) + body)) + (define (institute=? n1 n2) + (let ((aff1 (markup-option n1 :affiliation)) + (add1 (markup-option n1 :address)) + (aff2 (markup-option n2 :affiliation)) + (add2 (markup-option n2 :address))) + (and (equal? aff1 aff2) (equal? add1 add2)))) + (define (search-institute n i j) + (cond + ((null? i) + #f) + ((institute=? n (car i)) + j) + (else + (search-institute n (cdr i) (- j 1))))) + (if (null? (cdr body)) + (begin + (markup-option-add! (car body) 'inst 1) + (&latex-author-1 (car body)) + (&latex-inst-n body)) + ;; collect the institutes + (let loop ((ns body) + (is '()) + (j 1)) + (if (null? ns) + (begin + (&latex-author-n body) + (&latex-inst-n (reverse! is))) + (let* ((n (car ns)) + (si (search-institute n is (- j 1)))) + (if (integer? si) + (begin + (markup-option-add! n 'inst si) + (loop (cdr ns) is j)) + (begin + (markup-option-add! n 'inst j) + (loop (cdr ns) + (cons n is) + (+ 1 j))))))))) + (else + (skribe-error 'author + "Illegal `lncs' author" + body)))))) + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (lambda (n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (inst (markup-option n 'inst))) + (if name (output name e)) + (if title (output title e)) + (if inst (printf "\\inst{~a}\n" inst))))))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-lncs-abstract he + :action (lambda (n e) + (let* ((bg (or (engine-custom e 'abstract-background) + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e))))) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-lncs-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/scribe.scm b/src/guile/skribilo/package/scribe.scm new file mode 100644 index 0000000..8e99c76 --- /dev/null +++ b/src/guile/skribilo/package/scribe.scm @@ -0,0 +1,231 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/scribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 29 10:07:21 2003 */ +;* Last change : Wed Oct 8 09:56:52 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Scribe Compatibility kit */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package scribe)) + +;*---------------------------------------------------------------------*/ +;* style ... */ +;*---------------------------------------------------------------------*/ +(define (style . styles) + (define (load-style style) + (let ((name (cond + ((string? style) + style) + ((symbol? style) + (string-append (symbol->string style) ".scr"))))) + (skribe-load name :engine *skribe-engine*))) + (for-each load-style styles)) + +;*---------------------------------------------------------------------*/ +;* chapter ... */ +;*---------------------------------------------------------------------*/ +(define skribe-chapter chapter) + +(define-markup (chapter #!rest opt #!key title subtitle split number toc file) + (apply skribe-chapter + :title (or title subtitle) + :number number + :toc toc + :file file + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* table-of-contents ... */ +;*---------------------------------------------------------------------*/ +(define-markup (table-of-contents #!rest opts #!key chapter section subsection) + (apply toc opts)) + +;*---------------------------------------------------------------------*/ +;* frame ... */ +;*---------------------------------------------------------------------*/ +(define skribe-frame frame) + +(define-markup (frame #!rest opt #!key width margin) + (apply skribe-frame + :width (if (real? width) (* 100 width) width) + :margin margin + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* copyright ... */ +;*---------------------------------------------------------------------*/ +(define (copyright) + (symbol 'copyright)) + +;*---------------------------------------------------------------------*/ +;* sect ... */ +;*---------------------------------------------------------------------*/ +(define (sect) + (symbol 'section)) + +;*---------------------------------------------------------------------*/ +;* euro ... */ +;*---------------------------------------------------------------------*/ +(define (euro) + (symbol 'euro)) + +;*---------------------------------------------------------------------*/ +;* tab ... */ +;*---------------------------------------------------------------------*/ +(define (tab) + (char #\tab)) + +;*---------------------------------------------------------------------*/ +;* space ... */ +;*---------------------------------------------------------------------*/ +(define (space) + (char #\space)) + +;*---------------------------------------------------------------------*/ +;* print-bibliography ... */ +;*---------------------------------------------------------------------*/ +(define-markup (print-bibliography #!rest opts + #!key all (sort bib-sort/authors)) + (the-bibliography all sort)) + +;*---------------------------------------------------------------------*/ +;* linebreak ... */ +;*---------------------------------------------------------------------*/ +(define skribe-linebreak linebreak) + +(define-markup (linebreak . lnum) + (cond + ((null? lnum) + (skribe-linebreak)) + ((string? (car lnum)) + (skribe-linebreak (string->number (car lnum)))) + (else + (skribe-linebreak (car lnum))))) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define skribe-ref ref) + +(define-markup (ref #!rest opts + #!key scribe url id page figure mark + chapter section subsection subsubsection subsubsection + bib bib+ number) + (let ((bd (the-body opts)) + (args (apply append (the-options opts :id)))) + (if id (set! args (cons* :mark id args))) + (if (pair? bd) (set! args (cons* :text bd args))) + (apply skribe-ref args))) + +;*---------------------------------------------------------------------*/ +;* indexes ... */ +;*---------------------------------------------------------------------*/ +(define *scribe-indexes* + (list (cons "theindex" (make-index "theindex")))) + +(define skribe-index index) +(define skribe-make-index make-index) + +(define-markup (make-index index) + (let ((i (skribe-make-index index))) + (set! *scribe-indexes* (cons (cons index i) *scribe-indexes*)) + i)) + +(define-markup (index #!rest opts #!key note index shape) + (let ((i (if (not index) + "theindex" + (let ((i (assoc index *scribe-indexes*))) + (if (pair? i) + (cdr i) + (make-index index)))))) + (apply skribe-index :note note :index i :shape shape (the-body opts)))) + +(define-markup (print-index #!rest opts + #!key split (char-offset 0) (header-limit 100)) + (apply the-index + :split split + :char-offset char-offset + :header-limit header-limit + (map (lambda (i) + (let ((c (assoc i *scribe-indexes*))) + (if (pair? c) + (cdr c) + (skribe-error 'the-index "Unknown index" i)))) + (the-body opts)))) + +;*---------------------------------------------------------------------*/ +;* format? */ +;*---------------------------------------------------------------------*/ +(define (scribe-format? fmt) #f) + +;*---------------------------------------------------------------------*/ +;* scribe-url ... */ +;*---------------------------------------------------------------------*/ +(define (scribe-url) (skribe-url)) + +;*---------------------------------------------------------------------*/ +;* Various configurations */ +;*---------------------------------------------------------------------*/ +(define *scribe-background* #f) +(define *scribe-foreground* #f) +(define *scribe-tbackground* #f) +(define *scribe-tforeground* #f) +(define *scribe-title-font* #f) +(define *scribe-author-font* #f) +(define *scribe-chapter-numbering* #f) +(define *scribe-footer* #f) +(define *scribe-prgm-color* #f) + +;*---------------------------------------------------------------------*/ +;* prgm ... */ +;*---------------------------------------------------------------------*/ +(define-markup (prgm #!rest opts + #!key lnum lnumwidth language bg frame (width 1.) + colors (monospace #t)) + (let* ((w (cond + ((real? width) (* width 100.)) + ((number? width) width) + (else 100.))) + (body (if language + (source :language language (the-body opts)) + (the-body opts))) + (body (if monospace + (prog :line lnum body) + body)) + (body (if bg + (color :width 100. :bg bg body) + body))) + (skribe-frame :width w + :border (if frame 1 #f) + body))) + +;*---------------------------------------------------------------------*/ +;* latex configuration */ +;*---------------------------------------------------------------------*/ +(define *scribe-tex-predocument* #f) + +;*---------------------------------------------------------------------*/ +;* latex-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (latex-prelude e) + (if (engine-format? "latex" e) + (begin + (if *scribe-tex-predocument* + (engine-custom-set! e 'predocument *scribe-tex-predocument*))))) + +;*---------------------------------------------------------------------*/ +;* html-prelude ... */ +;*---------------------------------------------------------------------*/ +(define (html-prelude e) + (if (engine-format? "html" e) + (begin + #f))) + +;*---------------------------------------------------------------------*/ +;* prelude */ +;*---------------------------------------------------------------------*/ +(let ((p (user-prelude))) + (user-prelude-set! (lambda (e) (p e) (latex-prelude e)))) diff --git a/src/guile/skribilo/package/sigplan.scm b/src/guile/skribilo/package/sigplan.scm new file mode 100644 index 0000000..b5269dc --- /dev/null +++ b/src/guile/skribilo/package/sigplan.scm @@ -0,0 +1,157 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/sigplan.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Sep 28 14:40:38 2003 */ +;* Last change : Wed May 18 16:00:38 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe style for ACMPROC articles. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package sigplan)) + +;*---------------------------------------------------------------------*/ +;* LaTeX global customizations */ +;*---------------------------------------------------------------------*/ +(let ((le (find-engine 'latex))) + (engine-custom-set! le + 'documentclass + "\\documentclass[twocolumns]{sigplanconf}") + ;; &latex-author + (markup-writer '&latex-author le + :before (lambda (n e) + (let ((body (markup-body n))) + (printf "\\authorinfo{\n" + (if (pair? body) (length body) 1)))) + :action (lambda (n e) + (let ((body (markup-body n))) + (for-each (lambda (a) + (display "}\n\\authorinfo{") + (output a e)) + (if (pair? body) body (list body))))) + :after "}\n") + ;; author + (let ((old-author (markup-writer-get 'author le))) + (markup-writer 'author le + :options (writer-options old-author) + :action (writer-action old-author))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category le + :options '(:index :section :subsection) + :before (lambda (n e) + (display "\\category{") + (display (markup-option n :index)) + (display "}") + (display "{") + (display (markup-option n :section)) + (display "}") + (display "{") + (display (markup-option n :subsection)) + (display "}\n[")) + :after "]\n") + (markup-writer '&acm-terms le + :before "\\terms{" + :after "}") + (markup-writer '&acm-keywords le + :before "\\keywords{" + :after "}") + (markup-writer '&acm-copyright le + :action (lambda (n e) + (display "\\conferenceinfo{") + (output (markup-option n :conference) e) + (display ",} {") + (output (markup-option n :location) e) + (display "}\n") + (display "\\copyrightyear{") + (output (markup-option n :year) e) + (display "}\n") + (display "\\copyrightdata{") + (output (markup-option n :crdata) e) + (display "}\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML global customizations */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (markup-writer '&html-acmproc-abstract he + :action (lambda (n e) + (let* ((ebg (engine-custom e 'abstract-background)) + (bg (or (and (string? ebg) + (> (string-length ebg) 0)) + ebg + "#cccccc")) + (exp (p (center (color :bg bg :width 90. + (markup-body n)))))) + (skribe-eval exp e)))) + ;; ACM category, terms, and keywords + (markup-writer '&acm-category :action #f) + (markup-writer '&acm-terms :action #f) + (markup-writer '&acm-keywords :action #f) + (markup-writer '&acm-copyright :action #f)) + +;*---------------------------------------------------------------------*/ +;* abstract ... */ +;*---------------------------------------------------------------------*/ +(define-markup (abstract #!rest opt #!key postscript) + (if (engine-format? "latex") + (section :number #f :title "ABSTRACT" (p (the-body opt))) + (let ((a (new markup + (markup '&html-acmproc-abstract) + (body (the-body opt))))) + (list (if postscript + (section :number #f :toc #f :title "Postscript download" + postscript)) + (section :number #f :toc #f :title "Abstract" a) + (section :number #f :toc #f :title "Table of contents" + (toc :subsection #t)))))) + +;*---------------------------------------------------------------------*/ +;* acm-category ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-category #!rest opt #!key index section subsection) + (new markup + (markup '&acm-category) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-terms ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-terms #!rest opt) + (new markup + (markup '&acm-terms) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-keywords ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-keywords #!rest opt) + (new markup + (markup '&acm-keywords) + (options (the-options opt)) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* acm-copyright ... */ +;*---------------------------------------------------------------------*/ +(define-markup (acm-copyright #!rest opt #!key conference location year crdata) + (let* ((le (find-engine 'latex)) + (cop (format "\\conferenceinfo{~a,} {~a} +\\CopyrightYear{~a} +\\crdata{~a}\n" conference location year crdata)) + (old (engine-custom le 'predocument))) + (if (string? old) + (engine-custom-set! le 'predocument (string-append cop old)) + (engine-custom-set! le 'predocument cop)))) + +;*---------------------------------------------------------------------*/ +;* references ... */ +;*---------------------------------------------------------------------*/ +(define (references) + (list "\n\n" + (if (engine-format? "latex") + (font :size -1 (flush :side 'left (the-bibliography))) + (section :title "References" + (font :size -1 (the-bibliography)))))) diff --git a/src/guile/skribilo/package/skribe.scm b/src/guile/skribilo/package/skribe.scm new file mode 100644 index 0000000..86425ac --- /dev/null +++ b/src/guile/skribilo/package/skribe.scm @@ -0,0 +1,76 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/skribe.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jan 11 11:23:12 2002 */ +;* Last change : Sun Jul 11 12:22:38 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The standard Skribe style (always loaded). */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* p ... */ +;*---------------------------------------------------------------------*/ +(define-markup (p #!rest opt #!key ident (class #f) &skribe-eval-location) + (paragraph :ident ident :class class :loc &skribe-eval-location + (the-body opt))) + +;*---------------------------------------------------------------------*/ +;* fg ... */ +;*---------------------------------------------------------------------*/ +(define (fg c . body) + (color :fg c body)) + +;*---------------------------------------------------------------------*/ +;* bg ... */ +;*---------------------------------------------------------------------*/ +(define (bg c . body) + (color :bg c body)) + +;*---------------------------------------------------------------------*/ +;* counter ... */ +;* ------------------------------------------------------------- */ +;* This produces a kind of "local enumeration" that is: */ +;* (counting "toto," "tutu," "titi.") */ +;* produces: */ +;* i) toto, ii) tutu, iii) titi. */ +;*---------------------------------------------------------------------*/ +(define-markup (counter #!rest opts #!key (numbering 'roman)) + (define items (if (eq? (car opts) :numbering) (cddr opts) opts)) + (define vroman '#(- "i" "ii" "iii" "iv" "v" "vi" "vii" "viii" "ix" "x")) + (define (the-roman-number num) + (if (< num (vector-length vroman)) + (list (list "(" (it (vector-ref vroman num)) ") ")) + (skribe-error 'counter + "too many items for roman numbering" + (length items)))) + (define (the-arabic-number num) + (list (list "(" (it (integer->string num)) ") "))) + (define (the-alpha-number num) + (list (list "(" (it (+ (integer->char #\a) num -1)) ") "))) + (let ((the-number (case numbering + ((roman) the-roman-number) + ((arabic) the-arabic-number) + ((alpha) the-alpha-number) + (else (skribe-error 'counter + "Illegal numbering" + numbering))))) + (let loop ((num 1) + (items items) + (res '())) + (if (null? items) + (reverse! res) + (loop (+ num 1) + (cdr items) + (cons (list (the-number num) (car items)) res)))))) + +;*---------------------------------------------------------------------*/ +;* q */ +;*---------------------------------------------------------------------*/ +(define-markup (q #!rest opt) + (new markup + (markup 'q) + (options (the-options opt)) + (body (the-body opt)))) + diff --git a/src/guile/skribilo/package/slide.scm b/src/guile/skribilo/package/slide.scm new file mode 100644 index 0000000..37ee054 --- /dev/null +++ b/src/guile/skribilo/package/slide.scm @@ -0,0 +1,667 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/slide.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Oct 3 12:22:13 2003 */ +;* Last change : Mon Aug 23 09:08:21 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe style for slides */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package slide)) + +;*---------------------------------------------------------------------*/ +;* slide-options */ +;*---------------------------------------------------------------------*/ +(define &slide-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-predocument + "\\special{landscape} + \\slideframe{none} + \\centerslidesfalse + \\raggedslides[0pt] + \\renewcommand{\\slideleftmargin}{0.2in} + \\renewcommand{\\slidetopmargin}{0.3in} + \\newdimen\\slidewidth \\slidewidth 9in") + +;*---------------------------------------------------------------------*/ +;* &slide-seminar-maketitle ... */ +;*---------------------------------------------------------------------*/ +(define &slide-seminar-maketitle + "\\def\\labelitemi{$\\bullet$} + \\def\\labelitemii{$\\circ$} + \\def\\labelitemiii{$\\diamond$} + \\def\\labelitemiv{$\\cdot$} + \\pagestyle{empty} + \\slideframe{none} + \\centerslidestrue + \\begin{slide} + \\date{} + \\maketitle + \\end{slide} + \\slideframe{none} + \\centerslidesfalse") + +;*---------------------------------------------------------------------*/ +;* &slide-prosper-predocument ... */ +;*---------------------------------------------------------------------*/ +(define &slide-prosper-predocument + "\\slideCaption{}\n") + +;*---------------------------------------------------------------------*/ +;* %slide-the-slides ... */ +;*---------------------------------------------------------------------*/ +(define %slide-the-slides '()) +(define %slide-the-counter 0) +(define %slide-initialized #f) +(define %slide-latex-mode 'seminar) + +;*---------------------------------------------------------------------*/ +;* %slide-initialize! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-initialize!) + (unless %slide-initialized + (set! %slide-initialized #t) + (case %slide-latex-mode + ((seminar) + (%slide-seminar-setup!)) + ((advi) + (%slide-advi-setup!)) + ((prosper) + (%slide-prosper-setup!)) + (else + (skribe-error 'slide "Illegal latex mode" %slide-latex-mode))))) + +;*---------------------------------------------------------------------*/ +;* slide ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide #!rest opt + #!key + (ident #f) (class #f) + (toc #t) + title (number #t) + (vspace #f) (vfill #f) + (transition #f) + (bg #f) (image #f)) + (%slide-initialize!) + (let ((s (new container + (markup 'slide) + (ident (if (not ident) + (symbol->string (gensym 'slide)) + ident)) + (class class) + (required-options '(:title :number :toc)) + (options `((:number + ,(cond + ((number? number) + (set! %slide-the-counter number) + number) + (number + (set! %slide-the-counter + (+ 1 %slide-the-counter)) + %slide-the-counter) + (else + #f))) + (:toc ,toc) + ,@(the-options opt :ident :class :vspace :toc))) + (body (if vspace + (list (slide-vspace vspace) (the-body opt)) + (the-body opt)))))) + (set! %slide-the-slides (cons s %slide-the-slides)) + s)) + +;*---------------------------------------------------------------------*/ +;* ref ... */ +;*---------------------------------------------------------------------*/ +(define %slide-old-ref ref) + +(define-markup (ref #!rest opt #!key (slide #f)) + (if (not slide) + (apply %slide-old-ref opt) + (new unresolved + (proc (lambda (n e env) + (cond + ((eq? slide 'next) + (let ((c (assq n %slide-the-slides))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((eq? slide 'prev) + (let ((c (assq n (reverse %slide-the-slides)))) + (if (pair? c) + (handle (cadr c)) + #f))) + ((number? slide) + (let loop ((s %slide-the-slides)) + (cond + ((null? s) + #f) + ((= slide (markup-option (car s) :number)) + (handle (car s))) + (else + (loop (cdr s)))))) + (else + #f))))))) + +;*---------------------------------------------------------------------*/ +;* slide-pause ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-pause) + (new markup + (markup 'slide-pause))) + +;*---------------------------------------------------------------------*/ +;* slide-vspace ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-vspace #!rest opt #!key (unit 'cm)) + (new markup + (markup 'slide-vspace) + (options `((:unit ,unit) ,@(the-options opt :unit))) + (body (the-body opt)))) + +;*---------------------------------------------------------------------*/ +;* slide-embed ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-embed #!rest opt + #!key + command + (geometry-opt "-geometry") + (geometry #f) (rgeometry #f) + (transient #f) (transient-opt #f) + (alt #f) + &skribe-eval-location) + (if (not (string? command)) + (skribe-error 'slide-embed + "No command provided" + command) + (new markup + (markup 'slide-embed) + (loc &skribe-eval-location) + (required-options '(:alt)) + (options `((:geometry-opt ,geometry-opt) + (:alt ,alt) + ,@(the-options opt :geometry-opt :alt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-record ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-record #!rest opt #!key ident class tag (play #t)) + (if (not tag) + (skribe-error 'slide-record "Tag missing" tag) + (new markup + (markup 'slide-record) + (ident ident) + (class class) + (options `((:play ,play) ,@(the-options opt))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play #!rest opt #!key ident class tag color) + (if (not tag) + (skribe-error 'slide-play "Tag missing" tag) + (new markup + (markup 'slide-play) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + ,@(the-options opt :color))) + (body (the-body opt))))) + +;*---------------------------------------------------------------------*/ +;* slide-play* ... */ +;*---------------------------------------------------------------------*/ +(define-markup (slide-play* #!rest opt + #!key ident class color (scolor "#000000")) + (let ((body (the-body opt))) + (for-each (lambda (lbl) + (match-case lbl + ((?id ?col) + (skribe-use-color! col)))) + body) + (new markup + (markup 'slide-play*) + (ident ident) + (class class) + (options `((:color ,(if color (skribe-use-color! color) #f)) + (:scolor ,(if color (skribe-use-color! scolor) #f)) + ,@(the-options opt :color :scolor))) + (body body)))) + +;*---------------------------------------------------------------------*/ +;* base */ +;*---------------------------------------------------------------------*/ +(let ((be (find-engine 'base))) + (skribe-message "Base slides setup...\n") + ;; slide-pause + (markup-writer 'slide-pause be + :action #f) + ;; slide-vspace + (markup-writer 'slide-vspace be + :options '() + :action #f) + ;; slide-embed + (markup-writer 'slide-embed be + :options '(:alt :geometry-opt) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-record + (markup-writer 'slide-record be + :options '(:tag :play) + :action (lambda (n e) + (output (markup-body n) e))) + ;; slide-play + (markup-writer 'slide-play be + :options '(:tag :color) + :action (lambda (n e) + (output (markup-option n :alt) e))) + ;; slide-play* + (markup-writer 'slide-play* be + :options '(:tag :color :scolor) + :action (lambda (n e) + (output (markup-option n :alt) e)))) + +;*---------------------------------------------------------------------*/ +;* slide-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (slide-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 95.))) + +;*---------------------------------------------------------------------*/ +;* html-slide-title ... */ +;*---------------------------------------------------------------------*/ +(define (html-slide-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (slide-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><strong>" tfont) + (output title e) + (display "</strong></font>")) + (begin + (printf "<div class=\"skribetitle\"><strong><big><big><big>") + (output title e) + (display "</big></big></big></strong</div>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + +;*---------------------------------------------------------------------*/ +;* slide-number ... */ +;*---------------------------------------------------------------------*/ +(define (slide-number) + (length (filter (lambda (n) + (and (is-markup? n 'slide) + (markup-option n :number))) + %slide-the-slides))) + +;*---------------------------------------------------------------------*/ +;* html */ +;*---------------------------------------------------------------------*/ +(let ((he (find-engine 'html))) + (skribe-message "HTML slides setup...\n") + ;; &html-page-title + (markup-writer '&html-document-title he + :predicate (lambda (n e) %slide-initialized) + :action html-slide-title) + ;; slide + (markup-writer 'slide he + :options '(:title :number :transition :toc :bg) + :before (lambda (n e) + (printf "<a name=\"~a\">" (markup-ident n)) + (display "<br>\n")) + :action (lambda (n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (skribe-eval + (center + (color :width (slide-body-width e) + :bg (or (markup-option n :bg) "#ffffff") + (table :width 100. + (tr (th :align 'left + (list + (if nb + (format "~a / ~a -- " nb + (slide-number))) + t))) + (tr (td (hrule))) + (tr (td :width 100. :align 'left + (markup-body n)))) + (linebreak))) + e))) + :after "<br>") + ;; slide-vspace + (markup-writer 'slide-vspace he + :action (lambda (n e) (display "<br>")))) + +;*---------------------------------------------------------------------*/ +;* latex */ +;*---------------------------------------------------------------------*/ +(define &latex-slide #f) +(define &latex-pause #f) +(define &latex-embed #f) +(define &latex-record #f) +(define &latex-play #f) +(define &latex-play* #f) + +(let ((le (find-engine 'latex))) + ;; slide-vspace + (markup-writer 'slide-vspace le + :options '(:unit) + :action (lambda (n e) + (display "\n\\vspace{") + (output (markup-body n) e) + (printf " ~a}\n\n" (markup-option n :unit)))) + ;; slide-slide + (markup-writer 'slide le + :options '(:title :number :transition :vfill :toc :vspace :image) + :action (lambda (n e) + (if (procedure? &latex-slide) + (&latex-slide n e)))) + ;; slide-pause + (markup-writer 'slide-pause le + :options '() + :action (lambda (n e) + (if (procedure? &latex-pause) + (&latex-pause n e)))) + ;; slide-embed + (markup-writer 'slide-embed le + :options '(:alt :command :geometry-opt :geometry + :rgeometry :transient :transient-opt) + :action (lambda (n e) + (if (procedure? &latex-embed) + (&latex-embed n e)))) + ;; slide-record + (markup-writer 'slide-record le + :options '(:tag :play) + :action (lambda (n e) + (if (procedure? &latex-record) + (&latex-record n e)))) + ;; slide-play + (markup-writer 'slide-play le + :options '(:tag :color) + :action (lambda (n e) + (if (procedure? &latex-play) + (&latex-play n e)))) + ;; slide-play* + (markup-writer 'slide-play* le + :options '(:tag :color :scolor) + :action (lambda (n e) + (if (procedure? &latex-play*) + (&latex-play* n e))))) + +;*---------------------------------------------------------------------*/ +;* %slide-seminar-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-seminar-setup!) + (skribe-message "Seminar slides setup...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + ;; latex configuration + (define (seminar-slide n e) + (let ((nb (markup-option n :number)) + (t (markup-option n :title))) + (display "\\begin{slide}\n") + (if nb (printf "~a/~a -- " nb (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n")) + (engine-custom-set! le 'documentclass + "\\documentclass[landscape]{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'hyperref-usepackage + "\\usepackage[setpagesize=false]{hyperref}\n") + ;; slide-slide + (set! &latex-slide seminar-slide))) + +;*---------------------------------------------------------------------*/ +;* %slide-advi-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-advi-setup!) + (skribe-message "Generating `Advi Seminar' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base))) + (define (advi-geometry geo) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)" geo))) + (if (pair? r) + (let* ((w (cadr r)) + (w' (string->integer w)) + (w'' (number->string (/ w' *skribe-slide-advi-scale*))) + (h (caddr r)) + (h' (string->integer h)) + (h'' (number->string (/ h' *skribe-slide-advi-scale*)))) + (values "" (string-append w "x" h "+!x+!y"))) + (let ((r (pregexp-match "([0-9]+)x([0-9]+)[+](-?[0-9]+)[+](-?[0-9]+)" geo))) + (if (pair? r) + (let ((w (number->string (/ (string->integer (cadr r)) + *skribe-slide-advi-scale*))) + (h (number->string (/ (string->integer (caddr r)) + *skribe-slide-advi-scale*))) + (x (cadddr r)) + (y (car (cddddr r)))) + (values (string-append "width=" w "cm,height=" h "cm") + "!g")) + (values "" geo)))))) + (define (advi-transition trans) + (cond + ((string? trans) + (printf "\\advitransition{~s}" trans)) + ((and (symbol? trans) + (memq trans '(wipe block slide))) + (printf "\\advitransition{~s}" trans)) + (else + #f))) + ;; latex configuration + (define (advi-slide n e) + (let ((i (markup-option n :image)) + (n (markup-option n :number)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition))) + (if (and i (engine-custom e 'advi)) + (printf "\\advibg[global]{image=~a}\n" + (if (and (pair? i) + (null? (cdr i)) + (string? (car i))) + (car i) + i))) + (display "\\begin{slide}\n") + (advi-transition (or lt gt)) + (if n (printf "~a/~a -- " n (slide-number))) + (output t e) + (display "\\hrule\n")) + (output (markup-body n) e) + (if (markup-option n :vill) (display "\\vfill\n")) + (display "\\end{slide}\n\n\n")) + ;; advi record + (define (advi-record n e) + (display "\\advirecord") + (when (markup-option n :play) (display "[play]")) + (printf "{~a}{" (markup-option n :tag)) + (output (markup-body n) e) + (display "}")) + ;; advi play + (define (advi-play n e) + (display "\\adviplay") + (let ((c (markup-option n :color))) + (when c + (display "[") + (display (skribe-get-latex-color c)) + (display "]"))) + (printf "{~a}" (markup-option n :tag))) + ;; advi play* + (define (advi-play* n e) + (let ((c (skribe-get-latex-color (markup-option n :color))) + (d (skribe-get-latex-color (markup-option n :scolor)))) + (let loop ((lbls (markup-body n)) + (last #f)) + (when last + (display "\\adviplay[") + (display d) + (printf "]{~a}" last)) + (when (pair? lbls) + (let ((lbl (car lbls))) + (match-case lbl + ((?id ?col) + (display "\\adviplay[") + (display (skribe-get-latex-color col)) + (printf "]{" ~a "}" id) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) id)) + (else + (display "\\adviplay[") + (display c) + (printf "]{~a}" lbl) + (skribe-eval (slide-pause) e) + (loop (cdr lbls) lbl)))))))) + (engine-custom-set! le 'documentclass + "\\documentclass{seminar}\n") + (let ((o (engine-custom le 'predocument))) + (engine-custom-set! le 'predocument + (if (string? o) + (string-append &slide-seminar-predocument o) + &slide-seminar-predocument))) + (engine-custom-set! le 'maketitle + &slide-seminar-maketitle) + (engine-custom-set! le 'usepackage + (string-append "\\usepackage{advi}\n" + (engine-custom le 'usepackage))) + ;; slide + (set! &latex-slide advi-slide) + (set! &latex-pause + (lambda (n e) (display "\\adviwait\n"))) + (set! &latex-embed + (lambda (n e) + (let ((geometry-opt (markup-option n :geometry-opt)) + (geometry (markup-option n :geometry)) + (rgeometry (markup-option n :rgeometry)) + (transient (markup-option n :transient)) + (transient-opt (markup-option n :transient-opt)) + (cmd (markup-option n :command))) + (let* ((a (string-append "ephemeral=" + (symbol->string (gensym)))) + (c (cond + (geometry + (string-append cmd " " + geometry-opt " " + geometry)) + (rgeometry + (multiple-value-bind (aopt dopt) + (advi-geometry rgeometry) + (set! a (string-append a "," aopt)) + (string-append cmd " " + geometry-opt " " + dopt))) + (else + cmd))) + (c (if (and transient transient-opt) + (string-append c " " transient-opt " !p") + c))) + (printf "\\adviembed[~a]{~a}\n" a c))))) + (set! &latex-record advi-record) + (set! &latex-play advi-play) + (set! &latex-play* advi-play*))) + +;*---------------------------------------------------------------------*/ +;* %slide-prosper-setup! ... */ +;*---------------------------------------------------------------------*/ +(define (%slide-prosper-setup!) + (skribe-message "Generating `Prosper' slides...\n") + (let ((le (find-engine 'latex)) + (be (find-engine 'base)) + (overlay-count 0)) + ;; transitions + (define (prosper-transition trans) + (cond + ((string? trans) + (printf "[~s]" trans)) + ((eq? trans 'slide) + (printf "[Blinds]")) + ((and (symbol? trans) + (memq trans '(split blinds box wipe dissolve glitter))) + (printf "[~s]" + (string-upcase (symbol->string trans)))) + (else + #f))) + ;; latex configuration + (define (prosper-slide n e) + (let* ((i (markup-option n :image)) + (t (markup-option n :title)) + (lt (markup-option n :transition)) + (gt (engine-custom e 'transition)) + (pa (search-down (lambda (x) (is-markup? x 'slide-pause)) n)) + (lpa (length pa))) + (set! overlay-count 1) + (if (>= lpa 1) (printf "\\overlays{~a}{%\n" (+ 1 lpa))) + (display "\\begin{slide}") + (prosper-transition (or lt gt)) + (display "{") + (output t e) + (display "}\n") + (output (markup-body n) e) + (display "\\end{slide}\n") + (if (>= lpa 1) (display "}\n")) + (newline) + (newline))) + (engine-custom-set! le 'documentclass "\\documentclass[pdf,skribe,slideColor,nototal]{prosper}\n") + (let* ((cap (engine-custom le 'slide-caption)) + (o (engine-custom le 'predocument)) + (n (if (string? cap) + (format "~a\\slideCaption{~a}\n" + &slide-prosper-predocument + cap) + &slide-prosper-predocument))) + (engine-custom-set! le 'predocument + (if (string? o) (string-append n o) n))) + (engine-custom-set! le 'hyperref-usepackage "\\usepackage{hyperref}\n") + ;; writers + (set! &latex-slide prosper-slide) + (set! &latex-pause + (lambda (n e) + (set! overlay-count (+ 1 overlay-count)) + (printf "\\FromSlide{~s}%\n" overlay-count))))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &slide-load-options) + (p (memq :prosper opt))) + (if (and (pair? p) (pair? (cdr p)) (cadr p)) + ;; prosper + (set! %slide-latex-mode 'prosper) + (let ((a (memq :advi opt))) + (if (and (pair? a) (pair? (cdr a)) (cadr a)) + ;; advi + (set! %slide-latex-mode 'advi))))) diff --git a/src/guile/skribilo/package/web-article.scm b/src/guile/skribilo/package/web-article.scm new file mode 100644 index 0000000..6a480be --- /dev/null +++ b/src/guile/skribilo/package/web-article.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-article.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jan 10 09:09:43 2004 */ +;* Last change : Wed Mar 24 16:45:08 2004 (serrano) */ +;* Copyright : 2004 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* A Skribe style for producing web articles */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-article)) + +;*---------------------------------------------------------------------*/ +;* &web-article-load-options ... */ +;*---------------------------------------------------------------------*/ +(define &web-article-load-options (skribe-load-options)) + +;*---------------------------------------------------------------------*/ +;* web-article-body-width ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-body-width e) + (let ((w (engine-custom e 'body-width))) + (if (or (number? w) (string? w)) w 98.))) + +;*---------------------------------------------------------------------*/ +;* html-document-title-web ... */ +;*---------------------------------------------------------------------*/ +(define (html-document-title-web n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (tbg (engine-custom e 'title-background)) + (tfg (engine-custom e 'title-foreground)) + (tfont (engine-custom e 'title-font))) + (printf "<center><table cellspacing='0' cellpadding='0' width=\"~a\" class=\"skribetitle\"><tbody>\n<tr>" + (html-width (web-article-body-width e))) + (if (string? tbg) + (printf "<td bgcolor=\"~a\">" tbg) + (display "<td>")) + (if (string? tfg) + (printf "<font color=\"~a\">" tfg)) + (if title + (begin + (display "<center>") + (if (string? tfont) + (begin + (printf "<font ~a><b>" tfont) + (output title e) + (display "</b></font>")) + (begin + (printf "<h1>") + (output title e) + (display "</h1>"))) + (display "</center>\n"))) + (if (not authors) + (display "\n") + (html-title-authors authors e)) + (if (string? tfg) + (display "</font>")) + (display "</td></tr></tbody></table></center>\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-document-title ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-document-title n e) + (let* ((title (markup-body n)) + (authors (markup-option n 'author)) + (id (markup-ident n))) + ;; the title + (printf "<div id=\"~a\" class=\"document-title-title\">\n" + (string-canonicalize id)) + (output title e) + (display "</div>\n") + ;; the authors + (printf "<div id=\"~a\" class=\"document-title-authors\">\n" + (string-canonicalize id)) + (for-each (lambda (a) (output a e)) + (cond + ((is-markup? authors 'author) + (list authors)) + ((list? authors) + authors) + (else + '()))) + (display "</div>\n"))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-author ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-author n e) + (let ((name (markup-option n :name)) + (title (markup-option n :title)) + (affiliation (markup-option n :affiliation)) + (email (markup-option n :email)) + (url (markup-option n :url)) + (address (markup-option n :address)) + (phone (markup-option n :phone)) + (nfn (engine-custom e 'author-font)) + (align (markup-option n :align))) + (when name + (printf "<span class=\"document-author-name\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output name e) + (display "</span>\n")) + (when title + (printf "<span class=\"document-author-title\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output title e) + (display "</span>\n")) + (when affiliation + (printf "<span class=\"document-author-affiliation\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output affiliation e) + (display "</span>\n")) + (when (pair? address) + (printf "<span class=\"document-author-address\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (for-each (lambda (a) + (output a e) + (newline)) + address) + (display "</span>\n")) + (when phone + (printf "<span class=\"document-author-phone\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output phone e) + (display "</span>\n")) + (when email + (printf "<span class=\"document-author-email\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output email e) + (display "</span>\n")) + (when url + (printf "<span class=\"document-author-url\" id=\"~a\">" + (string-canonicalize (markup-ident n))) + (output url e) + (display "</span>\n")))) + +;*---------------------------------------------------------------------*/ +;* HTML settings */ +;*---------------------------------------------------------------------*/ +(define (web-article-modern-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :action html-document-title-web) + ;; section + (markup-writer 'section he + :options 'all + :before "<br>" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background))) + (markup-writer 'section e1 + :options 'all + :action (lambda (n e2) (output n e sec))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg n)) + e1)))) + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before "<br>" + :action (lambda (n e) + (let ((e1 (make-engine 'html-web :delegate e)) + (bg (engine-custom he 'section-background)) + (fg (engine-custom he 'subsection-title-foreground))) + (markup-writer '&html-footnotes e1 + :options 'all + :action (lambda (n e2) + (invoke (writer-action ft) n e))) + (skribe-eval + (center (color :width (web-article-body-width e) + :margin 5 :bg bg :fg fg n)) + e1)))))) + +;*---------------------------------------------------------------------*/ +;* web-article-css-setup ... */ +;*---------------------------------------------------------------------*/ +(define (web-article-css-setup he) + (let ((sec (markup-writer-get 'section he)) + (ft (markup-writer-get '&html-footnotes he))) + ;; &html-document-title + (markup-writer '&html-document-title he + :before (lambda (n e) + (printf "<div id=\"~a\" class=\"document-title\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-document-title + :after "</div>\n") + ;; author + (markup-writer 'author he + :options '(:name :title :affiliation :email :url :address :phone :photo :align) + :before (lambda (n e) + (printf "<span id=\"~a\" class=\"document-author\">\n" + (string-canonicalize (markup-ident n)))) + :action web-article-css-author + :after "</span\n") + ;; section + (markup-writer 'section he + :options 'all + :before (lambda (n e) + (printf "<div class=\"section\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) (output n e sec)) + :after "</div>\n") + ;; &html-footnotes + (markup-writer '&html-footnotes he + :options 'all + :before (lambda (n e) + (printf "<div class=\"footnotes\" id=\"~a\">" + (string-canonicalize (markup-ident n)))) + :action (lambda (n e) + (output n e ft)) + :after "</div>\n"))) + +;*---------------------------------------------------------------------*/ +;* Setup ... */ +;*---------------------------------------------------------------------*/ +(let* ((opt &web-article-load-options) + (p (memq :style opt)) + (css (memq :css opt)) + (he (find-engine 'html))) + (cond + ((and (pair? p) (pair? (cdr p)) (eq? (cadr p) 'css)) + (web-article-css-setup he)) + ((and (pair? css) (pair? (cdr css)) (string? (cadr css))) + (engine-custom-set! he 'css (cadr css)) + (web-article-css-setup he)) + (else + (web-article-modern-setup he)))) diff --git a/src/guile/skribilo/package/web-book.scm b/src/guile/skribilo/package/web-book.scm new file mode 100644 index 0000000..a954c7a --- /dev/null +++ b/src/guile/skribilo/package/web-book.scm @@ -0,0 +1,109 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/skr/web-book.skr */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 10:54:32 2003 */ +;* Last change : Mon Nov 8 10:43:46 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe web book style. */ +;*=====================================================================*/ + +(define-skribe-module (skribilo package web-book)) + +;*---------------------------------------------------------------------*/ +;* html customization */ +;*---------------------------------------------------------------------*/ +(define he (find-engine 'html)) +(engine-custom-set! he 'main-browsing-extra #f) +(engine-custom-set! he 'chapter-file #t) + +;*---------------------------------------------------------------------*/ +;* main-browsing ... */ +;*---------------------------------------------------------------------*/ +(define main-browsing + (lambda (n e) + ;; search the document + (let ((p (ast-document n))) + (cond + ((document? p) + ;; got it + (let* ((mt (markup-option p :margin-title)) + (r (ref :handle (handle p) + :text (or mt (markup-option p :title)))) + (fx (engine-custom e 'web-book-main-browsing-extra))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold "main page")))) + (tr :bg (engine-custom e 'background) + (td (apply table :width 100. :border 0 + (tr (td :align 'left + :valign 'top + (bold "top:")) + (td :align 'right + :valign 'top r)) + (if (procedure? fx) + (list (tr (td :width 100. + :colspan 2 + (fx n e)))) + '())))))))) + ((not p) + ;; no document!!! + #f))))) + +;*---------------------------------------------------------------------*/ +;* chapter-browsing ... */ +;*---------------------------------------------------------------------*/ +(define chapter-browsing + (lambda (n e) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (markup-option n :title))))) + (tr :bg (engine-custom e 'background) + (td (toc (handle n) :chapter #t :section #t :subsection #t))))))) + +;*---------------------------------------------------------------------*/ +;* document-browsing ... */ +;*---------------------------------------------------------------------*/ +(define document-browsing + (lambda (n e) + (let ((chap (find1-down (lambda (n) + (is-markup? n 'chapter)) + n))) + (center + (table :width 97. :border 1 :frame 'box + :cellpadding 0 :cellspacing 0 + (tr :bg (engine-custom e 'title-background) + (th (color :fg (engine-custom e 'background) + (bold (if chap "Chapters" "Sections"))))) + (tr :bg (engine-custom e 'background) + (td (if chap + (toc (handle n) :chapter #t :section #f) + (toc (handle n) :section #t :subsection #t))))))))) + +;*---------------------------------------------------------------------*/ +;* left margin ... */ +;*---------------------------------------------------------------------*/ +(engine-custom-set! he 'left-margin-size 20.) + +(engine-custom-set! he 'left-margin + (lambda (n e) + (let ((d (ast-document n)) + (c (ast-chapter n))) + (list (linebreak 1) + (main-browsing n e) + (if (is-markup? c 'chapter) + (list (linebreak 2) + (chapter-browsing c e)) + #f) + (if (document? d) + (list (linebreak 2) + (document-browsing d e)) + #f))))) + diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..a1c58fb --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm index 673a166..714f19e 100644 --- a/src/guile/skribilo/reader/skribe.scm +++ b/src/guile/skribilo/reader/skribe.scm @@ -22,7 +22,7 @@ :use-module (skribilo reader) :use-module (ice-9 optargs) - ;; the Scheme reader composition framework + ;; the Scheme reader composition framework :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) :export (reader-specification @@ -54,19 +54,39 @@ the Skribe syntax." (sharp-reader (r:make-reader (cons dsssl-keyword-reader (map r:standard-token-reader '(character srfi-4 + vector number+radix - boolean)))))) - (r:make-reader (cons (r:make-token-reader #\# sharp-reader) - (map r:standard-token-reader - `(whitespace - sexp string number - symbol-lower-case - symbol-upper-case - symbol-misc-chars - quote-quasiquote-unquote - semicolon-comment - keyword ;; keywords à la `:key' - skribe-exp)))))) + boolean))) + #f ;; use default fault handler + 'reader/record-positions)) + (colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (square-bracket-free-symbol-misc-chars + (let* ((tr (r:standard-token-reader 'guile-symbol-misc-chars)) + (tr-spec (r:token-reader-specification tr)) + (tr-proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (or (eq? chr #\[) + (eq? chr #\])))) + tr-spec) + tr-proc)))) + + (r:make-reader (cons* (r:make-token-reader #\# sharp-reader) + colon-keywords + square-bracket-free-symbol-misc-chars + (map r:standard-token-reader + `(whitespace + sexp string guile-number + guile-symbol-lower-case + guile-symbol-upper-case + quote-quasiquote-unquote + semicolon-comment + skribe-exp))) + #f ;; use the default fault handler + 'reader/record-positions + ))) ;; We actually cache an instance here. (define *skribe-reader* (%make-skribe-reader)) diff --git a/src/guile/skribilo/resolve.scm b/src/guile/skribilo/resolve.scm index 14f36b2..a39bb77 100644 --- a/src/guile/skribilo/resolve.scm +++ b/src/guile/skribilo/resolve.scm @@ -178,7 +178,7 @@ (cadr c) n))) ((eq? (slot-ref n 'parent) 'unspecified) - (skribe-error 'resolve-parent "Orphan node" n)) + (skribe-error 'resolve-parent "orphan node" n)) (else (slot-ref n 'parent))))) @@ -211,7 +211,7 @@ (let ((c (assq (symbol-append cnt '-counter) e))) (if (not (pair? c)) (if (or (null? opt) (not (car opt)) (null? e)) - (skribe-error cnt "Orphan node" n) + (skribe-error cnt "orphan node" n) (begin (set-cdr! (last-pair e) (list (list (symbol-append cnt '-counter) 0) diff --git a/src/guile/skribilo/skribe/Makefile.am b/src/guile/skribilo/skribe/Makefile.am new file mode 100644 index 0000000..2850c4d --- /dev/null +++ b/src/guile/skribilo/skribe/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo +dist_guilemodule_DATA = api.scm bib.scm index.scm param.scm sui.scm utils.scm diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm index d66b3b4..34528ac 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/skribe/api.scm @@ -274,8 +274,8 @@ (new unresolved (proc (lambda (n e env) (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) + 'footnote #t)))))) + ,@(the-options opts :ident :class)))) (body (the-body opts)))) ;*---------------------------------------------------------------------*/ @@ -466,9 +466,9 @@ "start line > stop line" (format #f "~a/~a" start stop))) ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) + (skribe-error 'source "illegal language" language)) ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) + (skribe-error 'source "illegal tab" tab)) (file (let ((s (if (not definition) (source-read-lines file start stop tab) @@ -489,7 +489,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (language #!key name (fontifier #f) (extractor #f)) (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") + (skribe-type-error 'language "illegal name" name "string") (new language (name name) (fontifier fontifier) diff --git a/src/guile/skribilo/skribe/index.scm b/src/guile/skribilo/skribe/index.scm index 840a179..415cadf 100644 --- a/src/guile/skribilo/skribe/index.scm +++ b/src/guile/skribilo/skribe/index.scm @@ -36,24 +36,24 @@ ;*---------------------------------------------------------------------*/ ;* index? ... */ ;*---------------------------------------------------------------------*/ -(define (index? obj) +(define-public (index? obj) (hashtable? obj)) ;*---------------------------------------------------------------------*/ ;* *index-table* ... */ ;*---------------------------------------------------------------------*/ -(define *index-table* #f) +(define-public *index-table* #f) ;*---------------------------------------------------------------------*/ ;* make-index-table ... */ ;*---------------------------------------------------------------------*/ -(define (make-index-table ident) +(define-public (make-index-table ident) (make-hashtable)) ;*---------------------------------------------------------------------*/ ;* default-index ... */ ;*---------------------------------------------------------------------*/ -(define (default-index) +(define-public (default-index) (if (not *index-table*) (set! *index-table* (make-index-table "default-index"))) *index-table*) @@ -61,7 +61,7 @@ ;*---------------------------------------------------------------------*/ ;* resolve-the-index ... */ ;*---------------------------------------------------------------------*/ -(define (resolve-the-index loc i c indexes split char-offset header-limit col) +(define-public (resolve-the-index loc i c indexes split char-offset header-limit col) ;; fetch the descriminating index name letter (define (index-ref n) (let ((name (markup-option n 'name))) @@ -70,7 +70,7 @@ (string-ref name char-offset)))) ;; sort a bucket of entries (the entries in a bucket share there name) (define (sort-entries-bucket ie) - (sort ie + (sort ie (lambda (i1 i2) (or (not (markup-option i1 :note)) (markup-option i2 :note))))) diff --git a/src/guile/skribilo/skribe/param.scm b/src/guile/skribilo/skribe/param.scm index 8daca62..6aebd0a 100644 --- a/src/guile/skribilo/skribe/param.scm +++ b/src/guile/skribilo/skribe/param.scm @@ -44,15 +44,16 @@ ;* *skribe-auto-mode-alist* ... */ ;*---------------------------------------------------------------------*/ (define *skribe-auto-mode-alist* - '(("html" . html) - ("sui" . sui) - ("tex" . latex) - ("ctex" . context) - ("xml" . xml) - ("info" . info) - ("txt" . ascii) - ("mgp" . mgp) - ("man" . man))) + ;; Note: In Skribilo, this list is completely useless. + '(("html" . html) + ("sui" . sui) + ("tex" . latex) + ("ctex" . context) + ("xml" . xml) + ("info" . info) + ("txt" . ascii) + ("mgp" . mgp) + ("man" . man))) ;*---------------------------------------------------------------------*/ ;* *skribe-auto-load-alist* ... */ diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index c682687..e03deae 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,7 +1,8 @@ ;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; source.scm -- Highlighting source files. ;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -19,24 +20,16 @@ ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. ;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 3-Sep-2003 12:22 (eg) -;;;; Last file update: 27-Oct-2004 20:09 (eg) -;;;; (define-module (skribilo source) :export (source-read-lines source-read-definition source-fontify) - :use-module (skribilo vars)) - - -;; Temporary solution -(define (language-extractor lang) - (slot-ref lang 'extractor)) + :use-module (skribilo types) + :use-module (skribilo vars) + :use-module (skribilo lib) + :use-module (ice-9 rdelim)) -(define (language-fontifier lang) - (slot-ref lang 'fontifier)) ;*---------------------------------------------------------------------*/ @@ -172,7 +165,7 @@ (if (= i j) (reverse! r) (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) + ((char=? (string-ref str i) #\newline) (loop (+ i 1) (+ i 1) (if (= i j) @@ -180,7 +173,7 @@ (cons* 'eol (substring str j i) r)))) ((and (char=? (string-ref str i) #\cr) (< (+ i 1) l) - (char=? (string-ref str (+ i 1)) #\Newline)) + (char=? (string-ref str (+ i 1)) #\newline)) (loop (+ i 2) (+ i 2) (if (= i j) diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index 4b3729c..ac1edc4 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -43,7 +43,7 @@ container-ident container-body <document> document? document-ident document-body document-options document-end - <language> language? + <language> language? language-extractor language-fontifier <location> location? ast-location location-file location-line location-pos @@ -66,14 +66,6 @@ (parent :accessor ast-parent :init-keyword :parent :init-value 'unspecified) (loc :init-value #f)) -(define-method (initialize (ast <ast>) . args) - (next-method) - (let ((file (port-filename (current-input-port))) - (line (port-line (current-input-port))) - (column (port-column (current-input-port)))) - (slot-set! ast 'loc - (make <location> - :file file :line line :pos (* line column))))) (define (ast? obj) (is-a? obj <ast>)) (define (ast-loc obj) (slot-ref obj 'loc)) @@ -291,8 +283,8 @@ ;;; ====================================================================== (define-class <language> () (name :init-keyword :name :init-value #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-value #f :getter langage-extractor)) + (fontifier :init-keyword :fontifier :init-value #f :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f :getter language-extractor)) (define (language? obj) (is-a? obj <language>)) diff --git a/src/stklos/Makefile.in b/src/stklos/Makefile.in deleted file mode 100644 index 80a26de..0000000 --- a/src/stklos/Makefile.in +++ /dev/null @@ -1,110 +0,0 @@ -# -# Makefile.in -- Skribe Src Makefile -# -# Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/biblio.stk b/src/stklos/biblio.stk deleted file mode 100644 index 5691588..0000000 --- a/src/stklos/biblio.stk +++ /dev/null @@ -1,161 +0,0 @@ -;;;; -;;;; biblio.stk -- Bibliography functions -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/c-lex.l b/src/stklos/c-lex.l deleted file mode 100644 index a5b337e..0000000 --- a/src/stklos/c-lex.l +++ /dev/null @@ -1,67 +0,0 @@ -;;;; -;;;; c-lex.l -- C fontifier for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/c.stk b/src/stklos/c.stk deleted file mode 100644 index 265c421..0000000 --- a/src/stklos/c.stk +++ /dev/null @@ -1,95 +0,0 @@ -;;;; -;;;; c.stk -- C fontifier for Skribe -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/color.stk b/src/stklos/color.stk deleted file mode 100644 index 0cb829f..0000000 --- a/src/stklos/color.stk +++ /dev/null @@ -1,622 +0,0 @@ -;;;; -;;;; color.stk -- Skribe Color Management -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/configure.stk b/src/stklos/configure.stk deleted file mode 100644 index ece7abc..0000000 --- a/src/stklos/configure.stk +++ /dev/null @@ -1,90 +0,0 @@ -;;;; -;;;; configure.stk -- Skribe configuration options -;;;; -;;;; Copyright © 2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/debug.stk b/src/stklos/debug.stk deleted file mode 100644 index a9fefde..0000000 --- a/src/stklos/debug.stk +++ /dev/null @@ -1,161 +0,0 @@ -;;;; -;;;; debug.stk -- Debug Facilities (stolen to Manuel Serrano) -;;;; -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/engine.stk b/src/stklos/engine.stk deleted file mode 100644 index a13ed0f..0000000 --- a/src/stklos/engine.stk +++ /dev/null @@ -1,242 +0,0 @@ -;;;; -;;;; engines.stk -- Skribe Engines Stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/eval.stk b/src/stklos/eval.stk deleted file mode 100644 index 3acace9..0000000 --- a/src/stklos/eval.stk +++ /dev/null @@ -1,149 +0,0 @@ -;;;; -;;;; eval.stk -- Skribe Evaluator -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/lib.stk b/src/stklos/lib.stk deleted file mode 100644 index 3c3b9f0..0000000 --- a/src/stklos/lib.stk +++ /dev/null @@ -1,317 +0,0 @@ -;;;; -;;;; lib.stk -- Utilities -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/lisp-lex.l b/src/stklos/lisp-lex.l deleted file mode 100644 index efad24b..0000000 --- a/src/stklos/lisp-lex.l +++ /dev/null @@ -1,91 +0,0 @@ -;;;; -*- Scheme -*- -;;;; -;;;; lisp-lex.l -- SILex input for the Lisp Languages -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/lisp.stk b/src/stklos/lisp.stk deleted file mode 100644 index 9bfe75a..0000000 --- a/src/stklos/lisp.stk +++ /dev/null @@ -1,294 +0,0 @@ -;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/main.stk b/src/stklos/main.stk deleted file mode 100644 index 4905423..0000000 --- a/src/stklos/main.stk +++ /dev/null @@ -1,264 +0,0 @@ -;;;; -;;;; skribe.stk -- Skribe Main -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/output.stk b/src/stklos/output.stk deleted file mode 100644 index 3c00323..0000000 --- a/src/stklos/output.stk +++ /dev/null @@ -1,158 +0,0 @@ -;;;; -;;;; output.stk -- Skribe Output Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/prog.stk b/src/stklos/prog.stk deleted file mode 100644 index 6301ece..0000000 --- a/src/stklos/prog.stk +++ /dev/null @@ -1,219 +0,0 @@ -;;;; -;;;; prog.stk -- All the stuff for the prog markup -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/reader.stk b/src/stklos/reader.stk deleted file mode 100644 index bd38562..0000000 --- a/src/stklos/reader.stk +++ /dev/null @@ -1,136 +0,0 @@ -;;;; -;;;; reader.stk -- Reader hook for the open bracket -;;;; -;;;; Copyright (C) 2001-2003 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/resolve.stk b/src/stklos/resolve.stk deleted file mode 100644 index 91dc965..0000000 --- a/src/stklos/resolve.stk +++ /dev/null @@ -1,255 +0,0 @@ -;;;; -;;;; resolve.stk -- Skribe Resolve Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/runtime.stk b/src/stklos/runtime.stk deleted file mode 100644 index 58d0d45..0000000 --- a/src/stklos/runtime.stk +++ /dev/null @@ -1,456 +0,0 @@ -;;;; -;;;; runtime.stk -- Skribe runtime system -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/source.stk b/src/stklos/source.stk deleted file mode 100644 index a3102c1..0000000 --- a/src/stklos/source.stk +++ /dev/null @@ -1,191 +0,0 @@ -;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/types.stk b/src/stklos/types.stk deleted file mode 100644 index fb16230..0000000 --- a/src/stklos/types.stk +++ /dev/null @@ -1,294 +0,0 @@ -;;;; -;;;; types.stk -- Definition of Skribe classes -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/vars.stk b/src/stklos/vars.stk deleted file mode 100644 index 1c875f8..0000000 --- a/src/stklos/vars.stk +++ /dev/null @@ -1,82 +0,0 @@ -;;;; -;;;; vars.stk -- Skribe Globals -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/verify.stk b/src/stklos/verify.stk deleted file mode 100644 index da9b132..0000000 --- a/src/stklos/verify.stk +++ /dev/null @@ -1,157 +0,0 @@ -;;;; -;;;; verify.stk -- Skribe Verification Stage -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/writer.stk b/src/stklos/writer.stk deleted file mode 100644 index 2b0f91c..0000000 --- a/src/stklos/writer.stk +++ /dev/null @@ -1,211 +0,0 @@ -;;;; -;;;; writer.stk -- Skribe Writer Stuff -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/xml-lex.l b/src/stklos/xml-lex.l deleted file mode 100644 index 5d9a8d9..0000000 --- a/src/stklos/xml-lex.l +++ /dev/null @@ -1,64 +0,0 @@ -;;;; -*- Scheme -*- -;;;; -;;;; xml-lex.l -- SILex input for the XML languages -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <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/src/stklos/xml.stk b/src/stklos/xml.stk deleted file mode 100644 index 47dd46f..0000000 --- a/src/stklos/xml.stk +++ /dev/null @@ -1,52 +0,0 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <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))) -) |