diff options
| -rw-r--r-- | ChangeLog | 52 | ||||
| -rw-r--r-- | arch-config | 5 | ||||
| -rw-r--r-- | doc/user/user.skb | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/ast.scm | 2 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/Makefile.am | 16 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/c-lex.l.scm | 1225 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/lisp-lex.l | 53 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/lisp-lex.l.scm | 1249 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/lisp.scm | 108 | ||||
| -rw-r--r-- | src/guile/skribilo/coloring/xml-lex.l.scm | 1221 | ||||
| -rw-r--r-- | src/guile/skribilo/prog.scm | 6 | ||||
| -rw-r--r-- | src/guile/skribilo/source.scm | 11 |
12 files changed, 3859 insertions, 91 deletions
@@ -2,6 +2,58 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2 # +2006-02-10 17:19:34 GMT Ludovic Courtes <ludovic.courtes@laas.fr> patch-33 + + Summary: + Fixed syntax highlighting thanks to SILex. + Revision: + skribilo--devel--1.2--patch-33 + + * arch-config: New file. + + * src/guile/skribilo/coloring/c-lex.l.scm: New. + + * src/guile/skribilo/coloring/lisp-lex.l.scm: New. + + * src/guile/skribilo/coloring/xml-lex.l.scm: New. + + * doc/user/user.skb: Include `prgm.skb' (works now). + + * src/guile/skribilo/ast.scm: Export `node-body'. + + * src/guile/skribilo/coloring/Makefile.am (dist_guilemodule_DATA): Added + the SILex-generated files. + (%.l.scm): New rule. + + * src/guile/skribilo/coloring/lisp-lex.l: Use the SRFI-39 parameters. + + * src/guile/skribilo/coloring/lisp.scm: Use SRFI-39 parameters instead of + fluids. Load `lisp-lex.l.scm'. + + * src/guile/skribilo/prog.scm: Autoload `ast' upon `node-body' too. + (make-line-mark): Use `hash-set!'. + (resolve-line): Use `hash-ref'. + + * src/guile/skribilo/source.scm (source-read-lines): Use + `string-prefix-length' instead of `substring=?'. + + new files: + arch-config + src/guile/skribilo/coloring/.arch-ids/c-lex.l.scm.id + src/guile/skribilo/coloring/.arch-ids/lisp-lex.l.scm.id + src/guile/skribilo/coloring/.arch-ids/xml-lex.l.scm.id + src/guile/skribilo/coloring/c-lex.l.scm + src/guile/skribilo/coloring/lisp-lex.l.scm + src/guile/skribilo/coloring/xml-lex.l.scm + + modified files: + ChangeLog doc/user/user.skb src/guile/skribilo/ast.scm + src/guile/skribilo/coloring/Makefile.am + src/guile/skribilo/coloring/lisp-lex.l + src/guile/skribilo/coloring/lisp.scm + src/guile/skribilo/prog.scm src/guile/skribilo/source.scm + + 2006-02-10 14:44:59 GMT Ludovic Courtes <ludovic.courtes@laas.fr> patch-32 Summary: diff --git a/arch-config b/arch-config new file mode 100644 index 0000000..e7aa342 --- /dev/null +++ b/arch-config @@ -0,0 +1,5 @@ +# GNU Arch configuration to build the thing. + +./src/guile/silex lcourtes@laas.fr--2005-libre/silex--dube--1.0 + +# arch-tag: bdeb0fe5-6cac-4ad3-b6a6-7fd2197a76c6 diff --git a/doc/user/user.skb b/doc/user/user.skb index 0c74e66..f4f6849 100644 --- a/doc/user/user.skb +++ b/doc/user/user.skb @@ -115,7 +115,7 @@ as HTML, Info pages, man pages, Postscript, etc.])))) (include "bib.skb") ;;; Computer programs -;;(include "prgm.skb") +(include "prgm.skb") ;;; Standard Library (include "lib.skb") diff --git a/src/guile/skribilo/ast.scm b/src/guile/skribilo/ast.scm index ff61ff7..1856389 100644 --- a/src/guile/skribilo/ast.scm +++ b/src/guile/skribilo/ast.scm @@ -29,7 +29,7 @@ <command> command? command-fmt command-body <unresolved> unresolved? unresolved-proc <handle> handle? handle-ast handle-body - <node> node? node-options node-loc + <node> node? node-options node-loc node-body <processor> processor? processor-combinator processor-engine <markup> markup? bind-markup! markup-options is-markup? diff --git a/src/guile/skribilo/coloring/Makefile.am b/src/guile/skribilo/coloring/Makefile.am index c8f9242..b952237 100644 --- a/src/guile/skribilo/coloring/Makefile.am +++ b/src/guile/skribilo/coloring/Makefile.am @@ -1,2 +1,16 @@ guilemoduledir = $(GUILE_SITE)/skribilo/coloring -dist_guilemodule_DATA = c.scm lisp.scm xml.scm +dist_guilemodule_DATA = c.scm lisp.scm xml.scm \ + lisp-lex.l.scm xml-lex.l.scm c-lex.l.scm + + +EXTRA_DIST = lisp-lex.l xml-lex.l c-lex.l + +# Building the lexers with SILex. You must previously run +# `tla build-config ./arch-config' for this to run. +# +# Note: Those files should normally be part of the distribution, making +# this rule useless to the user. +%.l.scm: %.l + $(GUILE) -L $(top_srcdir)/src/guile/silex \ + -c '(load-from-path "lex.scm") (lex "$^" "$@")' + diff --git a/src/guile/skribilo/coloring/c-lex.l.scm b/src/guile/skribilo/coloring/c-lex.l.scm new file mode 100644 index 0000000..c9129cf --- /dev/null +++ b/src/guile/skribilo/coloring/c-lex.l.scm @@ -0,0 +1,1225 @@ +; *** 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)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-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 + (<<EOF>>-action #f) + (<<ERROR>>-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 <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-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 <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-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 <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-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)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-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 + <<EOF>>-action + <<ERROR>>-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 ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-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/lisp-lex.l b/src/guile/skribilo/coloring/lisp-lex.l index efad24b..c4db526 100644 --- a/src/guile/skribilo/coloring/lisp-lex.l +++ b/src/guile/skribilo/coloring/lisp-lex.l @@ -1,29 +1,24 @@ -;;;; -*- Scheme -*- -;;;; -;;;; lisp-lex.l -- SILex input for the Lisp Languages -;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, -;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 21-Dec-2003 17:19 (eg) -;;;; Last file update: 5-Jan-2004 18:24 (eg) -;;;; +;;; lisp-lex.l -- SILex input for the Lisp Languages +;;; +;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +;;; USA. + space [ \n\9] letter [#?!_:a-zA-Z\-] @@ -42,7 +37,7 @@ digit [0-9] (body yytext)) ;; Skribe text (i.e. [....]) -\[|\] (if *bracket-highlight* +\[|\] (if (*bracket-highlight*) (new markup (markup '&source-bracket) (body yytext)) @@ -68,7 +63,7 @@ digit [0-9] (let* ((len (string-length yytext)) (c (string-ref yytext (- len 1)))) (if (char=? c #\>) - (if *class-highlight* + (if (*class-highlight*) (new markup (markup '&source-module) (body yytext)) @@ -76,7 +71,7 @@ digit [0-9] yytext))) ; no (else (let ((tmp (assoc (string->symbol yytext) - *the-keys*))) + (*the-keys*)))) (if tmp (new markup (markup (cdr tmp)) diff --git a/src/guile/skribilo/coloring/lisp-lex.l.scm b/src/guile/skribilo/coloring/lisp-lex.l.scm new file mode 100644 index 0000000..b5db4e8 --- /dev/null +++ b/src/guile/skribilo/coloring/lisp-lex.l.scm @@ -0,0 +1,1249 @@ +; *** 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)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-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 + (<<EOF>>-action #f) + (<<ERROR>>-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 <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-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 <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-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 <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-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)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-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 + <<EOF>>-action + <<ERROR>>-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 ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-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 1db9a3f..e3458b1 100644 --- a/src/guile/skribilo/coloring/lisp.scm +++ b/src/guile/skribilo/coloring/lisp.scm @@ -1,8 +1,7 @@ -;;;; ;;;; lisp.scm -- Lisp Family Fontification ;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -19,31 +18,29 @@ ;;;; along with this program; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, ;;;; USA. -;;;; -;;;; Author: Erick Gallesio [eg@essi.fr] -;;;; Creation date: 16-Oct-2003 22:17 (eg) -;;;; Last file update: 28-Oct-2004 21:14 (eg) -;;;; + (define-module (skribilo coloring lisp) :use-module (skribilo utils syntax) :use-module (skribilo source) :use-module (skribilo lib) :use-module (skribilo runtime) + :use-module (srfi srfi-39) :use-module (ice-9 match) + :autoload (ice-9 regex) (make-regexp) :autoload (skribilo reader) (make-reader) :export (skribe scheme stklos bigloo lisp)) -(define *bracket-highlight* (make-fluid)) -(define *class-highlight* (make-fluid)) -(define *the-keys* (make-fluid)) +(define *bracket-highlight* (make-parameter #t)) +(define *class-highlight* (make-parameter #t)) +(define *the-keys* (make-parameter '())) -(define *lisp-keys* (make-fluid)) -(define *scheme-keys* (make-fluid)) -(define *skribe-keys* (make-fluid)) -(define *stklos-keys* (make-fluid)) -(define *lisp-keys* (make-fluid)) +(define %lisp-keys #f) +(define %scheme-keys #f) +(define %skribe-keys #f) +(define %stklos-keys #f) +(define %lisp-keys #f) ;;; @@ -58,16 +55,19 @@ (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 read) - (let ((lisp-input (open-input-string s))) - (let loop ((token (read lisp-input)) - (res '())) - (if (eof-object? token) - (reverse! res) - (loop (read lisp-input) - (cons token res)))))) +(define (lisp-family-fontifier s) + (lexer-init 'port (open-input-string s)) + (let loop ((token (lexer)) + (res '())) + (if (eq? token 'eof) + (reverse! res) + (loop (lexer) + (cons token res))))) + ;;;; ====================================================================== ;;;; ;;;; LISP @@ -87,21 +87,21 @@ (else #f))))) (define (init-lisp-keys) - (unless *lisp-keys* - (set! *lisp-keys* + (unless %lisp-keys + (set! %lisp-keys (append ;; key (map (lambda (x) (cons x '&source-keyword)) '(setq if let let* letrec cond case else progn lambda)) ;; define (map (lambda (x) (cons x '&source-define)) '(defun defclass defmacro))))) - *lisp-keys*) + %lisp-keys) (define (lisp-fontifier s) - (with-fluids ((*the-keys* (init-lisp-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) - (lisp-family-fontifier s read))) + (parameterize ((*the-keys* (init-lisp-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) (define lisp @@ -110,6 +110,7 @@ (fontifier lisp-fontifier) (extractor lisp-extractor))) + ;;;; ====================================================================== ;;;; ;;;; SCHEME @@ -130,22 +131,22 @@ (define (init-scheme-keys) - (unless *scheme-keys* - (set! *scheme-keys* + (unless %scheme-keys + (set! %scheme-keys (append ;; key (map (lambda (x) (cons x '&source-keyword)) '(set! if let let* letrec quote cond case else begin do lambda)) ;; define (map (lambda (x) (cons x '&source-define)) '(define define-syntax))))) - *scheme-keys*) + %scheme-keys) (define (scheme-fontifier s) - (with-fluids ((*the-keys* (init-scheme-keys)) - (*bracket-highlight* #f) - (*class-highlight* #f)) - (lisp-family-fontifier s read))) + (parameterize ((*the-keys* (init-scheme-keys)) + (*bracket-highlight* #f) + (*class-highlight* #f)) + (lisp-family-fontifier s))) (define scheme @@ -154,6 +155,7 @@ (fontifier scheme-fontifier) (extractor scheme-extractor))) + ;;;; ====================================================================== ;;;; ;;;; STKLOS @@ -176,9 +178,9 @@ (define (init-stklos-keys) - (unless *stklos-keys* + (unless %stklos-keys (init-scheme-keys) - (set! *stklos-keys* (append *scheme-keys* + (set! %stklos-keys (append %scheme-keys ;; Markups (map (lambda (x) (cons x '&source-key)) '(select-module import export)) @@ -192,14 +194,14 @@ ;; error (map (lambda (x) (cons x '&source-error)) '(error call/cc))))) - *stklos-keys*) + %stklos-keys) (define (stklos-fontifier s) - (with-fluids ((*the-keys* (init-stklos-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) - (lisp-family-fontifier s read))) + (parameterize ((*the-keys* (init-stklos-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) (define stklos @@ -208,6 +210,7 @@ (fontifier stklos-fontifier) (extractor stklos-extractor))) + ;;;; ====================================================================== ;;;; ;;;; SKRIBE @@ -231,9 +234,9 @@ (define (init-skribe-keys) - (unless *skribe-keys* + (unless %skribe-keys (init-stklos-keys) - (set! *skribe-keys* (append *stklos-keys* + (set! %skribe-keys (append %stklos-keys ;; Markups (map (lambda (x) (cons x '&source-markup)) '(bold it emph tt color ref index underline @@ -254,14 +257,14 @@ ;; Define (map (lambda (x) (cons x '&source-define)) '(define-markup))))) - *skribe-keys*) + %skribe-keys) (define (skribe-fontifier s) - (with-fluids ((*the-keys* (init-skribe-keys)) - (*bracket-highlight* #t) - (*class-highlight* #t)) - (lisp-family-fontifier s (make-reader 'skribe)))) + (parameterize ((*the-keys* (init-skribe-keys)) + (*bracket-highlight* #t) + (*class-highlight* #t)) + (lisp-family-fontifier s))) (define skribe @@ -270,6 +273,7 @@ (fontifier skribe-fontifier) (extractor skribe-extractor))) + ;;;; ====================================================================== ;;;; ;;;; BIGLOO diff --git a/src/guile/skribilo/coloring/xml-lex.l.scm b/src/guile/skribilo/coloring/xml-lex.l.scm new file mode 100644 index 0000000..0e3fe05 --- /dev/null +++ b/src/guile/skribilo/coloring/xml-lex.l.scm @@ -0,0 +1,1221 @@ +; *** 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)) + (<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-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 + (<<EOF>>-action #f) + (<<ERROR>>-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 <<EOF>>-action) + (set! start-state (vector-ref states s1)) + (set! error-action <<ERROR>>-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 <<EOF>>-action) + (set! start-state1 (vector-ref states s1)) + (set! start-state2 (vector-ref states s2)) + (set! error-action <<ERROR>>-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 <<EOF>>-action et de <<ERROR>>-action + (set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action)) + (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-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)) + (<<EOF>>-action (vector-ref tables 1)) + (<<ERROR>>-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 + <<EOF>>-action + <<ERROR>>-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 ((<<EOF>>-pre-action (vector-ref tables 1)) + (<<ERROR>>-pre-action (vector-ref tables 2)) + (rules-pre-action (vector-ref tables 3)) + (code (vector-ref tables 5))) + (code <<EOF>>-pre-action <<ERROR>>-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/prog.scm b/src/guile/skribilo/prog.scm index 020a275..87b964b 100644 --- a/src/guile/skribilo/prog.scm +++ b/src/guile/skribilo/prog.scm @@ -23,7 +23,7 @@ :use-module (ice-9 regex) :autoload (ice-9 receive) (receive) :use-module (skribilo lib) ;; `new' - :autoload (skribilo ast) (node?) + :autoload (skribilo ast) (node? node-body) :export (make-prog-body resolve-line)) ;;; ====================================================================== @@ -57,14 +57,14 @@ (define (make-line-mark m lnum b) (let* ((ls (number->string lnum)) (n (list (mark ls) b))) - (hashtable-put! *lines* m n) + (hash-set! *lines* m n) n)) ;*---------------------------------------------------------------------*/ ;* resolve-line ... */ ;*---------------------------------------------------------------------*/ (define (resolve-line id) - (hashtable-get *lines* id)) + (hash-ref *lines* id)) ;*---------------------------------------------------------------------*/ ;* extract-string-mark ... */ diff --git a/src/guile/skribilo/source.scm b/src/guile/skribilo/source.scm index 4027372..24e4b67 100644 --- a/src/guile/skribilo/source.scm +++ b/src/guile/skribilo/source.scm @@ -1,7 +1,7 @@ ;;;; source.scm -- Highlighting source files. ;;;; -;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> -;;;; Copyright © 2005 Ludovic Courtès <ludovic.courtes@laas.fr> +;;;; Copyright 2003, 2004 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr> +;;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> ;;;; ;;;; ;;;; This program is free software; you can redistribute it and/or modify @@ -26,6 +26,7 @@ :use-module (srfi srfi-35) :autoload (srfi srfi-34) (raise) + :autoload (srfi srfi-13) (string-prefix-length) :autoload (skribilo condition) (&file-search-error &file-open-error) :use-module (skribilo utils syntax) @@ -75,7 +76,8 @@ (cond ((or (eof-object? s) (and (integer? stop) (> l stop)) - (and (string? stop) (substring=? stop s stopl))) + (and (string? stop) + (= (string-prefix-length stop s) stopl))) (apply string-append (reverse! r))) (armedp (loop (+ l 1) @@ -87,7 +89,8 @@ #t (read-line) (cons* "\n" (untabify s tab) r))) - ((and (string? start) (substring=? start s startl)) + ((and (string? start) + (= (string-prefix-length start s) startl)) (loop (+ l 1) #t (read-line) r)) (else (loop (+ l 1) #f (read-line) r)))))))))) |