diff options
Diffstat (limited to 'src/guile')
| -rw-r--r-- | src/guile/skribilo/coloring/lisp.scm | 113 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/xml.scm | 119 | ||||
| -rw-r--r-- | src/guile/skribilo/engine/lout.scm | 11 | ||||
| -rw-r--r-- | src/guile/skribilo/evaluator.scm | 8 | ||||
| -rw-r--r-- | src/guile/skribilo/lib.scm | 36 | ||||
| -rw-r--r-- | src/guile/skribilo/module.scm | 15 | ||||
| -rw-r--r-- | src/guile/skribilo/skribe/api.scm | 10 | ||||
| -rw-r--r-- | src/guile/skribilo/source.scm | 23 | ||||
| -rw-r--r-- | src/guile/skribilo/types.scm | 6 |
9 files changed, 189 insertions, 152 deletions
diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm index 53cf670..ad02431 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,46 +1,46 @@ ;;;; -;;;; lisp.stk -- Lisp Family Fontification -;;;; +;;;; lisp.scm -- Lisp Family Fontification +;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; +;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by ;;;; the Free Software Foundation; either version 2 of the License, or ;;;; (at your option) any later version. -;;;; +;;;; ;;;; This program is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;;; GNU General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU General Public License ;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; +;;;; ;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Creation date: 16-Oct-2003 22:17 (eg) ;;;; Last file update: 28-Oct-2004 21:14 (eg) ;;;; -(require "lex-rt") ;; to avoid module problems +(define-module (skribilo coloring lisp) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (skribilo runtime) + :export (skribe scheme stklos bigloo lisp)) -(define-module (skribilo lisp) - :export (skribe scheme stklos bigloo lisp) - :import (skribe source)) -(include "lisp-lex.stk") ;; SILex generated - -(define *bracket-highlight* #f) -(define *class-highlight* #f) -(define *the-keys* #f) +(define *bracket-highlight* (make-fluid)) +(define *class-highlight* (make-fluid)) +(define *the-keys* (make-fluid)) -(define *lisp-keys* #f) -(define *scheme-keys* #f) -(define *skribe-keys* #f) -(define *stklos-keys* #f) -(define *lisp-keys* #f) +(define *lisp-keys* (make-fluid)) +(define *scheme-keys* (make-fluid)) +(define *skribe-keys* (make-fluid)) +(define *stklos-keys* (make-fluid)) +(define *lisp-keys* (make-fluid)) ;;; @@ -57,17 +57,17 @@ (define (lisp-family-fontifier s) - (let ((lex (lisp-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) + (let ((lisp-input (open-input-string s))) + (let loop ((token (read lisp-input)) (res '())) - (if (eq? token 'eof) + (if (eof-object? token) (reverse! res) - (Loop (lexer-next-token lex) + (loop (read lisp-input) (cons token res)))))) ;;;; ====================================================================== ;;;; -;;;; LISP +;;;; LISP ;;;; ;;;; ====================================================================== (define (lisp-extractor iport def tab) @@ -77,17 +77,17 @@ (lambda (exp) (match-case exp (((or defun defmacro) ?fun ?- . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) ((defvar ?var . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-lisp-keys) (unless *lisp-keys* (set! *lisp-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(setq if let let* letrec cond case else progn lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -95,9 +95,9 @@ *lisp-keys*) (define (lisp-fontifier s) - (fluid-let ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) @@ -109,7 +109,7 @@ ;;;; ====================================================================== ;;;; -;;;; SCHEME +;;;; SCHEME ;;;; ;;;; ====================================================================== (define (scheme-extractor iport def tab) @@ -130,7 +130,7 @@ (unless *scheme-keys* (set! *scheme-keys* (append ;; key - (map (lambda (x) (cons x '&source-keyword)) + (map (lambda (x) (cons x '&source-keyword)) '(set! if let let* letrec quote cond case else begin do lambda)) ;; define (map (lambda (x) (cons x '&source-define)) @@ -139,11 +139,11 @@ (define (scheme-fontifier s) - (fluid-let ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) + (with-fluids ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) (lisp-family-fontifier s))) - + (define scheme (new language @@ -153,7 +153,7 @@ ;;;; ====================================================================== ;;;; -;;;; STKLOS +;;;; STKLOS ;;;; ;;;; ====================================================================== (define (stklos-extractor iport def tab) @@ -164,11 +164,11 @@ (match-case exp (((or define define-generic define-method define-macro) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-module) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define (init-stklos-keys) @@ -192,9 +192,9 @@ (define (stklos-fontifier s) - (fluid-let ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -206,7 +206,7 @@ ;;;; ====================================================================== ;;;; -;;;; SKRIBE +;;;; SKRIBE ;;;; ;;;; ====================================================================== (define (skribe-extractor iport def tab) @@ -250,12 +250,12 @@ (map (lambda (x) (cons x '&source-define)) '(define-markup))))) *skribe-keys*) - + (define (skribe-fontifier s) - (fluid-let ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) + (with-fluids ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) (lisp-family-fontifier s))) @@ -267,7 +267,7 @@ ;;;; ====================================================================== ;;;; -;;;; BIGLOO +;;;; BIGLOO ;;;; ;;;; ====================================================================== (define (bigloo-extractor iport def tab) @@ -279,15 +279,14 @@ (((or define define-inline define-generic define-method define-macro define-expander) (?fun . ?-) . ?-) - (and (eq? def fun) exp)) + (and (eq? def fun) exp)) (((or define define-struct define-library) (and (? symbol?) ?var) . ?-) - (and (eq? var def) exp)) + (and (eq? var def) exp)) (else - #f))))) + #f))))) (define bigloo (new language (name "bigloo") (fontifier scheme-fontifier) (extractor bigloo-extractor))) - diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm index d71e98c..e3db36f 100644 --- a/src/guile/skribilo/coloring/xml.scm +++ b/src/guile/skribilo/coloring/xml.scm @@ -1,53 +1,82 @@ -;;;; -;;;; xml.stk -- XML Fontification stuff -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:33 (eg) -;;;; Last file update: 28-Dec-2003 17:33 (eg) -;;;; - - -;(require "lex-rt") ;; to avoid module problems - - -(define-module (skribilo xml) - :export (xml)) - -(use-modules (skribilo source)) - -(include "xml-lex.stk") ;; SILex generated - -(define (xml-fontifier s) - (let ((lex (xml-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (Loop (lexer-next-token lex) - (cons token res)))))) +;;; xml.scm -- XML syntax highlighting. +;;; +;;; Copyright 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +(define-module (skribilo coloring xml) + :export (xml) + :use-module (skribilo source) + :use-module (skribilo lib) + :use-module (ice-9 rdelim) + :use-module (ice-9 regex)) + + +(define %comment-rx (make-regexp "<!--(.|\\n)*-->" regexp/extended)) + +(define (xml-fontifier str) + (let loop ((start 0) + (result '())) + (if (>= start (string-length str)) + (reverse! result) + (case (string-ref str start) + ((#\") + (let ((end (string-index str start #\"))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML string" + (string-drop str start)) + (loop end + (cons (new markup + (markup '&source-string) + (body (substring str start end))) + result))))) + ((#\<) + (let ((end (string-index str #\> start))) + (if (not end) + (skribe-error 'xml-fontifier + "unterminated XML tag" + (string-drop str start)) + (let ((comment? (regexp-exec %comment-rx + (substring str start end)))) + (loop end + (cons (if comment? + (new markup + (markup '&source-comment) + (body (substring str start end))) + (new markup + (markup '&source-module) + (body (substring str start end)))) + result)))))) + + (else + (loop (+ 1 start) + (if (or (null? result) + (not (string? (car result)))) + (cons (string (string-ref str start)) result) + (cons (string-append (car result) + (string (string-ref str start))) + (cdr result))))))))) + + (define xml (new language (name "xml") (fontifier xml-fontifier) (extractor #f))) +;;; xml.scm ends here diff --git a/src/guile/skribilo/engine/lout.scm b/src/guile/skribilo/engine/lout.scm index b466ac1..36df9f9 100644 --- a/src/guile/skribilo/engine/lout.scm +++ b/src/guile/skribilo/engine/lout.scm @@ -384,10 +384,10 @@ " @PageMark @Tag\n" "}\n\n" - "# @SkribeLeaders is used in `toc'\n" + "# @SkribiloLeaders is used in `toc'\n" "# (this is mostly copied from the expert's guide)\n" - "def @SkribeLeaders { " - ,leader " |" ,leader-space " @SkribeLeaders }\n\n")))) + "def @SkribiloLeaders { " + ,leader " |" ,leader-space " @SkribiloLeaders }\n\n")))) (define (lout-make-doc-cover-sheet doc engine) ;; Create a cover sheet for node `doc' which is a doc-style Lout document. @@ -397,7 +397,8 @@ (author (markup-option doc :author)) (date-line (engine-custom engine 'date-line)) (cover-sheet? (engine-custom engine 'cover-sheet?)) - (multi-column? (> 1 (engine-custom engine 'column-number)))) + (multi-column? (> (engine-custom engine 'column-number) 1))) + (if multi-column? ;; In single-column document, `@FullWidth' yields a blank page. (display "\n@FullWidth {")) @@ -1205,7 +1206,7 @@ (entry-proc node engine) (display " &1rt @OneCol { ") - (printf " @SkribeLeaders & @PageOf { ~a }" + (printf " @SkribiloLeaders & @PageOf { ~a }" (lout-tagify (markup-ident node))) (display " &0io } }") diff --git a/src/guile/skribilo/evaluator.scm b/src/guile/skribilo/evaluator.scm index 974d72a..def3280 100644 --- a/src/guile/skribilo/evaluator.scm +++ b/src/guile/skribilo/evaluator.scm @@ -175,16 +175,14 @@ path)) (when (> *skribe-verbose* 0) (format (current-error-port) " [including file: ~S]\n" path)) + (with-input-from-file path (lambda () (let Loop ((exp (%default-reader (current-input-port))) (res '())) - (format (current-error-port) "exp=~a~%" exp) (if (eof-object? exp) - (begin - (format (current-error-port) "include: eof reached~%") - (if (and (pair? res) (null? (cdr res))) + (if (and (pair? res) (null? (cdr res))) (car res) - (reverse! res))) + (reverse! res)) (Loop (%default-reader (current-input-port)) (cons (%evaluate exp) res)))))))) diff --git a/src/guile/skribilo/lib.scm b/src/guile/skribilo/lib.scm index d916db4..2961fc6 100644 --- a/src/guile/skribilo/lib.scm +++ b/src/guile/skribilo/lib.scm @@ -1,5 +1,5 @@ ;;; -;;; lib.stk -- Utilities +;;; lib.scm -- Utilities ;;; ;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;; @@ -18,11 +18,6 @@ ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;; USA. -;;; -;;; Author: Erick Gallesio [eg@essi.fr] -;;; Creation date: 11-Aug-2003 20:29 (eg) -;;; Last file update: 27-Oct-2004 12:41 (eg) -;;; (read-set! keywords 'prefix) @@ -59,7 +54,9 @@ hashtable->list skribe-read - find-runtime-type) + find-runtime-type + + date) :export-syntax (new define-markup define-simple-markup define-simple-container define-processor-markup @@ -73,6 +70,8 @@ :use-module (skribilo vars) :use-module (srfi srfi-1) + :use-module ((srfi srfi-19) :renamer (symbol-prefix-proc 's19:)) ;; date + :use-module (oop goops) :use-module (ice-9 optargs)) @@ -81,11 +80,20 @@ ;;; ;;; NEW ;;; + +(define %types-module (resolve-module '(skribilo types))) + (define-macro (new class . parameters) - `(make ,(string->symbol (format #f "<~a>" class)) - ,@(apply append (map (lambda (x) - `(,(symbol->keyword (car x)) ,(cadr x))) - parameters)))) + ;; Thanks to the trick below, modules don't need to import `(oop goops)' + ;; and `(skribilo types)' in order to make use of `new'. + (let* ((class-name (symbol-append '< class '>)) + (actual-class (module-ref %types-module class-name))) + `(let ((make ,make) + (,class-name ,actual-class)) + (make ,class-name + ,@(apply append (map (lambda (x) + `(,(symbol->keyword (car x)) ,(cadr x))) + parameters)))))) ;;; ;;; DEFINE-MARKUP @@ -387,3 +395,9 @@ (define-macro (when condition . exprs) `(if ,condition (begin ,@exprs))) + +(define (date) + (s19:date->string (s19:current-date) "~c")) + + +;;; lib.scm ends here diff --git a/src/guile/skribilo/module.scm b/src/guile/skribilo/module.scm index 1a8f622..bb0c5ad 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -42,7 +42,6 @@ '((srfi srfi-1) ;; lists (srfi srfi-13) ;; strings ;(srfi srfi-19) ;; date and time - (oop goops) ;; `make' (ice-9 optargs) ;; `define*' (ice-9 and-let-star) ;; `and-let*' (ice-9 receive) ;; `receive' @@ -60,9 +59,13 @@ (skribilo output) (skribilo evaluator) (skribilo color) - (skribilo debug))) + (skribilo debug) + (skribilo source) ;; `source-read-lines', `source-fontify', etc. + (skribilo coloring lisp) ;; `skribe', `scheme', `lisp' + (skribilo coloring xml) ;; `xml' + )) -(define *skribe-core-modules* +(define %skribe-core-modules '("utils" "api" "bib" "index" "param" "sui")) (define-macro (define-skribe-module name . options) @@ -81,7 +84,7 @@ ,(string->symbol mod)))) (and (not (equal? m name)) m))) - *skribe-core-modules*))))) + %skribe-core-modules))))) ;; Make it available to the top-level module. @@ -106,7 +109,7 @@ execution of Skribilo/Skribe code." (map (lambda (mod) `(skribilo skribe ,(string->symbol mod))) - *skribe-core-modules*))) + %skribe-core-modules))) (set-module-name! the-module '(skribilo-user)) the-module)) @@ -152,7 +155,7 @@ hierarchy and in @code{(run-time-module)}." (module-use! (run-time-module) (resolve-module `(skribilo skribe ,(string->symbol mod))))) - *skribe-core-modules*)) + %skribe-core-modules)) ;;; module.scm ends here diff --git a/src/guile/skribilo/skribe/api.scm b/src/guile/skribilo/skribe/api.scm index d66b3b4..34528ac 100644 --- a/src/guile/skribilo/skribe/api.scm +++ b/src/guile/skribilo/skribe/api.scm @@ -274,8 +274,8 @@ (new unresolved (proc (lambda (n e env) (resolve-counter n env - 'footnote #t))))) - ,@(the-options opts :ident :class))))) + 'footnote #t)))))) + ,@(the-options opts :ident :class)))) (body (the-body opts)))) ;*---------------------------------------------------------------------*/ @@ -466,9 +466,9 @@ "start line > stop line" (format #f "~a/~a" start stop))) ((and language (not (language? language))) - (skribe-error 'source "Illegal language" language)) + (skribe-error 'source "illegal language" language)) ((and tab (not (integer? tab))) - (skribe-error 'source "Illegal tab" tab)) + (skribe-error 'source "illegal tab" tab)) (file (let ((s (if (not definition) (source-read-lines file start stop tab) @@ -489,7 +489,7 @@ ;*---------------------------------------------------------------------*/ (define-markup (language #!key name (fontifier #f) (extractor #f)) (if (not (string? name)) - (skribe-type-error 'language "Illegal name, " name "string") + (skribe-type-error 'language "illegal name" name "string") (new language (name name) (fontifier fontifier) diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index c682687..e03deae 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,7 +1,8 @@ ;;;; -;;;; source.stk -- Skibe SOURCE implementation stuff +;;;; source.scm -- Highlighting source files. ;;;; ;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -19,24 +20,16 @@ ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. ;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 3-Sep-2003 12:22 (eg) -;;;; Last file update: 27-Oct-2004 20:09 (eg) -;;;; (define-module (skribilo source) :export (source-read-lines source-read-definition source-fontify) - :use-module (skribilo vars)) - - -;; Temporary solution -(define (language-extractor lang) - (slot-ref lang 'extractor)) + :use-module (skribilo types) + :use-module (skribilo vars) + :use-module (skribilo lib) + :use-module (ice-9 rdelim)) -(define (language-fontifier lang) - (slot-ref lang 'fontifier)) ;*---------------------------------------------------------------------*/ @@ -172,7 +165,7 @@ (if (= i j) (reverse! r) (reverse! (cons (substring str j i) r)))) - ((char=? (string-ref str i) #\Newline) + ((char=? (string-ref str i) #\newline) (loop (+ i 1) (+ i 1) (if (= i j) @@ -180,7 +173,7 @@ (cons* 'eol (substring str j i) r)))) ((and (char=? (string-ref str i) #\cr) (< (+ i 1) l) - (char=? (string-ref str (+ i 1)) #\Newline)) + (char=? (string-ref str (+ i 1)) #\newline)) (loop (+ i 2) (+ i 2) (if (= i j) diff --git a/src/guile/skribilo/types.scm b/src/guile/skribilo/types.scm index c6188b6..ac1edc4 100644 --- a/src/guile/skribilo/types.scm +++ b/src/guile/skribilo/types.scm @@ -43,7 +43,7 @@ container-ident container-body <document> document? document-ident document-body document-options document-end - <language> language? + <language> language? language-extractor language-fontifier <location> location? ast-location location-file location-line location-pos @@ -283,8 +283,8 @@ ;;; ====================================================================== (define-class <language> () (name :init-keyword :name :init-value #f :getter langage-name) - (fontifier :init-keyword :fontifier :init-value #f :getter langage-fontifier) - (extractor :init-keyword :extractor :init-value #f :getter langage-extractor)) + (fontifier :init-keyword :fontifier :init-value #f :getter language-fontifier) + (extractor :init-keyword :extractor :init-value #f :getter language-extractor)) (define (language? obj) (is-a? obj <language>)) |