From 2ae08bbb4f7906cb61648ab577bb77acfb6523a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Wed, 4 Jul 2007 20:35:23 +0000 Subject: Renamed the `coloring' module tree to `source' for consistency. git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-134 --- src/guile/skribilo/Makefile.am | 2 +- src/guile/skribilo/coloring/Makefile.am | 31 - src/guile/skribilo/coloring/c-lex.l | 73 -- src/guile/skribilo/coloring/c-lex.scm | 1257 --------------------------- src/guile/skribilo/coloring/c.scm | 86 -- src/guile/skribilo/coloring/lisp-lex.l | 86 -- src/guile/skribilo/coloring/lisp-lex.scm | 1257 --------------------------- src/guile/skribilo/coloring/lisp.scm | 292 ------- src/guile/skribilo/coloring/parameters.scm | 33 - src/guile/skribilo/coloring/xml-lex.l | 64 -- src/guile/skribilo/coloring/xml-lex.scm | 1229 --------------------------- src/guile/skribilo/coloring/xml.scm | 80 -- src/guile/skribilo/module.scm | 6 +- src/guile/skribilo/source/Makefile.am | 31 + src/guile/skribilo/source/c-lex.l | 73 ++ src/guile/skribilo/source/c-lex.scm | 1257 +++++++++++++++++++++++++++ src/guile/skribilo/source/c.scm | 86 ++ src/guile/skribilo/source/lisp-lex.l | 86 ++ src/guile/skribilo/source/lisp-lex.scm | 1258 ++++++++++++++++++++++++++++ src/guile/skribilo/source/lisp.scm | 292 +++++++ src/guile/skribilo/source/parameters.scm | 33 + src/guile/skribilo/source/xml-lex.l | 64 ++ src/guile/skribilo/source/xml-lex.scm | 1230 +++++++++++++++++++++++++++ src/guile/skribilo/source/xml.scm | 80 ++ 24 files changed, 4494 insertions(+), 4492 deletions(-) delete mode 100644 src/guile/skribilo/coloring/Makefile.am delete mode 100644 src/guile/skribilo/coloring/c-lex.l delete mode 100644 src/guile/skribilo/coloring/c-lex.scm delete mode 100644 src/guile/skribilo/coloring/c.scm delete mode 100644 src/guile/skribilo/coloring/lisp-lex.l delete mode 100644 src/guile/skribilo/coloring/lisp-lex.scm delete mode 100644 src/guile/skribilo/coloring/lisp.scm delete mode 100644 src/guile/skribilo/coloring/parameters.scm delete mode 100644 src/guile/skribilo/coloring/xml-lex.l delete mode 100644 src/guile/skribilo/coloring/xml-lex.scm delete mode 100644 src/guile/skribilo/coloring/xml.scm create mode 100644 src/guile/skribilo/source/Makefile.am create mode 100644 src/guile/skribilo/source/c-lex.l create mode 100644 src/guile/skribilo/source/c-lex.scm create mode 100644 src/guile/skribilo/source/c.scm create mode 100644 src/guile/skribilo/source/lisp-lex.l create mode 100644 src/guile/skribilo/source/lisp-lex.scm create mode 100644 src/guile/skribilo/source/lisp.scm create mode 100644 src/guile/skribilo/source/parameters.scm create mode 100644 src/guile/skribilo/source/xml-lex.l create mode 100644 src/guile/skribilo/source/xml-lex.scm create mode 100644 src/guile/skribilo/source/xml.scm (limited to 'src') diff --git a/src/guile/skribilo/Makefile.am b/src/guile/skribilo/Makefile.am index f25b08e..01e9153 100644 --- a/src/guile/skribilo/Makefile.am +++ b/src/guile/skribilo/Makefile.am @@ -8,6 +8,6 @@ dist_guilemodule_DATA = biblio.scm color.scm config.scm \ writer.scm ast.scm location.scm \ condition.scm -SUBDIRS = utils reader engine package coloring biblio +SUBDIRS = utils reader engine package source biblio include $(top_srcdir)/guile-lint.am diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am deleted file mode 100644 index 5073575..0000000 --- a/src/guile/skribilo/coloring/Makefile.am +++ /dev/null @@ -1,31 +0,0 @@ -guilemoduledir = $(GUILE_SITE)/skribilo/coloring -dist_guilemodule_DATA = parameters.scm c.scm lisp.scm xml.scm \ - lisp-lex.scm xml-lex.scm c-lex.scm - - -EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l - -# Building the lexers with SILex. You must previously run -# `tla build-config ./arch-config' for this to run. -# -# Note: Those files should normally be part of the distribution, making -# this rule useless to the user. -.l.scm: - $(GUILE) -L $(top_srcdir)/src/guile/silex \ - -c '(load-from-path "lex.scm") (lex "$^" "$@")' && \ - mv "$@" "$@.tmp" && \ - echo '(define-module (skribilo coloring $(^:%.l=%))' > "$@" && \ - echo ' :use-module (skribilo lib)' >> "$@" && \ - echo ' :use-module (skribilo coloring parameters)' \ - >> "$@" && \ - echo ' :use-module (srfi srfi-1)' >> "$@" && \ - echo ' :export (lexer-init lexer' >> "$@" && \ - echo ' lexer-get-func-column' >> "$@" && \ - echo ' lexer-get-func-offset' >> "$@" && \ - echo ' lexer-get-line lexer-getc' >> "$@" && \ - echo ' lexer-ungetc))' >> "$@" && \ - cat "$@.tmp" >> "$@" && \ - rm "$@.tmp" - - -include $(top_srcdir)/guile-lint.am diff --git a/src/guile/skribilo/coloring/c-lex.l b/src/guile/skribilo/coloring/c-lex.l deleted file mode 100644 index b28a91a..0000000 --- a/src/guile/skribilo/coloring/c-lex.l +++ /dev/null @@ -1,73 +0,0 @@ -;;; c-lex.l -- C fontifier for Skribilo. -;;; -;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI -;;; Copyright 2007 Ludovic Courtès -;;; -;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;; USA. - -space [ \n\9] -letter [_a-zA-Z] -alphanum [_a-zA-Z0-9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -;; Comments -;; FIXME: We shouldn't exclude `/' from comments but we do so to match the -;; shortest multi-line comment. -/\*(\n|[^/])*\*/ (let* ((not-line (char-set-complement (char-set #\newline))) - (lines (string-tokenize yytext not-line))) - (reverse! - (pair-fold (lambda (line* result) - (let* ((line (car line*)) - (last? (null? (cdr line*))) - (markup - (new markup - (markup '&source-line-comment) - (body line)))) - (if last? - (cons markup result) - (cons* (string #\newline) - markup result)))) - '() - lines))) - -//.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Identifiers (only letters since we are interested in keywords only) -[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) - (tmp (memq ident (*the-keys*)))) - (if tmp - (new markup - (markup '&source-module) - (body yytext)) - yytext)) - -;; Regular text (excluding `/' and `*') -[^\"a-zA-Z/*]+ (begin yytext) - -;; `/' and `*' alone. -/[^\*] (begin yytext) -\*[^/] (begin yytext) - - -<> 'eof -<> (skribe-error 'c-fontifier "Parse error" yytext) diff --git a/src/guile/skribilo/coloring/c-lex.scm b/src/guile/skribilo/coloring/c-lex.scm deleted file mode 100644 index 162c0c2..0000000 --- a/src/guile/skribilo/coloring/c-lex.scm +++ /dev/null @@ -1,1257 +0,0 @@ -(define-module (skribilo coloring c-lex) - :use-module (skribilo lib) - :use-module (skribilo coloring parameters) - :use-module (srfi srfi-1) - :export (lexer-init lexer - lexer-get-func-column - lexer-get-func-offset - lexer-get-line lexer-getc - lexer-ungetc)) -; *** This file starts with a copy of the file multilex.scm *** -; SILex - Scheme Implementation of Lex -; Copyright (C) 2001 Danny Dube' -; -; 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. - -; -; Gestion des Input Systems -; Fonctions a utiliser par l'usager: -; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -; - -; Taille initiale par defaut du buffer d'entree -(define lexer-init-buffer-len 1024) - -; Numero du caractere newline -(define lexer-integer-newline (char->integer #\newline)) - -; Constructeur d'IS brut -(define lexer-raw-IS-maker - (lambda (buffer read-ptr input-f counters) - (let ((input-f input-f) ; Entree reelle - (buffer buffer) ; Buffer - (buflen (string-length buffer)) - (read-ptr read-ptr) - (start-ptr 1) ; Marque de debut de lexeme - (start-line 1) - (start-column 1) - (start-offset 0) - (end-ptr 1) ; Marque de fin de lexeme - (point-ptr 1) ; Le point - (user-ptr 1) ; Marque de l'usager - (user-line 1) - (user-column 1) - (user-offset 0) - (user-up-to-date? #t)) ; Concerne la colonne seul. - (letrec - ((start-go-to-end-none ; Fonctions de depl. des marques - (lambda () - (set! start-ptr end-ptr))) - (start-go-to-end-line - (lambda () - (let loop ((ptr start-ptr) (line start-line)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1)) - (loop (+ ptr 1) line)))))) - (start-go-to-end-all - (lambda () - (set! start-offset (+ start-offset (- end-ptr start-ptr))) - (let loop ((ptr start-ptr) - (line start-line) - (column start-column)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1) 1) - (loop (+ ptr 1) line (+ column 1))))))) - (start-go-to-user-none - (lambda () - (set! start-ptr user-ptr))) - (start-go-to-user-line - (lambda () - (set! start-ptr user-ptr) - (set! start-line user-line))) - (start-go-to-user-all - (lambda () - (set! start-line user-line) - (set! start-offset user-offset) - (if user-up-to-date? - (begin - (set! start-ptr user-ptr) - (set! start-column user-column)) - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! start-ptr ptr) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1)))))))) - (end-go-to-point - (lambda () - (set! end-ptr point-ptr))) - (point-go-to-start - (lambda () - (set! point-ptr start-ptr))) - (user-go-to-start-none - (lambda () - (set! user-ptr start-ptr))) - (user-go-to-start-line - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line))) - (user-go-to-start-all - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line) - (set! user-column start-column) - (set! user-offset start-offset) - (set! user-up-to-date? #t))) - (init-lexeme-none ; Debute un nouveau lexeme - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-none)) - (point-go-to-start))) - (init-lexeme-line - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-line)) - (point-go-to-start))) - (init-lexeme-all - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-all)) - (point-go-to-start))) - (get-start-line ; Obtention des stats du debut du lxm - (lambda () - start-line)) - (get-start-column - (lambda () - start-column)) - (get-start-offset - (lambda () - start-offset)) - (peek-left-context ; Obtention de caracteres (#f si EOF) - (lambda () - (char->integer (string-ref buffer (- start-ptr 1))))) - (peek-char - (lambda () - (if (< point-ptr read-ptr) - (char->integer (string-ref buffer point-ptr)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (read-char - (lambda () - (if (< point-ptr read-ptr) - (let ((c (string-ref buffer point-ptr))) - (set! point-ptr (+ point-ptr 1)) - (char->integer c)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (set! point-ptr read-ptr) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (get-start-end-text ; Obtention du lexeme - (lambda () - (substring buffer start-ptr end-ptr))) - (get-user-line-line ; Fonctions pour l'usager - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - user-line)) - (get-user-line-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-line)) - (get-user-column-all - (lambda () - (cond ((< user-ptr start-ptr) - (user-go-to-start-all) - user-column) - (user-up-to-date? - user-column) - (else - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! user-column column) - (set! user-up-to-date? #t) - column) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1))))))))) - (get-user-offset-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-offset)) - (user-getc-none - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-none)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-line - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-ungetc-none - (lambda () - (if (> user-ptr start-ptr) - (set! user-ptr (- user-ptr 1))))) - (user-ungetc-line - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (set! user-line (- user-line 1)))))))) - (user-ungetc-all - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (begin - (set! user-line (- user-line 1)) - (set! user-up-to-date? #f)) - (set! user-column (- user-column 1))) - (set! user-offset (- user-offset 1))))))) - (reorganize-buffer ; Decaler ou agrandir le buffer - (lambda () - (if (< (* 2 start-ptr) buflen) - (let* ((newlen (* 2 buflen)) - (newbuf (make-string newlen)) - (delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! newbuf - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! buffer newbuf) - (set! buflen newlen) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))) - (let ((delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! buffer - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))))))) - (list (cons 'start-go-to-end - (cond ((eq? counters 'none) start-go-to-end-none) - ((eq? counters 'line) start-go-to-end-line) - ((eq? counters 'all ) start-go-to-end-all))) - (cons 'end-go-to-point - end-go-to-point) - (cons 'init-lexeme - (cond ((eq? counters 'none) init-lexeme-none) - ((eq? counters 'line) init-lexeme-line) - ((eq? counters 'all ) init-lexeme-all))) - (cons 'get-start-line - get-start-line) - (cons 'get-start-column - get-start-column) - (cons 'get-start-offset - get-start-offset) - (cons 'peek-left-context - peek-left-context) - (cons 'peek-char - peek-char) - (cons 'read-char - read-char) - (cons 'get-start-end-text - get-start-end-text) - (cons 'get-user-line - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) get-user-line-line) - ((eq? counters 'all ) get-user-line-all))) - (cons 'get-user-column - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-column-all))) - (cons 'get-user-offset - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-offset-all))) - (cons 'user-getc - (cond ((eq? counters 'none) user-getc-none) - ((eq? counters 'line) user-getc-line) - ((eq? counters 'all ) user-getc-all))) - (cons 'user-ungetc - (cond ((eq? counters 'none) user-ungetc-none) - ((eq? counters 'line) user-ungetc-line) - ((eq? counters 'all ) user-ungetc-all)))))))) - -; Construit un Input System -; Le premier parametre doit etre parmi "port", "procedure" ou "string" -; Prend un parametre facultatif qui doit etre parmi -; "none", "line" ou "all" -(define lexer-make-IS - (lambda (input-type input . largs) - (let ((counters-type (cond ((null? largs) - 'line) - ((memq (car largs) '(none line all)) - (car largs)) - (else - 'line)))) - (cond ((and (eq? input-type 'port) (input-port? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f (lambda () (read-char input)))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'procedure) (procedure? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f input)) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'string) (string? input)) - (let* ((buffer (string-append (string #\newline) input)) - (read-ptr (string-length buffer)) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - (else - (let* ((buffer (string #\newline)) - (read-ptr 1) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) - -; Les fonctions: -; lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -(define lexer-get-func-getc - (lambda (IS) (cdr (assq 'user-getc IS)))) -(define lexer-get-func-ungetc - (lambda (IS) (cdr (assq 'user-ungetc IS)))) -(define lexer-get-func-line - (lambda (IS) (cdr (assq 'get-user-line IS)))) -(define lexer-get-func-column - (lambda (IS) (cdr (assq 'get-user-column IS)))) -(define lexer-get-func-offset - (lambda (IS) (cdr (assq 'get-user-offset IS)))) - -; -; Gestion des lexers -; - -; Fabrication de lexer a partir d'arbres de decision -(define lexer-make-tree-lexer - (lambda (tables IS) - (letrec - (; Contenu de la table - (counters-type (vector-ref tables 0)) - (<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-actions (vector-ref tables 3)) - (table-nl-start (vector-ref tables 5)) - (table-no-nl-start (vector-ref tables 6)) - (trees-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8)) - - ; Contenu du IS - (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) - (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) - (IS-init-lexeme (cdr (assq 'init-lexeme IS))) - (IS-get-start-line (cdr (assq 'get-start-line IS))) - (IS-get-start-column (cdr (assq 'get-start-column IS))) - (IS-get-start-offset (cdr (assq 'get-start-offset IS))) - (IS-peek-left-context (cdr (assq 'peek-left-context IS))) - (IS-peek-char (cdr (assq 'peek-char IS))) - (IS-read-char (cdr (assq 'read-char IS))) - (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) - (IS-get-user-line (cdr (assq 'get-user-line IS))) - (IS-get-user-column (cdr (assq 'get-user-column IS))) - (IS-get-user-offset (cdr (assq 'get-user-offset IS))) - (IS-user-getc (cdr (assq 'user-getc IS))) - (IS-user-ungetc (cdr (assq 'user-ungetc IS))) - - ; Resultats - (<>-action #f) - (<>-action #f) - (rules-actions #f) - (states #f) - (final-lexer #f) - - ; Gestion des hooks - (hook-list '()) - (add-hook - (lambda (thunk) - (set! hook-list (cons thunk hook-list)))) - (apply-hooks - (lambda () - (let loop ((l hook-list)) - (if (pair? l) - (begin - ((car l)) - (loop (cdr l))))))) - - ; Preparation des actions - (set-action-statics - (lambda (pre-action) - (pre-action final-lexer IS-user-getc IS-user-ungetc))) - (prepare-special-action-none - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda () - (action ""))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-line - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline) - (action "" yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-all - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (action "" yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-special-action-none pre-action)) - ((eq? counters-type 'line) - (prepare-special-action-line pre-action)) - ((eq? counters-type 'all) - (prepare-special-action-all pre-action))))) - (prepare-action-yytext-none - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-line - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-all - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline yycolumn yyoffset)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-yytext-all pre-action))))) - (prepare-action-no-yytext-none - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (start-go-to-end) - (action))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-line - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (start-go-to-end) - (action yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-all - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (start-go-to-end) - (action yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-no-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-no-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-no-yytext-all pre-action))))) - - ; Fabrique les fonctions de dispatch - (prepare-dispatch-err - (lambda (leaf) - (lambda (c) - #f))) - (prepare-dispatch-number - (lambda (leaf) - (let ((state-function #f)) - (let ((result - (lambda (c) - state-function)) - (hook - (lambda () - (set! state-function (vector-ref states leaf))))) - (add-hook hook) - result)))) - (prepare-dispatch-leaf - (lambda (leaf) - (if (eq? leaf 'err) - (prepare-dispatch-err leaf) - (prepare-dispatch-number leaf)))) - (prepare-dispatch-< - (lambda (tree) - (let ((left-tree (list-ref tree 1)) - (right-tree (list-ref tree 2))) - (let ((bound (list-ref tree 0)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (< c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-= - (lambda (tree) - (let ((left-tree (list-ref tree 2)) - (right-tree (list-ref tree 3))) - (let ((bound (list-ref tree 1)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (= c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-tree - (lambda (tree) - (cond ((not (pair? tree)) - (prepare-dispatch-leaf tree)) - ((eq? (car tree) '=) - (prepare-dispatch-= tree)) - (else - (prepare-dispatch-< tree))))) - (prepare-dispatch - (lambda (tree) - (let ((dicho-func (prepare-dispatch-tree tree))) - (lambda (c) - (and c (dicho-func c)))))) - - ; Fabrique les fonctions de transition (read & go) et (abort) - (prepare-read-n-go - (lambda (tree) - (let ((dispatch-func (prepare-dispatch tree)) - (read-char IS-read-char)) - (lambda () - (dispatch-func (read-char)))))) - (prepare-abort - (lambda (tree) - (lambda () - #f))) - (prepare-transition - (lambda (tree) - (if (eq? tree 'err) - (prepare-abort tree) - (prepare-read-n-go tree)))) - - ; Fabrique les fonctions d'etats ([set-end] & trans) - (prepare-state-no-acc - (lambda (s r1 r2) - (let ((trans-func (prepare-transition (vector-ref trees-v s)))) - (lambda (action) - (let ((next-state (trans-func))) - (if next-state - (next-state action) - action)))))) - (prepare-state-yes-no - (lambda (s r1 r2) - (let ((peek-char IS-peek-char) - (end-go-to-point IS-end-go-to-point) - (new-action1 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - (begin - (end-go-to-point) - new-action1) - action)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state-diff-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (peek-char IS-peek-char) - (new-action1 #f) - (new-action2 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (end-go-to-point) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - new-action1 - new-action2)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1)) - (set! new-action2 (vector-ref rules-actions r2))))) - (add-hook hook) - result)))) - (prepare-state-same-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (trans-func (prepare-transition (vector-ref trees-v s))) - (new-action #f)) - (let ((result - (lambda (action) - (end-go-to-point) - (let ((next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state - (lambda (s) - (let* ((acc (vector-ref acc-v s)) - (r1 (car acc)) - (r2 (cdr acc))) - (cond ((not r1) (prepare-state-no-acc s r1 r2)) - ((not r2) (prepare-state-yes-no s r1 r2)) - ((< r1 r2) (prepare-state-diff-acc s r1 r2)) - (else (prepare-state-same-acc s r1 r2)))))) - - ; Fabrique la fonction de lancement du lexage a l'etat de depart - (prepare-start-same - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (start-state #f) - (error-action #f)) - (let ((result - (lambda () - (if (not (peek-char)) - eof-action - (start-state error-action)))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state (vector-ref states s1)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start-diff - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (peek-left-context IS-peek-left-context) - (start-state1 #f) - (start-state2 #f) - (error-action #f)) - (let ((result - (lambda () - (cond ((not (peek-char)) - eof-action) - ((= (peek-left-context) lexer-integer-newline) - (start-state1 error-action)) - (else - (start-state2 error-action))))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state1 (vector-ref states s1)) - (set! start-state2 (vector-ref states s2)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start - (lambda () - (let ((s1 table-nl-start) - (s2 table-no-nl-start)) - (if (= s1 s2) - (prepare-start-same s1 s2) - (prepare-start-diff s1 s2))))) - - ; Fabrique la fonction principale - (prepare-lexer-none - (lambda () - (let ((init-lexeme IS-init-lexeme) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - ((start-func)))))) - (prepare-lexer-line - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line))) - ((start-func) yyline)))))) - (prepare-lexer-all - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (get-start-column IS-get-start-column) - (get-start-offset IS-get-start-offset) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line)) - (yycolumn (get-start-column)) - (yyoffset (get-start-offset))) - ((start-func) yyline yycolumn yyoffset)))))) - (prepare-lexer - (lambda () - (cond ((eq? counters-type 'none) (prepare-lexer-none)) - ((eq? counters-type 'line) (prepare-lexer-line)) - ((eq? counters-type 'all) (prepare-lexer-all)))))) - - ; Calculer la valeur de <>-action et de <>-action - (set! <>-action (prepare-special-action <>-pre-action)) - (set! <>-action (prepare-special-action <>-pre-action)) - - ; Calculer la valeur de rules-actions - (let* ((len (quotient (vector-length rules-pre-actions) 2)) - (v (make-vector len))) - (let loop ((r (- len 1))) - (if (< r 0) - (set! rules-actions v) - (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) - (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) - (action (if yytext? - (prepare-action-yytext pre-action) - (prepare-action-no-yytext pre-action)))) - (vector-set! v r action) - (loop (- r 1)))))) - - ; Calculer la valeur de states - (let* ((len (vector-length trees-v)) - (v (make-vector len))) - (let loop ((s (- len 1))) - (if (< s 0) - (set! states v) - (begin - (vector-set! v s (prepare-state s)) - (loop (- s 1)))))) - - ; Calculer la valeur de final-lexer - (set! final-lexer (prepare-lexer)) - - ; Executer les hooks - (apply-hooks) - - ; Resultat - final-lexer))) - -; Fabrication de lexer a partir de listes de caracteres taggees -(define lexer-make-char-lexer - (let* ((char->class - (lambda (c) - (let ((n (char->integer c))) - (list (cons n n))))) - (merge-sort - (lambda (l combine zero-elt) - (if (null? l) - zero-elt - (let loop1 ((l l)) - (if (null? (cdr l)) - (car l) - (loop1 - (let loop2 ((l l)) - (cond ((null? l) - l) - ((null? (cdr l)) - l) - (else - (cons (combine (car l) (cadr l)) - (loop2 (cddr l)))))))))))) - (finite-class-union - (lambda (c1 c2) - (let loop ((c1 c1) (c2 c2) (u '())) - (if (null? c1) - (if (null? c2) - (reverse u) - (loop c1 (cdr c2) (cons (car c2) u))) - (if (null? c2) - (loop (cdr c1) c2 (cons (car c1) u)) - (let* ((r1 (car c1)) - (r2 (car c2)) - (r1start (car r1)) - (r1end (cdr r1)) - (r2start (car r2)) - (r2end (cdr r2))) - (if (<= r1start r2start) - (cond ((< (+ r1end 1) r2start) - (loop (cdr c1) c2 (cons r1 u))) - ((<= r1end r2end) - (loop (cdr c1) - (cons (cons r1start r2end) (cdr c2)) - u)) - (else - (loop c1 (cdr c2) u))) - (cond ((> r1start (+ r2end 1)) - (loop c1 (cdr c2) (cons r2 u))) - ((>= r1end r2end) - (loop (cons (cons r2start r1end) (cdr c1)) - (cdr c2) - u)) - (else - (loop (cdr c1) c2 u)))))))))) - (char-list->class - (lambda (cl) - (let ((classes (map char->class cl))) - (merge-sort classes finite-class-union '())))) - (class-< - (lambda (b1 b2) - (cond ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - (else (< b1 b2))))) - (finite-class-compl - (lambda (c) - (let loop ((c c) (start 'inf-)) - (if (null? c) - (list (cons start 'inf+)) - (let* ((r (car c)) - (rstart (car r)) - (rend (cdr r))) - (if (class-< start rstart) - (cons (cons start (- rstart 1)) - (loop c rstart)) - (loop (cdr c) (+ rend 1)))))))) - (tagged-chars->class - (lambda (tcl) - (let* ((inverse? (car tcl)) - (cl (cdr tcl)) - (class-tmp (char-list->class cl))) - (if inverse? (finite-class-compl class-tmp) class-tmp)))) - (charc->arc - (lambda (charc) - (let* ((tcl (car charc)) - (dest (cdr charc)) - (class (tagged-chars->class tcl))) - (cons class dest)))) - (arc->sharcs - (lambda (arc) - (let* ((range-l (car arc)) - (dest (cdr arc)) - (op (lambda (range) (cons range dest)))) - (map op range-l)))) - (class-<= - (lambda (b1 b2) - (cond ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - (else (<= b1 b2))))) - (sharc-<= - (lambda (sharc1 sharc2) - (class-<= (caar sharc1) (caar sharc2)))) - (merge-sharcs - (lambda (l1 l2) - (let loop ((l1 l1) (l2 l2)) - (cond ((null? l1) - l2) - ((null? l2) - l1) - (else - (let ((sharc1 (car l1)) - (sharc2 (car l2))) - (if (sharc-<= sharc1 sharc2) - (cons sharc1 (loop (cdr l1) l2)) - (cons sharc2 (loop l1 (cdr l2)))))))))) - (class-= eqv?) - (fill-error - (lambda (sharcs) - (let loop ((sharcs sharcs) (start 'inf-)) - (cond ((class-= start 'inf+) - '()) - ((null? sharcs) - (cons (cons (cons start 'inf+) 'err) - (loop sharcs 'inf+))) - (else - (let* ((sharc (car sharcs)) - (h (caar sharc)) - (t (cdar sharc))) - (if (class-< start h) - (cons (cons (cons start (- h 1)) 'err) - (loop sharcs h)) - (cons sharc (loop (cdr sharcs) - (if (class-= t 'inf+) - 'inf+ - (+ t 1))))))))))) - (charcs->tree - (lambda (charcs) - (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) - (sharcs-l (map op charcs)) - (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) - (full-sharcs (fill-error sorted-sharcs)) - (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) - (table (list->vector (map op full-sharcs)))) - (let loop ((left 0) (right (- (vector-length table) 1))) - (if (= left right) - (cdr (vector-ref table left)) - (let ((mid (quotient (+ left right 1) 2))) - (if (and (= (+ left 2) right) - (= (+ (car (vector-ref table mid)) 1) - (car (vector-ref table right))) - (eqv? (cdr (vector-ref table left)) - (cdr (vector-ref table right)))) - (list '= - (car (vector-ref table mid)) - (cdr (vector-ref table mid)) - (cdr (vector-ref table left))) - (list (car (vector-ref table mid)) - (loop left (- mid 1)) - (loop mid right)))))))))) - (lambda (tables IS) - (let ((counters (vector-ref tables 0)) - (<>-action (vector-ref tables 1)) - (<>-action (vector-ref tables 2)) - (rules-actions (vector-ref tables 3)) - (nl-start (vector-ref tables 5)) - (no-nl-start (vector-ref tables 6)) - (charcs-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8))) - (let* ((len (vector-length charcs-v)) - (v (make-vector len))) - (let loop ((i (- len 1))) - (if (>= i 0) - (begin - (vector-set! v i (charcs->tree (vector-ref charcs-v i))) - (loop (- i 1))) - (lexer-make-tree-lexer - (vector counters - <>-action - <>-action - rules-actions - 'decision-trees - nl-start - no-nl-start - v - acc-v) - IS)))))))) - -; Fabrication d'un lexer a partir de code pre-genere -(define lexer-make-code-lexer - (lambda (tables IS) - (let ((<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-action (vector-ref tables 3)) - (code (vector-ref tables 5))) - (code <>-pre-action <>-pre-action rules-pre-action IS)))) - -(define lexer-make-lexer - (lambda (tables IS) - (let ((automaton-type (vector-ref tables 4))) - (cond ((eq? automaton-type 'decision-trees) - (lexer-make-tree-lexer tables IS)) - ((eq? automaton-type 'tagged-chars-lists) - (lexer-make-char-lexer tables IS)) - ((eq? automaton-type 'code) - (lexer-make-code-lexer tables IS)))))) - -; -; Table generated from the file c-lex.l by SILex 1.0 -; - -(define lexer-default-table - (vector - 'line - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - 'eof - )) - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (skribe-error 'c-fontifier "Parse error" yytext) - )) - (vector - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-string) - (body yytext)) -;; Comments -;; FIXME: We shouldn't exclude `/' from comments but we do so to match the -;; shortest multi-line comment. - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (let* ((not-line (char-set-complement (char-set #\newline))) - (lines (string-tokenize yytext not-line))) - (reverse! - (pair-fold (lambda (line* result) - (let* ((line (car line*)) - (last? (null? (cdr line*))) - (markup - (new markup - (markup '&source-line-comment) - (body line)))) - (if last? - (cons markup result) - (cons* (string #\newline) - markup result)))) - '() - lines))) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Identifiers (only letters since we are interested in keywords only) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (let* ((ident (string->symbol yytext)) - (tmp (memq ident (*the-keys*)))) - (if tmp - (new markup - (markup '&source-module) - (body yytext)) - yytext)) - -;; Regular text (excluding `/' and `*') - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin yytext) - -;; `/' and `*' alone. - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin yytext) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin yytext) - ))) - 'decision-trees - 0 - 0 - '#((48 (42 (= 34 6 2) (43 1 (47 2 5))) (95 (65 2 (91 4 2)) (97 (96 3 2) - (123 4 2)))) (= 47 err 7) (47 (35 (34 2 err) (= 42 err 2)) (91 (48 err - (65 2 err)) (97 2 (123 err 2)))) (48 (42 (= 34 err 2) (43 err (47 2 - err))) (95 (65 2 (91 4 2)) (97 (96 3 2) (123 4 2)))) (95 (65 err (91 4 - err)) (97 (96 4 err) (123 4 err))) (43 (42 8 10) (= 47 9 8)) (= 34 11 - 6) err err (= 10 err 12) (43 (42 10 13) (= 47 err 10)) err (= 10 err - 12) (43 (42 10 13) (= 47 14 10)) err) - '#((#f . #f) (#f . #f) (4 . 4) (3 . 3) (3 . 3) (#f . #f) (#f . #f) (6 . - 6) (5 . 5) (2 . 2) (#f . #f) (0 . 0) (2 . 2) (#f . #f) (1 . 1)))) - -; -; User functions -; - -(define lexer #f) - -(define lexer-get-line #f) -(define lexer-getc #f) -(define lexer-ungetc #f) - -(define lexer-init - (lambda (input-type input) - (let ((IS (lexer-make-IS input-type input 'line))) - (set! lexer (lexer-make-lexer lexer-default-table IS)) - (set! lexer-get-line (lexer-get-func-line IS)) - (set! lexer-getc (lexer-get-func-getc IS)) - (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/c.scm b/src/guile/skribilo/coloring/c.scm deleted file mode 100644 index 0d94307..0000000 --- a/src/guile/skribilo/coloring/c.scm +++ /dev/null @@ -1,86 +0,0 @@ -;;; c.scm -- C fontifier. -;;; -;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI -;;; Copyright 2007 Ludovic Courtès -;;; -;;; -;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;; USA. - -(define-module (skribilo coloring c) - :use-module (skribilo lib) - :use-module (skribilo utils syntax) - :use-module (skribilo coloring c-lex) ;; SILex generated - :use-module (skribilo coloring parameters) - :use-module (srfi srfi-39) - :export (c c-language java)) - -(fluid-set! current-reader %skribilo-module-reader) - - -;;; -;;; Generic fontifier. -;;; - -(define (fontifier s) - (lexer-init 'port (open-input-string s)) - (let loop ((token (lexer)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (loop (lexer) - (cons token res))))) - - -;;; -;;; C. -;;; - -(define %c-keys - '(for while return break continue void do if else typedef struct union - goto switch case static extern default)) - -(define (c-fontifier s) - (parameterize ((*the-keys* %c-keys)) - (fontifier s))) - -(define c - (new language - (name "C") - (fontifier c-fontifier) - (extractor #f))) - -(define c-language - ;; This alias is defined for the user's convenience. - c) - - -;;; -;;; Java. -;;; - -(define %java-keys - (append %c-keys - '(public final class throw catch))) - -(define (java-fontifier s) - (parameterize ((*the-keys* %java-keys)) - (fontifier s))) - -(define java - (new language - (name "java") - (fontifier java-fontifier) - (extractor #f))) diff --git a/src/guile/skribilo/coloring/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l deleted file mode 100644 index 30b6a44..0000000 --- a/src/guile/skribilo/coloring/lisp-lex.l +++ /dev/null @@ -1,86 +0,0 @@ -;;; lisp-lex.l -- SILex input for the Lisp Languages -;;; -;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI -;;; Copyright 2006 Ludovic Courtès -;;; -;;; -;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;; USA. - - -space [ \n\9] -letter [#?!_:a-zA-Z\-] -digit [0-9] - - -%% -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) - -;;Comment -\;.* (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Skribe text (i.e. [....]) -\[|\] (if (*bracket-highlight*) - (new markup - (markup '&source-bracket) - (body yytext)) - yytext) -;; Spaces & parenthesis -[ \n\9\(\)]+ (begin - yytext) - -;; Identifier (real syntax is slightly more complicated but we are -;; interested here in the identifiers that we will fontify) -[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) - (cond - ((or (char=? c #\:) - (char=? (string-ref yytext - (- (string-length yytext) 1)) - #\:)) - ;; Scheme keyword - (new markup - (markup '&source-type) - (body yytext))) - ((char=? c #\<) - ;; STklos class - (let* ((len (string-length yytext)) - (c (string-ref yytext (- len 1)))) - (if (char=? c #\>) - (if (*class-highlight*) - (new markup - (markup '&source-module) - (body yytext)) - yytext) ; no - yytext))) ; no - (else - (let ((tmp (assoc (string->symbol yytext) - (*the-keys*)))) - (if tmp - (new markup - (markup (cdr tmp)) - (body yytext)) - yytext))))) - - -<> 'eof -<> (skribe-error 'lisp-fontifier "Parse error" yytext) - - -; LocalWords: fontify diff --git a/src/guile/skribilo/coloring/lisp-lex.scm b/src/guile/skribilo/coloring/lisp-lex.scm deleted file mode 100644 index f68f320..0000000 --- a/src/guile/skribilo/coloring/lisp-lex.scm +++ /dev/null @@ -1,1257 +0,0 @@ -(define-module (skribilo coloring lisp-lex) - :use-module (skribilo lib) - :use-module (skribilo coloring parameters) - :export (lexer-init lexer - lexer-get-func-column - lexer-get-func-offset - lexer-get-line lexer-getc - lexer-ungetc)) -; *** This file starts with a copy of the file multilex.scm *** -; SILex - Scheme Implementation of Lex -; Copyright (C) 2001 Danny Dube' -; -; 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. - -; -; Gestion des Input Systems -; Fonctions a utiliser par l'usager: -; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -; - -; Taille initiale par defaut du buffer d'entree -(define lexer-init-buffer-len 1024) - -; Numero du caractere newline -(define lexer-integer-newline (char->integer #\newline)) - -; Constructeur d'IS brut -(define lexer-raw-IS-maker - (lambda (buffer read-ptr input-f counters) - (let ((input-f input-f) ; Entree reelle - (buffer buffer) ; Buffer - (buflen (string-length buffer)) - (read-ptr read-ptr) - (start-ptr 1) ; Marque de debut de lexeme - (start-line 1) - (start-column 1) - (start-offset 0) - (end-ptr 1) ; Marque de fin de lexeme - (point-ptr 1) ; Le point - (user-ptr 1) ; Marque de l'usager - (user-line 1) - (user-column 1) - (user-offset 0) - (user-up-to-date? #t)) ; Concerne la colonne seul. - (letrec - ((start-go-to-end-none ; Fonctions de depl. des marques - (lambda () - (set! start-ptr end-ptr))) - (start-go-to-end-line - (lambda () - (let loop ((ptr start-ptr) (line start-line)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1)) - (loop (+ ptr 1) line)))))) - (start-go-to-end-all - (lambda () - (set! start-offset (+ start-offset (- end-ptr start-ptr))) - (let loop ((ptr start-ptr) - (line start-line) - (column start-column)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1) 1) - (loop (+ ptr 1) line (+ column 1))))))) - (start-go-to-user-none - (lambda () - (set! start-ptr user-ptr))) - (start-go-to-user-line - (lambda () - (set! start-ptr user-ptr) - (set! start-line user-line))) - (start-go-to-user-all - (lambda () - (set! start-line user-line) - (set! start-offset user-offset) - (if user-up-to-date? - (begin - (set! start-ptr user-ptr) - (set! start-column user-column)) - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! start-ptr ptr) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1)))))))) - (end-go-to-point - (lambda () - (set! end-ptr point-ptr))) - (point-go-to-start - (lambda () - (set! point-ptr start-ptr))) - (user-go-to-start-none - (lambda () - (set! user-ptr start-ptr))) - (user-go-to-start-line - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line))) - (user-go-to-start-all - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line) - (set! user-column start-column) - (set! user-offset start-offset) - (set! user-up-to-date? #t))) - (init-lexeme-none ; Debute un nouveau lexeme - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-none)) - (point-go-to-start))) - (init-lexeme-line - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-line)) - (point-go-to-start))) - (init-lexeme-all - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-all)) - (point-go-to-start))) - (get-start-line ; Obtention des stats du debut du lxm - (lambda () - start-line)) - (get-start-column - (lambda () - start-column)) - (get-start-offset - (lambda () - start-offset)) - (peek-left-context ; Obtention de caracteres (#f si EOF) - (lambda () - (char->integer (string-ref buffer (- start-ptr 1))))) - (peek-char - (lambda () - (if (< point-ptr read-ptr) - (char->integer (string-ref buffer point-ptr)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (read-char - (lambda () - (if (< point-ptr read-ptr) - (let ((c (string-ref buffer point-ptr))) - (set! point-ptr (+ point-ptr 1)) - (char->integer c)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (set! point-ptr read-ptr) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (get-start-end-text ; Obtention du lexeme - (lambda () - (substring buffer start-ptr end-ptr))) - (get-user-line-line ; Fonctions pour l'usager - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - user-line)) - (get-user-line-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-line)) - (get-user-column-all - (lambda () - (cond ((< user-ptr start-ptr) - (user-go-to-start-all) - user-column) - (user-up-to-date? - user-column) - (else - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! user-column column) - (set! user-up-to-date? #t) - column) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1))))))))) - (get-user-offset-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-offset)) - (user-getc-none - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-none)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-line - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-ungetc-none - (lambda () - (if (> user-ptr start-ptr) - (set! user-ptr (- user-ptr 1))))) - (user-ungetc-line - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (set! user-line (- user-line 1)))))))) - (user-ungetc-all - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (begin - (set! user-line (- user-line 1)) - (set! user-up-to-date? #f)) - (set! user-column (- user-column 1))) - (set! user-offset (- user-offset 1))))))) - (reorganize-buffer ; Decaler ou agrandir le buffer - (lambda () - (if (< (* 2 start-ptr) buflen) - (let* ((newlen (* 2 buflen)) - (newbuf (make-string newlen)) - (delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! newbuf - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! buffer newbuf) - (set! buflen newlen) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))) - (let ((delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! buffer - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))))))) - (list (cons 'start-go-to-end - (cond ((eq? counters 'none) start-go-to-end-none) - ((eq? counters 'line) start-go-to-end-line) - ((eq? counters 'all ) start-go-to-end-all))) - (cons 'end-go-to-point - end-go-to-point) - (cons 'init-lexeme - (cond ((eq? counters 'none) init-lexeme-none) - ((eq? counters 'line) init-lexeme-line) - ((eq? counters 'all ) init-lexeme-all))) - (cons 'get-start-line - get-start-line) - (cons 'get-start-column - get-start-column) - (cons 'get-start-offset - get-start-offset) - (cons 'peek-left-context - peek-left-context) - (cons 'peek-char - peek-char) - (cons 'read-char - read-char) - (cons 'get-start-end-text - get-start-end-text) - (cons 'get-user-line - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) get-user-line-line) - ((eq? counters 'all ) get-user-line-all))) - (cons 'get-user-column - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-column-all))) - (cons 'get-user-offset - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-offset-all))) - (cons 'user-getc - (cond ((eq? counters 'none) user-getc-none) - ((eq? counters 'line) user-getc-line) - ((eq? counters 'all ) user-getc-all))) - (cons 'user-ungetc - (cond ((eq? counters 'none) user-ungetc-none) - ((eq? counters 'line) user-ungetc-line) - ((eq? counters 'all ) user-ungetc-all)))))))) - -; Construit un Input System -; Le premier parametre doit etre parmi "port", "procedure" ou "string" -; Prend un parametre facultatif qui doit etre parmi -; "none", "line" ou "all" -(define lexer-make-IS - (lambda (input-type input . largs) - (let ((counters-type (cond ((null? largs) - 'line) - ((memq (car largs) '(none line all)) - (car largs)) - (else - 'line)))) - (cond ((and (eq? input-type 'port) (input-port? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f (lambda () (read-char input)))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'procedure) (procedure? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f input)) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'string) (string? input)) - (let* ((buffer (string-append (string #\newline) input)) - (read-ptr (string-length buffer)) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - (else - (let* ((buffer (string #\newline)) - (read-ptr 1) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) - -; Les fonctions: -; lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -(define lexer-get-func-getc - (lambda (IS) (cdr (assq 'user-getc IS)))) -(define lexer-get-func-ungetc - (lambda (IS) (cdr (assq 'user-ungetc IS)))) -(define lexer-get-func-line - (lambda (IS) (cdr (assq 'get-user-line IS)))) -(define lexer-get-func-column - (lambda (IS) (cdr (assq 'get-user-column IS)))) -(define lexer-get-func-offset - (lambda (IS) (cdr (assq 'get-user-offset IS)))) - -; -; Gestion des lexers -; - -; Fabrication de lexer a partir d'arbres de decision -(define lexer-make-tree-lexer - (lambda (tables IS) - (letrec - (; Contenu de la table - (counters-type (vector-ref tables 0)) - (<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-actions (vector-ref tables 3)) - (table-nl-start (vector-ref tables 5)) - (table-no-nl-start (vector-ref tables 6)) - (trees-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8)) - - ; Contenu du IS - (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) - (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) - (IS-init-lexeme (cdr (assq 'init-lexeme IS))) - (IS-get-start-line (cdr (assq 'get-start-line IS))) - (IS-get-start-column (cdr (assq 'get-start-column IS))) - (IS-get-start-offset (cdr (assq 'get-start-offset IS))) - (IS-peek-left-context (cdr (assq 'peek-left-context IS))) - (IS-peek-char (cdr (assq 'peek-char IS))) - (IS-read-char (cdr (assq 'read-char IS))) - (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) - (IS-get-user-line (cdr (assq 'get-user-line IS))) - (IS-get-user-column (cdr (assq 'get-user-column IS))) - (IS-get-user-offset (cdr (assq 'get-user-offset IS))) - (IS-user-getc (cdr (assq 'user-getc IS))) - (IS-user-ungetc (cdr (assq 'user-ungetc IS))) - - ; Resultats - (<>-action #f) - (<>-action #f) - (rules-actions #f) - (states #f) - (final-lexer #f) - - ; Gestion des hooks - (hook-list '()) - (add-hook - (lambda (thunk) - (set! hook-list (cons thunk hook-list)))) - (apply-hooks - (lambda () - (let loop ((l hook-list)) - (if (pair? l) - (begin - ((car l)) - (loop (cdr l))))))) - - ; Preparation des actions - (set-action-statics - (lambda (pre-action) - (pre-action final-lexer IS-user-getc IS-user-ungetc))) - (prepare-special-action-none - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda () - (action ""))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-line - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline) - (action "" yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-all - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (action "" yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-special-action-none pre-action)) - ((eq? counters-type 'line) - (prepare-special-action-line pre-action)) - ((eq? counters-type 'all) - (prepare-special-action-all pre-action))))) - (prepare-action-yytext-none - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-line - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-all - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline yycolumn yyoffset)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-yytext-all pre-action))))) - (prepare-action-no-yytext-none - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (start-go-to-end) - (action))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-line - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (start-go-to-end) - (action yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-all - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (start-go-to-end) - (action yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-no-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-no-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-no-yytext-all pre-action))))) - - ; Fabrique les fonctions de dispatch - (prepare-dispatch-err - (lambda (leaf) - (lambda (c) - #f))) - (prepare-dispatch-number - (lambda (leaf) - (let ((state-function #f)) - (let ((result - (lambda (c) - state-function)) - (hook - (lambda () - (set! state-function (vector-ref states leaf))))) - (add-hook hook) - result)))) - (prepare-dispatch-leaf - (lambda (leaf) - (if (eq? leaf 'err) - (prepare-dispatch-err leaf) - (prepare-dispatch-number leaf)))) - (prepare-dispatch-< - (lambda (tree) - (let ((left-tree (list-ref tree 1)) - (right-tree (list-ref tree 2))) - (let ((bound (list-ref tree 0)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (< c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-= - (lambda (tree) - (let ((left-tree (list-ref tree 2)) - (right-tree (list-ref tree 3))) - (let ((bound (list-ref tree 1)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (= c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-tree - (lambda (tree) - (cond ((not (pair? tree)) - (prepare-dispatch-leaf tree)) - ((eq? (car tree) '=) - (prepare-dispatch-= tree)) - (else - (prepare-dispatch-< tree))))) - (prepare-dispatch - (lambda (tree) - (let ((dicho-func (prepare-dispatch-tree tree))) - (lambda (c) - (and c (dicho-func c)))))) - - ; Fabrique les fonctions de transition (read & go) et (abort) - (prepare-read-n-go - (lambda (tree) - (let ((dispatch-func (prepare-dispatch tree)) - (read-char IS-read-char)) - (lambda () - (dispatch-func (read-char)))))) - (prepare-abort - (lambda (tree) - (lambda () - #f))) - (prepare-transition - (lambda (tree) - (if (eq? tree 'err) - (prepare-abort tree) - (prepare-read-n-go tree)))) - - ; Fabrique les fonctions d'etats ([set-end] & trans) - (prepare-state-no-acc - (lambda (s r1 r2) - (let ((trans-func (prepare-transition (vector-ref trees-v s)))) - (lambda (action) - (let ((next-state (trans-func))) - (if next-state - (next-state action) - action)))))) - (prepare-state-yes-no - (lambda (s r1 r2) - (let ((peek-char IS-peek-char) - (end-go-to-point IS-end-go-to-point) - (new-action1 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - (begin - (end-go-to-point) - new-action1) - action)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state-diff-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (peek-char IS-peek-char) - (new-action1 #f) - (new-action2 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (end-go-to-point) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - new-action1 - new-action2)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1)) - (set! new-action2 (vector-ref rules-actions r2))))) - (add-hook hook) - result)))) - (prepare-state-same-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (trans-func (prepare-transition (vector-ref trees-v s))) - (new-action #f)) - (let ((result - (lambda (action) - (end-go-to-point) - (let ((next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state - (lambda (s) - (let* ((acc (vector-ref acc-v s)) - (r1 (car acc)) - (r2 (cdr acc))) - (cond ((not r1) (prepare-state-no-acc s r1 r2)) - ((not r2) (prepare-state-yes-no s r1 r2)) - ((< r1 r2) (prepare-state-diff-acc s r1 r2)) - (else (prepare-state-same-acc s r1 r2)))))) - - ; Fabrique la fonction de lancement du lexage a l'etat de depart - (prepare-start-same - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (start-state #f) - (error-action #f)) - (let ((result - (lambda () - (if (not (peek-char)) - eof-action - (start-state error-action)))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state (vector-ref states s1)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start-diff - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (peek-left-context IS-peek-left-context) - (start-state1 #f) - (start-state2 #f) - (error-action #f)) - (let ((result - (lambda () - (cond ((not (peek-char)) - eof-action) - ((= (peek-left-context) lexer-integer-newline) - (start-state1 error-action)) - (else - (start-state2 error-action))))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state1 (vector-ref states s1)) - (set! start-state2 (vector-ref states s2)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start - (lambda () - (let ((s1 table-nl-start) - (s2 table-no-nl-start)) - (if (= s1 s2) - (prepare-start-same s1 s2) - (prepare-start-diff s1 s2))))) - - ; Fabrique la fonction principale - (prepare-lexer-none - (lambda () - (let ((init-lexeme IS-init-lexeme) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - ((start-func)))))) - (prepare-lexer-line - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line))) - ((start-func) yyline)))))) - (prepare-lexer-all - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (get-start-column IS-get-start-column) - (get-start-offset IS-get-start-offset) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line)) - (yycolumn (get-start-column)) - (yyoffset (get-start-offset))) - ((start-func) yyline yycolumn yyoffset)))))) - (prepare-lexer - (lambda () - (cond ((eq? counters-type 'none) (prepare-lexer-none)) - ((eq? counters-type 'line) (prepare-lexer-line)) - ((eq? counters-type 'all) (prepare-lexer-all)))))) - - ; Calculer la valeur de <>-action et de <>-action - (set! <>-action (prepare-special-action <>-pre-action)) - (set! <>-action (prepare-special-action <>-pre-action)) - - ; Calculer la valeur de rules-actions - (let* ((len (quotient (vector-length rules-pre-actions) 2)) - (v (make-vector len))) - (let loop ((r (- len 1))) - (if (< r 0) - (set! rules-actions v) - (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) - (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) - (action (if yytext? - (prepare-action-yytext pre-action) - (prepare-action-no-yytext pre-action)))) - (vector-set! v r action) - (loop (- r 1)))))) - - ; Calculer la valeur de states - (let* ((len (vector-length trees-v)) - (v (make-vector len))) - (let loop ((s (- len 1))) - (if (< s 0) - (set! states v) - (begin - (vector-set! v s (prepare-state s)) - (loop (- s 1)))))) - - ; Calculer la valeur de final-lexer - (set! final-lexer (prepare-lexer)) - - ; Executer les hooks - (apply-hooks) - - ; Resultat - final-lexer))) - -; Fabrication de lexer a partir de listes de caracteres taggees -(define lexer-make-char-lexer - (let* ((char->class - (lambda (c) - (let ((n (char->integer c))) - (list (cons n n))))) - (merge-sort - (lambda (l combine zero-elt) - (if (null? l) - zero-elt - (let loop1 ((l l)) - (if (null? (cdr l)) - (car l) - (loop1 - (let loop2 ((l l)) - (cond ((null? l) - l) - ((null? (cdr l)) - l) - (else - (cons (combine (car l) (cadr l)) - (loop2 (cddr l)))))))))))) - (finite-class-union - (lambda (c1 c2) - (let loop ((c1 c1) (c2 c2) (u '())) - (if (null? c1) - (if (null? c2) - (reverse u) - (loop c1 (cdr c2) (cons (car c2) u))) - (if (null? c2) - (loop (cdr c1) c2 (cons (car c1) u)) - (let* ((r1 (car c1)) - (r2 (car c2)) - (r1start (car r1)) - (r1end (cdr r1)) - (r2start (car r2)) - (r2end (cdr r2))) - (if (<= r1start r2start) - (cond ((< (+ r1end 1) r2start) - (loop (cdr c1) c2 (cons r1 u))) - ((<= r1end r2end) - (loop (cdr c1) - (cons (cons r1start r2end) (cdr c2)) - u)) - (else - (loop c1 (cdr c2) u))) - (cond ((> r1start (+ r2end 1)) - (loop c1 (cdr c2) (cons r2 u))) - ((>= r1end r2end) - (loop (cons (cons r2start r1end) (cdr c1)) - (cdr c2) - u)) - (else - (loop (cdr c1) c2 u)))))))))) - (char-list->class - (lambda (cl) - (let ((classes (map char->class cl))) - (merge-sort classes finite-class-union '())))) - (class-< - (lambda (b1 b2) - (cond ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - (else (< b1 b2))))) - (finite-class-compl - (lambda (c) - (let loop ((c c) (start 'inf-)) - (if (null? c) - (list (cons start 'inf+)) - (let* ((r (car c)) - (rstart (car r)) - (rend (cdr r))) - (if (class-< start rstart) - (cons (cons start (- rstart 1)) - (loop c rstart)) - (loop (cdr c) (+ rend 1)))))))) - (tagged-chars->class - (lambda (tcl) - (let* ((inverse? (car tcl)) - (cl (cdr tcl)) - (class-tmp (char-list->class cl))) - (if inverse? (finite-class-compl class-tmp) class-tmp)))) - (charc->arc - (lambda (charc) - (let* ((tcl (car charc)) - (dest (cdr charc)) - (class (tagged-chars->class tcl))) - (cons class dest)))) - (arc->sharcs - (lambda (arc) - (let* ((range-l (car arc)) - (dest (cdr arc)) - (op (lambda (range) (cons range dest)))) - (map op range-l)))) - (class-<= - (lambda (b1 b2) - (cond ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - (else (<= b1 b2))))) - (sharc-<= - (lambda (sharc1 sharc2) - (class-<= (caar sharc1) (caar sharc2)))) - (merge-sharcs - (lambda (l1 l2) - (let loop ((l1 l1) (l2 l2)) - (cond ((null? l1) - l2) - ((null? l2) - l1) - (else - (let ((sharc1 (car l1)) - (sharc2 (car l2))) - (if (sharc-<= sharc1 sharc2) - (cons sharc1 (loop (cdr l1) l2)) - (cons sharc2 (loop l1 (cdr l2)))))))))) - (class-= eqv?) - (fill-error - (lambda (sharcs) - (let loop ((sharcs sharcs) (start 'inf-)) - (cond ((class-= start 'inf+) - '()) - ((null? sharcs) - (cons (cons (cons start 'inf+) 'err) - (loop sharcs 'inf+))) - (else - (let* ((sharc (car sharcs)) - (h (caar sharc)) - (t (cdar sharc))) - (if (class-< start h) - (cons (cons (cons start (- h 1)) 'err) - (loop sharcs h)) - (cons sharc (loop (cdr sharcs) - (if (class-= t 'inf+) - 'inf+ - (+ t 1))))))))))) - (charcs->tree - (lambda (charcs) - (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) - (sharcs-l (map op charcs)) - (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) - (full-sharcs (fill-error sorted-sharcs)) - (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) - (table (list->vector (map op full-sharcs)))) - (let loop ((left 0) (right (- (vector-length table) 1))) - (if (= left right) - (cdr (vector-ref table left)) - (let ((mid (quotient (+ left right 1) 2))) - (if (and (= (+ left 2) right) - (= (+ (car (vector-ref table mid)) 1) - (car (vector-ref table right))) - (eqv? (cdr (vector-ref table left)) - (cdr (vector-ref table right)))) - (list '= - (car (vector-ref table mid)) - (cdr (vector-ref table mid)) - (cdr (vector-ref table left))) - (list (car (vector-ref table mid)) - (loop left (- mid 1)) - (loop mid right)))))))))) - (lambda (tables IS) - (let ((counters (vector-ref tables 0)) - (<>-action (vector-ref tables 1)) - (<>-action (vector-ref tables 2)) - (rules-actions (vector-ref tables 3)) - (nl-start (vector-ref tables 5)) - (no-nl-start (vector-ref tables 6)) - (charcs-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8))) - (let* ((len (vector-length charcs-v)) - (v (make-vector len))) - (let loop ((i (- len 1))) - (if (>= i 0) - (begin - (vector-set! v i (charcs->tree (vector-ref charcs-v i))) - (loop (- i 1))) - (lexer-make-tree-lexer - (vector counters - <>-action - <>-action - rules-actions - 'decision-trees - nl-start - no-nl-start - v - acc-v) - IS)))))))) - -; Fabrication d'un lexer a partir de code pre-genere -(define lexer-make-code-lexer - (lambda (tables IS) - (let ((<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-action (vector-ref tables 3)) - (code (vector-ref tables 5))) - (code <>-pre-action <>-pre-action rules-pre-action IS)))) - -(define lexer-make-lexer - (lambda (tables IS) - (let ((automaton-type (vector-ref tables 4))) - (cond ((eq? automaton-type 'decision-trees) - (lexer-make-tree-lexer tables IS)) - ((eq? automaton-type 'tagged-chars-lists) - (lexer-make-char-lexer tables IS)) - ((eq? automaton-type 'code) - (lexer-make-code-lexer tables IS)))))) - -; -; Table generated from the file lisp-lex.l by SILex 1.0 -; - -(define lexer-default-table - (vector - 'line - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - 'eof - )) - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (skribe-error 'lisp-fontifier "Parse error" yytext) - - -; LocalWords: fontify - )) - (vector - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-string) - (body yytext)) - -;;Comment - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-line-comment) - (body yytext)) - -;; Skribe text (i.e. [....]) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (if (*bracket-highlight*) - (new markup - (markup '&source-bracket) - (body yytext)) - yytext) -;; Spaces & parenthesis - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin - yytext) - -;; Identifier (real syntax is slightly more complicated but we are -;; interested here in the identifiers that we will fontify) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (let ((c (string-ref yytext 0))) - (cond - ((or (char=? c #\:) - (char=? (string-ref yytext - (- (string-length yytext) 1)) - #\:)) - ;; Scheme keyword - (new markup - (markup '&source-type) - (body yytext))) - ((char=? c #\<) - ;; STklos class - (let* ((len (string-length yytext)) - (c (string-ref yytext (- len 1)))) - (if (char=? c #\>) - (if (*class-highlight*) - (new markup - (markup '&source-module) - (body yytext)) - yytext) ; no - yytext))) ; no - (else - (let ((tmp (assoc (string->symbol yytext) - (*the-keys*)))) - (if tmp - (new markup - (markup (cdr tmp)) - (body yytext)) - yytext))))) - ))) - 'decision-trees - 0 - 0 - '#((40 (32 (9 1 (11 2 1)) (34 (33 2 1) (35 5 1))) (91 (59 (42 2 1) (60 4 - 1)) (93 (92 3 1) (94 3 1)))) (40 (32 (9 1 (11 err 1)) (34 (33 err 1) - (35 err 1))) (91 (59 (42 err 1) (60 err 1)) (93 (92 err 1) (94 err - 1)))) (32 (9 err (11 2 err)) (40 (33 2 err) (42 2 err))) err (= 10 err - 4) (= 34 6 5) err) - '#((#f . #f) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (#f . #f) (0 . 0)))) - -; -; User functions -; - -(define lexer #f) - -(define lexer-get-line #f) -(define lexer-getc #f) -(define lexer-ungetc #f) - -(define lexer-init - (lambda (input-type input) - (let ((IS (lexer-make-IS input-type input 'line))) - (set! lexer (lexer-make-lexer lexer-default-table IS)) - (set! lexer-get-line (lexer-get-func-line IS)) - (set! lexer-getc (lexer-get-func-getc IS)) - (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/lisp.scm b/src/guile/skribilo/coloring/lisp.scm deleted file mode 100644 index 46e8c59..0000000 --- a/src/guile/skribilo/coloring/lisp.scm +++ /dev/null @@ -1,292 +0,0 @@ -;;; lisp.scm -- Lisp Family Fontification -;;; -;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI -;;; Copyright 2005, 2006, 2007 Ludovic Courtès -;;; -;;; -;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;; USA. - - -(define-module (skribilo coloring lisp) - :use-module (skribilo utils syntax) - :use-module (skribilo source) - :use-module (skribilo coloring parameters) - :use-module (skribilo lib) - :use-module (srfi srfi-39) - :use-module (ice-9 match) - :autoload (skribilo reader) (make-reader) - :autoload (skribilo coloring lisp-lex) (lexer-init) - :export (skribe scheme stklos bigloo lisp)) - - -(define %lisp-keys #f) -(define %scheme-keys #f) -(define %skribe-keys #f) -(define %stklos-keys #f) -(define %lisp-keys #f) - - - -;;; -;;; definition-search -;;; - -(define (definition-search inp read tab def?) - (let Loop ((exp (read inp))) - (unless (eof-object? exp) - (if (def? exp) - (let ((start (and (pair? exp) (source-property exp 'line))) - (stop (port-line inp))) - (source-read-lines (port-filename inp) start stop tab)) - (Loop (read inp)))))) - -(define (lisp-family-fontifier s) - (lexer-init 'port (open-input-string s)) - (let loop ((token (lexer)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (loop (lexer) - (cons token res))))) - - -;;; -;;; Lisp. -;;; - -(define (lisp-extractor iport def tab) - (definition-search - iport - read - tab - (lambda (exp) - (match exp - (((or 'defun 'defmacro) fun _ . _) - (and (eq? def fun) exp)) - (('defvar var . _) - (and (eq? var def) exp)) - (else #f))))) - -(define (init-lisp-keys) - (unless %lisp-keys - (set! %lisp-keys - (append ;; key - (map (lambda (x) (cons x '&source-keyword)) - '(setq if let let* letrec cond case else progn lambda)) - ;; define - (map (lambda (x) (cons x '&source-define)) - '(defun defclass defmacro))))) - %lisp-keys) - -(define (lisp-fontifier s) - (parameterize ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) - (lisp-family-fontifier s))) - - -(define lisp - (new language - (name "lisp") - (fontifier lisp-fontifier) - (extractor lisp-extractor))) - - -;;; -;;; Scheme. -;;; - -(define (scheme-extractor iport def tab) - (definition-search - iport - %skribilo-module-reader - tab - (lambda (exp) - (match exp - (((or 'define 'define-macro) (fun . _) . _) - (and (eq? def fun) exp)) - (('define (? symbol? var) . _) - (and (eq? var def) exp)) - (else #f))))) - - -(define (init-scheme-keys) - (unless %scheme-keys - (set! %scheme-keys - (append ;; key - (map (lambda (x) (cons x '&source-keyword)) - '(set! if let let* letrec quote cond case else begin do lambda)) - ;; define - (map (lambda (x) (cons x '&source-define)) - '(define define-syntax))))) - %scheme-keys) - - -(define (scheme-fontifier s) - (parameterize ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) - (lisp-family-fontifier s))) - - -(define scheme - (new language - (name "scheme") - (fontifier scheme-fontifier) - (extractor scheme-extractor))) - - -;;; -;;; STkLos. -;;; - -(define (stklos-extractor iport def tab) - (definition-search - iport - %skribilo-module-reader - tab - (lambda (exp) - (match exp - (((or 'define 'define-generic 'define-method 'define-macro) - (fun . _) . _) - (and (eq? def fun) exp)) - (((or 'define 'define-module) (? symbol? var) . _) - (and (eq? var def) exp)) - (else - #f))))) - - -(define (init-stklos-keys) - (unless %stklos-keys - (init-scheme-keys) - (set! %stklos-keys (append %scheme-keys - ;; Markups - (map (lambda (x) (cons x '&source-key)) - '(select-module import export)) - ;; Key - (map (lambda (x) (cons x '&source-keyword)) - '(case-lambda dotimes match-case match-lambda)) - ;; Define - (map (lambda (x) (cons x '&source-define)) - '(define-generic define-class - define-macro define-method define-module)) - ;; error - (map (lambda (x) (cons x '&source-error)) - '(error call/cc))))) - %stklos-keys) - - -(define (stklos-fontifier s) - (parameterize ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) - (lisp-family-fontifier s))) - - -(define stklos - (new language - (name "stklos") - (fontifier stklos-fontifier) - (extractor stklos-extractor))) - - -;;; -;;; Skribe. -;;; - -(define (skribe-extractor iport def tab) - (definition-search - iport - (make-reader 'skribe) - tab - (lambda (exp) - (match exp - (((or 'define 'define-macro 'define-markup 'define-public) - (fun . _) . _) - (and (eq? def fun) exp)) - (('define (? symbol? var) . _) - (and (eq? var def) exp)) - (('markup-output (quote mk) . _) - (and (eq? mk def) exp)) - (else #f))))) - - -(define (init-skribe-keys) - (unless %skribe-keys - (init-stklos-keys) - (set! %skribe-keys (append %stklos-keys - ;; Markups - (map (lambda (x) (cons x '&source-markup)) - '(bold it emph tt color ref index underline - roman figure center pre flush hrule - linebreak image kbd code var samp - sc sf sup sub - itemize description enumerate item - table tr td th item prgm author - prgm hook font - document chapter section subsection - subsubsection paragraph p handle resolve - processor abstract margin toc - table-of-contents current-document - current-chapter current-section - document-sections* section-number - footnote print-index include skribe-load - slide)) - ;; Define - (map (lambda (x) (cons x '&source-define)) - '(define-markup))))) - %skribe-keys) - - -(define (skribe-fontifier s) - (parameterize ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) - (lisp-family-fontifier s))) - - -(define skribe - (new language - (name "skribe") - (fontifier skribe-fontifier) - (extractor skribe-extractor))) - - -;;; -;;; Bigloo. -;;; - -(define (bigloo-extractor iport def tab) - (definition-search - iport - %skribilo-module-reader - tab - (lambda (exp) - (match exp - (((or 'define 'define-inline 'define-generic - 'define-method 'define-macro 'define-expander) - (fun . _) . _) - (and (eq? def fun) exp)) - (((or 'define 'define-struct 'define-library) - (? symbol? var) . _) - (and (eq? var def) exp)) - (else #f))))) - -(define bigloo - (new language - (name "bigloo") - (fontifier scheme-fontifier) - (extractor bigloo-extractor))) diff --git a/src/guile/skribilo/coloring/parameters.scm b/src/guile/skribilo/coloring/parameters.scm deleted file mode 100644 index cb4e9bb..0000000 --- a/src/guile/skribilo/coloring/parameters.scm +++ /dev/null @@ -1,33 +0,0 @@ -;;; lisp.scm -- Lisp Family Fontification -;;; -;;; Copyright 2007 Ludovic Courtès -;;; -;;; -;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;; USA. - -(define-module (skribilo coloring parameters) - :use-module (srfi srfi-39) - :export (*bracket-highlight* *class-highlight* *the-keys*)) - -;;; -;;; Parameters used by the fontifiers. -;;; - -(define *bracket-highlight* (make-parameter #t)) -(define *class-highlight* (make-parameter #t)) -(define *the-keys* (make-parameter '())) - -;;; arch-tag: 232c250e-0022-418f-9219-03b4446d0b55 diff --git a/src/guile/skribilo/coloring/xml-lex.l b/src/guile/skribilo/coloring/xml-lex.l deleted file mode 100644 index aa7d312..0000000 --- a/src/guile/skribilo/coloring/xml-lex.l +++ /dev/null @@ -1,64 +0,0 @@ -;;;; -*- Scheme -*- -;;;; -;;;; xml-lex.l -- SILex input for the XML languages -;;;; -;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI -;;;; -;;;; -;;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 21-Dec-2003 22:38 (eg) -;;;; - -space [ \n\9] - -%% - -;; Strings -\"[^\"]*\" (new markup - (markup '&source-string) - (body yytext)) -'[^']*' (new markup - (markup '&source-string) - (body yytext)) - -;;Comment - (new markup - (markup '&source-comment) - (body yytext)) - -;; Markup -<[^>\n ]+|> (new markup - (markup '&source-module) - (body yytext)) - -;; Regular text -[^<>\"']+ (begin yytext) - - -<> 'eof -<> (skribe-error 'xml-fontifier "Parse error" yytext) - - - - - - - - - \ No newline at end of file diff --git a/src/guile/skribilo/coloring/xml-lex.scm b/src/guile/skribilo/coloring/xml-lex.scm deleted file mode 100644 index d14aa5d..0000000 --- a/src/guile/skribilo/coloring/xml-lex.scm +++ /dev/null @@ -1,1229 +0,0 @@ -(define-module (skribilo coloring xml-lex) - :use-module (skribilo lib) - :use-module (skribilo coloring parameters) - :export (lexer-init lexer - lexer-get-func-column - lexer-get-func-offset - lexer-get-line lexer-getc - lexer-ungetc)) -; *** This file starts with a copy of the file multilex.scm *** -; SILex - Scheme Implementation of Lex -; Copyright (C) 2001 Danny Dube' -; -; 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. - -; -; Gestion des Input Systems -; Fonctions a utiliser par l'usager: -; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -; - -; Taille initiale par defaut du buffer d'entree -(define lexer-init-buffer-len 1024) - -; Numero du caractere newline -(define lexer-integer-newline (char->integer #\newline)) - -; Constructeur d'IS brut -(define lexer-raw-IS-maker - (lambda (buffer read-ptr input-f counters) - (let ((input-f input-f) ; Entree reelle - (buffer buffer) ; Buffer - (buflen (string-length buffer)) - (read-ptr read-ptr) - (start-ptr 1) ; Marque de debut de lexeme - (start-line 1) - (start-column 1) - (start-offset 0) - (end-ptr 1) ; Marque de fin de lexeme - (point-ptr 1) ; Le point - (user-ptr 1) ; Marque de l'usager - (user-line 1) - (user-column 1) - (user-offset 0) - (user-up-to-date? #t)) ; Concerne la colonne seul. - (letrec - ((start-go-to-end-none ; Fonctions de depl. des marques - (lambda () - (set! start-ptr end-ptr))) - (start-go-to-end-line - (lambda () - (let loop ((ptr start-ptr) (line start-line)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1)) - (loop (+ ptr 1) line)))))) - (start-go-to-end-all - (lambda () - (set! start-offset (+ start-offset (- end-ptr start-ptr))) - (let loop ((ptr start-ptr) - (line start-line) - (column start-column)) - (if (= ptr end-ptr) - (begin - (set! start-ptr ptr) - (set! start-line line) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) (+ line 1) 1) - (loop (+ ptr 1) line (+ column 1))))))) - (start-go-to-user-none - (lambda () - (set! start-ptr user-ptr))) - (start-go-to-user-line - (lambda () - (set! start-ptr user-ptr) - (set! start-line user-line))) - (start-go-to-user-all - (lambda () - (set! start-line user-line) - (set! start-offset user-offset) - (if user-up-to-date? - (begin - (set! start-ptr user-ptr) - (set! start-column user-column)) - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! start-ptr ptr) - (set! start-column column)) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1)))))))) - (end-go-to-point - (lambda () - (set! end-ptr point-ptr))) - (point-go-to-start - (lambda () - (set! point-ptr start-ptr))) - (user-go-to-start-none - (lambda () - (set! user-ptr start-ptr))) - (user-go-to-start-line - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line))) - (user-go-to-start-all - (lambda () - (set! user-ptr start-ptr) - (set! user-line start-line) - (set! user-column start-column) - (set! user-offset start-offset) - (set! user-up-to-date? #t))) - (init-lexeme-none ; Debute un nouveau lexeme - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-none)) - (point-go-to-start))) - (init-lexeme-line - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-line)) - (point-go-to-start))) - (init-lexeme-all - (lambda () - (if (< start-ptr user-ptr) - (start-go-to-user-all)) - (point-go-to-start))) - (get-start-line ; Obtention des stats du debut du lxm - (lambda () - start-line)) - (get-start-column - (lambda () - start-column)) - (get-start-offset - (lambda () - start-offset)) - (peek-left-context ; Obtention de caracteres (#f si EOF) - (lambda () - (char->integer (string-ref buffer (- start-ptr 1))))) - (peek-char - (lambda () - (if (< point-ptr read-ptr) - (char->integer (string-ref buffer point-ptr)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (read-char - (lambda () - (if (< point-ptr read-ptr) - (let ((c (string-ref buffer point-ptr))) - (set! point-ptr (+ point-ptr 1)) - (char->integer c)) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer point-ptr c) - (set! read-ptr (+ point-ptr 1)) - (set! point-ptr read-ptr) - (char->integer c)) - (begin - (set! input-f (lambda () 'eof)) - #f)))))) - (get-start-end-text ; Obtention du lexeme - (lambda () - (substring buffer start-ptr end-ptr))) - (get-user-line-line ; Fonctions pour l'usager - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - user-line)) - (get-user-line-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-line)) - (get-user-column-all - (lambda () - (cond ((< user-ptr start-ptr) - (user-go-to-start-all) - user-column) - (user-up-to-date? - user-column) - (else - (let loop ((ptr start-ptr) (column start-column)) - (if (= ptr user-ptr) - (begin - (set! user-column column) - (set! user-up-to-date? #t) - column) - (if (char=? (string-ref buffer ptr) #\newline) - (loop (+ ptr 1) 1) - (loop (+ ptr 1) (+ column 1))))))))) - (get-user-offset-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - user-offset)) - (user-getc-none - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-none)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-line - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-line)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (set! user-line (+ user-line 1))) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-getc-all - (lambda () - (if (< user-ptr start-ptr) - (user-go-to-start-all)) - (if (< user-ptr read-ptr) - (let ((c (string-ref buffer user-ptr))) - (set! user-ptr (+ user-ptr 1)) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (let ((c (input-f))) - (if (char? c) - (begin - (if (= read-ptr buflen) - (reorganize-buffer)) - (string-set! buffer user-ptr c) - (set! read-ptr (+ read-ptr 1)) - (set! user-ptr read-ptr) - (if (char=? c #\newline) - (begin - (set! user-line (+ user-line 1)) - (set! user-column 1)) - (set! user-column (+ user-column 1))) - (set! user-offset (+ user-offset 1)) - c) - (begin - (set! input-f (lambda () 'eof)) - 'eof)))))) - (user-ungetc-none - (lambda () - (if (> user-ptr start-ptr) - (set! user-ptr (- user-ptr 1))))) - (user-ungetc-line - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (set! user-line (- user-line 1)))))))) - (user-ungetc-all - (lambda () - (if (> user-ptr start-ptr) - (begin - (set! user-ptr (- user-ptr 1)) - (let ((c (string-ref buffer user-ptr))) - (if (char=? c #\newline) - (begin - (set! user-line (- user-line 1)) - (set! user-up-to-date? #f)) - (set! user-column (- user-column 1))) - (set! user-offset (- user-offset 1))))))) - (reorganize-buffer ; Decaler ou agrandir le buffer - (lambda () - (if (< (* 2 start-ptr) buflen) - (let* ((newlen (* 2 buflen)) - (newbuf (make-string newlen)) - (delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! newbuf - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! buffer newbuf) - (set! buflen newlen) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))) - (let ((delta (- start-ptr 1))) - (let loop ((from (- start-ptr 1))) - (if (< from buflen) - (begin - (string-set! buffer - (- from delta) - (string-ref buffer from)) - (loop (+ from 1))))) - (set! read-ptr (- read-ptr delta)) - (set! start-ptr (- start-ptr delta)) - (set! end-ptr (- end-ptr delta)) - (set! point-ptr (- point-ptr delta)) - (set! user-ptr (- user-ptr delta))))))) - (list (cons 'start-go-to-end - (cond ((eq? counters 'none) start-go-to-end-none) - ((eq? counters 'line) start-go-to-end-line) - ((eq? counters 'all ) start-go-to-end-all))) - (cons 'end-go-to-point - end-go-to-point) - (cons 'init-lexeme - (cond ((eq? counters 'none) init-lexeme-none) - ((eq? counters 'line) init-lexeme-line) - ((eq? counters 'all ) init-lexeme-all))) - (cons 'get-start-line - get-start-line) - (cons 'get-start-column - get-start-column) - (cons 'get-start-offset - get-start-offset) - (cons 'peek-left-context - peek-left-context) - (cons 'peek-char - peek-char) - (cons 'read-char - read-char) - (cons 'get-start-end-text - get-start-end-text) - (cons 'get-user-line - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) get-user-line-line) - ((eq? counters 'all ) get-user-line-all))) - (cons 'get-user-column - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-column-all))) - (cons 'get-user-offset - (cond ((eq? counters 'none) #f) - ((eq? counters 'line) #f) - ((eq? counters 'all ) get-user-offset-all))) - (cons 'user-getc - (cond ((eq? counters 'none) user-getc-none) - ((eq? counters 'line) user-getc-line) - ((eq? counters 'all ) user-getc-all))) - (cons 'user-ungetc - (cond ((eq? counters 'none) user-ungetc-none) - ((eq? counters 'line) user-ungetc-line) - ((eq? counters 'all ) user-ungetc-all)))))))) - -; Construit un Input System -; Le premier parametre doit etre parmi "port", "procedure" ou "string" -; Prend un parametre facultatif qui doit etre parmi -; "none", "line" ou "all" -(define lexer-make-IS - (lambda (input-type input . largs) - (let ((counters-type (cond ((null? largs) - 'line) - ((memq (car largs) '(none line all)) - (car largs)) - (else - 'line)))) - (cond ((and (eq? input-type 'port) (input-port? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f (lambda () (read-char input)))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'procedure) (procedure? input)) - (let* ((buffer (make-string lexer-init-buffer-len #\newline)) - (read-ptr 1) - (input-f input)) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - ((and (eq? input-type 'string) (string? input)) - (let* ((buffer (string-append (string #\newline) input)) - (read-ptr (string-length buffer)) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) - (else - (let* ((buffer (string #\newline)) - (read-ptr 1) - (input-f (lambda () 'eof))) - (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) - -; Les fonctions: -; lexer-get-func-getc, lexer-get-func-ungetc, -; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset -(define lexer-get-func-getc - (lambda (IS) (cdr (assq 'user-getc IS)))) -(define lexer-get-func-ungetc - (lambda (IS) (cdr (assq 'user-ungetc IS)))) -(define lexer-get-func-line - (lambda (IS) (cdr (assq 'get-user-line IS)))) -(define lexer-get-func-column - (lambda (IS) (cdr (assq 'get-user-column IS)))) -(define lexer-get-func-offset - (lambda (IS) (cdr (assq 'get-user-offset IS)))) - -; -; Gestion des lexers -; - -; Fabrication de lexer a partir d'arbres de decision -(define lexer-make-tree-lexer - (lambda (tables IS) - (letrec - (; Contenu de la table - (counters-type (vector-ref tables 0)) - (<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-actions (vector-ref tables 3)) - (table-nl-start (vector-ref tables 5)) - (table-no-nl-start (vector-ref tables 6)) - (trees-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8)) - - ; Contenu du IS - (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) - (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) - (IS-init-lexeme (cdr (assq 'init-lexeme IS))) - (IS-get-start-line (cdr (assq 'get-start-line IS))) - (IS-get-start-column (cdr (assq 'get-start-column IS))) - (IS-get-start-offset (cdr (assq 'get-start-offset IS))) - (IS-peek-left-context (cdr (assq 'peek-left-context IS))) - (IS-peek-char (cdr (assq 'peek-char IS))) - (IS-read-char (cdr (assq 'read-char IS))) - (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) - (IS-get-user-line (cdr (assq 'get-user-line IS))) - (IS-get-user-column (cdr (assq 'get-user-column IS))) - (IS-get-user-offset (cdr (assq 'get-user-offset IS))) - (IS-user-getc (cdr (assq 'user-getc IS))) - (IS-user-ungetc (cdr (assq 'user-ungetc IS))) - - ; Resultats - (<>-action #f) - (<>-action #f) - (rules-actions #f) - (states #f) - (final-lexer #f) - - ; Gestion des hooks - (hook-list '()) - (add-hook - (lambda (thunk) - (set! hook-list (cons thunk hook-list)))) - (apply-hooks - (lambda () - (let loop ((l hook-list)) - (if (pair? l) - (begin - ((car l)) - (loop (cdr l))))))) - - ; Preparation des actions - (set-action-statics - (lambda (pre-action) - (pre-action final-lexer IS-user-getc IS-user-ungetc))) - (prepare-special-action-none - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda () - (action ""))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-line - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline) - (action "" yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action-all - (lambda (pre-action) - (let ((action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (action "" yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-special-action - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-special-action-none pre-action)) - ((eq? counters-type 'line) - (prepare-special-action-line pre-action)) - ((eq? counters-type 'all) - (prepare-special-action-all pre-action))))) - (prepare-action-yytext-none - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-line - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext-all - (lambda (pre-action) - (let ((get-start-end-text IS-get-start-end-text) - (start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (let ((yytext (get-start-end-text))) - (start-go-to-end) - (action yytext yyline yycolumn yyoffset)))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-yytext-all pre-action))))) - (prepare-action-no-yytext-none - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda () - (start-go-to-end) - (action))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-line - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline) - (start-go-to-end) - (action yyline))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext-all - (lambda (pre-action) - (let ((start-go-to-end IS-start-go-to-end) - (action #f)) - (let ((result - (lambda (yyline yycolumn yyoffset) - (start-go-to-end) - (action yyline yycolumn yyoffset))) - (hook - (lambda () - (set! action (set-action-statics pre-action))))) - (add-hook hook) - result)))) - (prepare-action-no-yytext - (lambda (pre-action) - (cond ((eq? counters-type 'none) - (prepare-action-no-yytext-none pre-action)) - ((eq? counters-type 'line) - (prepare-action-no-yytext-line pre-action)) - ((eq? counters-type 'all) - (prepare-action-no-yytext-all pre-action))))) - - ; Fabrique les fonctions de dispatch - (prepare-dispatch-err - (lambda (leaf) - (lambda (c) - #f))) - (prepare-dispatch-number - (lambda (leaf) - (let ((state-function #f)) - (let ((result - (lambda (c) - state-function)) - (hook - (lambda () - (set! state-function (vector-ref states leaf))))) - (add-hook hook) - result)))) - (prepare-dispatch-leaf - (lambda (leaf) - (if (eq? leaf 'err) - (prepare-dispatch-err leaf) - (prepare-dispatch-number leaf)))) - (prepare-dispatch-< - (lambda (tree) - (let ((left-tree (list-ref tree 1)) - (right-tree (list-ref tree 2))) - (let ((bound (list-ref tree 0)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (< c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-= - (lambda (tree) - (let ((left-tree (list-ref tree 2)) - (right-tree (list-ref tree 3))) - (let ((bound (list-ref tree 1)) - (left-func (prepare-dispatch-tree left-tree)) - (right-func (prepare-dispatch-tree right-tree))) - (lambda (c) - (if (= c bound) - (left-func c) - (right-func c))))))) - (prepare-dispatch-tree - (lambda (tree) - (cond ((not (pair? tree)) - (prepare-dispatch-leaf tree)) - ((eq? (car tree) '=) - (prepare-dispatch-= tree)) - (else - (prepare-dispatch-< tree))))) - (prepare-dispatch - (lambda (tree) - (let ((dicho-func (prepare-dispatch-tree tree))) - (lambda (c) - (and c (dicho-func c)))))) - - ; Fabrique les fonctions de transition (read & go) et (abort) - (prepare-read-n-go - (lambda (tree) - (let ((dispatch-func (prepare-dispatch tree)) - (read-char IS-read-char)) - (lambda () - (dispatch-func (read-char)))))) - (prepare-abort - (lambda (tree) - (lambda () - #f))) - (prepare-transition - (lambda (tree) - (if (eq? tree 'err) - (prepare-abort tree) - (prepare-read-n-go tree)))) - - ; Fabrique les fonctions d'etats ([set-end] & trans) - (prepare-state-no-acc - (lambda (s r1 r2) - (let ((trans-func (prepare-transition (vector-ref trees-v s)))) - (lambda (action) - (let ((next-state (trans-func))) - (if next-state - (next-state action) - action)))))) - (prepare-state-yes-no - (lambda (s r1 r2) - (let ((peek-char IS-peek-char) - (end-go-to-point IS-end-go-to-point) - (new-action1 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - (begin - (end-go-to-point) - new-action1) - action)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state-diff-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (peek-char IS-peek-char) - (new-action1 #f) - (new-action2 #f) - (trans-func (prepare-transition (vector-ref trees-v s)))) - (let ((result - (lambda (action) - (end-go-to-point) - (let* ((c (peek-char)) - (new-action - (if (or (not c) (= c lexer-integer-newline)) - new-action1 - new-action2)) - (next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action1 (vector-ref rules-actions r1)) - (set! new-action2 (vector-ref rules-actions r2))))) - (add-hook hook) - result)))) - (prepare-state-same-acc - (lambda (s r1 r2) - (let ((end-go-to-point IS-end-go-to-point) - (trans-func (prepare-transition (vector-ref trees-v s))) - (new-action #f)) - (let ((result - (lambda (action) - (end-go-to-point) - (let ((next-state (trans-func))) - (if next-state - (next-state new-action) - new-action)))) - (hook - (lambda () - (set! new-action (vector-ref rules-actions r1))))) - (add-hook hook) - result)))) - (prepare-state - (lambda (s) - (let* ((acc (vector-ref acc-v s)) - (r1 (car acc)) - (r2 (cdr acc))) - (cond ((not r1) (prepare-state-no-acc s r1 r2)) - ((not r2) (prepare-state-yes-no s r1 r2)) - ((< r1 r2) (prepare-state-diff-acc s r1 r2)) - (else (prepare-state-same-acc s r1 r2)))))) - - ; Fabrique la fonction de lancement du lexage a l'etat de depart - (prepare-start-same - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (start-state #f) - (error-action #f)) - (let ((result - (lambda () - (if (not (peek-char)) - eof-action - (start-state error-action)))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state (vector-ref states s1)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start-diff - (lambda (s1 s2) - (let ((peek-char IS-peek-char) - (eof-action #f) - (peek-left-context IS-peek-left-context) - (start-state1 #f) - (start-state2 #f) - (error-action #f)) - (let ((result - (lambda () - (cond ((not (peek-char)) - eof-action) - ((= (peek-left-context) lexer-integer-newline) - (start-state1 error-action)) - (else - (start-state2 error-action))))) - (hook - (lambda () - (set! eof-action <>-action) - (set! start-state1 (vector-ref states s1)) - (set! start-state2 (vector-ref states s2)) - (set! error-action <>-action)))) - (add-hook hook) - result)))) - (prepare-start - (lambda () - (let ((s1 table-nl-start) - (s2 table-no-nl-start)) - (if (= s1 s2) - (prepare-start-same s1 s2) - (prepare-start-diff s1 s2))))) - - ; Fabrique la fonction principale - (prepare-lexer-none - (lambda () - (let ((init-lexeme IS-init-lexeme) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - ((start-func)))))) - (prepare-lexer-line - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line))) - ((start-func) yyline)))))) - (prepare-lexer-all - (lambda () - (let ((init-lexeme IS-init-lexeme) - (get-start-line IS-get-start-line) - (get-start-column IS-get-start-column) - (get-start-offset IS-get-start-offset) - (start-func (prepare-start))) - (lambda () - (init-lexeme) - (let ((yyline (get-start-line)) - (yycolumn (get-start-column)) - (yyoffset (get-start-offset))) - ((start-func) yyline yycolumn yyoffset)))))) - (prepare-lexer - (lambda () - (cond ((eq? counters-type 'none) (prepare-lexer-none)) - ((eq? counters-type 'line) (prepare-lexer-line)) - ((eq? counters-type 'all) (prepare-lexer-all)))))) - - ; Calculer la valeur de <>-action et de <>-action - (set! <>-action (prepare-special-action <>-pre-action)) - (set! <>-action (prepare-special-action <>-pre-action)) - - ; Calculer la valeur de rules-actions - (let* ((len (quotient (vector-length rules-pre-actions) 2)) - (v (make-vector len))) - (let loop ((r (- len 1))) - (if (< r 0) - (set! rules-actions v) - (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) - (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) - (action (if yytext? - (prepare-action-yytext pre-action) - (prepare-action-no-yytext pre-action)))) - (vector-set! v r action) - (loop (- r 1)))))) - - ; Calculer la valeur de states - (let* ((len (vector-length trees-v)) - (v (make-vector len))) - (let loop ((s (- len 1))) - (if (< s 0) - (set! states v) - (begin - (vector-set! v s (prepare-state s)) - (loop (- s 1)))))) - - ; Calculer la valeur de final-lexer - (set! final-lexer (prepare-lexer)) - - ; Executer les hooks - (apply-hooks) - - ; Resultat - final-lexer))) - -; Fabrication de lexer a partir de listes de caracteres taggees -(define lexer-make-char-lexer - (let* ((char->class - (lambda (c) - (let ((n (char->integer c))) - (list (cons n n))))) - (merge-sort - (lambda (l combine zero-elt) - (if (null? l) - zero-elt - (let loop1 ((l l)) - (if (null? (cdr l)) - (car l) - (loop1 - (let loop2 ((l l)) - (cond ((null? l) - l) - ((null? (cdr l)) - l) - (else - (cons (combine (car l) (cadr l)) - (loop2 (cddr l)))))))))))) - (finite-class-union - (lambda (c1 c2) - (let loop ((c1 c1) (c2 c2) (u '())) - (if (null? c1) - (if (null? c2) - (reverse u) - (loop c1 (cdr c2) (cons (car c2) u))) - (if (null? c2) - (loop (cdr c1) c2 (cons (car c1) u)) - (let* ((r1 (car c1)) - (r2 (car c2)) - (r1start (car r1)) - (r1end (cdr r1)) - (r2start (car r2)) - (r2end (cdr r2))) - (if (<= r1start r2start) - (cond ((< (+ r1end 1) r2start) - (loop (cdr c1) c2 (cons r1 u))) - ((<= r1end r2end) - (loop (cdr c1) - (cons (cons r1start r2end) (cdr c2)) - u)) - (else - (loop c1 (cdr c2) u))) - (cond ((> r1start (+ r2end 1)) - (loop c1 (cdr c2) (cons r2 u))) - ((>= r1end r2end) - (loop (cons (cons r2start r1end) (cdr c1)) - (cdr c2) - u)) - (else - (loop (cdr c1) c2 u)))))))))) - (char-list->class - (lambda (cl) - (let ((classes (map char->class cl))) - (merge-sort classes finite-class-union '())))) - (class-< - (lambda (b1 b2) - (cond ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - (else (< b1 b2))))) - (finite-class-compl - (lambda (c) - (let loop ((c c) (start 'inf-)) - (if (null? c) - (list (cons start 'inf+)) - (let* ((r (car c)) - (rstart (car r)) - (rend (cdr r))) - (if (class-< start rstart) - (cons (cons start (- rstart 1)) - (loop c rstart)) - (loop (cdr c) (+ rend 1)))))))) - (tagged-chars->class - (lambda (tcl) - (let* ((inverse? (car tcl)) - (cl (cdr tcl)) - (class-tmp (char-list->class cl))) - (if inverse? (finite-class-compl class-tmp) class-tmp)))) - (charc->arc - (lambda (charc) - (let* ((tcl (car charc)) - (dest (cdr charc)) - (class (tagged-chars->class tcl))) - (cons class dest)))) - (arc->sharcs - (lambda (arc) - (let* ((range-l (car arc)) - (dest (cdr arc)) - (op (lambda (range) (cons range dest)))) - (map op range-l)))) - (class-<= - (lambda (b1 b2) - (cond ((eq? b1 'inf-) #t) - ((eq? b2 'inf+) #t) - ((eq? b1 'inf+) #f) - ((eq? b2 'inf-) #f) - (else (<= b1 b2))))) - (sharc-<= - (lambda (sharc1 sharc2) - (class-<= (caar sharc1) (caar sharc2)))) - (merge-sharcs - (lambda (l1 l2) - (let loop ((l1 l1) (l2 l2)) - (cond ((null? l1) - l2) - ((null? l2) - l1) - (else - (let ((sharc1 (car l1)) - (sharc2 (car l2))) - (if (sharc-<= sharc1 sharc2) - (cons sharc1 (loop (cdr l1) l2)) - (cons sharc2 (loop l1 (cdr l2)))))))))) - (class-= eqv?) - (fill-error - (lambda (sharcs) - (let loop ((sharcs sharcs) (start 'inf-)) - (cond ((class-= start 'inf+) - '()) - ((null? sharcs) - (cons (cons (cons start 'inf+) 'err) - (loop sharcs 'inf+))) - (else - (let* ((sharc (car sharcs)) - (h (caar sharc)) - (t (cdar sharc))) - (if (class-< start h) - (cons (cons (cons start (- h 1)) 'err) - (loop sharcs h)) - (cons sharc (loop (cdr sharcs) - (if (class-= t 'inf+) - 'inf+ - (+ t 1))))))))))) - (charcs->tree - (lambda (charcs) - (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) - (sharcs-l (map op charcs)) - (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) - (full-sharcs (fill-error sorted-sharcs)) - (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) - (table (list->vector (map op full-sharcs)))) - (let loop ((left 0) (right (- (vector-length table) 1))) - (if (= left right) - (cdr (vector-ref table left)) - (let ((mid (quotient (+ left right 1) 2))) - (if (and (= (+ left 2) right) - (= (+ (car (vector-ref table mid)) 1) - (car (vector-ref table right))) - (eqv? (cdr (vector-ref table left)) - (cdr (vector-ref table right)))) - (list '= - (car (vector-ref table mid)) - (cdr (vector-ref table mid)) - (cdr (vector-ref table left))) - (list (car (vector-ref table mid)) - (loop left (- mid 1)) - (loop mid right)))))))))) - (lambda (tables IS) - (let ((counters (vector-ref tables 0)) - (<>-action (vector-ref tables 1)) - (<>-action (vector-ref tables 2)) - (rules-actions (vector-ref tables 3)) - (nl-start (vector-ref tables 5)) - (no-nl-start (vector-ref tables 6)) - (charcs-v (vector-ref tables 7)) - (acc-v (vector-ref tables 8))) - (let* ((len (vector-length charcs-v)) - (v (make-vector len))) - (let loop ((i (- len 1))) - (if (>= i 0) - (begin - (vector-set! v i (charcs->tree (vector-ref charcs-v i))) - (loop (- i 1))) - (lexer-make-tree-lexer - (vector counters - <>-action - <>-action - rules-actions - 'decision-trees - nl-start - no-nl-start - v - acc-v) - IS)))))))) - -; Fabrication d'un lexer a partir de code pre-genere -(define lexer-make-code-lexer - (lambda (tables IS) - (let ((<>-pre-action (vector-ref tables 1)) - (<>-pre-action (vector-ref tables 2)) - (rules-pre-action (vector-ref tables 3)) - (code (vector-ref tables 5))) - (code <>-pre-action <>-pre-action rules-pre-action IS)))) - -(define lexer-make-lexer - (lambda (tables IS) - (let ((automaton-type (vector-ref tables 4))) - (cond ((eq? automaton-type 'decision-trees) - (lexer-make-tree-lexer tables IS)) - ((eq? automaton-type 'tagged-chars-lists) - (lexer-make-char-lexer tables IS)) - ((eq? automaton-type 'code) - (lexer-make-code-lexer tables IS)))))) - -; -; Table generated from the file xml-lex.l by SILex 1.0 -; - -(define lexer-default-table - (vector - 'line - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - 'eof - )) - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (skribe-error 'xml-fontifier "Parse error" yytext) - )) - (vector - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-string) - (body yytext)) - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-string) - (body yytext)) - -;;Comment - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-comment) - (body yytext)) - -;; Markup - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-module) - (body yytext)) - -;; Regular text - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin yytext) - ))) - 'decision-trees - 0 - 0 - '#((40 (35 (34 1 5) (39 1 4)) (61 (60 1 3) (= 62 2 1))) (40 (35 (34 1 - err) (39 1 err)) (61 (60 1 err) (= 62 err 1))) err (33 (11 (10 6 err) - (32 6 err)) (62 (34 7 6) (63 err 6))) (= 39 8 4) (= 34 9 5) (32 (= 10 - err 6) (62 (33 err 6) (63 err 6))) (33 (11 (10 6 err) (32 6 err)) (46 - (45 6 10) (= 62 err 6))) err err (33 (11 (10 6 err) (32 6 err)) (46 (45 - 6 11) (= 62 err 6))) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 13) (= - 62 12 11))) (= 45 14 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 15) - (= 62 12 11))) (= 45 16 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 - 15) (= 62 17 11))) (46 (45 12 16) (= 62 17 12)) (= 45 14 12)) - '#((#f . #f) (4 . 4) (3 . 3) (#f . #f) (#f . #f) (#f . #f) (3 . 3) (3 . - 3) (1 . 1) (0 . 0) (3 . 3) (3 . 3) (#f . #f) (3 . 3) (#f . #f) (3 . 3) - (#f . #f) (2 . 2)))) - -; -; User functions -; - -(define lexer #f) - -(define lexer-get-line #f) -(define lexer-getc #f) -(define lexer-ungetc #f) - -(define lexer-init - (lambda (input-type input) - (let ((IS (lexer-make-IS input-type input 'line))) - (set! lexer (lexer-make-lexer lexer-default-table IS)) - (set! lexer-get-line (lexer-get-func-line IS)) - (set! lexer-getc (lexer-get-func-getc IS)) - (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/coloring/xml.scm b/src/guile/skribilo/coloring/xml.scm deleted file mode 100644 index f6d69fd..0000000 --- a/src/guile/skribilo/coloring/xml.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;; xml.scm -- XML syntax highlighting. -;;; -;;; Copyright 2005 Ludovic Courtès -;;; -;;; -;;; 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 lib) - :use-module (ice-9 regex)) - - -(define %comment-rx (make-regexp "" 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/module.scm b/src/guile/skribilo/module.scm index 81d2a16..4e47192 100644 --- a/src/guile/skribilo/module.scm +++ b/src/guile/skribilo/module.scm @@ -75,9 +75,9 @@ ((skribilo source) . (source-read-lines source-fontify language? language-extractor language-fontifier source-fontify)) - ((skribilo coloring lisp) . (skribe scheme lisp)) - ((skribilo coloring xml) . (xml)) - ((skribilo coloring c) . (c java)) + ((skribilo source lisp) . (skribe scheme stklos bigloo lisp)) + ((skribilo source xml) . (xml)) + ((skribilo source c) . (c java)) ((skribilo prog) . (make-prog-body resolve-line)) ((skribilo color) . (skribe-color->rgb skribe-get-used-colors skribe-use-color!)) diff --git a/src/guile/skribilo/source/Makefile.am b/src/guile/skribilo/source/Makefile.am new file mode 100644 index 0000000..4c961cf --- /dev/null +++ b/src/guile/skribilo/source/Makefile.am @@ -0,0 +1,31 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/source +dist_guilemodule_DATA = parameters.scm c.scm lisp.scm xml.scm \ + lisp-lex.scm xml-lex.scm c-lex.scm + + +EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l + +# Building the lexers with SILex. You must previously run +# `tla build-config ./arch-config' for this to run. +# +# Note: Those files should normally be part of the distribution, making +# this rule useless to the user. +.l.scm: + $(GUILE) -L $(top_srcdir)/src/guile/silex \ + -c '(load-from-path "lex.scm") (lex "$^" "$@")' && \ + mv "$@" "$@.tmp" && \ + echo '(define-module (skribilo source $(^:%.l=%))' > "$@" && \ + echo ' :use-module (skribilo lib)' >> "$@" && \ + echo ' :use-module (skribilo source parameters)' \ + >> "$@" && \ + echo ' :use-module (srfi srfi-1)' >> "$@" && \ + echo ' :export (lexer-init lexer' >> "$@" && \ + echo ' lexer-get-func-column' >> "$@" && \ + echo ' lexer-get-func-offset' >> "$@" && \ + echo ' lexer-get-line lexer-getc' >> "$@" && \ + echo ' lexer-ungetc))' >> "$@" && \ + cat "$@.tmp" >> "$@" && \ + rm "$@.tmp" + + +include $(top_srcdir)/guile-lint.am diff --git a/src/guile/skribilo/source/c-lex.l b/src/guile/skribilo/source/c-lex.l new file mode 100644 index 0000000..b28a91a --- /dev/null +++ b/src/guile/skribilo/source/c-lex.l @@ -0,0 +1,73 @@ +;;; c-lex.l -- C fontifier for Skribilo. +;;; +;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2007 Ludovic Courtès +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +space [ \n\9] +letter [_a-zA-Z] +alphanum [_a-zA-Z0-9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +;; Comments +;; FIXME: We shouldn't exclude `/' from comments but we do so to match the +;; shortest multi-line comment. +/\*(\n|[^/])*\*/ (let* ((not-line (char-set-complement (char-set #\newline))) + (lines (string-tokenize yytext not-line))) + (reverse! + (pair-fold (lambda (line* result) + (let* ((line (car line*)) + (last? (null? (cdr line*))) + (markup + (new markup + (markup '&source-line-comment) + (body line)))) + (if last? + (cons markup result) + (cons* (string #\newline) + markup result)))) + '() + lines))) + +//.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) +[_a-zA-Z]+ (let* ((ident (string->symbol yytext)) + (tmp (memq ident (*the-keys*)))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text (excluding `/' and `*') +[^\"a-zA-Z/*]+ (begin yytext) + +;; `/' and `*' alone. +/[^\*] (begin yytext) +\*[^/] (begin yytext) + + +<> 'eof +<> (skribe-error 'c-fontifier "Parse error" yytext) diff --git a/src/guile/skribilo/source/c-lex.scm b/src/guile/skribilo/source/c-lex.scm new file mode 100644 index 0000000..72c4929 --- /dev/null +++ b/src/guile/skribilo/source/c-lex.scm @@ -0,0 +1,1257 @@ +(define-module (skribilo source c-lex) + :use-module (skribilo lib) + :use-module (skribilo source parameters) + :use-module (srfi srfi-1) + :export (lexer-init lexer + lexer-get-func-column + lexer-get-func-offset + lexer-get-line lexer-getc + lexer-ungetc)) +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file c-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'c-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) +;; Comments +;; FIXME: We shouldn't exclude `/' from comments but we do so to match the +;; shortest multi-line comment. + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let* ((not-line (char-set-complement (char-set #\newline))) + (lines (string-tokenize yytext not-line))) + (reverse! + (pair-fold (lambda (line* result) + (let* ((line (car line*)) + (last? (null? (cdr line*))) + (markup + (new markup + (markup '&source-line-comment) + (body line)))) + (if last? + (cons markup result) + (cons* (string #\newline) + markup result)))) + '() + lines))) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Identifiers (only letters since we are interested in keywords only) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let* ((ident (string->symbol yytext)) + (tmp (memq ident (*the-keys*)))) + (if tmp + (new markup + (markup '&source-module) + (body yytext)) + yytext)) + +;; Regular text (excluding `/' and `*') + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + +;; `/' and `*' alone. + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((48 (42 (= 34 6 2) (43 1 (47 2 5))) (95 (65 2 (91 4 2)) (97 (96 3 2) + (123 4 2)))) (= 47 err 7) (47 (35 (34 2 err) (= 42 err 2)) (91 (48 err + (65 2 err)) (97 2 (123 err 2)))) (48 (42 (= 34 err 2) (43 err (47 2 + err))) (95 (65 2 (91 4 2)) (97 (96 3 2) (123 4 2)))) (95 (65 err (91 4 + err)) (97 (96 4 err) (123 4 err))) (43 (42 8 10) (= 47 9 8)) (= 34 11 + 6) err err (= 10 err 12) (43 (42 10 13) (= 47 err 10)) err (= 10 err + 12) (43 (42 10 13) (= 47 14 10)) err) + '#((#f . #f) (#f . #f) (4 . 4) (3 . 3) (3 . 3) (#f . #f) (#f . #f) (6 . + 6) (5 . 5) (2 . 2) (#f . #f) (0 . 0) (2 . 2) (#f . #f) (1 . 1)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/source/c.scm b/src/guile/skribilo/source/c.scm new file mode 100644 index 0000000..a0d04e0 --- /dev/null +++ b/src/guile/skribilo/source/c.scm @@ -0,0 +1,86 @@ +;;; c.scm -- C fontifier. +;;; +;;; Copyright 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2007 Ludovic Courtès +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo source c) + :use-module (skribilo lib) + :use-module (skribilo utils syntax) + :use-module (skribilo source c-lex) ;; SILex generated + :use-module (skribilo source parameters) + :use-module (srfi srfi-39) + :export (c c-language java)) + +(fluid-set! current-reader %skribilo-module-reader) + + +;;; +;;; Generic fontifier. +;;; + +(define (fontifier s) + (lexer-init 'port (open-input-string s)) + (let loop ((token (lexer)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (loop (lexer) + (cons token res))))) + + +;;; +;;; C. +;;; + +(define %c-keys + '(for while return break continue void do if else typedef struct union + goto switch case static extern default)) + +(define (c-fontifier s) + (parameterize ((*the-keys* %c-keys)) + (fontifier s))) + +(define c + (new language + (name "C") + (fontifier c-fontifier) + (extractor #f))) + +(define c-language + ;; This alias is defined for the user's convenience. + c) + + +;;; +;;; Java. +;;; + +(define %java-keys + (append %c-keys + '(public final class throw catch))) + +(define (java-fontifier s) + (parameterize ((*the-keys* %java-keys)) + (fontifier s))) + +(define java + (new language + (name "java") + (fontifier java-fontifier) + (extractor #f))) diff --git a/src/guile/skribilo/source/lisp-lex.l b/src/guile/skribilo/source/lisp-lex.l new file mode 100644 index 0000000..30b6a44 --- /dev/null +++ b/src/guile/skribilo/source/lisp-lex.l @@ -0,0 +1,86 @@ +;;; lisp-lex.l -- SILex input for the Lisp Languages +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2006 Ludovic Courtès +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +space [ \n\9] +letter [#?!_:a-zA-Z\-] +digit [0-9] + + +%% +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) + +;;Comment +\;.* (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) +\[|\] (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis +[ \n\9\(\)]+ (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) +[^\;\"\[\] \n\9\(\)]+ (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if (*class-highlight*) + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + (*the-keys*)))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + + +<> 'eof +<> (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify diff --git a/src/guile/skribilo/source/lisp-lex.scm b/src/guile/skribilo/source/lisp-lex.scm new file mode 100644 index 0000000..3b47d95 --- /dev/null +++ b/src/guile/skribilo/source/lisp-lex.scm @@ -0,0 +1,1258 @@ +(define-module (skribilo source lisp-lex) + :use-module (skribilo lib) + :use-module (skribilo source parameters) + :use-module (srfi srfi-1) + :export (lexer-init lexer + lexer-get-func-column + lexer-get-func-offset + lexer-get-line lexer-getc + lexer-ungetc)) +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file lisp-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'lisp-fontifier "Parse error" yytext) + + +; LocalWords: fontify + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + +;; Skribe text (i.e. [....]) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (if (*bracket-highlight*) + (new markup + (markup '&source-bracket) + (body yytext)) + yytext) +;; Spaces & parenthesis + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin + yytext) + +;; Identifier (real syntax is slightly more complicated but we are +;; interested here in the identifiers that we will fontify) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (let ((c (string-ref yytext 0))) + (cond + ((or (char=? c #\:) + (char=? (string-ref yytext + (- (string-length yytext) 1)) + #\:)) + ;; Scheme keyword + (new markup + (markup '&source-type) + (body yytext))) + ((char=? c #\<) + ;; STklos class + (let* ((len (string-length yytext)) + (c (string-ref yytext (- len 1)))) + (if (char=? c #\>) + (if (*class-highlight*) + (new markup + (markup '&source-module) + (body yytext)) + yytext) ; no + yytext))) ; no + (else + (let ((tmp (assoc (string->symbol yytext) + (*the-keys*)))) + (if tmp + (new markup + (markup (cdr tmp)) + (body yytext)) + yytext))))) + ))) + 'decision-trees + 0 + 0 + '#((40 (32 (9 1 (11 2 1)) (34 (33 2 1) (35 5 1))) (91 (59 (42 2 1) (60 4 + 1)) (93 (92 3 1) (94 3 1)))) (40 (32 (9 1 (11 err 1)) (34 (33 err 1) + (35 err 1))) (91 (59 (42 err 1) (60 err 1)) (93 (92 err 1) (94 err + 1)))) (32 (9 err (11 2 err)) (40 (33 2 err) (42 2 err))) err (= 10 err + 4) (= 34 6 5) err) + '#((#f . #f) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (#f . #f) (0 . 0)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/source/lisp.scm b/src/guile/skribilo/source/lisp.scm new file mode 100644 index 0000000..77f1c9b --- /dev/null +++ b/src/guile/skribilo/source/lisp.scm @@ -0,0 +1,292 @@ +;;; lisp.scm -- Lisp Family Fontification +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI +;;; Copyright 2005, 2006, 2007 Ludovic Courtès +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + + +(define-module (skribilo source lisp) + :use-module (skribilo utils syntax) + :use-module (skribilo source) + :use-module (skribilo source parameters) + :use-module (skribilo lib) + :use-module (srfi srfi-39) + :use-module (ice-9 match) + :autoload (skribilo reader) (make-reader) + :autoload (skribilo source lisp-lex) (lexer-init) + :export (skribe scheme stklos bigloo lisp)) + + +(define %lisp-keys #f) +(define %scheme-keys #f) +(define %skribe-keys #f) +(define %stklos-keys #f) +(define %lisp-keys #f) + + + +;;; +;;; definition-search +;;; + +(define (definition-search inp read tab def?) + (let Loop ((exp (read inp))) + (unless (eof-object? exp) + (if (def? exp) + (let ((start (and (pair? exp) (source-property exp 'line))) + (stop (port-line inp))) + (source-read-lines (port-filename inp) start stop tab)) + (Loop (read inp)))))) + +(define (lisp-family-fontifier s) + (lexer-init 'port (open-input-string s)) + (let loop ((token (lexer)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (loop (lexer) + (cons token res))))) + + +;;; +;;; Lisp. +;;; + +(define (lisp-extractor iport def tab) + (definition-search + iport + read + tab + (lambda (exp) + (match exp + (((or 'defun 'defmacro) fun _ . _) + (and (eq? def fun) exp)) + (('defvar var . _) + (and (eq? var def) exp)) + (else #f))))) + +(define (init-lisp-keys) + (unless %lisp-keys + (set! %lisp-keys + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(setq if let let* letrec cond case else progn lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(defun defclass defmacro))))) + %lisp-keys) + +(define (lisp-fontifier s) + (parameterize ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define lisp + (new language + (name "lisp") + (fontifier lisp-fontifier) + (extractor lisp-extractor))) + + +;;; +;;; Scheme. +;;; + +(define (scheme-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro) (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? symbol? var) . _) + (and (eq? var def) exp)) + (else #f))))) + + +(define (init-scheme-keys) + (unless %scheme-keys + (set! %scheme-keys + (append ;; key + (map (lambda (x) (cons x '&source-keyword)) + '(set! if let let* letrec quote cond case else begin do lambda)) + ;; define + (map (lambda (x) (cons x '&source-define)) + '(define define-syntax))))) + %scheme-keys) + + +(define (scheme-fontifier s) + (parameterize ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) + + +(define scheme + (new language + (name "scheme") + (fontifier scheme-fontifier) + (extractor scheme-extractor))) + + +;;; +;;; STkLos. +;;; + +(define (stklos-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-generic 'define-method 'define-macro) + (fun . _) . _) + (and (eq? def fun) exp)) + (((or 'define 'define-module) (? symbol? var) . _) + (and (eq? var def) exp)) + (else + #f))))) + + +(define (init-stklos-keys) + (unless %stklos-keys + (init-scheme-keys) + (set! %stklos-keys (append %scheme-keys + ;; Markups + (map (lambda (x) (cons x '&source-key)) + '(select-module import export)) + ;; Key + (map (lambda (x) (cons x '&source-keyword)) + '(case-lambda dotimes match-case match-lambda)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-generic define-class + define-macro define-method define-module)) + ;; error + (map (lambda (x) (cons x '&source-error)) + '(error call/cc))))) + %stklos-keys) + + +(define (stklos-fontifier s) + (parameterize ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define stklos + (new language + (name "stklos") + (fontifier stklos-fontifier) + (extractor stklos-extractor))) + + +;;; +;;; Skribe. +;;; + +(define (skribe-extractor iport def tab) + (definition-search + iport + (make-reader 'skribe) + tab + (lambda (exp) + (match exp + (((or 'define 'define-macro 'define-markup 'define-public) + (fun . _) . _) + (and (eq? def fun) exp)) + (('define (? symbol? var) . _) + (and (eq? var def) exp)) + (('markup-output (quote mk) . _) + (and (eq? mk def) exp)) + (else #f))))) + + +(define (init-skribe-keys) + (unless %skribe-keys + (init-stklos-keys) + (set! %skribe-keys (append %stklos-keys + ;; Markups + (map (lambda (x) (cons x '&source-markup)) + '(bold it emph tt color ref index underline + roman figure center pre flush hrule + linebreak image kbd code var samp + sc sf sup sub + itemize description enumerate item + table tr td th item prgm author + prgm hook font + document chapter section subsection + subsubsection paragraph p handle resolve + processor abstract margin toc + table-of-contents current-document + current-chapter current-section + document-sections* section-number + footnote print-index include skribe-load + slide)) + ;; Define + (map (lambda (x) (cons x '&source-define)) + '(define-markup))))) + %skribe-keys) + + +(define (skribe-fontifier s) + (parameterize ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) + + +(define skribe + (new language + (name "skribe") + (fontifier skribe-fontifier) + (extractor skribe-extractor))) + + +;;; +;;; Bigloo. +;;; + +(define (bigloo-extractor iport def tab) + (definition-search + iport + %skribilo-module-reader + tab + (lambda (exp) + (match exp + (((or 'define 'define-inline 'define-generic + 'define-method 'define-macro 'define-expander) + (fun . _) . _) + (and (eq? def fun) exp)) + (((or 'define 'define-struct 'define-library) + (? symbol? var) . _) + (and (eq? var def) exp)) + (else #f))))) + +(define bigloo + (new language + (name "bigloo") + (fontifier scheme-fontifier) + (extractor bigloo-extractor))) diff --git a/src/guile/skribilo/source/parameters.scm b/src/guile/skribilo/source/parameters.scm new file mode 100644 index 0000000..9bcb8e6 --- /dev/null +++ b/src/guile/skribilo/source/parameters.scm @@ -0,0 +1,33 @@ +;;; lisp.scm -- Lisp Family Fontification +;;; +;;; Copyright 2007 Ludovic Courtès +;;; +;;; +;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo source parameters) + :use-module (srfi srfi-39) + :export (*bracket-highlight* *class-highlight* *the-keys*)) + +;;; +;;; Parameters used by the fontifiers. +;;; + +(define *bracket-highlight* (make-parameter #t)) +(define *class-highlight* (make-parameter #t)) +(define *the-keys* (make-parameter '())) + +;;; arch-tag: 232c250e-0022-418f-9219-03b4446d0b55 diff --git a/src/guile/skribilo/source/xml-lex.l b/src/guile/skribilo/source/xml-lex.l new file mode 100644 index 0000000..aa7d312 --- /dev/null +++ b/src/guile/skribilo/source/xml-lex.l @@ -0,0 +1,64 @@ +;;;; -*- Scheme -*- +;;;; +;;;; xml-lex.l -- SILex input for the XML languages +;;;; +;;;; Copyright © 2003 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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 Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Author: Erick Gallesio [eg@essi.fr] +;;;; Creation date: 21-Dec-2003 17:19 (eg) +;;;; Last file update: 21-Dec-2003 22:38 (eg) +;;;; + +space [ \n\9] + +%% + +;; Strings +\"[^\"]*\" (new markup + (markup '&source-string) + (body yytext)) +'[^']*' (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup +<[^>\n ]+|> (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text +[^<>\"']+ (begin yytext) + + +<> 'eof +<> (skribe-error 'xml-fontifier "Parse error" yytext) + + + + + + + + + \ No newline at end of file diff --git a/src/guile/skribilo/source/xml-lex.scm b/src/guile/skribilo/source/xml-lex.scm new file mode 100644 index 0000000..3ec6668 --- /dev/null +++ b/src/guile/skribilo/source/xml-lex.scm @@ -0,0 +1,1230 @@ +(define-module (skribilo source xml-lex) + :use-module (skribilo lib) + :use-module (skribilo source parameters) + :use-module (srfi srfi-1) + :export (lexer-init lexer + lexer-get-func-column + lexer-get-func-offset + lexer-get-line lexer-getc + lexer-ungetc)) +; *** This file starts with a copy of the file multilex.scm *** +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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. + +; +; Gestion des Input Systems +; Fonctions a utiliser par l'usager: +; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +; + +; Taille initiale par defaut du buffer d'entree +(define lexer-init-buffer-len 1024) + +; Numero du caractere newline +(define lexer-integer-newline (char->integer #\newline)) + +; Constructeur d'IS brut +(define lexer-raw-IS-maker + (lambda (buffer read-ptr input-f counters) + (let ((input-f input-f) ; Entree reelle + (buffer buffer) ; Buffer + (buflen (string-length buffer)) + (read-ptr read-ptr) + (start-ptr 1) ; Marque de debut de lexeme + (start-line 1) + (start-column 1) + (start-offset 0) + (end-ptr 1) ; Marque de fin de lexeme + (point-ptr 1) ; Le point + (user-ptr 1) ; Marque de l'usager + (user-line 1) + (user-column 1) + (user-offset 0) + (user-up-to-date? #t)) ; Concerne la colonne seul. + (letrec + ((start-go-to-end-none ; Fonctions de depl. des marques + (lambda () + (set! start-ptr end-ptr))) + (start-go-to-end-line + (lambda () + (let loop ((ptr start-ptr) (line start-line)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1)) + (loop (+ ptr 1) line)))))) + (start-go-to-end-all + (lambda () + (set! start-offset (+ start-offset (- end-ptr start-ptr))) + (let loop ((ptr start-ptr) + (line start-line) + (column start-column)) + (if (= ptr end-ptr) + (begin + (set! start-ptr ptr) + (set! start-line line) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) (+ line 1) 1) + (loop (+ ptr 1) line (+ column 1))))))) + (start-go-to-user-none + (lambda () + (set! start-ptr user-ptr))) + (start-go-to-user-line + (lambda () + (set! start-ptr user-ptr) + (set! start-line user-line))) + (start-go-to-user-all + (lambda () + (set! start-line user-line) + (set! start-offset user-offset) + (if user-up-to-date? + (begin + (set! start-ptr user-ptr) + (set! start-column user-column)) + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! start-ptr ptr) + (set! start-column column)) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1)))))))) + (end-go-to-point + (lambda () + (set! end-ptr point-ptr))) + (point-go-to-start + (lambda () + (set! point-ptr start-ptr))) + (user-go-to-start-none + (lambda () + (set! user-ptr start-ptr))) + (user-go-to-start-line + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line))) + (user-go-to-start-all + (lambda () + (set! user-ptr start-ptr) + (set! user-line start-line) + (set! user-column start-column) + (set! user-offset start-offset) + (set! user-up-to-date? #t))) + (init-lexeme-none ; Debute un nouveau lexeme + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-none)) + (point-go-to-start))) + (init-lexeme-line + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-line)) + (point-go-to-start))) + (init-lexeme-all + (lambda () + (if (< start-ptr user-ptr) + (start-go-to-user-all)) + (point-go-to-start))) + (get-start-line ; Obtention des stats du debut du lxm + (lambda () + start-line)) + (get-start-column + (lambda () + start-column)) + (get-start-offset + (lambda () + start-offset)) + (peek-left-context ; Obtention de caracteres (#f si EOF) + (lambda () + (char->integer (string-ref buffer (- start-ptr 1))))) + (peek-char + (lambda () + (if (< point-ptr read-ptr) + (char->integer (string-ref buffer point-ptr)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (read-char + (lambda () + (if (< point-ptr read-ptr) + (let ((c (string-ref buffer point-ptr))) + (set! point-ptr (+ point-ptr 1)) + (char->integer c)) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer point-ptr c) + (set! read-ptr (+ point-ptr 1)) + (set! point-ptr read-ptr) + (char->integer c)) + (begin + (set! input-f (lambda () 'eof)) + #f)))))) + (get-start-end-text ; Obtention du lexeme + (lambda () + (substring buffer start-ptr end-ptr))) + (get-user-line-line ; Fonctions pour l'usager + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + user-line)) + (get-user-line-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-line)) + (get-user-column-all + (lambda () + (cond ((< user-ptr start-ptr) + (user-go-to-start-all) + user-column) + (user-up-to-date? + user-column) + (else + (let loop ((ptr start-ptr) (column start-column)) + (if (= ptr user-ptr) + (begin + (set! user-column column) + (set! user-up-to-date? #t) + column) + (if (char=? (string-ref buffer ptr) #\newline) + (loop (+ ptr 1) 1) + (loop (+ ptr 1) (+ column 1))))))))) + (get-user-offset-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + user-offset)) + (user-getc-none + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-none)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-line + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-line)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (set! user-line (+ user-line 1))) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-getc-all + (lambda () + (if (< user-ptr start-ptr) + (user-go-to-start-all)) + (if (< user-ptr read-ptr) + (let ((c (string-ref buffer user-ptr))) + (set! user-ptr (+ user-ptr 1)) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (let ((c (input-f))) + (if (char? c) + (begin + (if (= read-ptr buflen) + (reorganize-buffer)) + (string-set! buffer user-ptr c) + (set! read-ptr (+ read-ptr 1)) + (set! user-ptr read-ptr) + (if (char=? c #\newline) + (begin + (set! user-line (+ user-line 1)) + (set! user-column 1)) + (set! user-column (+ user-column 1))) + (set! user-offset (+ user-offset 1)) + c) + (begin + (set! input-f (lambda () 'eof)) + 'eof)))))) + (user-ungetc-none + (lambda () + (if (> user-ptr start-ptr) + (set! user-ptr (- user-ptr 1))))) + (user-ungetc-line + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (set! user-line (- user-line 1)))))))) + (user-ungetc-all + (lambda () + (if (> user-ptr start-ptr) + (begin + (set! user-ptr (- user-ptr 1)) + (let ((c (string-ref buffer user-ptr))) + (if (char=? c #\newline) + (begin + (set! user-line (- user-line 1)) + (set! user-up-to-date? #f)) + (set! user-column (- user-column 1))) + (set! user-offset (- user-offset 1))))))) + (reorganize-buffer ; Decaler ou agrandir le buffer + (lambda () + (if (< (* 2 start-ptr) buflen) + (let* ((newlen (* 2 buflen)) + (newbuf (make-string newlen)) + (delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! newbuf + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! buffer newbuf) + (set! buflen newlen) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))) + (let ((delta (- start-ptr 1))) + (let loop ((from (- start-ptr 1))) + (if (< from buflen) + (begin + (string-set! buffer + (- from delta) + (string-ref buffer from)) + (loop (+ from 1))))) + (set! read-ptr (- read-ptr delta)) + (set! start-ptr (- start-ptr delta)) + (set! end-ptr (- end-ptr delta)) + (set! point-ptr (- point-ptr delta)) + (set! user-ptr (- user-ptr delta))))))) + (list (cons 'start-go-to-end + (cond ((eq? counters 'none) start-go-to-end-none) + ((eq? counters 'line) start-go-to-end-line) + ((eq? counters 'all ) start-go-to-end-all))) + (cons 'end-go-to-point + end-go-to-point) + (cons 'init-lexeme + (cond ((eq? counters 'none) init-lexeme-none) + ((eq? counters 'line) init-lexeme-line) + ((eq? counters 'all ) init-lexeme-all))) + (cons 'get-start-line + get-start-line) + (cons 'get-start-column + get-start-column) + (cons 'get-start-offset + get-start-offset) + (cons 'peek-left-context + peek-left-context) + (cons 'peek-char + peek-char) + (cons 'read-char + read-char) + (cons 'get-start-end-text + get-start-end-text) + (cons 'get-user-line + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) get-user-line-line) + ((eq? counters 'all ) get-user-line-all))) + (cons 'get-user-column + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-column-all))) + (cons 'get-user-offset + (cond ((eq? counters 'none) #f) + ((eq? counters 'line) #f) + ((eq? counters 'all ) get-user-offset-all))) + (cons 'user-getc + (cond ((eq? counters 'none) user-getc-none) + ((eq? counters 'line) user-getc-line) + ((eq? counters 'all ) user-getc-all))) + (cons 'user-ungetc + (cond ((eq? counters 'none) user-ungetc-none) + ((eq? counters 'line) user-ungetc-line) + ((eq? counters 'all ) user-ungetc-all)))))))) + +; Construit un Input System +; Le premier parametre doit etre parmi "port", "procedure" ou "string" +; Prend un parametre facultatif qui doit etre parmi +; "none", "line" ou "all" +(define lexer-make-IS + (lambda (input-type input . largs) + (let ((counters-type (cond ((null? largs) + 'line) + ((memq (car largs) '(none line all)) + (car largs)) + (else + 'line)))) + (cond ((and (eq? input-type 'port) (input-port? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f (lambda () (read-char input)))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'procedure) (procedure? input)) + (let* ((buffer (make-string lexer-init-buffer-len #\newline)) + (read-ptr 1) + (input-f input)) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + ((and (eq? input-type 'string) (string? input)) + (let* ((buffer (string-append (string #\newline) input)) + (read-ptr (string-length buffer)) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))) + (else + (let* ((buffer (string #\newline)) + (read-ptr 1) + (input-f (lambda () 'eof))) + (lexer-raw-IS-maker buffer read-ptr input-f counters-type))))))) + +; Les fonctions: +; lexer-get-func-getc, lexer-get-func-ungetc, +; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset +(define lexer-get-func-getc + (lambda (IS) (cdr (assq 'user-getc IS)))) +(define lexer-get-func-ungetc + (lambda (IS) (cdr (assq 'user-ungetc IS)))) +(define lexer-get-func-line + (lambda (IS) (cdr (assq 'get-user-line IS)))) +(define lexer-get-func-column + (lambda (IS) (cdr (assq 'get-user-column IS)))) +(define lexer-get-func-offset + (lambda (IS) (cdr (assq 'get-user-offset IS)))) + +; +; Gestion des lexers +; + +; Fabrication de lexer a partir d'arbres de decision +(define lexer-make-tree-lexer + (lambda (tables IS) + (letrec + (; Contenu de la table + (counters-type (vector-ref tables 0)) + (<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-actions (vector-ref tables 3)) + (table-nl-start (vector-ref tables 5)) + (table-no-nl-start (vector-ref tables 6)) + (trees-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8)) + + ; Contenu du IS + (IS-start-go-to-end (cdr (assq 'start-go-to-end IS))) + (IS-end-go-to-point (cdr (assq 'end-go-to-point IS))) + (IS-init-lexeme (cdr (assq 'init-lexeme IS))) + (IS-get-start-line (cdr (assq 'get-start-line IS))) + (IS-get-start-column (cdr (assq 'get-start-column IS))) + (IS-get-start-offset (cdr (assq 'get-start-offset IS))) + (IS-peek-left-context (cdr (assq 'peek-left-context IS))) + (IS-peek-char (cdr (assq 'peek-char IS))) + (IS-read-char (cdr (assq 'read-char IS))) + (IS-get-start-end-text (cdr (assq 'get-start-end-text IS))) + (IS-get-user-line (cdr (assq 'get-user-line IS))) + (IS-get-user-column (cdr (assq 'get-user-column IS))) + (IS-get-user-offset (cdr (assq 'get-user-offset IS))) + (IS-user-getc (cdr (assq 'user-getc IS))) + (IS-user-ungetc (cdr (assq 'user-ungetc IS))) + + ; Resultats + (<>-action #f) + (<>-action #f) + (rules-actions #f) + (states #f) + (final-lexer #f) + + ; Gestion des hooks + (hook-list '()) + (add-hook + (lambda (thunk) + (set! hook-list (cons thunk hook-list)))) + (apply-hooks + (lambda () + (let loop ((l hook-list)) + (if (pair? l) + (begin + ((car l)) + (loop (cdr l))))))) + + ; Preparation des actions + (set-action-statics + (lambda (pre-action) + (pre-action final-lexer IS-user-getc IS-user-ungetc))) + (prepare-special-action-none + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda () + (action ""))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-line + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline) + (action "" yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action-all + (lambda (pre-action) + (let ((action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (action "" yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-special-action + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-special-action-none pre-action)) + ((eq? counters-type 'line) + (prepare-special-action-line pre-action)) + ((eq? counters-type 'all) + (prepare-special-action-all pre-action))))) + (prepare-action-yytext-none + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-line + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext-all + (lambda (pre-action) + (let ((get-start-end-text IS-get-start-end-text) + (start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (let ((yytext (get-start-end-text))) + (start-go-to-end) + (action yytext yyline yycolumn yyoffset)))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-yytext-all pre-action))))) + (prepare-action-no-yytext-none + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda () + (start-go-to-end) + (action))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-line + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline) + (start-go-to-end) + (action yyline))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext-all + (lambda (pre-action) + (let ((start-go-to-end IS-start-go-to-end) + (action #f)) + (let ((result + (lambda (yyline yycolumn yyoffset) + (start-go-to-end) + (action yyline yycolumn yyoffset))) + (hook + (lambda () + (set! action (set-action-statics pre-action))))) + (add-hook hook) + result)))) + (prepare-action-no-yytext + (lambda (pre-action) + (cond ((eq? counters-type 'none) + (prepare-action-no-yytext-none pre-action)) + ((eq? counters-type 'line) + (prepare-action-no-yytext-line pre-action)) + ((eq? counters-type 'all) + (prepare-action-no-yytext-all pre-action))))) + + ; Fabrique les fonctions de dispatch + (prepare-dispatch-err + (lambda (leaf) + (lambda (c) + #f))) + (prepare-dispatch-number + (lambda (leaf) + (let ((state-function #f)) + (let ((result + (lambda (c) + state-function)) + (hook + (lambda () + (set! state-function (vector-ref states leaf))))) + (add-hook hook) + result)))) + (prepare-dispatch-leaf + (lambda (leaf) + (if (eq? leaf 'err) + (prepare-dispatch-err leaf) + (prepare-dispatch-number leaf)))) + (prepare-dispatch-< + (lambda (tree) + (let ((left-tree (list-ref tree 1)) + (right-tree (list-ref tree 2))) + (let ((bound (list-ref tree 0)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (< c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-= + (lambda (tree) + (let ((left-tree (list-ref tree 2)) + (right-tree (list-ref tree 3))) + (let ((bound (list-ref tree 1)) + (left-func (prepare-dispatch-tree left-tree)) + (right-func (prepare-dispatch-tree right-tree))) + (lambda (c) + (if (= c bound) + (left-func c) + (right-func c))))))) + (prepare-dispatch-tree + (lambda (tree) + (cond ((not (pair? tree)) + (prepare-dispatch-leaf tree)) + ((eq? (car tree) '=) + (prepare-dispatch-= tree)) + (else + (prepare-dispatch-< tree))))) + (prepare-dispatch + (lambda (tree) + (let ((dicho-func (prepare-dispatch-tree tree))) + (lambda (c) + (and c (dicho-func c)))))) + + ; Fabrique les fonctions de transition (read & go) et (abort) + (prepare-read-n-go + (lambda (tree) + (let ((dispatch-func (prepare-dispatch tree)) + (read-char IS-read-char)) + (lambda () + (dispatch-func (read-char)))))) + (prepare-abort + (lambda (tree) + (lambda () + #f))) + (prepare-transition + (lambda (tree) + (if (eq? tree 'err) + (prepare-abort tree) + (prepare-read-n-go tree)))) + + ; Fabrique les fonctions d'etats ([set-end] & trans) + (prepare-state-no-acc + (lambda (s r1 r2) + (let ((trans-func (prepare-transition (vector-ref trees-v s)))) + (lambda (action) + (let ((next-state (trans-func))) + (if next-state + (next-state action) + action)))))) + (prepare-state-yes-no + (lambda (s r1 r2) + (let ((peek-char IS-peek-char) + (end-go-to-point IS-end-go-to-point) + (new-action1 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + (begin + (end-go-to-point) + new-action1) + action)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state-diff-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (peek-char IS-peek-char) + (new-action1 #f) + (new-action2 #f) + (trans-func (prepare-transition (vector-ref trees-v s)))) + (let ((result + (lambda (action) + (end-go-to-point) + (let* ((c (peek-char)) + (new-action + (if (or (not c) (= c lexer-integer-newline)) + new-action1 + new-action2)) + (next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action1 (vector-ref rules-actions r1)) + (set! new-action2 (vector-ref rules-actions r2))))) + (add-hook hook) + result)))) + (prepare-state-same-acc + (lambda (s r1 r2) + (let ((end-go-to-point IS-end-go-to-point) + (trans-func (prepare-transition (vector-ref trees-v s))) + (new-action #f)) + (let ((result + (lambda (action) + (end-go-to-point) + (let ((next-state (trans-func))) + (if next-state + (next-state new-action) + new-action)))) + (hook + (lambda () + (set! new-action (vector-ref rules-actions r1))))) + (add-hook hook) + result)))) + (prepare-state + (lambda (s) + (let* ((acc (vector-ref acc-v s)) + (r1 (car acc)) + (r2 (cdr acc))) + (cond ((not r1) (prepare-state-no-acc s r1 r2)) + ((not r2) (prepare-state-yes-no s r1 r2)) + ((< r1 r2) (prepare-state-diff-acc s r1 r2)) + (else (prepare-state-same-acc s r1 r2)))))) + + ; Fabrique la fonction de lancement du lexage a l'etat de depart + (prepare-start-same + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (start-state #f) + (error-action #f)) + (let ((result + (lambda () + (if (not (peek-char)) + eof-action + (start-state error-action)))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start-diff + (lambda (s1 s2) + (let ((peek-char IS-peek-char) + (eof-action #f) + (peek-left-context IS-peek-left-context) + (start-state1 #f) + (start-state2 #f) + (error-action #f)) + (let ((result + (lambda () + (cond ((not (peek-char)) + eof-action) + ((= (peek-left-context) lexer-integer-newline) + (start-state1 error-action)) + (else + (start-state2 error-action))))) + (hook + (lambda () + (set! eof-action <>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <>-action)))) + (add-hook hook) + result)))) + (prepare-start + (lambda () + (let ((s1 table-nl-start) + (s2 table-no-nl-start)) + (if (= s1 s2) + (prepare-start-same s1 s2) + (prepare-start-diff s1 s2))))) + + ; Fabrique la fonction principale + (prepare-lexer-none + (lambda () + (let ((init-lexeme IS-init-lexeme) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + ((start-func)))))) + (prepare-lexer-line + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line))) + ((start-func) yyline)))))) + (prepare-lexer-all + (lambda () + (let ((init-lexeme IS-init-lexeme) + (get-start-line IS-get-start-line) + (get-start-column IS-get-start-column) + (get-start-offset IS-get-start-offset) + (start-func (prepare-start))) + (lambda () + (init-lexeme) + (let ((yyline (get-start-line)) + (yycolumn (get-start-column)) + (yyoffset (get-start-offset))) + ((start-func) yyline yycolumn yyoffset)))))) + (prepare-lexer + (lambda () + (cond ((eq? counters-type 'none) (prepare-lexer-none)) + ((eq? counters-type 'line) (prepare-lexer-line)) + ((eq? counters-type 'all) (prepare-lexer-all)))))) + + ; Calculer la valeur de <>-action et de <>-action + (set! <>-action (prepare-special-action <>-pre-action)) + (set! <>-action (prepare-special-action <>-pre-action)) + + ; Calculer la valeur de rules-actions + (let* ((len (quotient (vector-length rules-pre-actions) 2)) + (v (make-vector len))) + (let loop ((r (- len 1))) + (if (< r 0) + (set! rules-actions v) + (let* ((yytext? (vector-ref rules-pre-actions (* 2 r))) + (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1))) + (action (if yytext? + (prepare-action-yytext pre-action) + (prepare-action-no-yytext pre-action)))) + (vector-set! v r action) + (loop (- r 1)))))) + + ; Calculer la valeur de states + (let* ((len (vector-length trees-v)) + (v (make-vector len))) + (let loop ((s (- len 1))) + (if (< s 0) + (set! states v) + (begin + (vector-set! v s (prepare-state s)) + (loop (- s 1)))))) + + ; Calculer la valeur de final-lexer + (set! final-lexer (prepare-lexer)) + + ; Executer les hooks + (apply-hooks) + + ; Resultat + final-lexer))) + +; Fabrication de lexer a partir de listes de caracteres taggees +(define lexer-make-char-lexer + (let* ((char->class + (lambda (c) + (let ((n (char->integer c))) + (list (cons n n))))) + (merge-sort + (lambda (l combine zero-elt) + (if (null? l) + zero-elt + (let loop1 ((l l)) + (if (null? (cdr l)) + (car l) + (loop1 + (let loop2 ((l l)) + (cond ((null? l) + l) + ((null? (cdr l)) + l) + (else + (cons (combine (car l) (cadr l)) + (loop2 (cddr l)))))))))))) + (finite-class-union + (lambda (c1 c2) + (let loop ((c1 c1) (c2 c2) (u '())) + (if (null? c1) + (if (null? c2) + (reverse u) + (loop c1 (cdr c2) (cons (car c2) u))) + (if (null? c2) + (loop (cdr c1) c2 (cons (car c1) u)) + (let* ((r1 (car c1)) + (r2 (car c2)) + (r1start (car r1)) + (r1end (cdr r1)) + (r2start (car r2)) + (r2end (cdr r2))) + (if (<= r1start r2start) + (cond ((< (+ r1end 1) r2start) + (loop (cdr c1) c2 (cons r1 u))) + ((<= r1end r2end) + (loop (cdr c1) + (cons (cons r1start r2end) (cdr c2)) + u)) + (else + (loop c1 (cdr c2) u))) + (cond ((> r1start (+ r2end 1)) + (loop c1 (cdr c2) (cons r2 u))) + ((>= r1end r2end) + (loop (cons (cons r2start r1end) (cdr c1)) + (cdr c2) + u)) + (else + (loop (cdr c1) c2 u)))))))))) + (char-list->class + (lambda (cl) + (let ((classes (map char->class cl))) + (merge-sort classes finite-class-union '())))) + (class-< + (lambda (b1 b2) + (cond ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + (else (< b1 b2))))) + (finite-class-compl + (lambda (c) + (let loop ((c c) (start 'inf-)) + (if (null? c) + (list (cons start 'inf+)) + (let* ((r (car c)) + (rstart (car r)) + (rend (cdr r))) + (if (class-< start rstart) + (cons (cons start (- rstart 1)) + (loop c rstart)) + (loop (cdr c) (+ rend 1)))))))) + (tagged-chars->class + (lambda (tcl) + (let* ((inverse? (car tcl)) + (cl (cdr tcl)) + (class-tmp (char-list->class cl))) + (if inverse? (finite-class-compl class-tmp) class-tmp)))) + (charc->arc + (lambda (charc) + (let* ((tcl (car charc)) + (dest (cdr charc)) + (class (tagged-chars->class tcl))) + (cons class dest)))) + (arc->sharcs + (lambda (arc) + (let* ((range-l (car arc)) + (dest (cdr arc)) + (op (lambda (range) (cons range dest)))) + (map op range-l)))) + (class-<= + (lambda (b1 b2) + (cond ((eq? b1 'inf-) #t) + ((eq? b2 'inf+) #t) + ((eq? b1 'inf+) #f) + ((eq? b2 'inf-) #f) + (else (<= b1 b2))))) + (sharc-<= + (lambda (sharc1 sharc2) + (class-<= (caar sharc1) (caar sharc2)))) + (merge-sharcs + (lambda (l1 l2) + (let loop ((l1 l1) (l2 l2)) + (cond ((null? l1) + l2) + ((null? l2) + l1) + (else + (let ((sharc1 (car l1)) + (sharc2 (car l2))) + (if (sharc-<= sharc1 sharc2) + (cons sharc1 (loop (cdr l1) l2)) + (cons sharc2 (loop l1 (cdr l2)))))))))) + (class-= eqv?) + (fill-error + (lambda (sharcs) + (let loop ((sharcs sharcs) (start 'inf-)) + (cond ((class-= start 'inf+) + '()) + ((null? sharcs) + (cons (cons (cons start 'inf+) 'err) + (loop sharcs 'inf+))) + (else + (let* ((sharc (car sharcs)) + (h (caar sharc)) + (t (cdar sharc))) + (if (class-< start h) + (cons (cons (cons start (- h 1)) 'err) + (loop sharcs h)) + (cons sharc (loop (cdr sharcs) + (if (class-= t 'inf+) + 'inf+ + (+ t 1))))))))))) + (charcs->tree + (lambda (charcs) + (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc)))) + (sharcs-l (map op charcs)) + (sorted-sharcs (merge-sort sharcs-l merge-sharcs '())) + (full-sharcs (fill-error sorted-sharcs)) + (op (lambda (sharc) (cons (caar sharc) (cdr sharc)))) + (table (list->vector (map op full-sharcs)))) + (let loop ((left 0) (right (- (vector-length table) 1))) + (if (= left right) + (cdr (vector-ref table left)) + (let ((mid (quotient (+ left right 1) 2))) + (if (and (= (+ left 2) right) + (= (+ (car (vector-ref table mid)) 1) + (car (vector-ref table right))) + (eqv? (cdr (vector-ref table left)) + (cdr (vector-ref table right)))) + (list '= + (car (vector-ref table mid)) + (cdr (vector-ref table mid)) + (cdr (vector-ref table left))) + (list (car (vector-ref table mid)) + (loop left (- mid 1)) + (loop mid right)))))))))) + (lambda (tables IS) + (let ((counters (vector-ref tables 0)) + (<>-action (vector-ref tables 1)) + (<>-action (vector-ref tables 2)) + (rules-actions (vector-ref tables 3)) + (nl-start (vector-ref tables 5)) + (no-nl-start (vector-ref tables 6)) + (charcs-v (vector-ref tables 7)) + (acc-v (vector-ref tables 8))) + (let* ((len (vector-length charcs-v)) + (v (make-vector len))) + (let loop ((i (- len 1))) + (if (>= i 0) + (begin + (vector-set! v i (charcs->tree (vector-ref charcs-v i))) + (loop (- i 1))) + (lexer-make-tree-lexer + (vector counters + <>-action + <>-action + rules-actions + 'decision-trees + nl-start + no-nl-start + v + acc-v) + IS)))))))) + +; Fabrication d'un lexer a partir de code pre-genere +(define lexer-make-code-lexer + (lambda (tables IS) + (let ((<>-pre-action (vector-ref tables 1)) + (<>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <>-pre-action <>-pre-action rules-pre-action IS)))) + +(define lexer-make-lexer + (lambda (tables IS) + (let ((automaton-type (vector-ref tables 4))) + (cond ((eq? automaton-type 'decision-trees) + (lexer-make-tree-lexer tables IS)) + ((eq? automaton-type 'tagged-chars-lists) + (lexer-make-char-lexer tables IS)) + ((eq? automaton-type 'code) + (lexer-make-code-lexer tables IS)))))) + +; +; Table generated from the file xml-lex.l by SILex 1.0 +; + +(define lexer-default-table + (vector + 'line + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + 'eof + )) + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (skribe-error 'xml-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) + +;;Comment + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-comment) + (body yytext)) + +;; Markup + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-module) + (body yytext)) + +;; Regular text + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((40 (35 (34 1 5) (39 1 4)) (61 (60 1 3) (= 62 2 1))) (40 (35 (34 1 + err) (39 1 err)) (61 (60 1 err) (= 62 err 1))) err (33 (11 (10 6 err) + (32 6 err)) (62 (34 7 6) (63 err 6))) (= 39 8 4) (= 34 9 5) (32 (= 10 + err 6) (62 (33 err 6) (63 err 6))) (33 (11 (10 6 err) (32 6 err)) (46 + (45 6 10) (= 62 err 6))) err err (33 (11 (10 6 err) (32 6 err)) (46 (45 + 6 11) (= 62 err 6))) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 13) (= + 62 12 11))) (= 45 14 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 15) + (= 62 12 11))) (= 45 16 12) (33 (11 (10 11 12) (32 11 12)) (46 (45 11 + 15) (= 62 17 11))) (46 (45 12 16) (= 62 17 12)) (= 45 14 12)) + '#((#f . #f) (4 . 4) (3 . 3) (#f . #f) (#f . #f) (#f . #f) (3 . 3) (3 . + 3) (1 . 1) (0 . 0) (3 . 3) (3 . 3) (#f . #f) (3 . 3) (#f . #f) (3 . 3) + (#f . #f) (2 . 2)))) + +; +; User functions +; + +(define lexer #f) + +(define lexer-get-line #f) +(define lexer-getc #f) +(define lexer-ungetc #f) + +(define lexer-init + (lambda (input-type input) + (let ((IS (lexer-make-IS input-type input 'line))) + (set! lexer (lexer-make-lexer lexer-default-table IS)) + (set! lexer-get-line (lexer-get-func-line IS)) + (set! lexer-getc (lexer-get-func-getc IS)) + (set! lexer-ungetc (lexer-get-func-ungetc IS))))) diff --git a/src/guile/skribilo/source/xml.scm b/src/guile/skribilo/source/xml.scm new file mode 100644 index 0000000..05eac17 --- /dev/null +++ b/src/guile/skribilo/source/xml.scm @@ -0,0 +1,80 @@ +;;; xml.scm -- XML syntax highlighting. +;;; +;;; Copyright 2005, 2007 Ludovic Courtès +;;; +;;; +;;; 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 source xml) + :export (xml) + :use-module (skribilo lib) + :use-module (ice-9 regex)) + + +(define %comment-rx (make-regexp "" 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 -- cgit v1.2.3