From e66655d133b4d4d1555ddb81279eab5615a44bb7 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 6 Jun 2007 12:33:29 +0000 Subject: Cleaned up the source code fontifiers (under `coloring'). This brings `(skribilo coloring c)' to life! git-archimport-id: lcourtes@laas.fr--2006-libre/skribilo--devo--1.2--patch-63 --- src/guile/skribilo/coloring/Makefile.am | 20 +- src/guile/skribilo/coloring/c-lex.l.scm | 1225 --------------------------- src/guile/skribilo/coloring/c-lex.scm | 1233 +++++++++++++++++++++++++++ src/guile/skribilo/coloring/c.scm | 123 ++- src/guile/skribilo/coloring/lisp-lex.l.scm | 1249 --------------------------- src/guile/skribilo/coloring/lisp-lex.scm | 1257 ++++++++++++++++++++++++++++ src/guile/skribilo/coloring/lisp.scm | 102 +-- src/guile/skribilo/coloring/parameters.scm | 33 + src/guile/skribilo/coloring/xml-lex.l.scm | 1221 --------------------------- src/guile/skribilo/coloring/xml-lex.scm | 1229 +++++++++++++++++++++++++++ src/guile/skribilo/coloring/xml.scm | 2 - 11 files changed, 3870 insertions(+), 3824 deletions(-) delete mode 100644 src/guile/skribilo/coloring/c-lex.l.scm create mode 100644 src/guile/skribilo/coloring/c-lex.scm delete mode 100644 src/guile/skribilo/coloring/lisp-lex.l.scm create mode 100644 src/guile/skribilo/coloring/lisp-lex.scm create mode 100644 src/guile/skribilo/coloring/parameters.scm delete mode 100644 src/guile/skribilo/coloring/xml-lex.l.scm create mode 100644 src/guile/skribilo/coloring/xml-lex.scm (limited to 'src/guile') diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am index 2f68f5e..9a3e043 100644 --- a/src/guile/skribilo/coloring/Makefile.am +++ b/src/guile/skribilo/coloring/Makefile.am @@ -1,6 +1,6 @@ guilemoduledir = $(GUILE_SITE)/skribilo/coloring -dist_guilemodule_DATA = c.scm lisp.scm xml.scm \ - lisp-lex.l.scm xml-lex.l.scm c-lex.l.scm +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 @@ -10,9 +10,21 @@ EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l # # Note: Those files should normally be part of the distribution, making # this rule useless to the user. -%.l.scm: %.l +.l.scm: $(GUILE) -L $(top_srcdir)/src/guile/silex \ - -c '(load-from-path "lex.scm") (lex "$^" "$@")' + -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 ' :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.scm b/src/guile/skribilo/coloring/c-lex.l.scm deleted file mode 100644 index d78e09e..0000000 --- a/src/guile/skribilo/coloring/c-lex.l.scm +++ /dev/null @@ -1,1225 +0,0 @@ -; *** 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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 'lisp-fontifier "Parse error" yytext) - )) - (vector - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-string) - (body yytext)) -;;Comments - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (new markup - (markup '&source-line-comment) - (body yytext)) - )) - #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 - )) - #t - (lambda (yycontinue yygetc yyungetc) - (lambda (yytext yyline) - (begin yytext) - ))) - 'decision-trees - 0 - 0 - '#((65 (35 (34 1 5) (= 47 4 1)) (96 (91 3 (95 1 2)) (97 1 (123 3 1)))) - (65 (= 34 err 1) (97 (91 err 1) (123 err 1))) (91 (35 (34 1 err) (65 1 - 3)) (96 (95 1 2) (97 1 (123 3 1)))) (95 (65 err (91 3 err)) (97 (96 3 - err) (123 3 err))) (47 (35 (34 1 err) (= 42 7 1)) (91 (48 6 (65 1 err)) - (97 1 (123 err 1)))) (= 34 8 5) (35 (11 (10 6 1) (34 6 9)) (91 (65 6 9) - (97 6 (123 9 6)))) (42 (11 (10 7 1) (= 34 10 7)) (91 (43 11 (65 7 10)) - (97 7 (123 10 7)))) err (= 10 err 9) (11 (10 10 err) (= 42 12 10)) (43 - (34 (= 10 1 7) (35 10 (42 7 11))) (65 (= 47 13 7) (97 (91 10 7) (123 10 - 7)))) (42 (= 10 err 10) (47 (43 12 10) (48 14 10))) (42 (11 (10 7 1) (= - 34 10 7)) (91 (43 11 (65 7 10)) (97 7 (123 10 7)))) (11 (10 10 err) (= - 42 12 10))) - '#((#f . #f) (4 . 4) (3 . 3) (3 . 3) (4 . 4) (#f . #f) (2 . 2) (4 . 4) - (0 . 0) (2 . 2) (#f . #f) (4 . 4) (#f . #f) (1 . 1) (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-lex.scm b/src/guile/skribilo/coloring/c-lex.scm new file mode 100644 index 0000000..8ed6160 --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.scm @@ -0,0 +1,1233 @@ +(define-module (skribilo coloring c-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 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 'lisp-fontifier "Parse error" yytext) + )) + (vector + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-string) + (body yytext)) +;;Comments + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (new markup + (markup '&source-line-comment) + (body yytext)) + )) + #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 + )) + #t + (lambda (yycontinue yygetc yyungetc) + (lambda (yytext yyline) + (begin yytext) + ))) + 'decision-trees + 0 + 0 + '#((65 (35 (34 1 5) (= 47 4 1)) (96 (91 3 (95 1 2)) (97 1 (123 3 1)))) + (65 (= 34 err 1) (97 (91 err 1) (123 err 1))) (91 (35 (34 1 err) (65 1 + 3)) (96 (95 1 2) (97 1 (123 3 1)))) (95 (65 err (91 3 err)) (97 (96 3 + err) (123 3 err))) (47 (35 (34 1 err) (= 42 7 1)) (91 (48 6 (65 1 err)) + (97 1 (123 err 1)))) (= 34 8 5) (35 (11 (10 6 1) (34 6 9)) (91 (65 6 9) + (97 6 (123 9 6)))) (42 (11 (10 7 1) (= 34 10 7)) (91 (43 11 (65 7 10)) + (97 7 (123 10 7)))) err (= 10 err 9) (11 (10 10 err) (= 42 12 10)) (43 + (34 (= 10 1 7) (35 10 (42 7 11))) (65 (= 47 13 7) (97 (91 10 7) (123 10 + 7)))) (42 (= 10 err 10) (47 (43 12 10) (48 14 10))) (42 (11 (10 7 1) (= + 34 10 7)) (91 (43 11 (65 7 10)) (97 7 (123 10 7)))) (11 (10 10 err) (= + 42 12 10))) + '#((#f . #f) (4 . 4) (3 . 3) (3 . 3) (4 . 4) (#f . #f) (2 . 2) (4 . 4) + (0 . 0) (2 . 2) (#f . #f) (4 . 4) (#f . #f) (1 . 1) (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 index d2a2b9f..28533b4 100644 --- a/src/guile/skribilo/coloring/c.scm +++ b/src/guile/skribilo/coloring/c.scm @@ -1,67 +1,59 @@ -;;;; -;;;; c.stk -- C fontifier for Skribe -;;;; -;;;; Copyright © 2004 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: 6-Mar-2004 15:35 (eg) -;;;; Last file update: 7-Mar-2004 00:12 (eg) -;;;; - -(require "lex-rt") ;; to avoid module problems +;;; 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 c) - :export (c java) - :import (skribe runtime)) - -(include "c-lex.stk") ;; SILex generated + :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 java)) +(fluid-set! current-reader %skribilo-module-reader) -(define *the-keys* #f) + +;;; +;;; Generic fontifier. +;;; -(define *c-keys* #f) -(define *java-keys* #f) +(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 (fontifier s) - (let ((lex (c-lex (open-input-string s)))) - (let Loop ((token (lexer-next-token lex)) - (res '())) - (if (eq? token 'eof) - (reverse! res) - (Loop (lexer-next-token lex) - (cons token res)))))) - -;;;; ====================================================================== -;;;; -;;;; C -;;;; -;;;; ====================================================================== -(define (init-c-keys) - (unless *c-keys* - (set! *c-keys* '(for while return break continue void - do if else typedef struct union goto switch case - static extern default))) - *c-keys*) +(define %c-keys + '(for while return break continue void do if else typedef struct union + goto switch case static extern default)) (define (c-fontifier s) - (fluid-let ((*the-keys* (init-c-keys))) + (parameterize ((*the-keys* %c-keys)) (fontifier s))) (define c @@ -70,19 +62,17 @@ (fontifier c-fontifier) (extractor #f))) -;;;; ====================================================================== -;;;; -;;;; JAVA -;;;; -;;;; ====================================================================== -(define (init-java-keys) - (unless *java-keys* - (set! *java-keys* (append (init-c-keys) - '(public final class throw catch)))) - *java-keys*) + +;;; +;;; Java. +;;; + +(define %java-keys + (append %c-keys + '(public final class throw catch))) (define (java-fontifier s) - (fluid-let ((*the-keys* (init-java-keys))) + (parameterize ((*the-keys* %java-keys)) (fontifier s))) (define java @@ -90,4 +80,3 @@ (name "java") (fontifier java-fontifier) (extractor #f))) - diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm deleted file mode 100644 index 6ae7fe6..0000000 --- a/src/guile/skribilo/coloring/lisp-lex.l.scm +++ /dev/null @@ -1,1249 +0,0 @@ -; *** 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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-lex.scm b/src/guile/skribilo/coloring/lisp-lex.scm new file mode 100644 index 0000000..f68f320 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.scm @@ -0,0 +1,1257 @@ +(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 index 13bb6db..46e8c59 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,41 +1,37 @@ -;;;; lisp.scm -- Lisp Family Fontification -;;;; -;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI -;;;; Copyright 2005, 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. +;;; 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 (skribilo utils strings) :use-module (srfi srfi-39) :use-module (ice-9 match) - :autoload (ice-9 regex) (make-regexp) - :autoload (skribilo reader) (make-reader) + :autoload (skribilo reader) (make-reader) + :autoload (skribilo coloring lisp-lex) (lexer-init) :export (skribe scheme stklos bigloo lisp)) -(define *bracket-highlight* (make-parameter #t)) -(define *class-highlight* (make-parameter #t)) -(define *the-keys* (make-parameter '())) - (define %lisp-keys #f) (define %scheme-keys #f) (define %skribe-keys #f) @@ -43,9 +39,11 @@ (define %lisp-keys #f) + ;;; -;;; DEFINITION-SEARCH +;;; definition-search ;;; + (define (definition-search inp read tab def?) (let Loop ((exp (read inp))) (unless (eof-object? exp) @@ -55,9 +53,6 @@ (source-read-lines (port-filename inp) start stop tab)) (Loop (read inp)))))) -;; Load the SILex-generated lexer. -(load-from-path "skribilo/coloring/lisp-lex.l.scm") - (define (lisp-family-fontifier s) (lexer-init 'port (open-input-string s)) (let loop ((token (lexer)) @@ -68,11 +63,10 @@ (cons token res))))) -;;;; ====================================================================== -;;;; -;;;; LISP -;;;; -;;;; ====================================================================== +;;; +;;; Lisp. +;;; + (define (lisp-extractor iport def tab) (definition-search iport @@ -111,11 +105,10 @@ (extractor lisp-extractor))) -;;;; ====================================================================== -;;;; -;;;; SCHEME -;;;; -;;;; ====================================================================== +;;; +;;; Scheme. +;;; + (define (scheme-extractor iport def tab) (definition-search iport @@ -156,11 +149,10 @@ (extractor scheme-extractor))) -;;;; ====================================================================== -;;;; -;;;; STKLOS -;;;; -;;;; ====================================================================== +;;; +;;; STkLos. +;;; + (define (stklos-extractor iport def tab) (definition-search iport @@ -211,11 +203,10 @@ (extractor stklos-extractor))) -;;;; ====================================================================== -;;;; -;;;; SKRIBE -;;;; -;;;; ====================================================================== +;;; +;;; Skribe. +;;; + (define (skribe-extractor iport def tab) (definition-search iport @@ -274,11 +265,10 @@ (extractor skribe-extractor))) -;;;; ====================================================================== -;;;; -;;;; BIGLOO -;;;; -;;;; ====================================================================== +;;; +;;; Bigloo. +;;; + (define (bigloo-extractor iport def tab) (definition-search iport diff --git a/src/guile/skribilo/coloring/parameters.scm b/src/guile/skribilo/coloring/parameters.scm new file mode 100644 index 0000000..cb4e9bb --- /dev/null +++ b/src/guile/skribilo/coloring/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 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.scm b/src/guile/skribilo/coloring/xml-lex.l.scm deleted file mode 100644 index d58e42b..0000000 --- a/src/guile/skribilo/coloring/xml-lex.l.scm +++ /dev/null @@ -1,1221 +0,0 @@ -; *** 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 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-lex.scm b/src/guile/skribilo/coloring/xml-lex.scm new file mode 100644 index 0000000..d14aa5d --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.scm @@ -0,0 +1,1229 @@ +(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 index e3db36f..f6d69fd 100644 --- a/src/guile/skribilo/coloring/xml.scm +++ b/src/guile/skribilo/coloring/xml.scm @@ -20,9 +20,7 @@ (define-module (skribilo coloring xml) :export (xml) - :use-module (skribilo source) :use-module (skribilo lib) - :use-module (ice-9 rdelim) :use-module (ice-9 regex)) -- cgit v1.2.3