diff options
Diffstat (limited to 'src/bigloo')
| -rw-r--r-- | src/bigloo/Makefile | 271 | ||||
| -rw-r--r-- | src/bigloo/api.bgl | 117 | ||||
| -rw-r--r-- | src/bigloo/api.sch | 91 | ||||
| -rw-r--r-- | src/bigloo/asm.scm | 99 | ||||
| -rw-r--r-- | src/bigloo/bib.bgl | 161 | ||||
| -rw-r--r-- | src/bigloo/c.scm | 134 | ||||
| -rw-r--r-- | src/bigloo/color.scm | 702 | ||||
| -rw-r--r-- | src/bigloo/configure.bgl | 90 | ||||
| -rw-r--r-- | src/bigloo/debug.sch | 54 | ||||
| -rw-r--r-- | src/bigloo/debug.scm | 188 | ||||
| -rw-r--r-- | src/bigloo/engine.scm | 262 | ||||
| -rw-r--r-- | src/bigloo/eval.scm | 335 | ||||
| -rw-r--r-- | src/bigloo/evapi.scm | 39 | ||||
| -rw-r--r-- | src/bigloo/index.bgl | 32 | ||||
| -rw-r--r-- | src/bigloo/lib.bgl | 340 | ||||
| -rw-r--r-- | src/bigloo/lisp.scm | 530 | ||||
| -rw-r--r-- | src/bigloo/main.scm | 96 | ||||
| -rw-r--r-- | src/bigloo/new.sch | 17 | ||||
| -rw-r--r-- | src/bigloo/output.scm | 167 | ||||
| -rw-r--r-- | src/bigloo/param.bgl | 134 | ||||
| -rw-r--r-- | src/bigloo/parseargs.scm | 186 | ||||
| -rw-r--r-- | src/bigloo/prog.scm | 196 | ||||
| -rw-r--r-- | src/bigloo/read.scm | 482 | ||||
| -rw-r--r-- | src/bigloo/resolve.scm | 281 | ||||
| -rw-r--r-- | src/bigloo/source.scm | 238 | ||||
| -rw-r--r-- | src/bigloo/sui.bgl | 34 | ||||
| -rw-r--r-- | src/bigloo/types.scm | 685 | ||||
| -rw-r--r-- | src/bigloo/verify.scm | 143 | ||||
| -rw-r--r-- | src/bigloo/writer.scm | 232 | ||||
| -rw-r--r-- | src/bigloo/xml.scm | 92 |
30 files changed, 6428 insertions, 0 deletions
diff --git a/src/bigloo/Makefile b/src/bigloo/Makefile new file mode 100644 index 0000000..02d2b6a --- /dev/null +++ b/src/bigloo/Makefile @@ -0,0 +1,271 @@ +#*=====================================================================*/ +#* serrano/prgm/project/skribe/src/bigloo/Makefile */ +#* ------------------------------------------------------------- */ +#* Author : Manuel Serrano */ +#* Creation : Mon Jul 21 18:21:11 2003 */ +#* Last change : Fri Jun 4 10:10:50 2004 (serrano) */ +#* Copyright : 2003-04 Manuel Serrano */ +#* ------------------------------------------------------------- */ +#* The Makefile to build the Bigloo API */ +#*=====================================================================*/ + +#*---------------------------------------------------------------------*/ +#* General inclusion */ +#*---------------------------------------------------------------------*/ +include ../../etc/bigloo/Makefile.skb + +#*---------------------------------------------------------------------*/ +#* Compilers and tools */ +#*---------------------------------------------------------------------*/ +BSKBFLAGS = -I $(SRCDIR)/bigloo + +#*---------------------------------------------------------------------*/ +#* Targets ... */ +#*---------------------------------------------------------------------*/ +PROJECT = skribe +CTARGET = $(SKRIBEBINDIR)/skribe.bigloo +JVMTARGET = $(SKRIBEBINDIR)/skribe.zip + +PBASE = bigloo.$(PROJECT) +ODIR = o +CLASSDIR = class_s/bigloo/$(PROJECT) +OBJDIR = obj/bigloo/$(PROJECT) + +#*---------------------------------------------------------------------*/ +#* Objects */ +#*---------------------------------------------------------------------*/ +SRCDIR = .. +SKRIBECOMMON = param api bib index lib sui +SKRIBEBGL = types parseargs main eval evapi \ + output resolve verify debug read prog source \ + lisp xml c asm engine writer color +SKRIBEINCLUDE = api new debug + +MODULES = $(SKRIBEBGL:%=%.scm) \ + $(SKRIBECOMMON:%=%.bgl) \ + configure.bgl +INCLUDES = $(SKRIBEINCLUDE:%=%.sch) +SOURCES = $(MODULES) \ + $(SKRIBECOMMON:%=$(SRCDIR)/common/%.scm) \ + $(SRCDIR)/common/configure.scm \ + $(INCLUDES) +OBJECTS = $(SKRIBECOMMON) $(SKRIBEBGL) configure +COBJECTS = $(OBJECTS:%=$(ODIR)/%.o) +JVMCLASSES = $(OBJECTS:%=$(ODIR)/class_s/bigloo/$(PROJECT)/%.class) + +#*---------------------------------------------------------------------*/ +#* Population */ +#*---------------------------------------------------------------------*/ +POPULATIONBGL = $(MODULES) $(INCLUDES) Makefile +POPULATIONSCM = $(SKRIBECOMMON:%=%.scm) configure.scm.in + +#*---------------------------------------------------------------------*/ +#* Suffixes */ +#*---------------------------------------------------------------------*/ +.SUFFIXES: +.SUFFIXES: .scm .bgl .class .o .obj + +#*---------------------------------------------------------------------*/ +#* All */ +#*---------------------------------------------------------------------*/ +.PHONY: c jvm dotnet + +all: $(TARGET) + +c: $(CTARGET) +jvm: $(JVMTARGET) +dotnet: + echo "Not implemented yet" + +#*--- c ---------------------------------------------------------------*/ +$(CTARGET): $(SKRIBEBINDIR) .afile $(ODIR) $(COBJECTS) + $(BIGLOO) $(BLINKFLAGS) -o $@ $(COBJECTS) + +#*--- jvm -------------------------------------------------------------*/ +$(JVMTARGET): $(SKRIBEBINDIR) .afile .jfile $(ODIR) $(JVMCLASSES) + $(RM) -f $(JVMTARGET) + (cd $(ODIR)/class_s && \ + $(ZIP) -q $(ZFLAGS) $(JVMTARGET) -r .) + +$(SKRIBEBINDIR): + mkdir -p $(SKRIBEBINDIR) + +#*---------------------------------------------------------------------*/ +#* pop */ +#*---------------------------------------------------------------------*/ +.PHONY: pop + +pop: + @ echo $(POPULATIONSCM:%=src/common/%) + @ echo $(POPULATIONBGL:%=src/bigloo/%) + +#*---------------------------------------------------------------------*/ +#* ude */ +#*---------------------------------------------------------------------*/ +.PHONY: ude .etags .afile + +ude: + @ $(MAKE) -f Makefile .afile .etags dep + +.afile: + @ $(AFILE) -o .afile $(MODULES) + +.jfile: + @ $(JFILE) -I src -o .jfile -pbase $(PBASE) $(MODULES) + +.etags: + @ $(BTAGS) -o .etags $(SOURCES) + +dep: + @(num=`grep -n '^#bdepend start' Makefile | awk -F: '{ print $$1}' -`;\ + head -`expr $$num - 1` Makefile > /tmp/Makefile.aux) + @ $(BDEPEND) -search-path ../common \ + -search-path ../bigloo \ + -strict-obj-dir $(ODIR) \ + -strict-class-dir $(CLASSDIR) \ + -fno-mco $(SOURCES) >> /tmp/Makefile.aux + @ mv /tmp/Makefile.aux Makefile + +getbinary: + @ echo $(PROJECT) + +getsources: + @ echo $(SOURCES) + +#*---------------------------------------------------------------------*/ +#* The implicit rules */ +#*---------------------------------------------------------------------*/ +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/%.o: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BCFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: \ + $(SRCDIR)/bigloo/%.bgl $(SRCDIR)/common/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.bgl $(SRCDIR)/common/$*.scm -o $@ + +$(ODIR)/class_s/bigloo/$(PROJECT)/%.class: $(SRCDIR)/bigloo/%.scm + $(BIGLOO) $(BJVMFLAGS) $(BSKBFLAGS) $(BCOMMONFLAGS) -c \ + $(SRCDIR)/bigloo/$*.scm -o $@ + +$(OBJDIR)/%.obj: src/%.scm + $(BIGLOO) $(BDNFLAGS) $(BCOMMONFLAGS) -c $< -o $@ + +#*---------------------------------------------------------------------*/ +#* Ad hoc rules */ +#*---------------------------------------------------------------------*/ +$(ODIR): + mkdir -p $(ODIR) + +$(CLASSDIR): + mkdir -p $(CLASSDIR) + +$(OBJDIR): + mkdir -p $(OBJDIR) + + +#*---------------------------------------------------------------------*/ +#* install/uninstall */ +#*---------------------------------------------------------------------*/ +.PHONY: install uninstall install-c uninstall-c install-jvm uninstall-jvm + +install: + $(MAKE) install-$(TARGET) + +uninstall: + $(MAKE) uninstall-$(TARGET) + +install-c: $(DESTDIR)$(INSTALL_BINDIR) + cp $(CTARGET) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo \ + && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + ln -s skribe.bigloo $(DESTDIR)$(INSTALL_BINDIR)/skribe + +uninstall-c: + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe.bigloo + $(RM) -f $(DESTDIR)$(INSTALL_BINDIR)/skribe + +install-jvm: $(DESTDIR)$(INSTALL_FILDIR) + cp $(JVMTARGET) $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + cp $(FILDIR)/bigloo_s.zip $(DESTDIR)$(INSTALL_FILDIR) + +uninstall-jvm: + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/skribe.zip + $(RM) -f $(DESTDIR)$(INSTALL_FILDIR)/bigloo_s.zip + +$(DESTDIR)$(INSTALL_BINDIR): + mkdir -p $(DESTDIR)$(INSTALL_BINDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_BINDIR) + +$(DESTDIR)$(INSTALL_FILDIR): + mkdir -p $(DESTDIR)$(INSTALL_FILDIR) && chmod $(BMASK) $(DESTDIR)$(INSTALL_FILDIR) + +#*---------------------------------------------------------------------*/ +#* Clean */ +#*---------------------------------------------------------------------*/ +clean: + $(RM) -f .afile + $(RM) -f .jfile + $(RM) -rf $(ODIR) + $(RM) -f $(CTARGET) + $(RM) -f $(JVMTARGET) + +#*---------------------------------------------------------------------*/ +#* Cleanall */ +#*---------------------------------------------------------------------*/ +cleanall: clean + +#*---------------------------------------------------------------------*/ +#* Manual dependency */ +#*---------------------------------------------------------------------*/ +o/eval.o o/class/bigloo/skribe/eval.class: \ + $(SRCDIR)/bigloo/api.bgl $(SRCDIR)/common/api.scm + +#bdepend start (don't edit) +#*---------------------------------------------------------------------*/ +#* Dependencies ... */ +#*---------------------------------------------------------------------*/ +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/verify.o class_s/bigloo/skribe/verify.class: ../bigloo/debug.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/bib.o class_s/bigloo/skribe/bib.class: ../bigloo/new.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/source.o class_s/bigloo/skribe/source.class: ../bigloo/new.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/engine.o class_s/bigloo/skribe/engine.class: ../bigloo/debug.sch +o/lib.o class_s/bigloo/skribe/lib.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/writer.o class_s/bigloo/skribe/writer.class: ../bigloo/debug.sch +o/xml.o class_s/bigloo/skribe/xml.class: ../bigloo/new.sch +o/main.o class_s/bigloo/skribe/main.class: ../bigloo/debug.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/prog.o class_s/bigloo/skribe/prog.class: ../bigloo/new.sch +o/output.o class_s/bigloo/skribe/output.class: ../bigloo/debug.sch +o/resolve.o class_s/bigloo/skribe/resolve.class: ../bigloo/debug.sch +o/sui.o class_s/bigloo/skribe/sui.class: ../bigloo/debug.sch +o/asm.o class_s/bigloo/skribe/asm.class: ../bigloo/new.sch +o/eval.o class_s/bigloo/skribe/eval.class: ../bigloo/debug.sch +o/c.o class_s/bigloo/skribe/c.class: ../bigloo/new.sch +o/index.o class_s/bigloo/skribe/index.class: ../bigloo/new.sch +o/lisp.o class_s/bigloo/skribe/lisp.class: ../bigloo/new.sch +o/api.o class_s/bigloo/skribe/api.class: ../bigloo/new.sch \ + ../bigloo/api.sch +o/parseargs.o class_s/bigloo/skribe/parseargs.class: ../bigloo/debug.sch + +#bdepend stop diff --git a/src/bigloo/api.bgl b/src/bigloo/api.bgl new file mode 100644 index 0000000..55493b0 --- /dev/null +++ b/src/bigloo/api.bgl @@ -0,0 +1,117 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:21:34 2003 */ +;* Last change : Wed Dec 31 13:07:10 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo header for the API. */ +;* ------------------------------------------------------------- */ +;* Implementation: @label api@ */ +;* bigloo: @path ../common/api.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_api + + (include "new.sch" + "api.sch") + + (import skribe_param + skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_bib + skribe_index + skribe_prog + skribe_source + skribe_engine + skribe_color + skribe_sui) + + (export (include string) + + (document::%markup . opts) + (author::%markup . opts) + (toc::%markup . opts) + + (chapter::%markup . opts) + (section::%markup . opts) + (subsection::%markup . opts) + (subsubsection::%markup . opts) + (paragraph::%markup . opts) + + (footnote::%markup . opts) + + (linebreak . opts) + (hrule::%markup . opts) + + (color::%markup . opts) + (frame::%markup . opts) + (font::%markup . opts) + + (flush::%markup . opts) + (center::%markup . opts) + (pre::%markup . opts) + (prog::%markup . opts) + (source::obj . opts) + (language::obj . opts) + + (itemize::%markup . opts) + (enumerate::%markup . opts) + (description::%markup . opts) + (item::%markup . opts) + + (figure::%markup . opts) + + (table::%markup . opts) + (tr::%markup . opts) + (td::%markup . opts) + (th::%markup . opts) + + (image::%markup . opts) + + (blockquote::%markup . opts) + + (roman::%markup . opts) + (bold::%markup . opts) + (underline::%markup . opts) + (strike::%markup . opts) + (emph::%markup . opts) + (kbd::%markup . opts) + (it::%markup . opts) + (tt::%markup . opts) + (code::%markup . opts) + (var::%markup . opts) + (samp::%markup . opts) + (sf::%markup . opts) + (sc::%markup . opts) + (sub::%markup . opts) + (sup::%markup . opts) + + (mailto::%markup . opts) + (mark::%markup . opts) + + (handle . obj) + (ref::%ast . obj) + (resolve::%ast ::procedure) + + (bibliography . files) + (the-bibliography . opts) + + (make-index ::bstring) + (index . args) + (the-index . args) + + (char::bstring char) + (symbol::%markup symbol) + (!::%command string . args) + + (processor::%processor . opts) + + (html-processor::%processor . opts) + (tex-processor::%processor . opts))) diff --git a/src/bigloo/api.sch b/src/bigloo/api.sch new file mode 100644 index 0000000..390b8fa --- /dev/null +++ b/src/bigloo/api.sch @@ -0,0 +1,91 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/api.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Jul 21 18:15:25 2003 */ +;* Last change : Wed Oct 27 12:43:23 2004 (eg) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo macros for the API implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* define-pervasive-macro ... */ +;*---------------------------------------------------------------------*/ +(define-macro (define-pervasive-macro proto . body) + `(begin + (eval '(define-macro ,proto ,@body)) + (define-macro ,proto ,@body))) + +;*---------------------------------------------------------------------*/ +;* define-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-markup proto . body) + (define (s2k symbol) + (string->keyword (string-append ":" (symbol->string symbol)))) + (if (not (pair? proto)) + (error 'define-markup "Illegal markup definition" proto) + (let* ((id (car proto)) + (args (cdr proto)) + (dargs (dsssl-formals->scheme-formals args error))) + `(begin + ,(if (and (memq #!key args) + (memq '&skribe-eval-location args)) + `(define-expander ,id + (lambda (x e) + (append + (cons ',id (map (lambda (x) (e x e)) (cdr x))) + (list :&skribe-eval-location + '(skribe-eval-location))))) + #unspecified) + (define ,(cons id dargs) + ,(make-dsssl-function-prelude proto + args `(begin ,@body) + error s2k)))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-markup markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new markup + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-simple-container ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-simple-container markup) + `(define-markup (,markup #!rest opts #!key ident class loc) + (new container + (markup ',markup) + (ident (or ident (symbol->string (gensym ',markup)))) + (loc loc) + (class class) + (required-options '()) + (options (the-options opts :ident :class :loc)) + (body (the-body opts))))) + +;*---------------------------------------------------------------------*/ +;* define-processor-markup ... */ +;*---------------------------------------------------------------------*/ +(define-pervasive-macro (define-processor-markup proc) + `(define-markup (,proc #!rest opts) + (new processor + (engine (find-engine ',proc)) + (body (the-body opts)) + (options (the-options opts))))) + +;*---------------------------------------------------------------------*/ +;* new (at runtime) */ +;*---------------------------------------------------------------------*/ +(eval '(define-macro (new id . inits) + (cons (symbol-append 'new- id) + (map (lambda (i) + (list 'list (list 'quote (car i)) (cadr i))) + inits)))) diff --git a/src/bigloo/asm.scm b/src/bigloo/asm.scm new file mode 100644 index 0000000..03196ac --- /dev/null +++ b/src/bigloo/asm.scm @@ -0,0 +1,99 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/asm.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Tue Jan 20 06:07:44 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* ASM fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_asm + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export asm)) + +;*---------------------------------------------------------------------*/ +;* asm ... */ +;*---------------------------------------------------------------------*/ +(define asm + (new language + (name "asm") + (fontifier asm-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* asm-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (asm-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: "#" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((: (* (in #\tab #\space)) + (+ (out #\: #\Space #\Tab #\Newline)) #\:) + ;; labels + (let ((c (new markup + (markup '&source-define) + (body (the-string))))) + (cons c (ignore)))) + ((or (in "<>=!/\\+*-([])") + #\/ + (+ (out #\; #\Space #\Tab #\Newline #\( #\) #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-))) + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(asm)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/src/bigloo/bib.bgl b/src/bigloo/bib.bgl new file mode 100644 index 0000000..6b0f7dd --- /dev/null +++ b/src/bigloo/bib.bgl @@ -0,0 +1,161 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/bib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Dec 7 06:12:29 2001 */ +;* Last change : Tue Nov 2 17:14:02 2004 (serrano) */ +;* Copyright : 2001-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe Bibliography */ +;* ------------------------------------------------------------- */ +;* Implementation: @label bib@ */ +;* bigloo: @path ../common/bib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_bib + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_read) + + (export (bib-table?::bool ::obj) + (make-bib-table ::bstring) + (default-bib-table) + (bib-load! ::obj ::bstring ::obj) + (bib-add! ::obj . entries) + (resolve-bib ::obj ::obj) + (resolve-the-bib ::obj ::obj ::procedure ::obj ::symbol ::pair-nil) + (bib-sort/authors::pair-nil ::pair-nil) + (bib-sort/idents::pair-nil ::pair-nil) + (bib-sort/dates::pair-nil ::pair-nil))) + +;*---------------------------------------------------------------------*/ +;* bib-table? ... */ +;*---------------------------------------------------------------------*/ +(define (bib-table? obj) + (hashtable? obj)) + +;*---------------------------------------------------------------------*/ +;* *bib-table* ... */ +;*---------------------------------------------------------------------*/ +(define *bib-table* #f) + +;*---------------------------------------------------------------------*/ +;* make-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (make-bib-table ident) + (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* default-bib-table ... */ +;*---------------------------------------------------------------------*/ +(define (default-bib-table) + (if (not *bib-table*) + (set! *bib-table* (make-bib-table "default-bib-table"))) + *bib-table*) + +;*---------------------------------------------------------------------*/ +;* bib-parse-error ... */ +;*---------------------------------------------------------------------*/ +(define (bib-parse-error entry) + (if (epair? entry) + (match-case (cer entry) + ((at ?fname ?pos ?-) + (error/location "parse-biblio" + "bibliography syntax error" + entry + fname + pos)) + (else + (error 'bib-parse "bibliography syntax error" entry))) + (error 'bib-parse "bibliography syntax error" entry))) + +;*---------------------------------------------------------------------*/ +;* bib-duplicate ... */ +;*---------------------------------------------------------------------*/ +(define (bib-duplicate ident from old) + (let ((ofrom (markup-option old 'from))) + (skribe-warning 2 + 'bib + (format "Duplicated bibliographic entry ~a'.\n" ident) + (if ofrom + (format " Using version of `~a'.\n" ofrom) + "") + (if from + (format " Ignoring version of `~a'." from) + " Ignoring redefinition.")))) + +;*---------------------------------------------------------------------*/ +;* parse-bib ... */ +;*---------------------------------------------------------------------*/ +(define (parse-bib table port) + (if (not (bib-table? table)) + (skribe-error 'parse-bib "Illegal bibliography table" table) + (let ((from (input-port-name port))) + (let loop ((entry (skribe-read port))) + (if (not (eof-object? entry)) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fds) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fds) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident from old) + (hashtable-put! table + ident + (make-bib-entry kind + ident + fds + from)))) + (loop (skribe-read port))) + (else + (bib-parse-error entry)))))))) + +;*---------------------------------------------------------------------*/ +;* bib-add! ... */ +;*---------------------------------------------------------------------*/ +(define (bib-add! table . entries) + (if (not (bib-table? table)) + (skribe-error 'bib-add! "Illegal bibliography table" table) + (for-each (lambda (entry) + (match-case entry + (((and (? symbol?) ?kind) (and (? symbol?) ?ident) . ?fs) + (let* ((ident (symbol->string ident)) + (old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (((and (? symbol?) ?kind) (and (? string?) ?ident) . ?fs) + (let ((old (hashtable-get table ident))) + (if old + (bib-duplicate ident #f old) + (hashtable-put! table + ident + (make-bib-entry kind + ident fs #f))))) + (else + (bib-parse-error entry)))) + entries))) + + + diff --git a/src/bigloo/c.scm b/src/bigloo/c.scm new file mode 100644 index 0000000..07290ce --- /dev/null +++ b/src/bigloo/c.scm @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/c.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Thu May 27 10:11:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* C fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_c + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export C)) + +;*---------------------------------------------------------------------*/ +;* C stamps */ +;*---------------------------------------------------------------------*/ +(define *keyword* (gensym)) +(define *cpp* (gensym)) + +;*---------------------------------------------------------------------*/ +;* C keywords */ +;*---------------------------------------------------------------------*/ +(for-each (lambda (symbol) + (putprop! symbol *keyword* #t)) + '(for class template while return try catch break continue + do if else typedef struct union goto switch case + static extern default finally throw)) +(let ((sharp (string->symbol "#"))) + (for-each (lambda (symbol) + (putprop! (symbol-append sharp symbol) *cpp* #t)) + '(include define if ifdef ifdef else endif))) + +;*---------------------------------------------------------------------*/ +;* C ... */ +;*---------------------------------------------------------------------*/ +(define C + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* c-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (c-fontifier s) + (let ((g (regular-grammar () + ((: "/*" (* (or (out #\*) (: (+ #\*) (out #\/ #\*)))) + (+ #\*) "/") + ;; bold comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((: "//" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((in "{}") + ;; brackets + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-bracket) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\; #\Space #\Tab #\Newline #\( #\) #\{ #\} #\[ #\] #\" #\< #\> #\= #\! #\/ #\/ #\+ #\* #\-)) + ;; keywords + (let* ((string (the-string)) + (symbol (the-symbol))) + (cond + ((getprop symbol *keyword*) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((getprop symbol *cpp*) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons string (ignore)))))) + ((in "<>=!/\\+*-([])") + ;; regular text + (let ((s (the-string))) + (cons s (ignore)))) + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((+ (or #\; #\" #\# #\tab)) + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(C)" "Unexpected character" c))))))) + (read/rp g (open-input-string s)))) + diff --git a/src/bigloo/color.scm b/src/bigloo/color.scm new file mode 100644 index 0000000..e40638b --- /dev/null +++ b/src/bigloo/color.scm @@ -0,0 +1,702 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/color.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Apr 10 13:46:50 2002 */ +;* Last change : Wed Jan 7 11:39:58 2004 (serrano) */ +;* Copyright : 2002-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Tex color manager */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_color + (import skribe_configure) + (export (skribe-color->rgb ::obj) + (skribe-get-used-colors) + (skribe-use-color! color))) + +;*---------------------------------------------------------------------*/ +;* *skribe-rgb-string* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-rgb-string* + "255 250 250 snow +248 248 255 ghostwhite +245 245 245 whitesmoke +220 220 220 gainsboro +255 250 240 floralwhite +253 245 230 oldlace +250 240 230 linen +250 235 215 antiquewhite +255 239 213 papayawhip +255 235 205 blanchedalmond +255 228 196 bisque +255 218 185 peachpuff +255 222 173 navajowhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemonchiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mintcream +240 255 255 azure +240 248 255 aliceblue +230 230 250 lavender +255 240 245 lavenderblush +255 228 225 mistyrose +255 255 255 white +0 0 0 black +47 79 79 darkslategrey +105 105 105 dimgrey +112 128 144 slategrey +119 136 153 lightslategrey +190 190 190 grey +211 211 211 lightgrey +25 25 112 midnightblue +0 0 128 navy +0 0 128 navyblue +100 149 237 cornflowerblue +72 61 139 darkslateblue +106 90 205 slateblue +123 104 238 mediumslateblue +132 112 255 lightslateblue +0 0 205 mediumblue +65 105 225 royalblue +0 0 255 blue +30 144 255 dodgerblue +0 191 255 deepskyblue +135 206 235 skyblue +135 206 250 lightskyblue +70 130 180 steelblue +176 196 222 lightsteelblue +173 216 230 lightblue +176 224 230 powderblue +175 238 238 paleturquoise +0 206 209 darkturquoise +72 209 204 mediumturquoise +64 224 208 turquoise +0 255 255 cyan +224 255 255 lightcyan +95 158 160 cadetblue +102 205 170 mediumaquamarine +127 255 212 aquamarine +0 100 0 darkgreen +85 107 47 darkolivegreen +143 188 143 darkseagreen +46 139 87 seagreen +60 179 113 mediumseagreen +32 178 170 lightseagreen +152 251 152 palegreen +0 255 127 springgreen +124 252 0 lawngreen +0 255 0 green +127 255 0 chartreuse +0 250 154 mediumspringgreen +173 255 47 greenyellow +50 205 50 limegreen +154 205 50 yellowgreen +34 139 34 forestgreen +107 142 35 olivedrab +189 183 107 darkkhaki +240 230 140 khaki +238 232 170 palegoldenrod +250 250 210 lightgoldenrodyellow +255 255 224 lightyellow +255 255 0 yellow +255 215 0 gold +238 221 130 lightgoldenrod +218 165 32 goldenrod +184 134 11 darkgoldenrod +188 143 143 rosybrown +205 92 92 indianred +139 69 19 saddlebrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandybrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 darksalmon +250 128 114 salmon +255 160 122 lightsalmon +255 165 0 orange +255 140 0 darkorange +255 127 80 coral +240 128 128 lightcoral +255 99 71 tomato +255 69 0 orangered +255 0 0 red +255 105 180 hotpink +255 20 147 deeppink +255 192 203 pink +255 182 193 lightpink +219 112 147 palevioletred +176 48 96 maroon +199 21 133 mediumvioletred +208 32 144 violetred +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 mediumorchid +153 50 204 darkorchid +148 0 211 darkviolet +138 43 226 blueviolet +160 32 240 purple +147 112 219 mediumpurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 antiquewhite1 +238 223 204 antiquewhite2 +205 192 176 antiquewhite3 +139 131 120 antiquewhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 peachpuff1 +238 203 173 peachpuff2 +205 175 149 peachpuff3 +139 119 101 peachpuff4 +255 222 173 navajowhite1 +238 207 161 navajowhite2 +205 179 139 navajowhite3 +139 121 94 navajowhite4 +255 250 205 lemonchiffon1 +238 233 191 lemonchiffon2 +205 201 165 lemonchiffon3 +139 137 112 lemonchiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 lavenderblush1 +238 224 229 lavenderblush2 +205 193 197 lavenderblush3 +139 131 134 lavenderblush4 +255 228 225 mistyrose1 +238 213 210 mistyrose2 +205 183 181 mistyrose3 +139 125 123 mistyrose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 slateblue1 +122 103 238 slateblue2 +105 89 205 slateblue3 +71 60 139 slateblue4 +72 118 255 royalblue1 +67 110 238 royalblue2 +58 95 205 royalblue3 +39 64 139 royalblue4 +0 0 255 blue1 +0 0 238 blue2 +0 0 205 blue3 +0 0 139 blue4 +30 144 255 dodgerblue1 +28 134 238 dodgerblue2 +24 116 205 dodgerblue3 +16 78 139 dodgerblue4 +99 184 255 steelblue1 +92 172 238 steelblue2 +79 148 205 steelblue3 +54 100 139 steelblue4 +0 191 255 deepskyblue1 +0 178 238 deepskyblue2 +0 154 205 deepskyblue3 +0 104 139 deepskyblue4 +135 206 255 skyblue1 +126 192 238 skyblue2 +108 166 205 skyblue3 +74 112 139 skyblue4 +176 226 255 lightskyblue1 +164 211 238 lightskyblue2 +141 182 205 lightskyblue3 +96 123 139 lightskyblue4 +202 225 255 lightsteelblue1 +188 210 238 lightsteelblue2 +162 181 205 lightsteelblue3 +110 123 139 lightsteelblue4 +191 239 255 lightblue1 +178 223 238 lightblue2 +154 192 205 lightblue3 +104 131 139 lightblue4 +224 255 255 lightcyan1 +209 238 238 lightcyan2 +180 205 205 lightcyan3 +122 139 139 lightcyan4 +187 255 255 paleturquoise1 +174 238 238 paleturquoise2 +150 205 205 paleturquoise3 +102 139 139 paleturquoise4 +152 245 255 cadetblue1 +142 229 238 cadetblue2 +122 197 205 cadetblue3 +83 134 139 cadetblue4 +0 245 255 turquoise1 +0 229 238 turquoise2 +0 197 205 turquoise3 +0 134 139 turquoise4 +0 255 255 cyan1 +0 238 238 cyan2 +0 205 205 cyan3 +0 139 139 cyan4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 +69 139 116 aquamarine4 +193 255 193 darkseagreen1 +180 238 180 darkseagreen2 +155 205 155 darkseagreen3 +105 139 105 darkseagreen4 +84 255 159 seagreen1 +78 238 148 seagreen2 +67 205 128 seagreen3 +46 139 87 seagreen4 +154 255 154 palegreen1 +144 238 144 palegreen2 +124 205 124 palegreen3 +84 139 84 palegreen4 +0 255 127 springgreen1 +0 238 118 springgreen2 +0 205 102 springgreen3 +0 139 69 springgreen4 +0 255 0 green1 +0 238 0 green2 +0 205 0 green3 +0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 +69 139 0 chartreuse4 +192 255 62 olivedrab1 +179 238 58 olivedrab2 +154 205 50 olivedrab3 +105 139 34 olivedrab4 +202 255 112 darkolivegreen1 +188 238 104 darkolivegreen2 +162 205 90 darkolivegreen3 +110 139 61 darkolivegreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 lightgoldenrod1 +238 220 130 lightgoldenrod2 +205 190 112 lightgoldenrod3 +139 129 76 lightgoldenrod4 +255 255 224 lightyellow1 +238 238 209 lightyellow2 +205 205 180 lightyellow3 +139 139 122 lightyellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 darkgoldenrod1 +238 173 14 darkgoldenrod2 +205 149 12 darkgoldenrod3 +139 101 8 darkgoldenrod4 +255 193 193 rosybrown1 +238 180 180 rosybrown2 +205 155 155 rosybrown3 +139 105 105 rosybrown4 +255 106 106 indianred1 +238 99 99 indianred2 +205 85 85 indianred3 +139 58 58 indianred4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 lightsalmon1 +238 149 114 lightsalmon2 +205 129 98 lightsalmon3 +139 87 66 lightsalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 darkorange1 +238 118 0 darkorange2 +205 102 0 darkorange3 +139 69 0 darkorange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 orangered1 +238 64 0 orangered2 +205 55 0 orangered3 +139 37 0 orangered4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 deeppink1 +238 18 137 deeppink2 +205 16 118 deeppink3 +139 10 80 deeppink4 +255 110 180 hotpink1 +238 106 167 hotpink2 +205 96 144 hotpink3 +139 58 98 hotpink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 lightpink1 +238 162 173 lightpink2 +205 140 149 lightpink3 +139 95 101 lightpink4 +255 130 171 palevioletred1 +238 121 159 palevioletred2 +205 104 137 palevioletred3 +139 71 93 palevioletred4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 violetred1 +238 58 140 violetred2 +205 50 120 violetred3 +139 34 82 violetred4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 mediumorchid1 +209 95 238 mediumorchid2 +180 82 205 mediumorchid3 +122 55 139 mediumorchid4 +191 62 255 darkorchid1 +178 58 238 darkorchid2 +154 50 205 darkorchid3 +104 34 139 darkorchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 +85 26 139 purple4 +171 130 255 mediumpurple1 +159 121 238 mediumpurple2 +137 104 205 mediumpurple3 +93 71 139 mediumpurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 +0 0 0 grey0 +3 3 3 grey1 +5 5 5 grey2 +8 8 8 grey3 +10 10 10 grey4 +13 13 13 grey5 +15 15 15 grey6 +18 18 18 grey7 +20 20 20 grey8 +23 23 23 grey9 +26 26 26 grey10 +28 28 28 grey11 +31 31 31 grey12 +33 33 33 grey13 +36 36 36 grey14 +38 38 38 grey15 +41 41 41 grey16 +43 43 43 grey17 +46 46 46 grey18 +48 48 48 grey19 +51 51 51 grey20 +54 54 54 grey21 +56 56 56 grey22 +59 59 59 grey23 +61 61 61 grey24 +64 64 64 grey25 +66 66 66 grey26 +69 69 69 grey27 +71 71 71 grey28 +74 74 74 grey29 +77 77 77 grey30 +79 79 79 grey31 +82 82 82 grey32 +84 84 84 grey33 +87 87 87 grey34 +89 89 89 grey35 +92 92 92 grey36 +94 94 94 grey37 +97 97 97 grey38 +99 99 99 grey39 +102 102 102 grey40 +105 105 105 grey41 +107 107 107 grey42 +110 110 110 grey43 +112 112 112 grey44 +115 115 115 grey45 +117 117 117 grey46 +120 120 120 grey47 +122 122 122 grey48 +125 125 125 grey49 +127 127 127 grey50 +130 130 130 grey51 +133 133 133 grey52 +135 135 135 grey53 +138 138 138 grey54 +140 140 140 grey55 +143 143 143 grey56 +145 145 145 grey57 +148 148 148 grey58 +150 150 150 grey59 +153 153 153 grey60 +156 156 156 grey61 +158 158 158 grey62 +161 161 161 grey63 +163 163 163 grey64 +166 166 166 grey65 +168 168 168 grey66 +171 171 171 grey67 +173 173 173 grey68 +176 176 176 grey69 +179 179 179 grey70 +181 181 181 grey71 +184 184 184 grey72 +186 186 186 grey73 +189 189 189 grey74 +191 191 191 grey75 +194 194 194 grey76 +196 196 196 grey77 +199 199 199 grey78 +201 201 201 grey79 +204 204 204 grey80 +207 207 207 grey81 +209 209 209 grey82 +212 212 212 grey83 +214 214 214 grey84 +217 217 217 grey85 +219 219 219 grey86 +222 222 222 grey87 +224 224 224 grey88 +227 227 227 grey89 +229 229 229 grey90 +232 232 232 grey91 +235 235 235 grey92 +237 237 237 grey93 +240 240 240 grey94 +242 242 242 grey95 +245 245 245 grey96 +247 247 247 grey97 +250 250 250 grey98 +252 252 252 grey99 +255 255 255 grey100 +169 169 169 darkgrey +0 0 139 darkblue +0 139 139 darkcyan +139 0 139 darkmagenta +139 0 0 darkred +144 238 144 lightgreen") + +;*---------------------------------------------------------------------*/ +;* *rgb-port* ... */ +;*---------------------------------------------------------------------*/ +(define *rgb-port* #unspecified) + +;*---------------------------------------------------------------------*/ +;* same-color? ... */ +;*---------------------------------------------------------------------*/ +(define (same-color? s1 s2) + (define (skip-rgb s) + (let ((l (string-length s))) + (let loop ((i 0)) + (if (=fx i l) + l + (let ((c (string-ref s i))) + (if (or (char-numeric? c) (char-whitespace? c)) + (loop (+fx i 1)) + i)))))) + (let ((l1 (string-length s1)) + (l2 (string-length s2))) + (if (>fx l1 l2) + (let ((lc (skip-rgb s1))) + (and (=fx (-fx l1 lc) l2) + (let loop ((i1 (-fx l1 l2)) + (i2 0)) + (cond + ((=fx i1 l1) + #t) + ((char-ci=? (string-ref s1 i1) (string-ref s2 i2)) + (loop (+fx i1 1) (+fx i2 1))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* rgb-grep ... */ +;*---------------------------------------------------------------------*/ +(define (rgb-grep symbol) + (let ((parser (regular-grammar () + ((bol (: #\! (* all))) + (ignore)) + ((+ #\Newline) + (ignore)) + ((: (* (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ digit) + (+ (in #\space #\tab)) + (+ all)) + (let ((s (the-string))) + (if (same-color? s symbol) + (let ((m (pregexp-match "[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)[ \t]+.+" s))) + (values (string->number (cadr m)) + (string->number (caddr m)) + (string->number (cadddr m)))) + (ignore)))) + (else + (values 0 0 0))))) + ;; initialization the port reading rgb.txt file + (with-input-from-string *skribe-rgb-string* + (lambda () + (read/rp parser (current-input-port)))))) + +;*---------------------------------------------------------------------*/ +;* *color-parser* ... */ +;*---------------------------------------------------------------------*/ +(define *color-parser* + (regular-grammar ((blank* (* blank)) + (blank+ (+ blank))) + + ;; rgb color + ((: #\# (+ xdigit)) + (let ((val (the-substring 1 (the-length)))) + (cond + ((=fx (string-length val) 6) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 2 4) 16) + (string->integer (substring val 4 6) 16))) + ((=fx (string-length val) 12) + (values (string->integer (substring val 0 2) 16) + (string->integer (substring val 4 6) 16) + (string->integer (substring val 8 10) 16))) + (else + (values 0 0 0))))) + + ;; symbolic names + ((+ (out #\Newline)) + (let ((name (the-string))) + (cond + ((string-ci=? name "none") + (values 0 0 0)) + ((string-ci=? name "black") + (values #xff #xff #xff)) + ((string-ci=? name "white") + (values 0 0 0)) + (else + (rgb-grep name))))) + + ;; error + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* skribe-color->rgb ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-color->rgb spec) + (cond + ((string? spec) + (with-input-from-string spec + (lambda () + (read/rp *color-parser* (current-input-port))))) + ((fixnum? spec) + (values (bit-and #xff (bit-rsh spec 16)) + (bit-and #xff (bit-rsh spec 8)) + (bit-and #xff spec))) + (else + (values 0 0 0)))) + +;*---------------------------------------------------------------------*/ +;* *used-colors* ... */ +;*---------------------------------------------------------------------*/ +(define *used-colors* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-get-used-colors ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-get-used-colors) + *used-colors*) + +;*---------------------------------------------------------------------*/ +;* skribe-use-color! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-use-color! color) + (set! *used-colors* (cons color *used-colors*)) + color) diff --git a/src/bigloo/configure.bgl b/src/bigloo/configure.bgl new file mode 100644 index 0000000..e100d8d --- /dev/null +++ b/src/bigloo/configure.bgl @@ -0,0 +1,90 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/configure.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:42:21 2003 */ +;* Last change : Mon Feb 9 06:51:11 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The general configuration options. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_configure + (export (skribe-release) + (skribe-url) + (skribe-doc-dir) + (skribe-ext-dir) + (skribe-default-path) + (skribe-scheme) + + (skribe-configure . opt) + (skribe-enforce-configure . opt))) + +;*---------------------------------------------------------------------*/ +;* skribe-configuration ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configuration) + `((:release ,(skribe-release)) + (:scheme ,(skribe-scheme)) + (:url ,(skribe-url)) + (:doc-dir ,(skribe-doc-dir)) + (:ext-dir ,(skribe-ext-dir)) + (:default-path ,(skribe-default-path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-configure . opt) + (let ((conf (skribe-configuration))) + (cond + ((null? opt) + conf) + ((null? (cdr opt)) + (let ((cell (assq (car opt) conf))) + (if (pair? cell) + (cadr cell) + 'void))) + (else + (let loop ((opt opt)) + (cond + ((null? opt) + #t) + ((not (keyword? (car opt))) + #f) + ((or (null? (cdr opt)) (keyword? (cadr opt))) + #f) + (else + (let ((cell (assq (car opt) conf))) + (if (and (pair? cell) + (if (procedure? (cadr opt)) + ((cadr opt) (cadr cell)) + (equal? (cadr opt) (cadr cell)))) + (loop (cddr opt)) + #f))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-enforce-configure ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-enforce-configure . opt) + (let loop ((o opt)) + (when (pair? o) + (cond + ((or (not (keyword? (car o))) + (null? (cdr o))) + (error 'skribe-enforce-configure + "Illegal enforcement" + opt)) + ((skribe-configure (car o) (cadr o)) + (loop (cddr o))) + (else + (error 'skribe-enforce-configure + (format "Configuration mismatch: ~a" (car o)) + (if (procedure? (cadr o)) + (format "provided `~a'" + (skribe-configure (car o))) + (format "provided `~a', required `~a'" + (skribe-configure (car o)) + (cadr o))))))))) diff --git a/src/bigloo/debug.sch b/src/bigloo/debug.sch new file mode 100644 index 0000000..9b53c84 --- /dev/null +++ b/src/bigloo/debug.sch @@ -0,0 +1,54 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Thu May 29 06:46:33 2003 */ +;* Last change : Tue Nov 2 14:31:45 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* directives */ +;*---------------------------------------------------------------------*/ +(directives + (import skribe_debug)) + +;*---------------------------------------------------------------------*/ +;* when-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (when-debug level . exp) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(if (>= *skribe-debug* ,level) (begin ,@exp)) + #unspecified)) + +;*---------------------------------------------------------------------*/ +;* with-debug ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-debug level lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(%with-debug ,level ,lbl (lambda () (begin ,@arg*))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* with-push-trace ... */ +;*---------------------------------------------------------------------*/ +(define-macro (with-push-trace lbl . arg*) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + (let ((r (gensym))) + `(let () + (c-push-trace ,lbl) + (let ((,r ,@arg*)) + (c-pop-trace) + ,r))) + `(begin ,@arg*))) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define-expander debug-item + (lambda (x e) + (if (and (number? *compiler-debug*) (> *compiler-debug* 0)) + `(debug-item ,@(map (lambda (x) (e x e)) (cdr x))) + #unspecified))) diff --git a/src/bigloo/debug.scm b/src/bigloo/debug.scm new file mode 100644 index 0000000..8f1691c --- /dev/null +++ b/src/bigloo/debug.scm @@ -0,0 +1,188 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/debug.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jun 11 10:01:47 2003 */ +;* Last change : Thu Oct 28 21:33:00 2004 (eg) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Simple debug facilities */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_debug + + (export *skribe-debug* + *skribe-debug-symbols* + *skribe-debug-color* + + (skribe-debug::int) + (debug-port::output-port . ::obj) + (debug-margin::bstring) + (debug-color::bstring ::int . ::obj) + (debug-bold::bstring . ::obj) + (debug-string ::obj) + (debug-item . ::obj) + + (%with-debug ::obj ::obj ::procedure))) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-symbols* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-symbols* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-color* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-color* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-debug-item* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-debug-item* #f) + +;*---------------------------------------------------------------------*/ +;* *debug-port* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-port* (current-error-port)) + +;*---------------------------------------------------------------------*/ +;* *debug-depth* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-depth* 0) + +;*---------------------------------------------------------------------*/ +;* *debug-margin* ... */ +;*---------------------------------------------------------------------*/ +(define *debug-margin* "") + +;*---------------------------------------------------------------------*/ +;* *skribe-margin-debug-level* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-margin-debug-level* 0) + +;*---------------------------------------------------------------------*/ +;* skribe-debug ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-debug) + *skribe-debug*) + +;*---------------------------------------------------------------------*/ +;* debug-port ... */ +;*---------------------------------------------------------------------*/ +(define (debug-port . o) + (cond + ((null? o) + *debug-port*) + ((output-port? (car o)) + (set! *debug-port* o) + o) + (else + (error 'debug-port "Illegal debug port" (car o))))) + +;*---------------------------------------------------------------------*/ +;* debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (debug-margin) + *debug-margin*) + +;*---------------------------------------------------------------------*/ +;* debug-color ... */ +;*---------------------------------------------------------------------*/ +(define (debug-color col::int . o) + (with-output-to-string + (if *skribe-debug-color* + (lambda () + (display* "[0m[1;" (+ 31 col) "m") + (apply display* o) + (display "[0m")) + (lambda () + (apply display* o))))) + +;*---------------------------------------------------------------------*/ +;* debug-bold ... */ +;*---------------------------------------------------------------------*/ +(define (debug-bold . o) + (apply debug-color -30 o)) + +;*---------------------------------------------------------------------*/ +;* debug-item ... */ +;*---------------------------------------------------------------------*/ +(define (debug-item . args) + (if (or (>= *skribe-debug* *skribe-margin-debug-level*) + *skribe-debug-item*) + (begin + (display (debug-margin) *debug-port*) + (display (debug-color (-fx *debug-depth* 1) "- ")) + (for-each (lambda (a) (display a *debug-port*)) args) + (newline *debug-port*)))) + +;*---------------------------------------------------------------------*/ +;* %with-debug-margin ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug-margin margin thunk) + (let ((om *debug-margin*)) + (set! *debug-depth* (+fx *debug-depth* 1)) + (set! *debug-margin* (string-append om margin)) + (let ((res (thunk))) + (set! *debug-depth* (-fx *debug-depth* 1)) + (set! *debug-margin* om) + res))) + +;*---------------------------------------------------------------------*/ +;* %with-debug ... */ +;*---------------------------------------------------------------------*/ +(define (%with-debug lvl lbl thunk) + (let ((ol *skribe-margin-debug-level*) + (oi *skribe-debug-item*)) + (set! *skribe-margin-debug-level* lvl) + (let ((r (if (or (and (number? lvl) (>= *skribe-debug* lvl)) + (and (symbol? lbl) + (memq lbl *skribe-debug-symbols*) + (set! *skribe-debug-item* #t))) + (with-output-to-port *debug-port* + (lambda () + (display (debug-margin)) + (display (if (= *debug-depth* 0) + (debug-color *debug-depth* "+ " lbl) + (debug-color *debug-depth* "--+ " lbl))) + (newline) + (%with-debug-margin (debug-color *debug-depth* " |") + thunk))) + (thunk)))) + (set! *skribe-debug-item* oi) + (set! *skribe-margin-debug-level* ol) + r))) + +;*---------------------------------------------------------------------*/ +;* debug-string ... */ +;*---------------------------------------------------------------------*/ +(define (debug-string o) + (with-output-to-string + (lambda () + (write o)))) + +;*---------------------------------------------------------------------*/ +;* example */ +;*---------------------------------------------------------------------*/ +;; (%with-debug 0 'foo1.1 +;; (lambda () +;; (debug-item 'foo2.1) +;; (debug-item 'foo2.2) +;; (%with-debug 0 'foo2.3 +;; (lambda () +;; (debug-item 'foo3.1) +;; (%with-debug 0 'foo3.2 +;; (lambda () +;; (debug-item 'foo4.1) +;; (debug-item 'foo4.2))) +;; (debug-item 'foo3.3))) +;; (debug-item 'foo2.4))) + diff --git a/src/bigloo/engine.scm b/src/bigloo/engine.scm new file mode 100644 index 0000000..bd8a027 --- /dev/null +++ b/src/bigloo/engine.scm @@ -0,0 +1,262 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/engine.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 08:01:30 2003 */ +;* Last change : Fri May 21 16:12:32 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe engines */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_engine + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output) + + (export (make-engine::%engine ::symbol #!key v fmt in fi cu st if) + (copy-engine::%engine ::symbol ::%engine #!key v in fi cu st) + (find-engine ::symbol #!key version) + + (default-engine::obj) + (default-engine-set! ::%engine) + (push-default-engine ::%engine) + (pop-default-engine) + + (processor-get-engine ::obj ::obj ::%engine) + + (engine-format? ::bstring . e) + + (engine-custom::obj ::%engine ::symbol) + (engine-custom-set! ::%engine ::symbol ::obj) + + (engine-add-writer! ::%engine ::obj ::procedure ::obj + ::obj ::obj ::obj ::obj ::obj ::obj))) + +;*---------------------------------------------------------------------*/ +;* *engines* ... */ +;*---------------------------------------------------------------------*/ +(define *engines* '()) + +;*---------------------------------------------------------------------*/ +;* *default-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *default-engine* #f) +(define *default-engines* '()) + +;*---------------------------------------------------------------------*/ +;* default-engine-set! ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine-set! e) + (if (not (engine? e)) + (skribe-type-error 'default-engine-set! "engine" e (find-runtime-type e)) + (begin + (set! *default-engine* e) + (set! *default-engines* (cons *default-engine* *default-engines*)) + e))) + +;*---------------------------------------------------------------------*/ +;* default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (default-engine) + *default-engine*) + +;*---------------------------------------------------------------------*/ +;* push-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (push-default-engine e) + (set! *default-engines* (cons e *default-engines*)) + (default-engine-set! e)) + +;*---------------------------------------------------------------------*/ +;* pop-default-engine ... */ +;*---------------------------------------------------------------------*/ +(define (pop-default-engine) + (if (null? *default-engines*) + (skribe-error 'pop-default-engine "Empty engine stack" '()) + (begin + (set! *default-engines* (cdr *default-engines*)) + (if (pair? *default-engines*) + (default-engine-set! (car *default-engines*)) + (set! *default-engine* #f))))) + +;*---------------------------------------------------------------------*/ +;* processor-get-engine ... */ +;*---------------------------------------------------------------------*/ +(define (processor-get-engine combinator newe olde) + (cond + ((procedure? combinator) + (combinator newe olde)) + ((engine? newe) + newe) + (else + olde))) + +;*---------------------------------------------------------------------*/ +;* engine-format? ... */ +;*---------------------------------------------------------------------*/ +(define (engine-format? fmt . e) + (let ((e (cond + ((pair? e) (car e)) + ((%engine? *skribe-engine*) *skribe-engine*) + (else (find-engine *skribe-engine*))))) + (if (not (%engine? e)) + (skribe-error 'engine-format? "No engine" e) + (string=? fmt (%engine-format e))))) + +;*---------------------------------------------------------------------*/ +;* make-engine ... */ +;*---------------------------------------------------------------------*/ +(define (make-engine ident + #!key + (version #unspecified) + (format "raw") + (filter #f) + (delegate #f) + (symbol-table '()) + (custom '()) + (info '())) + (let ((e (instantiate::%engine + (ident ident) + (version version) + (format format) + (filter filter) + (delegate delegate) + (symbol-table symbol-table) + (customs custom) + (info info)))) + ;; store the engine in the global table + (set! *engines* (cons e *engines*)) + ;; return it + e)) + +;*---------------------------------------------------------------------*/ +;* copy-engine ... */ +;*---------------------------------------------------------------------*/ +(define (copy-engine ident + e + #!key + (version #unspecified) + (filter #f) + (delegate #f) + (symbol-table #f) + (custom #f)) + (let ((e (duplicate::%engine e + (ident ident) + (version version) + (filter (or filter (%engine-filter e))) + (delegate (or delegate (%engine-delegate e))) + (symbol-table (or symbol-table (%engine-symbol-table e))) + (customs (or custom (%engine-customs e)))))) + (set! *engines* (cons e *engines*)) + e)) + +;*---------------------------------------------------------------------*/ +;* find-loaded-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-loaded-engine id version) + (let loop ((es *engines*)) + (cond + ((null? es) + #f) + ((eq? (%engine-ident (car es)) id) + (cond + ((eq? version #unspecified) + (car es)) + ((eq? version (%engine-version (car es))) + (car es)) + (else + (loop (cdr es))))) + (else + (loop (cdr es)))))) + +;*---------------------------------------------------------------------*/ +;* find-engine ... */ +;*---------------------------------------------------------------------*/ +(define (find-engine id #!key (version #unspecified)) + (with-debug 5 'find-engine + (debug-item "id=" id " version=" version) + (or (find-loaded-engine id version) + (let ((c (assq id *skribe-auto-load-alist*))) + (debug-item "c=" c) + (if (and (pair? c) (string? (cdr c))) + (begin + (skribe-load (cdr c) :engine 'base) + (find-loaded-engine id version)) + #f))))) + +;*---------------------------------------------------------------------*/ +;* engine-custom ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom e id) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (cadr c) + #unspecified)))) + +;*---------------------------------------------------------------------*/ +;* engine-custom-set! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-custom-set! e id val) + (with-access::%engine e (customs) + (let ((c (assq id customs))) + (if (pair? c) + (set-car! (cdr c) val) + (set! customs (cons (list id val) customs)))))) + +;*---------------------------------------------------------------------*/ +;* engine-add-writer! ... */ +;*---------------------------------------------------------------------*/ +(define (engine-add-writer! e id pred upred opt before action after class va) + ;; check the arity of a procedure + (define (check-procedure name proc arity) + (cond + ((not (procedure? proc)) + (skribe-error id "Illegal procedure" proc)) + ((not (correct-arity? proc arity)) + (skribe-error id + (string-append "Illegal `" name "'procedure") + proc)))) + (define (check-output name proc) + (and proc (or (string? proc) (check-procedure name proc 2)))) + ;; check the engine + (if (not (engine? e)) + (skribe-error id "Illegal engine" e)) + ;; check the options + (if (not (or (eq? opt 'all) (list? opt))) + (skribe-error id "Illegal options" opt)) + ;; check the correctness of the predicate and the validator + (check-procedure "predicate" pred 2) + (when va (check-procedure "validate" va 2)) + ;; check the correctness of the three actions + (check-output "before" before) + (check-output "action" action) + (check-output "after" after) + ;; create a new writer... + (let ((n (instantiate::%writer + (ident (if (symbol? id) id 'all)) + (class class) + (pred pred) + (upred upred) + (options opt) + (before before) + (action action) + (after after) + (validate va)))) + ;; ...and bind it + (with-access::%engine e (writers) + (set! writers (cons n writers)) + n))) diff --git a/src/bigloo/eval.scm b/src/bigloo/eval.scm new file mode 100644 index 0000000..b5c6548 --- /dev/null +++ b/src/bigloo/eval.scm @@ -0,0 +1,335 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/eval.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed May 18 15:52:01 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe evaluator */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_eval + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_param + skribe_types + skribe_resolve + skribe_verify + skribe_output + skribe_read + skribe_lib + skribe_engine) + + (export (skribe-eval-location) + (skribe-error ::obj ::obj ::obj) + (skribe-type-error ::obj ::obj ::obj ::bstring) + (skribe-warning ::int . obj) + (skribe-warning/ast ::int ::%ast . obj) + (skribe-message ::bstring . obj) + (skribe-load ::bstring #!rest opt #!key engine path) + (skribe-load-options) + (skribe-include ::bstring . rest) + (skribe-open-bib-file ::bstring ::obj) + (skribe-eval-port ::input-port ::obj #!key env) + (skribe-eval ::obj ::%engine #!key env) + (skribe-path::pair-nil) + (skribe-path-set! ::obj) + (skribe-image-path::pair-nil) + (skribe-image-path-set! ::obj) + (skribe-bib-path::pair-nil) + (skribe-bib-path-set! ::obj) + (skribe-source-path::pair-nil) + (skribe-source-path-set! ::obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-location ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-location) + (evmeaning-location)) + +;*---------------------------------------------------------------------*/ +;* skribe-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-error proc msg obj) + (if (ast? obj) + (skribe-ast-error proc msg obj) + (error/evloc proc msg obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-type-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-type-error proc msg obj etype) + (let ((ty (if (%markup? obj) + (format "~a#~a" (markup-markup obj) (markup-ident obj)) + (find-runtime-type obj)))) + (skribe-error proc + (bigloo-type-error-msg msg etype ty) + obj))) + +;*---------------------------------------------------------------------*/ +;* skribe-ast-error ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-ast-error proc msg obj) + (let ((l (ast-loc obj)) + (shape (if (%markup? obj) + (%markup-markup obj) + (find-runtime-type obj)))) + (if (location? l) + (error/location proc msg shape (location-file l) (location-pos l)) + (error/evloc proc msg shape)))) + +;*---------------------------------------------------------------------*/ +;* error/evloc ... */ +;*---------------------------------------------------------------------*/ +(define (error/evloc proc msg obj) + (let ((l (evmeaning-location))) + (if (location? l) + (error/location proc msg obj (location-file l) (location-pos l)) + ((begin error) proc msg obj)))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning level . obj) + (if (>= *skribe-warning* level) + (let ((l (evmeaning-location))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply warning obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-warning/ast ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-warning/ast level ast . obj) + (if (>= *skribe-warning* level) + (let ((l (%ast-loc ast))) + (if (location? l) + (apply warning/location (location-file l) (location-pos l) obj) + (apply skribe-warning level obj))))) + +;*---------------------------------------------------------------------*/ +;* skribe-message ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-message fmt . obj) + (if (> *skribe-verbose* 0) + (apply fprintf (current-error-port) fmt obj))) + +;*---------------------------------------------------------------------*/ +;* *skribe-loaded* ... */ +;* ------------------------------------------------------------- */ +;* This hash table stores the list of loaded files in order */ +;* to avoid one file to be loaded twice. */ +;*---------------------------------------------------------------------*/ +(define *skribe-loaded* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* *skribe-load-options* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-load-options* '()) + +;*---------------------------------------------------------------------*/ +;* skribe-load ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load file #!rest opt #!key engine path) + (with-debug 4 'skribe-load + (debug-item " engine=" engine) + (debug-item " path=" path) + (debug-item " opt" opt) + (let* ((ei (cond + ((not engine) + *skribe-engine*) + ((engine? engine) + engine) + ((not (symbol? engine)) + (skribe-error 'skribe-load "Illegal engine" engine)) + (else + engine))) + (path (cond + ((not path) + (skribe-path)) + ((string? path) + (list path)) + ((not (and (list? path) (every? string? path))) + (skribe-error 'skribe-load "Illegal path" path)) + (else + path))) + (filep (find-file/path file path))) + (set! *skribe-load-options* opt) + (if (and (string? filep) (file-exists? filep)) + (if (not (hashtable-get *skribe-loaded* filep)) + (begin + (hashtable-put! *skribe-loaded* filep #t) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [loading file: " filep " " opt "]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [loading file: " filep "]"))) + (with-input-from-file filep + (lambda () + (skribe-eval-port (current-input-port) ei))))) + (skribe-error 'skribe-load + (format "Can't find file `~a' in path" file) + path))))) + +;*---------------------------------------------------------------------*/ +;* skribe-load-options ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-load-options) + *skribe-load-options*) + +;*---------------------------------------------------------------------*/ +;* evaluate ... */ +;*---------------------------------------------------------------------*/ +(define (evaluate exp) + (try (eval exp) + (lambda (a p m o) + (evmeaning-notify-error p m o) + (flush-output-port (current-error-port))))) + +;*---------------------------------------------------------------------*/ +;* skribe-include ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-include file . rest) + (let* ((path (cond + ((or (null? rest) (null? (cdr rest))) + (skribe-path)) + ((not (every? string? (cdr rest))) + (skribe-error 'skribe-include "Illegal path" (cdr rest))) + (else + (cdr rest)))) + (filep (find-file/path file (if (null? path) (skribe-path) path)))) + (if (and (string? filep) (file-exists? filep)) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [including file: " filep "]")) + (with-input-from-file filep + (lambda () + (let loop ((exp (skribe-read (current-input-port))) + (res '())) + (if (eof-object? exp) + (if (and (pair? res) (null? (cdr res))) + (car res) + (reverse! res)) + (loop (skribe-read (current-input-port)) + (cons (evaluate exp) res))))))) + (skribe-error 'skribe-include + (format "Can't find file `~a 'in path" file) + path)))) + +;*---------------------------------------------------------------------*/ +;* skribe-open-bib-file ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-open-bib-file file command) + (let ((filep (find-file/path file *skribe-bib-path*))) + (if (string? filep) + (begin + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [loading bib: " filep "]")) + (open-input-file (if (string? command) + (string-append "| " + (format command filep)) + filep))) + (begin + (skribe-warning 1 + 'bibliography + "Can't find bibliography -- " file) + #f)))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval-port ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval-port port ei #!key (env '())) + (with-debug 2 'skribe-eval-port + (debug-item "ei=" ei) + (let ((e (if (symbol? ei) (find-engine ei) ei))) + (debug-item "e=" e) + (if (not (%engine? e)) + (skribe-error 'find-engine "Can't find engine" ei) + (let loop ((exp (skribe-read port))) + (with-debug 10 'skribe-eval-port + (debug-item "exp=" exp)) + (if (not (eof-object? exp)) + (begin + (skribe-eval (evaluate exp) e :env env) + (loop (skribe-read port))))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-eval ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-eval a e #!key (env '())) + (with-debug 2 'skribe-eval + (debug-item "a=" a " e=" (%engine-ident e)) + (let ((a2 (resolve! a e env))) + (debug-item "resolved a=" a) + (let ((a3 (verify a2 e))) + (debug-item "verified a=" a3) + (output a3 e))))) + +;*---------------------------------------------------------------------*/ +;* skribe-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path) + *skribe-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-path-set! "Illegal path" path) + (set! *skribe-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path) + *skribe-image-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-image-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-image-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-image-path-set! "Illegal path" path) + (set! *skribe-image-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path) + *skribe-bib-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-bib-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-bib-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-bib-path-set! "Illegal path" path) + (set! *skribe-bib-path* path))) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path) + *skribe-source-path*) + +;*---------------------------------------------------------------------*/ +;* skribe-source-path-set! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-source-path-set! path) + (if (not (and (list? path) (every? string? path))) + (skribe-error 'skribe-source-path-set! "Illegal path" path) + (set! *skribe-source-path* path))) diff --git a/src/bigloo/evapi.scm b/src/bigloo/evapi.scm new file mode 100644 index 0000000..6f0d49e --- /dev/null +++ b/src/bigloo/evapi.scm @@ -0,0 +1,39 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/evapi.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 18:57:09 2003 */ +;* Last change : Sun Jul 11 11:32:23 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo eval declarations */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_evapi + (import skribe_types + skribe_lib + skribe_api + skribe_engine + skribe_writer + skribe_output + skribe_eval + skribe_read + skribe_resolve + skribe_param + skribe_source + skribe_index + skribe_configure + skribe_lisp + skribe_xml + skribe_c + skribe_asm + skribe_bib + skribe_color + skribe_sui + skribe_debug) + (eval (export-all))) + + diff --git a/src/bigloo/index.bgl b/src/bigloo/index.bgl new file mode 100644 index 0000000..9697981 --- /dev/null +++ b/src/bigloo/index.bgl @@ -0,0 +1,32 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/index.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 24 08:01:45 2003 */ +;* Last change : Wed Feb 4 05:24:10 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe indexes Bigloo module declaration */ +;* ------------------------------------------------------------- */ +;* Implementation: @label index@ */ +;* bigloo: @path ../common/index.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_index + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (index?::bool ::obj) + (default-index) + (make-index-table ::bstring) + (resolve-the-index ::obj ::obj ::obj ::pair-nil ::bool ::int ::int ::int))) + diff --git a/src/bigloo/lib.bgl b/src/bigloo/lib.bgl new file mode 100644 index 0000000..6dd6d37 --- /dev/null +++ b/src/bigloo/lib.bgl @@ -0,0 +1,340 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lib.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Dec 1 14:27:57 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe runtime (i.e., the style user functions). */ +;* ------------------------------------------------------------- */ +;* Implementation: @label lib@ */ +;* bigloo: @path ../common/lib.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lib + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output + skribe_engine) + + (export (markup-option ::%markup ::obj) + (markup-option-add! ::%markup ::obj ::obj) + (markup-class ::%markup) + + (container-env-get ::%container ::symbol) + (container-search-down::pair-nil ::procedure ::%container) + (search-down::pair-nil ::procedure ::obj) + + (find-markup-ident::pair-nil ::bstring) + + (find-down::pair-nil ::procedure ::obj) + (find1-down::obj ::procedure ::obj) + (find-up::pair-nil ::procedure ::obj) + (find1-up::obj ::procedure ::obj) + + (ast-document ::%ast) + (ast-chapter ::%ast) + (ast-section ::%ast) + + (the-body ::pair-nil) + (the-options ::pair-nil . rest) + + (list-split::pair-nil ::pair-nil ::int . ::obj) + + (generic ast->string::bstring ::obj) + + (strip-ref-base ::bstring) + (ast->file-location ::%ast) + + (convert-image ::bstring ::pair-nil) + + (make-string-replace ::pair-nil) + (string-canonicalize::bstring ::bstring) + (inline unspecified?::bool ::obj))) + +;*---------------------------------------------------------------------*/ +;* markup-option ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option m opt) + (if (%markup? m) + (with-access::%markup m (options) + (let ((c (assq opt options))) + (and (pair? c) (pair? (cdr c)) (cadr c)))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-option-add! ... */ +;*---------------------------------------------------------------------*/ +(define (markup-option-add! m opt val) + (if (%markup? m) + (with-access::%markup m (options) + (set! options (cons (list opt val) options))) + (skribe-type-error 'markup-option "Illegal markup:" m "markup"))) + +;*---------------------------------------------------------------------*/ +;* markup-class ... */ +;*---------------------------------------------------------------------*/ +(define (markup-class m) + (%markup-class m)) + +;*---------------------------------------------------------------------*/ +;* container-env-get ... */ +;*---------------------------------------------------------------------*/ +(define (container-env-get m key) + (with-access::%container m (env) + (let ((c (assq key env))) + (and (pair? c) (cadr c))))) + +;*---------------------------------------------------------------------*/ +;* strip-ref-base ... */ +;*---------------------------------------------------------------------*/ +(define (strip-ref-base file) + (if (not (string? *skribe-ref-base*)) + file + (let ((l (string-length *skribe-ref-base*))) + (cond + ((not (>fx (string-length file) (+fx l 2))) + file) + ((not (substring=? file *skribe-ref-base* l)) + file) + ((not (char=? (string-ref file l) (file-separator))) + file) + (else + (substring file (+fx l 1) (string-length file))))))) + +;*---------------------------------------------------------------------*/ +;* ast->file-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast->file-location ast) + (let ((l (ast-loc ast))) + (if (location? l) + (format "~a:~a" (location-file l) (location-pos l)) + ""))) + +;*---------------------------------------------------------------------*/ +;* builtin-convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (builtin-convert-image from fmt dir) + (let* ((s (suffix from)) + (f (string-append (prefix (basename from)) "." fmt)) + (to (make-file-name dir f))) + (cond + ((string=? s fmt) + to) + ((file-exists? to) + to) + (else + (let ((c (if (string=? s "fig") + (string-append "fig2dev -L " fmt " " from " > " to) + (string-append "convert " from " " to)))) + (cond + ((>fx *skribe-verbose* 1) + (fprint (current-error-port) + " [converting image: " from " (" c ")]")) + ((>fx *skribe-verbose* 0) + (fprint (current-error-port) + " [converting image: " from "]"))) + (if (=fx (system c) 0) to #f)))))) + +;*---------------------------------------------------------------------*/ +;* convert-image ... */ +;*---------------------------------------------------------------------*/ +(define (convert-image file formats) + (let ((path (find-file/path file (skribe-image-path)))) + (if (not (string? path)) + (skribe-error 'image + (format "Can't find `~a' image file in path: " file) + (skribe-image-path)) + (let ((suf (suffix file))) + (if (member suf formats) + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + #f))) + (if dir + (let ((dest (basename path))) + (copy-file path (make-file-name dir dest)) + dest) + path)) + (let loop ((fmts formats)) + (if (null? fmts) + #f + (let* ((dir (if (string? *skribe-dest*) + (dirname *skribe-dest*) + ".")) + (p (builtin-convert-image path (car fmts) dir))) + (if (string? p) + p + (loop (cdr fmts))))))))))) + +;*---------------------------------------------------------------------*/ +;* html-string ... */ +;*---------------------------------------------------------------------*/ +(define (html-string str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (if (=fx nlen len) + str + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let ((c (string-ref-ur str r))) + (case c + ((#\<) + (blit-string! "<" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\>) + (blit-string! ">" 0 res w 4) + (loop (+fx r 1) (+fx w 4))) + ((#\&) + (blit-string! "&" 0 res w 5) + (loop (+fx r 1) (+fx w 5))) + ((#\") + (blit-string! """ 0 res w 6) + (loop (+fx r 1) (+fx w 6))) + (else + (string-set! res w c) + (loop (+fx r 1) (+fx w 1))))))))) + (case (string-ref-ur str r) + ((#\< #\>) + (loop (+fx r 1) (+fx nlen 3))) + ((#\&) + (loop (+fx r 1) (+fx nlen 4))) + ((#\") + (loop (+fx r 1) (+fx nlen 5))) + (else + (loop (+fx r 1) nlen))))))) + +;*---------------------------------------------------------------------*/ +;* make-generic-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-generic-string-replace lst) + (lambda (str) + (let ((len (string-length str))) + (let loop ((r 0) + (nlen len)) + (if (=fx r len) + (let ((res (make-string nlen))) + (let loop ((r 0) + (w 0)) + (if (=fx w nlen) + res + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (let ((pl (string-length (cadr p)))) + (blit-string! (cadr p) 0 res w pl) + (loop (+fx r 1) (+fx w pl))) + (begin + (string-set! res w c) + (loop (+fx r 1) (+fx w 1)))))))) + (let* ((c (string-ref-ur str r)) + (p (assq c lst))) + (if (pair? p) + (loop (+fx r 1) + (+fx nlen (-fx (string-length (cadr p)) 1))) + (loop (+fx r 1) + nlen)))))))) + +;*---------------------------------------------------------------------*/ +;* make-string-replace ... */ +;*---------------------------------------------------------------------*/ +(define (make-string-replace lst) + (let ((l (sort lst (lambda (r1 r2) (char<? (car r1) (car r2)))))) + (cond + ((equal? l '((#\" """) (#\& "&") (#\< "<") (#\> ">"))) + html-string) + (else + (make-generic-string-replace lst))))) + +;*---------------------------------------------------------------------*/ +;* ast->string ... */ +;*---------------------------------------------------------------------*/ +(define-generic (ast->string ast) + (cond + ((string? ast) + ast) + ((number? ast) + (number->string ast)) + ((pair? ast) + (let* ((t (map ast->string ast)) + (res (make-string + (apply + -1 (length t) (map string-length t)) + #\space))) + (let loop ((t t) + (w 0)) + (if (null? t) + res + (let ((l (string-length (car t)))) + (blit-string! (car t) 0 res w l) + (loop (cdr t) (+ w l 1))))))) + (else + ""))) + +;*---------------------------------------------------------------------*/ +;* ast->string ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (ast->string ast::%node) + (ast->string (%node-body ast))) + +;*---------------------------------------------------------------------*/ +;* string-canonicalize ... */ +;*---------------------------------------------------------------------*/ +(define (string-canonicalize old) + (let* ((l (string-length old)) + (new (make-string l))) + (let loop ((r 0) + (w 0) + (s #f)) + (cond + ((=fx r l) + (cond + ((=fx w 0) + "") + ((char-whitespace? (string-ref new (-fx w 1))) + (substring new 0 (-fx w 1))) + ((=fx w r) + new) + (else + (substring new 0 w)))) + ((char-whitespace? (string-ref old r)) + (if s + (loop (+fx r 1) w #t) + (begin + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)))) + ((or (char=? (string-ref old r) #\#) + (char=? (string-ref old r) #\,) + (>= (char->integer (string-ref old r)) #x7f)) + (string-set! new w #\-) + (loop (+fx r 1) (+fx w 1) #t)) + (else + (string-set! new w (string-ref old r)) + (loop (+fx r 1) (+fx w 1) #f)))))) + +;*---------------------------------------------------------------------*/ +;* unspecified? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unspecified? obj) + (eq? obj #unspecified)) + +;*---------------------------------------------------------------------*/ +;* base */ +;* ------------------------------------------------------------- */ +;* A base engine must pre-exist before anything is loaded. In */ +;* particular, this dummy base engine is used to load the */ +;* actual definition of base. */ +;*---------------------------------------------------------------------*/ +(make-engine 'base :version 'bootstrap) + diff --git a/src/bigloo/lisp.scm b/src/bigloo/lisp.scm new file mode 100644 index 0000000..65a8227 --- /dev/null +++ b/src/bigloo/lisp.scm @@ -0,0 +1,530 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Aug 29 08:14:59 2003 */ +;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Handling of lispish source files. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_lisp + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export bigloo + scheme + lisp + skribe)) + +;*---------------------------------------------------------------------*/ +;* keys ... */ +;*---------------------------------------------------------------------*/ +(define *the-key* #f) +(define *bracket-highlight* #t) +(define *bigloo-key* #f) +(define *scheme-key* #f) +(define *lisp-key* #f) +(define *skribe-key* #f) + +;*---------------------------------------------------------------------*/ +;* init-bigloo-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-bigloo-fontifier!) + (if (not *bigloo-key*) + (begin + (set! *bigloo-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'symbol)) + '(set! if let cond case quote begin letrec let* + lambda export extern class generic inline + static import foreign type with-access instantiate + duplicate labels + match-case match-lambda + syntax-rules pragma widen! shrink! + wide-class profile profile/gc + regular-grammar lalr-grammar apply)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'define)) + '(define define-inline define-struct define-macro + define-generic define-method define-syntax + define-expander)) + ;; error + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'error)) + '(bind-exit unwind-protect call/cc error warning)) + ;; module + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'module)) + '(module import export library)) + ;; thread + (for-each (lambda (symbol) + (putprop! symbol *bigloo-key* 'thread)) + '(make-thread thread-start! thread-yield! + thread-await! thread-await*! + thread-sleep! thread-join! + thread-terminate! thread-suspend! + thread-resume! thread-yield! + thread-specific thread-specific-set! + thread-name thread-name-set! + scheduler-react! scheduler-start! + broadcast! scheduler-broadcast! + current-thread thread? + current-scheduler scheduler? make-scheduler + make-input-signal make-output-signal + make-connect-signal make-process-signal + make-accept-signal make-timer-signal + thread-get-values! thread-get-values*!))))) + +;*---------------------------------------------------------------------*/ +;* init-lisp-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-lisp-fontifier!) + (if (not *lisp-key*) + (begin + (set! *lisp-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'symbol)) + '(setq if let cond case else progn letrec let* + lambda labels try unwind-protect apply funcall)) + ;; defun + (for-each (lambda (symbol) + (putprop! symbol *lisp-key* 'define)) + '(define defun defvar defmacro))))) + +;*---------------------------------------------------------------------*/ +;* init-skribe-fontifier! ... */ +;*---------------------------------------------------------------------*/ +(define (init-skribe-fontifier!) + (if (not *skribe-key*) + (begin + (set! *skribe-key* (gensym)) + ;; language keywords + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'symbol)) + '(set! bold it emph tt color ref index underline + figure center pre flush hrule linebreak + image kbd code var samp sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font lambda)) + ;; define + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'define)) + '(define define-markup)) + ;; markup + (for-each (lambda (symbol) + (putprop! symbol *skribe-key* 'markup)) + '(document chapter section subsection subsubsection + paragraph p handle resolve processor + abstract margin toc table-of-contents + current-document current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide))))) + +;*---------------------------------------------------------------------*/ +;* bigloo ... */ +;*---------------------------------------------------------------------*/ +(define bigloo + (new language + (name "bigloo") + (fontifier bigloo-fontifier) + (extractor bigloo-extractor))) + +;*---------------------------------------------------------------------*/ +;* scheme ... */ +;*---------------------------------------------------------------------*/ +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + +;*---------------------------------------------------------------------*/ +;* lisp ... */ +;*---------------------------------------------------------------------*/ +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + +;*---------------------------------------------------------------------*/ +;* bigloo-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-fontifier s) + (init-bigloo-fontifier!) + (set! *the-key* *bigloo-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* bigloo-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (bigloo-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-inline define-generic + define-method define-macro define-expander) + (?fun . ?-) . ?-) + (eq? def fun)) + (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* skribe ... */ +;*---------------------------------------------------------------------*/ +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + +;*---------------------------------------------------------------------*/ +;* skribe-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-fontifier s) + (init-skribe-fontifier!) + (set! *the-key* *skribe-key*) + (set! *bracket-highlight* #t) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* skribe-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro define-markup) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + ((markup-output (quote ?mk) . ?-) + (eq? mk def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* scheme-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-fontifier s) s) + +;*---------------------------------------------------------------------*/ +;* scheme-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (scheme-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or define define-macro) (?fun . ?-) . ?-) + (eq? def fun)) + ((define (and (? symbol?) ?var) . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* lisp-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-fontifier s) + (init-lisp-fontifier!) + (set! *the-key* *lisp-key*) + (set! *bracket-highlight* #f) + (fontify-lisp (open-input-string s))) + +;*---------------------------------------------------------------------*/ +;* lisp-extractor ... */ +;*---------------------------------------------------------------------*/ +(define (lisp-extractor iport def tab) + (definition-search iport + tab + (lambda (exp) + (match-case exp + (((or defun defmacro) ?fun ?- . ?-) + (eq? def fun)) + ((defvar ?var . ?-) + (eq? var def)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* definition-search ... */ +;* ------------------------------------------------------------- */ +;* This function seeks a Bigloo definition. If it finds it, it */ +;* returns two values the starting char number of the definition */ +;* and the stop char. */ +;*---------------------------------------------------------------------*/ +(define (definition-search ip tab semipred) + (cond-expand + (bigloo2.6 + (define (reader-current-line-number) + (let* ((port (open-input-string "(9)")) + (exp (read port #t))) + (close-input-port port) + (line-number exp))) + (define (line-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos ?line) + line)))) + (reader-reset!) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (line-number exp)) + (e (reader-current-line-number))) + (source-read-lines (input-port-name ip) b e tab))))))) + (else + (define (char-number expr) + (and (epair? expr) + (match-case (cer expr) + ((at ?- ?pos) + pos)))) + (let loop ((exp (read ip #t))) + (if (not (eof-object? exp)) + (let ((v (semipred exp))) + (if (not v) + (loop (read ip #t)) + (let* ((b (char-number exp)) + (e (input-port-position ip))) + (source-read-chars (input-port-name ip) + b + e + tab))))))))) + + +;*---------------------------------------------------------------------*/ +;* fontify-lisp ... */ +;*---------------------------------------------------------------------*/ +(define (fontify-lisp port::input-port) + (let ((g (regular-grammar () + ((: ";;" (* all)) + ;; italic comments + (let ((c (new markup + (markup '&source-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";*" (* all)) + ;; bold comments + (let ((c (new markup + (markup '&source-line-comment) + (body (the-string))))) + (cons c (ignore)))) + ((: ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-string))) + (cons str (ignore)))) + ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all)) + ;; plain comments + (let ((str (the-substring 1 (the-length)))) + (cons str (ignore)))) + ((+ #\Space) + ;; separators + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + (#\( + ;; open parenthesis + (let ((str (highlight (the-string)))) + (pupush-highlight) + (cons str (ignore)))) + (#\) + ;; close parenthesis + (let ((str (highlight (the-string) -1))) + (cons str (ignore)))) + ((+ (in "[]")) + ;; brackets + (let ((s (the-string))) + (if *bracket-highlight* + (let ((c (new markup + (markup '&source-bracket) + (body s)))) + (cons c (ignore))) + (cons s (ignore))))) + ((+ #\Tab) + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((: #\( (+ (out "; \t()[]:\"\n"))) + ;; keywords + (let* ((string (the-substring 1 (the-length))) + (symbol (string->symbol string)) + (key (getprop symbol *the-key*))) + (cons + "(" + (case key + ((symbol) + (let ((c (new markup + (markup '&source-keyword) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((define) + (let ((c (new markup + (markup '&source-define) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-define) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((error) + (let ((c (new markup + (markup '&source-error) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((module) + (let ((c (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body string)))) + (push-highlight (lambda (e) + (new markup + (markup '&source-module) + (ident (symbol->string (gensym))) + (body e))) + 1) + (cons c (ignore)))) + ((markup) + (let ((c (new markup + (markup '&source-markup) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + ((thread) + (let ((c (new markup + (markup '&source-thread) + (ident (symbol->string (gensym))) + (body string)))) + (cons c (ignore)))) + (else + (cons (highlight string 1) (ignore))))))) + ((+ (out "; \t()[]:\"\n")) + (let ((string (the-string))) + (cons (highlight string 1) (ignore)))) + ((+ #\Newline) + ;; newline + (let ((str (the-string))) + (cons (highlight str) (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (ident (symbol->string (gensym))) + (body s)))) + str) + (ignore)))) + ((: "::" (+ (out ";\n \t()[]:\""))) + ;; type annotations + (let ((c (new markup + (markup '&source-type) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\""))) + ;; keywords annotations + (let ((c (new markup + (markup '&source-key) + (ident (symbol->string (gensym))) + (body (the-string))))) + (cons c (ignore)))) + ((+ (or #\: #\; #\")) + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + ((: #\# #\\ (+ (out " \n\t"))) + ;; characters + (let ((str (the-string))) + (cons (highlight str 1) (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(lisp)" "Unexpected character" c))))))) + (reset-highlight!) + (read/rp g port))) + +;*---------------------------------------------------------------------*/ +;* *highlight* ... */ +;*---------------------------------------------------------------------*/ +(define *highlight* '()) + +;*---------------------------------------------------------------------*/ +;* reset-highlight! ... */ +;*---------------------------------------------------------------------*/ +(define (reset-highlight!) + (set! *highlight* '())) + +;*---------------------------------------------------------------------*/ +;* push-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (push-highlight col pv) + (set! *highlight* (cons (cons col pv) *highlight*))) + +;*---------------------------------------------------------------------*/ +;* pupush-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pupush-highlight) + (if (pair? *highlight*) + (let ((c (car *highlight*))) + (set-cdr! c 100000)))) + +;*---------------------------------------------------------------------*/ +;* pop-highlight ... */ +;*---------------------------------------------------------------------*/ +(define (pop-highlight pv) + (case pv + ((-1) + (set! *highlight* (cdr *highlight*))) + ((0) + 'nop) + (else + (let ((c (car *highlight*))) + (if (>fx (cdr c) 1) + (set-cdr! c (-fx (cdr c) 1)) + (set! *highlight* (cdr *highlight*))))))) + +;*---------------------------------------------------------------------*/ +;* highlight ... */ +;*---------------------------------------------------------------------*/ +(define (highlight exp . pop) + (if (pair? *highlight*) + (let* ((c (car *highlight*)) + (r (if (>fx (cdr c) 0) + ((car c) exp) + exp))) + (if (pair? pop) (pop-highlight (car pop))) + r) + exp)) + + diff --git a/src/bigloo/main.scm b/src/bigloo/main.scm new file mode 100644 index 0000000..5b9e5e5 --- /dev/null +++ b/src/bigloo/main.scm @@ -0,0 +1,96 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/main.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:51:49 2003 */ +;* Last change : Wed May 18 15:45:27 2005 (serrano) */ +;* Copyright : 2003-05 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe main entry point */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_main + + (include "debug.sch") + + (import skribe_types + skribe_parse-args + skribe_param + skribe_lib + skribe_eval + skribe_read + skribe_engine + skribe_evapi) + + (main main)) + +;*---------------------------------------------------------------------*/ +;* main ... */ +;*---------------------------------------------------------------------*/ +(define (main args) + (with-debug 2 'main + (debug-item "parse env variables...") + (parse-env-variables) + + (debug-item "load rc file...") + (load-rc) + + (debug-item "parse command line...") + (parse-args args) + + (debug-item "load base...") + (skribe-load "base.skr" :engine 'base) + + (debug-item "preload... (" *skribe-engine* ")") + (for-each (lambda (f) + (skribe-load f :engine *skribe-engine*)) + *skribe-preload*) + + ;; Load the specified variants + (debug-item "variant... (" *skribe-variants* ")") + (for-each (lambda (x) + (skribe-load (format "~a.skr" x) :engine *skribe-engine*)) + (reverse! *skribe-variants*)) + + (debug-item "body..." *skribe-engine*) + (if (string? *skribe-dest*) + (cond-expand + (bigloo2.6 + (try (with-output-to-file *skribe-dest* doskribe) + (lambda (e a b c) + (delete-file *skribe-dest*) + (let ((s (with-output-to-string + (lambda () (write c))))) + (notify-error a b s)) + (exit -1)))) + (else + (with-exception-handler + (lambda (e) + (if (&warning? e) + (raise e) + (begin + (delete-file *skribe-dest*) + (if (&error? e) + (error-notify e) + (raise e)) + (exit 1)))) + (lambda () + (with-output-to-file *skribe-dest* doskribe))))) + (doskribe)))) + +;*---------------------------------------------------------------------*/ +;* doskribe ... */ +;*---------------------------------------------------------------------*/ +(define (doskribe) + (let ((e (find-engine *skribe-engine*))) + (if (and (engine? e) (pair? *skribe-precustom*)) + (for-each (lambda (cv) + (engine-custom-set! e (car cv) (cdr cv))) + *skribe-precustom*)) + (if (pair? *skribe-src*) + (for-each (lambda (f) (skribe-load f :engine *skribe-engine*)) + *skribe-src*) + (skribe-eval-port (current-input-port) *skribe-engine*)))) diff --git a/src/bigloo/new.sch b/src/bigloo/new.sch new file mode 100644 index 0000000..16bb7d5 --- /dev/null +++ b/src/bigloo/new.sch @@ -0,0 +1,17 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/new.sch */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sun Aug 17 11:58:30 2003 */ +;* Last change : Wed Sep 10 11:14:15 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The new facility */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* new ... */ +;*---------------------------------------------------------------------*/ +(define-macro (new id . inits) + `(,(symbol-append 'instantiate::% id) ,@inits)) + diff --git a/src/bigloo/output.scm b/src/bigloo/output.scm new file mode 100644 index 0000000..4bc6271 --- /dev/null +++ b/src/bigloo/output.scm @@ -0,0 +1,167 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/output.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Wed Feb 4 10:33:19 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe engine */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_output + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (output ::obj ::%engine . w))) + +;*---------------------------------------------------------------------*/ +;* output ... */ +;*---------------------------------------------------------------------*/ +(define (output node e . writer) + (with-debug 3 'output + (debug-item "node=" node " " (if (markup? node) (markup-markup node) "")) + (debug-item "writer=" writer) + (if (pair? writer) + (cond + ((%writer? (car writer)) + (out/writer node e (car writer))) + ((not (car writer)) + (skribe-error 'output + (format "Illegal `~a' user writer" (%engine-ident e)) + (if (markup? node) (%markup-markup node) node))) + (else + (skribe-error 'output "Illegal user writer" (car writer)))) + (out node e)))) + +;*---------------------------------------------------------------------*/ +;* out/writer ... */ +;*---------------------------------------------------------------------*/ +(define (out/writer n e w) + (with-debug 5 'out/writer + (debug-item "n=" (find-runtime-type n) + " " (if (markup? n) (markup-markup n) "")) + (debug-item "e=" (%engine-ident e)) + (debug-item "w=" (%writer-ident w)) + (if (%writer? w) + (with-access::%writer w (before action after) + (invoke before n e) + (invoke action n e) + (invoke after n e))))) + +;*---------------------------------------------------------------------*/ +;* out ... */ +;*---------------------------------------------------------------------*/ +(define-generic (out node e::%engine) + (cond + ((pair? node) + (out* node e)) + ((string? node) + (let ((f (%engine-filter e))) + (if (procedure? f) + (display (f node)) + (display node)))) + ((number? node) + (display node)) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* out ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (out n::%processor e::%engine) + (with-access::%processor n (combinator engine body procedure) + (let ((newe (processor-get-engine combinator engine e))) + (out (procedure body newe) newe)))) + +;*---------------------------------------------------------------------*/ +;* out ::%command ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%command e::%engine) + (with-access::%command node (fmt body) + (let ((lb (length body)) + (lf (string-length fmt))) + (define (loops i n) + (if (= i lf) + (begin + (if (> n 0) + (if (<= n lb) + (output (list-ref body (- n 1)) e) + (skribe-error '! + "Too few arguments provided" + node))) + lf) + (let ((c (string-ref fmt i))) + (cond + ((char=? c #\$) + (display "$") + (+ 1 i)) + ((not (char-numeric? c)) + (cond + ((= n 0) + i) + ((<= n lb) + (output (list-ref body (- n 1)) e) + i) + (else + (skribe-error '! + "Too few arguments provided" + node)))) + (else + (loops (+ i 1) + (+ (- (char->integer c) + (char->integer #\0)) + (* 10 n)))))))) + (let loop ((i 0)) + (cond + ((= i lf) + #f) + ((not (char=? (string-ref fmt i) #\$)) + (display (string-ref fmt i)) + (loop (+ i 1))) + (else + (loop (loops (+ i 1) 0)))))))) + +;*---------------------------------------------------------------------*/ +;* out ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%handle e::%engine) + #unspecified) + +;*---------------------------------------------------------------------*/ +;* out ::%unresolved ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%unresolved e::%engine) + (error 'output "Orphan unresolved" node)) + +;*---------------------------------------------------------------------*/ +;* out ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (out node::%markup e::%engine) + (let ((w (lookup-markup-writer node e))) + (if (writer? w) + (out/writer node e w) + (output (%markup-body node) e)))) + +;*---------------------------------------------------------------------*/ +;* out* ... */ +;*---------------------------------------------------------------------*/ +(define (out* n+ e) + (let loop ((n* n+)) + (cond + ((pair? n*) + (out (car n*) e) + (loop (cdr n*))) + ((not (null? n*)) + (error 'output "Illegal argument" n*))))) + + diff --git a/src/bigloo/param.bgl b/src/bigloo/param.bgl new file mode 100644 index 0000000..6ff6b42 --- /dev/null +++ b/src/bigloo/param.bgl @@ -0,0 +1,134 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/param.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Sat Jul 26 14:03:15 2003 */ +;* Last change : Wed Mar 3 10:18:48 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe parameters */ +;* ------------------------------------------------------------- */ +;* Implementation: @label param@ */ +;* bigloo: @path ../common/param.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_param + + (import skribe_configure) + + (export *skribe-verbose* + *skribe-warning* + *skribe-path* + *skribe-bib-path* + *skribe-source-path* + *skribe-image-path* + *load-rc* + + *skribe-src* + *skribe-dest* + *skribe-engine* + *skribe-variants* + *skribe-chapter-split* + + *skribe-ref-base* + + *skribe-rc-directory* + *skribe-rc-file* + *skribe-auto-mode-alist* + *skribe-auto-load-alist* + *skribe-preload* + *skribe-precustom* + + *skribebib-auto-mode-alist*)) + +;*---------------------------------------------------------------------*/ +;* *skribe-verbose* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-verbose* 0) + +;*---------------------------------------------------------------------*/ +;* *skribe-warning* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-warning* 5) + +;*---------------------------------------------------------------------*/ +;* *skribe-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-path* (skribe-default-path)) + +;*---------------------------------------------------------------------*/ +;* *skribe-bib-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-bib-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-source-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-source-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *skribe-image-path* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-image-path* '(".")) + +;*---------------------------------------------------------------------*/ +;* *load-rc* ... */ +;*---------------------------------------------------------------------*/ +(define *load-rc* #t) + +;*---------------------------------------------------------------------*/ +;* *skribe-src* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-src* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-dest* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-dest* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-engine* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-engine* 'html) + +;*---------------------------------------------------------------------*/ +;* *skribe-variants* */ +;*---------------------------------------------------------------------*/ +(define *skribe-variants* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-chapter-split* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-chapter-split* '()) + +;*---------------------------------------------------------------------*/ +;* *skribe-ref-base* ... */ +;*---------------------------------------------------------------------*/ +(define *skribe-ref-base* #f) + +;*---------------------------------------------------------------------*/ +;* *skribe-rc-directory* ... */ +;* ------------------------------------------------------------- */ +;* The "runtime command" file directory. */ +;*---------------------------------------------------------------------*/ +(define *skribe-rc-directory* + (let ((home (getenv "HOME")) + (host (hostname))) + (let loop ((host (if (not (string? host)) (getenv "HOST") host))) + (if (string? host) + (let ((home/host (string-append home "/.skribe" host))) + (if (and (file-exists? home/host) (directory? home/host)) + home/host + (if (string=? (suffix host) "") + (let ((home/def (make-file-name home ".skribe"))) + (cond + ((and (file-exists? home/def) + (directory? home/def)) + home/def) + (else + home))) + (loop (prefix host))))))))) + diff --git a/src/bigloo/parseargs.scm b/src/bigloo/parseargs.scm new file mode 100644 index 0000000..4ce58c4 --- /dev/null +++ b/src/bigloo/parseargs.scm @@ -0,0 +1,186 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/parseargs.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:52:53 2003 */ +;* Last change : Wed Nov 10 10:57:40 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Argument parsing */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_parse-args + + (include "debug.sch") + + (import skribe_configure + skribe_param + skribe_read + skribe_types + skribe_eval) + + (export (parse-env-variables) + (parse-args ::pair) + (load-rc))) + +;*---------------------------------------------------------------------*/ +;* parse-env-variables ... */ +;*---------------------------------------------------------------------*/ +(define (parse-env-variables) + (let ((e (getenv "SKRIBEPATH"))) + (if (string? e) + (skribe-path-set! (append (unix-path->list e) (skribe-path)))))) + +;*---------------------------------------------------------------------*/ +;* parse-args ... */ +;*---------------------------------------------------------------------*/ +(define (parse-args args) + (define (usage args-parse-usage) + (print "usage: skribe [options] [input]") + (newline) + (args-parse-usage #f) + (newline) + (print "Rc file:") + (newline) + (print " *skribe-rc* (searched in \".\" then $HOME)") + (newline) + (print "Target formats:") + (for-each (lambda (f) (print " - " (car f))) *skribe-auto-mode-alist*) + (newline) + (print "Shell Variables:") + (newline) + (for-each (lambda (var) + (print " - " (car var) " " (cdr var))) + '(("SKRIBEPATH" . "Skribe input path (all files)")))) + (define (version) + (print "skribe v" (skribe-release))) + (define (query) + (version) + (newline) + (for-each (lambda (x) + (let ((s (keyword->string (car x)))) + (printf " ~a: ~a\n" + (substring s 1 (string-length s)) + (cadr x)))) + (skribe-configure))) + (let ((np '()) + (engine #f)) + (args-parse (cdr args) + ((("-h" "--help") (help "This message")) + (usage args-parse-usage) + (exit 0)) + (("--options" (help "Display the skribe options and exit")) + (args-parse-usage #t) + (exit 0)) + (("--version" (help "The version of Skribe")) + (version) + (exit 0)) + ((("-q" "--query") (help "Display informations about the Skribe configuration")) + (query) + (exit 0)) + ((("-c" "--custom") ?key=val (synopsis "Preset custom value")) + (let ((l (string-length key=val))) + (let loop ((i 0)) + (cond + ((= i l) + (skribe-error 'skribe "Illegal option" key=val)) + ((char=? (string-ref key=val i) #\=) + (let ((key (substring key=val 0 i)) + (val (substring key=val (+ i 1) l))) + (set! *skribe-precustom* + (cons (cons (string->symbol key) val) + *skribe-precustom*)))) + (else + (loop (+ i 1))))))) + (("-v?level" (help "Increase or set verbosity level (-v0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-verbose* (+fx 1 *skribe-verbose*)) + (set! *skribe-verbose* (string->integer level)))) + (("-w?level" (help "Increase or set warning level (-w0 for crystal silence)")) + (if (string=? level "") + (set! *skribe-warning* (+fx 1 *skribe-warning*)) + (set! *skribe-warning* (string->integer level)))) + (("-g?level" (help "Increase or set debug level")) + (if (string=? level "") + (set! *skribe-debug* (+fx 1 *skribe-debug*)) + (let ((l (string->integer level))) + (if (= l 0) + (begin + (set! *skribe-debug* 1) + (set! *skribe-debug-symbols* + (cons (string->symbol level) + *skribe-debug-symbols*))) + (set! *skribe-debug* l))))) + (("--no-color" (help "Disable coloring for debug")) + (set! *skribe-debug-color* #f)) + ((("-t" "--target") ?e (help "The output target format")) + (set! engine (string->symbol e))) + (("-I" ?path (help "Add <path> to skribe path")) + (set! np (cons path np))) + (("-B" ?path (help "Add <path> to skribe bibliography path")) + (skribe-bib-path-set! (cons path (skribe-bib-path)))) + (("-S" ?path (help "Add <path> to skribe source path")) + (skribe-source-path-set! (cons path (skribe-source-path)))) + (("-P" ?path (help "Add <path> to skribe image path")) + (skribe-image-path-set! (cons path (skribe-image-path)))) + ((("-C" "--split-chapter") ?chapter (help "Emit chapter's sections in separate files")) + (set! *skribe-chapter-split* (cons chapter *skribe-chapter-split*))) + (("--eval" ?expr (help "Evaluate expression")) + (with-input-from-string expr + (lambda () + (eval (skribe-read))))) + (("--no-init-file" (help "Dont load rc Skribe file")) + (set! *load-rc* #f)) + ((("-p" "--preload") ?file (help "Preload file")) + (set! *skribe-preload* (cons file *skribe-preload*))) + ((("-u" "--use-variant") ?variant (help "use <variant> output format")) + (set! *skribe-variants* (cons variant *skribe-variants*))) + ((("-o" "--output") ?o (help "The output target name")) + (set! *skribe-dest* o) + (let* ((s (suffix o)) + (c (assoc s *skribe-auto-mode-alist*))) + (if (and (pair? c) (symbol? (cdr c))) + (set! *skribe-engine* (cdr c))))) + ((("-b" "--base") ?base (help "The base prefix to be removed from hyperlinks")) + (set! *skribe-ref-base* base)) + ;; skribe rc directory + ((("-d" "--rc-dir") ?dir (synopsis "Set the skribe RC directory")) + (set! *skribe-rc-directory* dir)) + (else + (set! *skribe-src* (cons else *skribe-src*)))) + ;; we have to configure according to the environment variables + (if engine (set! *skribe-engine* engine)) + (set! *skribe-src* (reverse! *skribe-src*)) + (skribe-path-set! (append (build-path-from-shell-variable "SKRIBEPATH") + (reverse! np) + (skribe-path))))) + +;*---------------------------------------------------------------------*/ +;* build-path-from-shell-variable ... */ +;*---------------------------------------------------------------------*/ +(define (build-path-from-shell-variable var) + (let ((val (getenv var))) + (if (string? val) + (string-case val + ((+ (out #\:)) + (let* ((str (the-string)) + (res (ignore))) + (cons str res))) + (#\: + (ignore)) + (else + '())) + '()))) + +;*---------------------------------------------------------------------*/ +;* load-rc ... */ +;*---------------------------------------------------------------------*/ +(define (load-rc) + (if *load-rc* + (let ((file (make-file-name *skribe-rc-directory* *skribe-rc-file*))) + (if (and (string? file) (file-exists? file)) + (loadq file))))) + diff --git a/src/bigloo/prog.scm b/src/bigloo/prog.scm new file mode 100644 index 0000000..baad0f0 --- /dev/null +++ b/src/bigloo/prog.scm @@ -0,0 +1,196 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/prog.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Aug 27 09:14:28 2003 */ +;* Last change : Tue Oct 7 15:07:48 2003 (serrano) */ +;* Copyright : 2003 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe prog bigloo implementation */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_prog + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api) + + (export (make-prog-body ::obj ::obj ::obj ::obj) + (resolve-line ::bstring))) + +;*---------------------------------------------------------------------*/ +;* *lines* ... */ +;*---------------------------------------------------------------------*/ +(define *lines* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* make-line-mark ... */ +;*---------------------------------------------------------------------*/ +(define (make-line-mark m lnum b) + (let* ((ls (integer->string lnum)) + (n (list (mark ls) b))) + (hashtable-put! *lines* m n) + n)) + +;*---------------------------------------------------------------------*/ +;* resolve-line ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-line id) + (hashtable-get *lines* id)) + +;*---------------------------------------------------------------------*/ +;* extract-string-mark ... */ +;*---------------------------------------------------------------------*/ +(define (extract-string-mark line mark regexp) + (let ((m (pregexp-match regexp line))) + (if (pair? m) + (values (substring (car m) + (string-length mark) + (string-length (car m))) + (pregexp-replace regexp line "")) + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* extract-mark ... */ +;* ------------------------------------------------------------- */ +;* Extract the prog mark from a line. */ +;*---------------------------------------------------------------------*/ +(define (extract-mark line mark regexp) + (cond + ((not regexp) + (values #f line)) + ((string? line) + (extract-string-mark line mark regexp)) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + (values #f line) + (multiple-value-bind (m l) + (extract-mark (car ls) mark regexp) + (if (not m) + (loop (cdr ls) (cons l res)) + (values m (append (reverse! res) (cons l (cdr ls))))))))) + ((%node? line) + (multiple-value-bind (m l) + (extract-mark (%node-body line) mark regexp) + (if (not m) + (values #f line) + (begin + (%node-body-set! line l) + (values m line))))) + (else + (values #f line)))) + +;*---------------------------------------------------------------------*/ +;* split-line ... */ +;*---------------------------------------------------------------------*/ +(define (split-line line) + (cond + ((string? line) + (let ((l (string-length line))) + (let loop ((r1 0) + (r2 0) + (res '())) + (cond + ((=fx r2 l) + (if (=fx r1 r2) + (reverse! res) + (reverse! (cons (substring line r1 r2) res)))) + ((char=? (string-ref line r2) #\Newline) + (loop (+fx r2 1) + (+fx r2 1) + (if (=fx r1 r2) + (cons 'eol res) + (cons* 'eol (substring line r1 r2) res)))) + (else + (loop r1 + (+fx r2 1) + res)))))) + ((pair? line) + (let loop ((ls line) + (res '())) + (if (null? ls) + res + (loop (cdr ls) (append res (split-line (car ls))))))) + (else + (list line)))) + +;*---------------------------------------------------------------------*/ +;* flat-lines ... */ +;*---------------------------------------------------------------------*/ +(define (flat-lines lines) + (apply append (map split-line lines))) + +;*---------------------------------------------------------------------*/ +;* collect-lines ... */ +;*---------------------------------------------------------------------*/ +(define (collect-lines lines) + (let loop ((lines (flat-lines lines)) + (res '()) + (tmp '())) + (cond + ((null? lines) + (reverse! (cons (reverse! tmp) res))) + ((eq? (car lines) 'eol) + (cond + ((null? (cdr lines)) + (reverse! (cons (reverse! tmp) res))) + ((and (null? res) (null? tmp)) + (loop (cdr lines) + res + '())) + (else + (loop (cdr lines) + (cons (reverse! tmp) res) + '())))) + (else + (loop (cdr lines) + res + (cons (car lines) tmp)))))) + +;*---------------------------------------------------------------------*/ +;* make-prog-body ... */ +;*---------------------------------------------------------------------*/ +(define (make-prog-body src lnum-init ldigit mark) + (define (int->str i rl) + (let* ((s (integer->string i)) + (l (string-length s))) + (if (= l rl) + s + (string-append (make-string (- rl l) #\space) s)))) + (let* ((regexp (and mark + (format "~a[-a-zA-Z_][-0-9a-zA-Z_]+" + (pregexp-quote mark)))) + (src (cond + ((not (pair? src)) (list src)) + ((and (pair? (car src)) (null? (cdr src))) (car src)) + (else src))) + (lines (collect-lines src)) + (lnum (if (integer? lnum-init) lnum-init 1)) + (s (integer->string (+fx (if (integer? ldigit) + (max lnum (expt 10 (-fx ldigit 1))) + lnum) + (length lines)))) + (cs (string-length s))) + (let loop ((lines lines) + (lnum lnum) + (res '())) + (if (null? lines) + (reverse! res) + (multiple-value-bind (m l) + (extract-mark (car lines) mark regexp) + (let ((n (new markup + (markup '&prog-line) + (ident (and lnum-init (int->str lnum cs))) + (body (if m (make-line-mark m lnum l) l))))) + (loop (cdr lines) + (+ lnum 1) + (cons n res)))))))) diff --git a/src/bigloo/read.scm b/src/bigloo/read.scm new file mode 100644 index 0000000..91cd345 --- /dev/null +++ b/src/bigloo/read.scm @@ -0,0 +1,482 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/read.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Dec 27 11:16:00 1994 */ +;* Last change : Mon Nov 8 13:30:32 2004 (serrano) */ +;* ------------------------------------------------------------- */ +;* Skribe's reader */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* Le module */ +;*---------------------------------------------------------------------*/ +(module skribe_read + (export (skribe-read . port))) + +;*---------------------------------------------------------------------*/ +;* Global counteurs ... */ +;*---------------------------------------------------------------------*/ +(define *par-open* 0) + +;*---------------------------------------------------------------------*/ +;* Parenthesis mismatch (or unclosing) errors. */ +;*---------------------------------------------------------------------*/ +(define *list-error-level* 20) +(define *list-errors* (make-vector *list-error-level* #unspecified)) +(define *vector-errors* (make-vector *list-error-level* #unspecified)) + +;*---------------------------------------------------------------------*/ +;* Control variables. */ +;*---------------------------------------------------------------------*/ +(define *end-of-list* (cons 0 0)) +(define *dotted-mark* (cons 1 1)) + +;*---------------------------------------------------------------------*/ +;* skribe-reader-reset! ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-reader-reset!) + (set! *par-open* 0)) + +;*---------------------------------------------------------------------*/ +;* read-error ... */ +;*---------------------------------------------------------------------*/ +(define (read-error msg obj port) + (let* ((obj-loc (if (epair? obj) + (match-case (cer obj) + ((at ?fname ?pos ?-) + pos) + (else + #f)) + #f)) + (loc (if (number? obj-loc) + obj-loc + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (if (<fx open-key (vector-length *list-errors*)) + (vector-ref *list-errors* open-key) + #f))) + (else + #f))))) + (if (fixnum? loc) + (error/location "skribe-read" msg obj (input-port-name port) loc) + (error "skribe-read" msg obj)))) + +;*---------------------------------------------------------------------*/ +;* make-list! ... */ +;*---------------------------------------------------------------------*/ +(define (make-list! l port) + (define (reverse-proper-list! l) + (let nr ((l l) + (r '())) + (cond + ((eq? (car l) *dotted-mark*) + (read-error "Illegal pair" r port)) + ((null? (cdr l)) + (set-cdr! l r) + l) + (else + (let ((cdrl (cdr l))) + (nr cdrl + (begin (set-cdr! l r) + l))))))) + (define (reverse-improper-list! l) + (let nr ((l (cddr l)) + (r (car l))) + (cond + ((eq? (car l) *dotted-mark*) + (read-error "Illegal pair" r port)) + ((null? (cdr l)) + (set-cdr! l r) + l) + (else + (let ((cdrl (cdr l))) + (nr cdrl + (begin (set-cdr! l r) + l))))))) + (cond + ((null? l) + l) + ((and (pair? l) (pair? (cdr l)) (eq? (cadr l) *dotted-mark*)) + (if (null? (cddr l)) + (car l) + (reverse-improper-list! l))) + (else + (reverse-proper-list! l)))) + +;*---------------------------------------------------------------------*/ +;* make-at ... */ +;*---------------------------------------------------------------------*/ +(define (make-at name pos) + (cond-expand + ((or bigloo2.4 bigloo2.5 bigloo2.6) + `(at ,name ,pos _)) + (else + `(at ,name ,pos)))) + +;*---------------------------------------------------------------------*/ +;* collect-up-to ... */ +;* ------------------------------------------------------------- */ +;* The first pair of the list is special because of source file */ +;* location. We want the location to be associated to the first */ +;* open parenthesis, not the last character of the car of the list. */ +;*---------------------------------------------------------------------*/ +(define-inline (collect-up-to ignore kind port) + (let ((name (input-port-name port))) + (let* ((pos (input-port-position port)) + (item (ignore))) + (if (eq? item *end-of-list*) + '() + (let loop ((acc (econs item '() (make-at name pos)))) + (let ((item (ignore))) + (if (eq? item *end-of-list*) + acc + (loop (let ((new-pos (input-port-position port))) + (econs item + acc + (make-at name new-pos))))))))))) + +;*---------------------------------------------------------------------*/ +;* read-quote ... */ +;*---------------------------------------------------------------------*/ +(define (read-quote kwote port ignore) + (let* ((pos (input-port-position port)) + (obj (ignore))) + (if (or (eof-object? obj) (eq? obj *end-of-list*)) + (error/location "read" + "Illegal quotation" + kwote + (input-port-name port) + pos)) + (econs kwote + (cons obj '()) + (make-at (input-port-name port) pos)))) + +;*---------------------------------------------------------------------*/ +;* *sexp-grammar* ... */ +;*---------------------------------------------------------------------*/ +(define *sexp-grammar* + (regular-grammar ((float (or (: (* digit) "." (+ digit)) + (: (+ digit) "." (* digit)))) + (letter (in ("azAZ") (#a128 #a255))) + (special (in "!@~$%^&*></-_+\\=?.:{}")) + (kspecial (in "!@~$%^&*></-_+\\=?.")) + (quote (in "\",'`")) + (paren (in "()")) + (id (: (* digit) + (or letter special) + (* (or letter special digit (in ",'`"))))) + (kid (: (* digit) + (or letter kspecial) + (* (or letter kspecial digit (in ",'`"))))) + (blank (in #\Space #\Tab #a012 #a013))) + + ;; newlines + ((+ #\Newline) + (ignore)) + + ;; blank lines + ((+ blank) + (ignore)) + + ;; comments + ((: ";" (* all)) + (ignore)) + + ;; the interpreter header or the dsssl named constants + ((: "#!" (+ (in letter))) + (let* ((str (the-string))) + (cond + ((string=? str "#!optional") + boptional) + ((string=? str "#!rest") + brest) + ((string=? str "#!key") + bkey) + (else + (ignore))))) + + ;; characters + ((: (uncase "#a") (= 3 digit)) + (let ((string (the-string))) + (if (not (=fx (the-length) 5)) + (error/location "skribe-read" + "Illegal ascii character" + string + (input-port-name (the-port)) + (input-port-position (the-port))) + (integer->char (string->integer (the-substring 2 5)))))) + ((: "#\\" (or letter digit special (in "|#; []" quote paren))) + (string-ref (the-string) 2)) + ((: "#\\" (>= 2 letter)) + (let ((char-name (string->symbol + (string-upcase! + (the-substring 2 (the-length)))))) + (case char-name + ((NEWLINE) + #\Newline) + ((TAB) + #\tab) + ((SPACE) + #\space) + ((RETURN) + (integer->char 13)) + (else + (error/location "skribe-read" + "Illegal character" + (the-string) + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; ucs-2 characters + ((: "#u" (= 4 xdigit)) + (integer->ucs2 (string->integer (the-substring 2 6) 16))) + + ((: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 1 (-fx (the-length) 1)))) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (escape-C-string str)))) + ;; ucs2 strings + ((: "#u\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (let ((str (the-substring 3 (-fx (the-length) 1)))) + (utf8-string->ucs2-string str))) + + ;; fixnums + ((: (? (in "-+")) (+ digit)) + (the-fixnum)) + ((: "#o" (? (in "-+")) (+ (in ("07")))) + (string->integer (the-substring 2 (the-length)) 8)) + ((: "#d" (? (in "-+")) (+ (in ("09")))) + (string->integer (the-substring 2 (the-length)) 10)) + ((: "#x" (? (in "-+")) (+ (in (uncase (in ("09af")))))) + (string->integer (the-substring 2 (the-length)) 16)) + ((: "#e" (? (in "-+")) (+ digit)) + (string->elong (the-substring 2 (the-length)) 10)) + ((: "#l" (? (in "-+")) (+ digit)) + (string->llong (the-substring 2 (the-length)) 10)) + + ;; flonum + ((: (? (in "-+")) + (or float + (: (or float (+ digit)) (in "eE") (? (in "+-")) (+ digit)))) + (the-flonum)) + + ;; doted pairs + ("." + (if (<=fx *par-open* 0) + (error/location "read" + "Illegal token" + #\. + (input-port-name (the-port)) + (input-port-position (the-port))) + *dotted-mark*)) + + ;; unspecified and eof-object + ((: "#" (in "ue") (+ (in "nspecified-objt"))) + (let ((symbol (string->symbol + (string-upcase! + (the-substring 1 (the-length)))))) + (case symbol + ((UNSPECIFIED) + unspec) + ((EOF-OBJECT) + beof) + (else + (error/location "read" + "Illegal identifier" + symbol + (input-port-name (the-port)) + (input-port-position (the-port))))))) + + ;; booleans + ((: "#" (uncase #\t)) + #t) + ((: "#" (uncase #\f)) + #f) + + ;; keywords + ((or (: ":" kid) (: kid ":")) + ;; since the keyword expression is also matched by the id + ;; rule, keyword rule has to be placed before the id rule. + (the-keyword)) + + ;; identifiers + (id + ;; this rule has to be placed after the rule matching the `.' char + (the-symbol)) + ((: "|" (+ (or (out #a000 #\\ #\|) (: #\\ all))) "|") + (if (=fx (the-length) 2) + (the-symbol) + (let ((str (the-substring 0 (-fx (the-length) 1)))) + (string->symbol (escape-C-string str))))) + + ;; quotations + ("'" + (read-quote 'quote (the-port) ignore)) + ("`" + (read-quote 'quasiquote (the-port) ignore)) + ("," + (read-quote 'unquote (the-port) ignore)) + (",@" + (read-quote 'unquote-splicing (the-port) ignore)) + + ;; lists + (#\( + ;; if possible, we store the opening parenthesis. + (if (and (vector? *list-errors*) + (<fx *par-open* (vector-length *list-errors*))) + (vector-set! *list-errors* + *par-open* + (input-port-position (the-port)))) + ;; we increment the number of open parenthesis + (set! *par-open* (+fx 1 *par-open*)) + ;; and then, we compute the result list... + (make-list! (collect-up-to ignore "list" (the-port)) (the-port))) + (#\) + ;; we decrement the number of open parenthesis + (set! *par-open* (-fx *par-open* 1)) + (if (<fx *par-open* 0) + (begin + (warning/location (input-port-name (the-port)) + (input-port-position (the-port)) + "read" + "Superfluous closing parenthesis `" + (the-string) + "'") + (set! *par-open* 0) + (ignore)) + *end-of-list*)) + + ;; list of strings + (#\[ + (let ((exp (read/rp *text-grammar* (the-port)))) + (list 'quasiquote exp))) + + ;; vectors + ("#(" + ;; if possible, we store the opening parenthesis. + (if (and (vector? *vector-errors*) + (<fx *par-open* (vector-length *vector-errors*))) + (let ((pos (input-port-position (the-port)))) + (vector-set! *vector-errors* *par-open* pos))) + ;; we increment the number of open parenthesis + (set! *par-open* (+fx 1 *par-open*)) + (list->vector (reverse! (collect-up-to ignore "vector" (the-port))))) + + ;; error or eof + (else + (let ((port (the-port)) + (char (the-failure))) + (if (eof-object? char) + (cond + ((>fx *par-open* 0) + (let ((open-key (-fx *par-open* 1))) + (skribe-reader-reset!) + (if (and (<fx open-key (vector-length *list-errors*)) + (fixnum? (vector-ref *list-errors* open-key))) + (error/location "skribe-read" + "Unclosed list" + char + (input-port-name port) + (vector-ref *list-errors* open-key)) + (error "skribe-read" + "Unexpected end-of-file" + "Unclosed list")))) + (else + (reset-eof port) + char)) + (error/location "skribe-read" + "Illegal char" + (illegal-char-rep char) + (input-port-name port) + (input-port-position port))))))) + +;*---------------------------------------------------------------------*/ +;* *text-grammar* ... */ +;* ------------------------------------------------------------- */ +;* The grammar that parses texts (the [...] forms). */ +;*---------------------------------------------------------------------*/ +(define *text-grammar* + (regular-grammar () + ((: (* (out ",[]\\")) #\]) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1)))) + (econs item '() loc))) + ((: (* (out ",[\\")) ",]") + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1)))) + (econs item '() loc))) + ((: (* (out ",[]\\")) #\,) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-substring 0 (-fx (the-length) 1))) + (sexp (read/rp *sexp-grammar* (the-port))) + (rest (ignore))) + (if (string=? item "") + (cons (list 'unquote sexp) rest) + (econs item (cons (list 'unquote sexp) rest) loc)))) + ((or (+ (out ",[]\\")) + (+ #\Newline) + (: (* (out ",[]\\")) #\, (out "([]\\"))) + (let* ((port (the-port)) + (name (input-port-name port)) + (pos (input-port-position port)) + (loc (make-at name pos)) + (item (the-string)) + (rest (ignore))) + (econs item rest loc))) + ("\\\\" + (cons "\\" (ignore))) + ("\\n" + (cons "\n" (ignore))) + ("\\t" + (cons "\t" (ignore))) + ("\\]" + (cons "]" (ignore))) + ("\\[" + (cons "[" (ignore))) + ("\\," + (cons "," (ignore))) + (#\\ + (cons "\\" (ignore))) + (else + (let ((c (the-failure)) + (port (the-port))) + (define (err msg) + (error/location "skribe-read-text" + msg + (the-failure) + (input-port-name port) + (input-port-position port))) + (cond + ((eof-object? c) + (err "Illegal `end of file'")) + ((char=? c #\[) + (err "Illegal nested `[...]' form")) + (else + (err "Illegal string character"))))))) + +;*---------------------------------------------------------------------*/ +;* skribe-read ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-read . input-port) + (cond + ((null? input-port) + (read/rp *sexp-grammar* (current-input-port))) + ((not (input-port? (car input-port))) + (error "read" "type `input-port' expected" (car input-port))) + (else + (let ((port (car input-port))) + (if (closed-input-port? port) + (error "read" "Illegal closed input port" port) + (read/rp *sexp-grammar* port)))))) + diff --git a/src/bigloo/resolve.scm b/src/bigloo/resolve.scm new file mode 100644 index 0000000..7507560 --- /dev/null +++ b/src/bigloo/resolve.scm @@ -0,0 +1,281 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/resolve.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jul 25 09:31:18 2003 */ +;* Last change : Sun Jul 11 09:17:52 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe resolve stage */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_resolve + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_bib + skribe_eval) + + (import skribe_index) + + (export (resolve! ::obj ::%engine ::pair-nil) + (resolve-children ::obj) + (resolve-children* ::obj) + (resolve-parent ::%ast ::pair-nil) + (resolve-search-parent ::%ast ::pair-nil ::procedure) + (resolve-counter ::%ast ::pair-nil ::symbol ::obj . o) + (resolve-ident ::bstring ::obj ::%ast ::obj))) + +;*---------------------------------------------------------------------*/ +;* *unresolved* ... */ +;*---------------------------------------------------------------------*/ +(define *unresolved* #f) + +;*---------------------------------------------------------------------*/ +;* resolve! ... */ +;* ------------------------------------------------------------- */ +;* This function iterates over an ast until all unresolved */ +;* references are resolved. */ +;*---------------------------------------------------------------------*/ +(define (resolve! ast engine env) + (with-debug 3 'resolve + (debug-item "ast=" ast) + (let ((old *unresolved*)) + (let loop ((ast ast)) + (set! *unresolved* #f) + (let ((ast (do-resolve! ast engine env))) + (if *unresolved* + (loop ast) + (begin + (set! *unresolved* old) + ast))))))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ... */ +;*---------------------------------------------------------------------*/ +(define-generic (do-resolve! ast engine env) + (if (pair? ast) + (do-resolve*! ast engine env) + ast)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%node engine env) + (with-access::%node node (body options parent) + (with-debug 5 'do-resolve::body + (debug-item "node=" (if (markup? node) + (markup-markup node) + (find-runtime-type node))) + (debug-item "body=" (find-runtime-type body)) + (if (not (eq? parent #unspecified)) + node + (let ((p (assq 'parent env))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (if (pair? options) + (begin + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine env))) + options) + (debug-item "resolved options=" options))))) + (set! body (do-resolve! body engine env)) + node))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%container ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%container engine env0) + (with-access::%container node (body options env parent) + (with-debug 5 'do-resolve::%container + (debug-item "markup=" (markup-markup node)) + (debug-item "body=" (find-runtime-type body)) + (debug-item "env0=" env0) + (debug-item "env=" env) + (if (not (eq? parent #unspecified)) + node + (let ((p (assq 'parent env0))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p))) + (if (pair? options) + (let ((e (append `((parent ,node)) env0))) + (debug-item "unresolved options=" options) + (for-each (lambda (o) + (set-car! (cdr o) + (do-resolve! (cadr o) engine e))) + options) + (debug-item "resolved options=" options))) + (let ((e `((parent ,node) ,@env ,@env0))) + (set! body (do-resolve! body engine e)) + node)))) + ;; return the container + node)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%document ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%document engine env0) + (with-access::%document node (env) + (call-next-method) + ;; resolve the engine custom + (let ((env (append `((parent ,node)) env0))) + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (debug-item "custom=" i " " a) + (set-car! (cdr c) (do-resolve! a engine env)))) + (%engine-customs engine))) + ;; return the container + node)) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::%unresolved ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%unresolved engine env) + (with-debug 5 'do-resolve::%unresolved + (debug-item "node=" node) + (with-access::%unresolved node (proc parent loc) + (let ((p (assq 'parent env))) + (set! parent (and (pair? p) (pair? (cdr p)) (cadr p)))) + (let ((res (resolve! (proc node engine env) engine env))) + (if (ast? res) (%ast-loc-set! res loc)) + (debug-item "res=" res) + (set! *unresolved* #t) + res)))) + +;*---------------------------------------------------------------------*/ +;* do-resolve! ::handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (do-resolve! node::%handle engine env) + node) + +;*---------------------------------------------------------------------*/ +;* do-resolve*! ... */ +;*---------------------------------------------------------------------*/ +(define (do-resolve*! n+ engine env) + (let loop ((n* n+)) + (cond + ((pair? n*) + (set-car! n* (do-resolve! (car n*) engine env)) + (loop (cdr n*))) + ((not (null? n*)) + (skribe-error 'do-resolve "Illegal argument" n*)) + (else + n+)))) + +;*---------------------------------------------------------------------*/ +;* resolve-children ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-children n) + (if (pair? n) + n + (list n))) + +;*---------------------------------------------------------------------*/ +;* resolve-children* ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-children* n) + (cond + ((pair? n) + (map resolve-children* n)) + ((%container? n) + (cons n (resolve-children* (%container-body n)))) + (else + (list n)))) + +;*---------------------------------------------------------------------*/ +;* resolve-parent ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-parent n e) + (with-debug 5 'resolve-parent + (debug-item "n=" n) + (cond + ((not (%ast? n)) + (let ((c (assq 'parent e))) + (if (pair? c) + (cadr c) + n))) + ((eq? (%ast-parent n) #unspecified) + (skribe-error 'resolve-parent "Orphan node" n)) + (else + (%ast-parent n))))) + +;*---------------------------------------------------------------------*/ +;* resolve-search-parent ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-search-parent n e pred) + (with-debug 5 'resolve-search-parent + (debug-item "node=" (find-runtime-type n)) + (debug-item "searching=" pred) + (let ((p (resolve-parent n e))) + (debug-item "parent=" (find-runtime-type p) " " + (if (markup? p) (markup-markup p) "???")) + (cond + ((pred p) + p) + ((%unresolved? p) + p) + ((not p) + #f) + (else + (resolve-search-parent p e pred)))))) + +;*---------------------------------------------------------------------*/ +;* resolve-counter ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-counter n e cnt val . opt) + (let ((c (assq (symbol-append cnt '-counter) e))) + (if (not (pair? c)) + (if (or (null? opt) (not (car opt)) (null? e)) + (skribe-error cnt "Orphan node" n) + (begin + (set-cdr! (last-pair e) + (list (list (symbol-append cnt '-counter) 0) + (list (symbol-append cnt '-env) '()))) + (resolve-counter n e cnt val))) + (let* ((num (cadr c)) + (nval (if (integer? val) + val + (+ 1 num)))) + (let ((c2 (assq (symbol-append cnt '-env) e))) + (set-car! (cdr c2) (cons (resolve-parent n e) (cadr c2)))) + (cond + ((integer? val) + (set-car! (cdr c) val) + (car val)) + ((not val) + val) + (else + (set-car! (cdr c) (+ 1 num)) + (+ 1 num))))))) + +;*---------------------------------------------------------------------*/ +;* resolve-ident ... */ +;*---------------------------------------------------------------------*/ +(define (resolve-ident ident markup n e) + (with-debug 4 'resolve-ident + (debug-item "ident=" ident) + (debug-item "markup=" markup) + (debug-item "n=" (if (markup? n) (markup-markup n) n)) + (if (not (string? ident)) + (skribe-type-error 'resolve-ident + "Illegal ident" + ident + "string") + (let ((mks (find-markups ident))) + (and mks + (if (not markup) + (car mks) + (let loop ((mks mks)) + (cond + ((null? mks) + #f) + ((is-markup? (car mks) markup) + (car mks)) + (else + (loop (cdr mks))))))))))) diff --git a/src/bigloo/source.scm b/src/bigloo/source.scm new file mode 100644 index 0000000..babadff --- /dev/null +++ b/src/bigloo/source.scm @@ -0,0 +1,238 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/source.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Aug 29 07:27:25 2003 */ +;* Last change : Tue Nov 2 14:25:50 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Bigloo handling of Skribe programs. */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_source + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param) + + (export (source-read-chars::bstring ::bstring ::int ::int ::obj) + (source-read-lines::bstring ::bstring ::obj ::obj ::obj) + (source-read-definition::bstring ::bstring ::obj ::obj ::obj) + (source-fontify ::obj ::obj) + (split-string-newline::pair-nil ::bstring))) + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-chars file start stop tab) + (define (readl p) + (read/rp (regular-grammar () + ((: (* (out #\Newline)) (? #\Newline)) + (the-string)) + (else + (the-failure))) + p)) + (let ((p (find-file/path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let loop ((c -1) + (s (readl (current-input-port))) + (r '())) + (let ((p (input-port-position (current-input-port)))) + (cond + ((eof-object? s) + (apply string-append (reverse! r))) + ((>=fx p stop) + (let* ((len (-fx (-fx stop start) c)) + (line (untabify (substring s 0 len) tab))) + (apply string-append + (reverse! (cons line r))))) + ((>=fx c 0) + (loop (+fx (string-length s) c) + (readl (current-input-port)) + (cons (untabify s tab) r))) + ((>=fx p start) + (let* ((len (string-length s)) + (nc (-fx p start))) + (if (>fx p stop) + (untabify + (substring s + (-fx len (-fx p start)) + (-fx (-fx p stop) 1)) + tab) + (loop nc + (readl (current-input-port)) + (list + (untabify + (substring s + (-fx len (-fx p start)) + len) + tab)))))) + (else + (loop c (readl (current-input-port)) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-lines ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-lines file start stop tab) + (let ((p (find-file/path file (skribe-source-path)))) + (if (or (not (string? p)) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' source file in path" file) + (skribe-source-path)) + (with-input-from-file p + (lambda () + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (let ((startl (if (string? start) (string-length start) -1)) + (stopl (if (string? stop) (string-length stop) -1))) + (let loop ((l 1) + (armedp (not (or (integer? start) + (string? start)))) + (s (read-line)) + (r '())) + (cond + ((or (eof-object? s) + (and (integer? stop) (> l stop)) + (and (string? stop) (substring=? stop s stopl))) + (apply string-append (reverse! r))) + (armedp + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (integer? start) (>= l start)) + (loop (+fx l 1) + #t + (read-line) + (cons* "\n" (untabify s tab) r))) + ((and (string? start) (substring=? start s startl)) + (loop (+fx l 1) #t (read-line) r)) + (else + (loop (+fx l 1) #f (read-line) r)))))))))) + +;*---------------------------------------------------------------------*/ +;* untabify ... */ +;*---------------------------------------------------------------------*/ +(define (untabify obj tab) + (if (not tab) + obj + (let ((len (string-length obj)) + (tabl tab)) + (let loop ((i 0) + (col 1)) + (cond + ((=fx i len) + (let ((nlen (-fx col 1))) + (if (=fx len nlen) + obj + (let ((new (make-string col #\space))) + (let liip ((i 0) + (j 0) + (col 1)) + (cond + ((=fx i len) + new) + ((char=? (string-ref obj i) #\tab) + (let ((next-tab (*fx (/fx (+fx col tabl) + tabl) + tabl))) + (liip (+fx i 1) + next-tab + next-tab))) + (else + (string-set! new j (string-ref obj i)) + (liip (+fx i 1) (+fx j 1) (+fx col 1))))))))) + ((char=? (string-ref obj i) #\tab) + (loop (+fx i 1) + (*fx (/fx (+fx col tabl) tabl) tabl))) + (else + (loop (+fx i 1) (+fx col 1)))))))) + +;*---------------------------------------------------------------------*/ +;* source-read-definition ... */ +;*---------------------------------------------------------------------*/ +(define (source-read-definition file definition tab lang) + (let ((p (find-file/path file (skribe-source-path)))) + (cond + ((not (%language-extractor lang)) + (skribe-error 'source + "The specified language has not defined extractor" + lang)) + ((or (not p) (not (file-exists? p))) + (skribe-error 'source + (format "Can't find `~a' program file in path" file) + (skribe-source-path))) + (else + (let ((ip (open-input-file p))) + (if (>fx *skribe-verbose* 0) + (fprint (current-error-port) " [source file: " p "]")) + (if (not (input-port? ip)) + (skribe-error 'source "Can't open file for input" p) + (unwind-protect + (let ((s ((%language-extractor lang) ip definition tab))) + (if (not (string? s)) + (skribe-error 'source + "Can't find definition" + definition) + s)) + (close-input-port ip)))))))) + +;*---------------------------------------------------------------------*/ +;* source-fontify ... */ +;*---------------------------------------------------------------------*/ +(define (source-fontify o language) + (define (fontify f o) + (cond + ((string? o) (f o)) + ((pair? o) (map (lambda (s) (if (string? s) (f s) (fontify f s))) o)) + (else o))) + (let ((f (%language-fontifier language))) + (if (procedure? f) + (fontify f o) + o))) + +;*---------------------------------------------------------------------*/ +;* split-string-newline ... */ +;*---------------------------------------------------------------------*/ +(define (split-string-newline str) + (let ((l (string-length str))) + (let loop ((i 0) + (j 0) + (r '())) + (cond + ((=fx i l) + (if (=fx i j) + (reverse! r) + (reverse! (cons (substring str j i) r)))) + ((char=? (string-ref str i) #\Newline) + (loop (+fx i 1) + (+fx i 1) + (if (=fx i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + ((and (char=? (string-ref str i) #a013) + (<fx (+fx i 1) l) + (char=? (string-ref str (+fx i 1)) #\Newline)) + (loop (+fx i 2) + (+fx i 2) + (if (=fx i j) + (cons 'eol r) + (cons* 'eol (substring str j i) r)))) + (else + (loop (+fx i 1) j r)))))) + diff --git a/src/bigloo/sui.bgl b/src/bigloo/sui.bgl new file mode 100644 index 0000000..63c5477 --- /dev/null +++ b/src/bigloo/sui.bgl @@ -0,0 +1,34 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/sui.bgl */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Wed Jul 23 12:48:11 2003 */ +;* Last change : Thu Jan 1 16:16:03 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe runtime (i.e., the style user functions). */ +;* ------------------------------------------------------------- */ +;* Implementation: @label sui@ */ +;* bigloo: @path ../common/sui.scm@ */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_sui + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_output + skribe_engine) + + (export (load-sui ::bstring) + (sui-ref->url ::bstring ::obj ::obj ::pair-nil) + (sui-title::bstring ::pair-nil) + (sui-file::obj ::pair-nil) + (sui-key::obj ::pair-nil ::obj) + (sui-filter::pair-nil ::obj ::procedure ::procedure))) + diff --git a/src/bigloo/types.scm b/src/bigloo/types.scm new file mode 100644 index 0000000..b8babd4 --- /dev/null +++ b/src/bigloo/types.scm @@ -0,0 +1,685 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/types.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:40:42 2003 */ +;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The definition of the Skribe classes */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_types + + (export (abstract-class %ast + (parent (default #unspecified)) + (loc (default (evmeaning-location)))) + + (class %command::%ast + (fmt::bstring read-only) + (body (default #f))) + + (class %unresolved::%ast + (proc::procedure read-only)) + + (class %handle::%ast + (ast (default #f))) + + (abstract-class %node::%ast + (required-options::pair-nil read-only (default '())) + (options::pair-nil (default '())) + (body (default #f))) + + (class %processor::%node + (combinator (default (lambda (e1 e2) e1))) + (procedure::procedure (default (lambda (n e) n))) + engine) + + (class %markup::%node + (markup-init) + (ident (default #f)) + (class (default #f)) + (markup::symbol read-only)) + + (class %container::%markup + (env::pair-nil (default '()))) + + (class %document::%container) + + (class %engine + (ident::symbol read-only) + (format::bstring (default "raw")) + (info::pair-nil (default '())) + (version::obj read-only (default #unspecified)) + (delegate read-only (default #f)) + (writers::pair-nil (default '())) + (filter::obj (default #f)) + (customs::pair-nil (default '())) + (symbol-table::pair-nil (default '()))) + + (class %writer + (ident::symbol read-only) + (class read-only) + (pred::procedure read-only) + (upred read-only) + (options::obj read-only) + (verified?::bool (default #f)) + (validate (default #f)) + (before read-only) + (action read-only) + (after read-only)) + + (class %language + (name::bstring read-only) + (fontifier read-only (default #f)) + (extractor read-only (default #f))) + + (markup-init ::%markup) + (find-markups ::bstring) + + (inline ast?::bool ::obj) + (inline ast-parent::obj ::%ast) + (inline ast-loc::obj ::%ast) + (inline ast-loc-set!::obj ::%ast ::obj) + (ast-location::bstring ::%ast) + + (new-command . inits) + (inline command?::bool ::obj) + (inline command-fmt::bstring ::%command) + (inline command-body::obj ::%command) + + (new-unresolved . inits) + (inline unresolved?::bool ::obj) + (inline unresolved-proc::procedure ::%unresolved) + + (new-handle . inits) + (inline handle?::bool ::obj) + (inline handle-ast::obj ::%handle) + + (inline node?::bool ::obj) + (inline node-body::obj ::%node) + (inline node-options::pair-nil ::%node) + (inline node-loc::obj ::%node) + + (new-processor . inits) + (inline processor?::bool ::obj) + (inline processor-combinator::obj ::%processor) + (inline processor-engine::obj ::%processor) + + (new-markup . inits) + (inline markup?::bool ::obj) + (inline is-markup?::bool ::obj ::symbol) + (inline markup-markup::obj ::%markup) + (inline markup-ident::obj ::%markup) + (inline markup-body::obj ::%markup) + (inline markup-options::pair-nil ::%markup) + + (new-container . inits) + (inline container?::bool ::obj) + (inline container-ident::obj ::%container) + (inline container-body::obj ::%container) + (inline container-options::pair-nil ::%container) + + (new-document . inits) + (inline document?::bool ::obj) + (inline document-ident::bool ::%document) + (inline document-body::bool ::%document) + (inline document-options::pair-nil ::%document) + (inline document-env::pair-nil ::%document) + + (inline engine?::bool ::obj) + (inline engine-ident::obj ::obj) + (inline engine-format::obj ::obj) + (inline engine-customs::pair-nil ::obj) + (inline engine-filter::obj ::obj) + (inline engine-symbol-table::pair-nil ::%engine) + + (inline writer?::bool ::obj) + (inline writer-before::obj ::%writer) + (inline writer-action::obj ::%writer) + (inline writer-after::obj ::%writer) + (inline writer-options::obj ::%writer) + + (inline language?::bool ::obj) + (inline language-name::obj ::obj) + (inline language-fontifier::obj ::obj) + (inline language-extractor::obj ::obj) + + (new-language . inits) + + (location?::bool ::obj) + (location-file::bstring ::pair) + (location-pos::int ::pair))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate ... */ +;*---------------------------------------------------------------------*/ +(define-macro (skribe-instantiate type values . slots) + `(begin + (skribe-instantiate-check-values ',type ,values ',slots) + (,(symbol-append 'instantiate::% type) + ,@(map (lambda (slot) + (let ((id (if (pair? slot) (car slot) slot)) + (def (if (pair? slot) (cadr slot) #f))) + `(,id (new-get-value ',id ,values ,def)))) + slots)))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate-check-values ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-instantiate-check-values id values slots) + (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) + (when (pair? bs) + (for-each (lambda (b) + (error (symbol-append '|new | id) + "Illegal field" + b)) + bs)))) + +;*---------------------------------------------------------------------*/ +;* object-print ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-print obj::%ast port print-slot::procedure) + (let* ((class (object-class obj)) + (class-name (class-name class))) + (display "#|" port) + (display class-name port) + (display #\| port))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%ast ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%ast . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a>" + (find-runtime-type n))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a>" + (find-runtime-type n) + (markup-markup n))) + +;*---------------------------------------------------------------------*/ +;* object-write ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-write n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a:~a>" + (find-runtime-type n) + (markup-markup n) + (find-runtime-type (markup-body n)))) + +;*---------------------------------------------------------------------*/ +;* *node-table* */ +;* ------------------------------------------------------------- */ +;* A private hashtable that stores all the nodes of an ast. It */ +;* is used for retreiving a node from its identifier. */ +;*---------------------------------------------------------------------*/ +(define *node-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* ast? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast? obj) + (%ast? obj)) + +;*---------------------------------------------------------------------*/ +;* ast-parent ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-parent obj) + (%ast-parent obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc obj) + (%ast-loc obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc-set! ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc-set! obj loc) + (%ast-loc-set! obj loc)) + +;*---------------------------------------------------------------------*/ +;* ast-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast-location obj) + (with-access::%ast obj (loc) + (if (location? loc) + (let* ((fname (location-file loc)) + (char (location-pos loc)) + (pwd (pwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (and (>fx lenf len))) + (substring fname len (+fx 1 (string-length fname))) + fname))) + (format "~a, char ~a" file char)) + "no source location"))) + +;*---------------------------------------------------------------------*/ +;* new-command ... */ +;*---------------------------------------------------------------------*/ +(define (new-command . init) + (skribe-instantiate command init + (parent #unspecified) + (loc #f) + fmt + (body #f))) + +;*---------------------------------------------------------------------*/ +;* command? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command? obj) + (%command? obj)) + +;*---------------------------------------------------------------------*/ +;* command-fmt ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-fmt cmd) + (%command-fmt cmd)) + +;*---------------------------------------------------------------------*/ +;* command-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-body cmd) + (%command-body cmd)) + +;*---------------------------------------------------------------------*/ +;* new-unresolved ... */ +;*---------------------------------------------------------------------*/ +(define (new-unresolved . init) + (skribe-instantiate unresolved init + (parent #unspecified) + loc + proc)) + +;*---------------------------------------------------------------------*/ +;* unresolved? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved? obj) + (%unresolved? obj)) + +;*---------------------------------------------------------------------*/ +;* unresolved-proc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved-proc unr) + (%unresolved-proc unr)) + +;*---------------------------------------------------------------------*/ +;* new-handle ... */ +;*---------------------------------------------------------------------*/ +(define (new-handle . init) + (skribe-instantiate handle init + (parent #unspecified) + loc + (ast #f))) + +;*---------------------------------------------------------------------*/ +;* handle? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle? obj) + (%handle? obj)) + +;*---------------------------------------------------------------------*/ +;* handle-ast ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle-ast obj) + (%handle-ast obj)) + +;*---------------------------------------------------------------------*/ +;* node? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node? obj) + (%node? obj)) + +;*---------------------------------------------------------------------*/ +;* node-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-body obj) + (%node-body obj)) + +;*---------------------------------------------------------------------*/ +;* node-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-options obj) + (%node-options obj)) + +;*---------------------------------------------------------------------*/ +;* node-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-loc obj) + (%node-loc obj)) + +;*---------------------------------------------------------------------*/ +;* new-processor ... */ +;*---------------------------------------------------------------------*/ +(define (new-processor . init) + (skribe-instantiate processor init + (parent #unspecified) + loc + (combinator (lambda (e1 e2) e1)) + engine + (body #f))) + +;*---------------------------------------------------------------------*/ +;* processor? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor? obj) + (%processor? obj)) + +;*---------------------------------------------------------------------*/ +;* processor-combinator ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-combinator proc) + (%processor-combinator proc)) + +;*---------------------------------------------------------------------*/ +;* processor-engine ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-engine proc) + (%processor-engine proc)) + +;*---------------------------------------------------------------------*/ +;* new-markup ... */ +;*---------------------------------------------------------------------*/ +(define (new-markup . init) + (skribe-instantiate markup init + (parent #unspecified) + (loc #f) + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()))) + +;*---------------------------------------------------------------------*/ +;* markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup? obj) + (%markup? obj)) + +;*---------------------------------------------------------------------*/ +;* is-markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (is-markup? obj markup) + (and (markup? obj) (eq? (markup-markup obj) markup))) + +;*---------------------------------------------------------------------*/ +;* markup-init ... */ +;* ------------------------------------------------------------- */ +;* The markup constructor simply stores in the markup table the */ +;* news markups. */ +;*---------------------------------------------------------------------*/ +(define (markup-init markup) + (bind-markup! markup)) + +;*---------------------------------------------------------------------*/ +;* bind-markup! ... */ +;*---------------------------------------------------------------------*/ +(define (bind-markup! node) + (hashtable-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + +;*---------------------------------------------------------------------*/ +;* find-markups ... */ +;*---------------------------------------------------------------------*/ +(define (find-markups ident) + (hashtable-get *node-table* ident)) + +;*---------------------------------------------------------------------*/ +;* markup-markup ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-markup obj) + (%markup-markup obj)) + +;*---------------------------------------------------------------------*/ +;* markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-ident obj) + (%markup-ident obj)) + +;*---------------------------------------------------------------------*/ +;* markup-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-body obj) + (%markup-body obj)) + +;*---------------------------------------------------------------------*/ +;* markup-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-options obj) + (%markup-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-container ... */ +;*---------------------------------------------------------------------*/ +(define (new-container . init) + (skribe-instantiate container init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* container? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container? obj) + (%container? obj)) + +;*---------------------------------------------------------------------*/ +;* container-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-ident obj) + (%container-ident obj)) + +;*---------------------------------------------------------------------*/ +;* container-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-body obj) + (%container-body obj)) + +;*---------------------------------------------------------------------*/ +;* container-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-options obj) + (%container-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-document ... */ +;*---------------------------------------------------------------------*/ +(define (new-document . init) + (skribe-instantiate document init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* document? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document? obj) + (%document? obj)) + +;*---------------------------------------------------------------------*/ +;* document-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-options doc) + (%document-options doc)) + +;*---------------------------------------------------------------------*/ +;* document-env ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-env doc) + (%document-env doc)) + +;*---------------------------------------------------------------------*/ +;* document-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-ident doc) + (%document-ident doc)) + +;*---------------------------------------------------------------------*/ +;* document-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-body doc) + (%document-body doc)) + +;*---------------------------------------------------------------------*/ +;* engine? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine? obj) + (%engine? obj)) + +;*---------------------------------------------------------------------*/ +;* engine-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-ident obj) + (%engine-ident obj)) + +;*---------------------------------------------------------------------*/ +;* engine-format ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-format obj) + (%engine-format obj)) + +;*---------------------------------------------------------------------*/ +;* engine-customs ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-customs obj) + (%engine-customs obj)) + +;*---------------------------------------------------------------------*/ +;* engine-filter ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-filter obj) + (%engine-filter obj)) + +;*---------------------------------------------------------------------*/ +;* engine-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-symbol-table obj) + (%engine-symbol-table obj)) + +;*---------------------------------------------------------------------*/ +;* writer? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer? obj) + (%writer? obj)) + +;*---------------------------------------------------------------------*/ +;* writer-before ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-before obj) + (%writer-before obj)) + +;*---------------------------------------------------------------------*/ +;* writer-action ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-action obj) + (%writer-action obj)) + +;*---------------------------------------------------------------------*/ +;* writer-after ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-after obj) + (%writer-after obj)) + +;*---------------------------------------------------------------------*/ +;* writer-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-options obj) + (%writer-options obj)) + +;*---------------------------------------------------------------------*/ +;* language? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language? obj) + (%language? obj)) + +;*---------------------------------------------------------------------*/ +;* language-name ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-name lg) + (%language-name lg)) + +;*---------------------------------------------------------------------*/ +;* language-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-fontifier lg) + (%language-fontifier lg)) + +;*---------------------------------------------------------------------*/ +;* language-extractor ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-extractor lg) + (%language-extractor lg)) + +;*---------------------------------------------------------------------*/ +;* new-get-value ... */ +;*---------------------------------------------------------------------*/ +(define (new-get-value key init def) + (let ((c (assq key init))) + (match-case c + ((?- ?v) + v) + (else + def)))) + +;*---------------------------------------------------------------------*/ +;* new-language ... */ +;*---------------------------------------------------------------------*/ +(define (new-language . init) + (skribe-instantiate language init name fontifier extractor)) + +;*---------------------------------------------------------------------*/ +;* location? ... */ +;*---------------------------------------------------------------------*/ +(define (location? o) + (match-case o + ((at ?- ?-) + #t) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* location-file ... */ +;*---------------------------------------------------------------------*/ +(define (location-file o) + (match-case o + ((at ?fname ?-) + fname) + (else + (error 'location-file "Illegal location" o)))) + +;*---------------------------------------------------------------------*/ +;* location-pos ... */ +;*---------------------------------------------------------------------*/ +(define (location-pos o) + (match-case o + ((at ?- ?loc) + loc) + (else + (error 'location-pos "Illegal location" o)))) diff --git a/src/bigloo/verify.scm b/src/bigloo/verify.scm new file mode 100644 index 0000000..602a951 --- /dev/null +++ b/src/bigloo/verify.scm @@ -0,0 +1,143 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/verify.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Fri Jul 25 09:54:55 2003 */ +;* Last change : Thu Sep 23 19:58:01 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The Skribe verification stage */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_verify + + (include "debug.sch") + + (import skribe_types + skribe_lib + skribe_engine + skribe_writer + skribe_eval) + + (export (generic verify ::obj ::%engine))) + +;*---------------------------------------------------------------------*/ +;* check-required-options ... */ +;*---------------------------------------------------------------------*/ +(define (check-required-options n::%markup w::%writer e::%engine) + (with-access::%markup n (required-options) + (with-access::%writer w (ident options verified?) + (or verified? + (eq? options 'all) + (begin + (for-each (lambda (o) + (if (not (memq o options)) + (skribe-error (%engine-ident e) + (format "Option unsupported: ~a, supported options: ~a" o options) + n))) + required-options) + (set! verified? #t)))))) + +;*---------------------------------------------------------------------*/ +;* check-options ... */ +;* ------------------------------------------------------------- */ +;* Only keywords are checked, symbols are voluntary left unchecked. */ +;*---------------------------------------------------------------------*/ +(define (check-options eo*::pair-nil m::%markup e::%engine) + (with-debug 6 'check-options + (debug-item "markup=" (%markup-markup m)) + (debug-item "options=" (%markup-options m)) + (debug-item "eo*=" eo*) + (for-each (lambda (o2) + (for-each (lambda (o) + (if (and (keyword? o) + (not (eq? o :&skribe-eval-location)) + (not (memq o eo*))) + (skribe-warning/ast + 3 + m + 'verify + (format "Engine `~a' does not support markup `~a' option `~a' -- ~a" + (%engine-ident e) + (%markup-markup m) + o + (markup-option m o))))) + o2)) + (%markup-options m)))) + +;*---------------------------------------------------------------------*/ +;* verify :: ... */ +;*---------------------------------------------------------------------*/ +(define-generic (verify node e) + (if (pair? node) + (for-each (lambda (n) (verify n e)) node)) + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%processor ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify n::%processor e) + (with-access::%processor n (combinator engine body) + (verify body (processor-get-engine combinator engine e)) + n)) + +;*---------------------------------------------------------------------*/ +;* verify ::%node ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%node e) + (with-access::%node node (body options) + (verify body e) + (for-each (lambda (o) (verify (cadr o) e)) options) + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%markup e) + (with-debug 5 'verify::%markup + (debug-item "node=" (%markup-markup node)) + (debug-item "options=" (%markup-options node)) + (debug-item "e=" (%engine-ident e)) + (call-next-method) + (let ((w (lookup-markup-writer node e))) + (if (%writer? w) + (begin + (check-required-options node w e) + (if (pair? (%writer-options w)) + (check-options (%writer-options w) node e)) + (let ((validate (%writer-validate w))) + (when (procedure? validate) + (unless (validate node e) + (skribe-warning + 1 + node + (format "Node `~a' forbidden here by ~a engine" + (markup-markup node) + (engine-ident e)) + node))))))) + ;; return the node + node)) + +;*---------------------------------------------------------------------*/ +;* verify ::%document ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%document e) + (call-next-method) + ;; verify the engine custom + (for-each (lambda (c) + (let ((i (car c)) + (a (cadr c))) + (set-car! (cdr c) (verify a e)))) + (%engine-customs e)) + ;; return the node + node) + +;*---------------------------------------------------------------------*/ +;* verify ::%handle ... */ +;*---------------------------------------------------------------------*/ +(define-method (verify node::%handle e) + node) + diff --git a/src/bigloo/writer.scm b/src/bigloo/writer.scm new file mode 100644 index 0000000..ce515bf --- /dev/null +++ b/src/bigloo/writer.scm @@ -0,0 +1,232 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/writer.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Sep 9 06:19:57 2003 */ +;* Last change : Tue Nov 2 14:33:59 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* Skribe writer management */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_writer + + (option (set! dsssl-symbol->keyword + (lambda (s) + (string->keyword + (string-append ":" (symbol->string s)))))) + + (include "debug.sch") + + (import skribe_types + skribe_eval + skribe_param + skribe_engine + skribe_output + skribe_lib) + + (export (invoke proc node e) + + (lookup-markup-writer ::%markup ::%engine) + + (markup-writer ::obj #!optional e #!key p class opt va bef aft act) + (copy-markup-writer ::obj ::obj #!optional e #!key p c o v b ac a) + (markup-writer-get ::obj #!optional e #!key class pred) + (markup-writer-get*::pair-nil ::obj #!optional e #!key class))) + +;*---------------------------------------------------------------------*/ +;* invoke ... */ +;*---------------------------------------------------------------------*/ +(define (invoke proc node e) + (let ((id (if (markup? node) + (string->symbol + (format "~a#~a" + (%engine-ident e) + (%markup-markup node))) + (%engine-ident e)))) + (with-push-trace id + (with-debug 5 'invoke + (debug-item "e=" (%engine-ident e)) + (debug-item "node=" (find-runtime-type node) + " " (if (markup? node) (%markup-markup node) "")) + (if (string? proc) + (display proc) + (if (procedure? proc) + (proc node e))))))) + +;*---------------------------------------------------------------------*/ +;* lookup-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (lookup-markup-writer node e) + (with-access::%engine e (writers delegate) + (let loop ((w* writers)) + (cond + ((pair? w*) + (with-access::%writer (car w*) (pred) + (if (pred node e) + (car w*) + (loop (cdr w*))))) + ((engine? delegate) + (lookup-markup-writer node delegate)) + (else + #f))))) + +;*---------------------------------------------------------------------*/ +;* make-writer-predicate ... */ +;*---------------------------------------------------------------------*/ +(define (make-writer-predicate markup predicate class) + (let* ((t1 (if (symbol? markup) + (lambda (n e) (is-markup? n markup)) + (lambda (n e) #t))) + (t2 (if class + (lambda (n e) + (and (t1 n e) (equal? (%markup-class n) class))) + t1))) + (if predicate + (cond + ((not (procedure? predicate)) + (skribe-error 'markup-writer + "Illegal predicate (procedure expected)" + predicate)) + ((not (correct-arity? predicate 2)) + (skribe-error 'markup-writer + "Illegal predicate arity (2 arguments expected)" + predicate)) + (else + (lambda (n e) + (and (t2 n e) (predicate n e))))) + t2))) + +;*---------------------------------------------------------------------*/ +;* markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (markup-writer markup + #!optional + engine + #!key + (predicate #f) + (class #f) + (options '()) + (validate #f) + (before #f) + (action #unspecified) + (after #f)) + (let ((e (or engine (default-engine)))) + (cond + ((and (not (symbol? markup)) (not (eq? markup #t))) + (skribe-error 'markup-writer "Illegal markup" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + ((and (not predicate) + (not class) + (null? options) + (not before) + (eq? action #unspecified) + (not after)) + (skribe-error 'markup-writer "Illegal writer" markup)) + (else + (let ((m (make-writer-predicate markup predicate class)) + (ac (if (eq? action #unspecified) + (lambda (n e) + (output (markup-body n) e)) + action))) + (engine-add-writer! e markup m predicate + options before ac after class validate)))))) + +;*---------------------------------------------------------------------*/ +;* copy-markup-writer ... */ +;*---------------------------------------------------------------------*/ +(define (copy-markup-writer markup old-engine + #!optional new-engine + #!key + (predicate #unspecified) + (class #unspecified) + (options #unspecified) + (validate #unspecified) + (before #unspecified) + (action #unspecified) + (after #unspecified)) + (let ((old (markup-writer-get markup old-engine)) + (new-engine (or new-engine old-engine))) + (markup-writer markup new-engine + :pred (if (unspecified? predicate) + (%writer-pred old) + predicate) + :class (if (unspecified? class) + (%writer-class old) + class) + :options (if (unspecified? options) + (%writer-options old) + options) + :validate (if (unspecified? validate) + (%writer-validate old) + validate) + :before (if (unspecified? before) + (%writer-before old) + before) + :action (if (unspecified? action) + (%writer-action old) + action) + :after (if (unspecified? after) + (%writer-after old) after)))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get ... */ +;* ------------------------------------------------------------- */ +;* Finds the writer that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get markup #!optional engine #!key (class #f) (pred #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e)) + (let loop ((w* (%engine-writers e))) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class) + (or (eq? pred #unspecified) + (eq? (%writer-upred (car w*)) pred))) + (car w*) + (loop (cdr w*)))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e))) + (else + #f)))))))) + +;*---------------------------------------------------------------------*/ +;* markup-writer-get* ... */ +;* ------------------------------------------------------------- */ +;* Finds alll writers that matches MARKUP with optional CLASS */ +;* attribute. */ +;*---------------------------------------------------------------------*/ +(define (markup-writer-get* markup #!optional engine #!key (class #f)) + (let ((e (or engine (default-engine)))) + (cond + ((not (symbol? markup)) + (skribe-error 'markup-writer "Illegal symbol" markup)) + ((not (engine? e)) + (skribe-error 'markup-writer "Illegal engine" e)) + (else + (let liip ((e e) + (res '())) + (let loop ((w* (%engine-writers e)) + (res res)) + (cond + ((pair? w*) + (if (and (eq? (%writer-ident (car w*)) markup) + (equal? (%writer-class (car w*)) class)) + (loop (cdr w*) (cons (car w*) res)) + (loop (cdr w*) res))) + ((engine? (%engine-delegate e)) + (liip (%engine-delegate e) res)) + (else + (reverse! res))))))))) diff --git a/src/bigloo/xml.scm b/src/bigloo/xml.scm new file mode 100644 index 0000000..d4c662e --- /dev/null +++ b/src/bigloo/xml.scm @@ -0,0 +1,92 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/xml.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Mon Sep 1 12:08:39 2003 */ +;* Last change : Mon May 17 10:14:24 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* XML fontification */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_xml + + (include "new.sch") + + (import skribe_types + skribe_lib + skribe_resolve + skribe_eval + skribe_api + skribe_param + skribe_source) + + (export xml)) + +;*---------------------------------------------------------------------*/ +;* xml ... */ +;*---------------------------------------------------------------------*/ +(define xml + (new language + (name "xml") + (fontifier xml-fontifier) + (extractor #f))) + +;*---------------------------------------------------------------------*/ +;* xml-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define (xml-fontifier s) + (let ((g (regular-grammar () + ((: #\; (in "<!--") (* (or all #\Newline)) "-->") + ;; italic comments + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-line-comment) + (body s)))) + str) + (ignore)))) + ((+ (or #\Newline #\Space)) + ;; separators + (let ((str (the-string))) + (cons str (ignore)))) + ((or (: #\< (+ (out #\> #\space #\tab #\Newline))) #\>) + ;; markup + (let ((str (the-string))) + (let ((c (new markup + (markup '&source-module) + (body (the-string))))) + (cons c (ignore))))) + ((+ (out #\< #\> #\Space #\Tab #\= #\")) + ;; regular text + (let ((string (the-string))) + (cons string (ignore)))) + ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"") + (: "\'" (* (or (out #a000 #\\ #\') (: #\\ all))) "\'")) + ;; strings + (let ((str (split-string-newline (the-string)))) + (append (map (lambda (s) + (if (eq? s 'eol) + "\n" + (new markup + (markup '&source-string) + (body s)))) + str) + (ignore)))) + ((in "\"=") + (let ((str (the-string))) + (cons str (ignore)))) + (else + (let ((c (the-failure))) + (if (eof-object? c) + '() + (error "source(xml)" "Unexpected character" c))))))) + (with-input-from-string s + (lambda () + (read/rp g (current-input-port)))))) + |