Add SILex, for simplicity.

1 files changed, 812 insertions, 0 deletions

diff --git a/src/guile/silex/lexparser.scm b/src/guile/silex/lexparser.scm
new file mode 100644
index 0000000..75072ed
--- /dev/null
+++ b/src/guile/silex/lexparser.scm
@@ -0,0 +1,812 @@
+; 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.
+
+;
+; Fonctions auxilliaires du lexer
+;
+
+(define parse-spec-char
+  (lambda (lexeme line column)
+    (make-tok char-tok lexeme line column newline-ch)))
+
+(define parse-digits-char
+  (lambda (lexeme line column)
+    (let* ((num (substring lexeme 1 (string-length lexeme)))
+	   (n (string->number num)))
+      (make-tok char-tok lexeme line column n))))
+
+(define parse-quoted-char
+  (lambda (lexeme line column)
+    (let ((c (string-ref lexeme 1)))
+      (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define parse-ordinary-char
+  (lambda (lexeme line column)
+    (let ((c (string-ref lexeme 0)))
+      (make-tok char-tok lexeme line column (char->integer c)))))
+
+(define string-downcase
+  (lambda (s)
+    (let* ((l (string->list s))
+	   (ld (map char-downcase l)))
+      (list->string ld))))
+
+(define extract-id
+  (lambda (s)
+    (let ((len (string-length s)))
+      (substring s 1 (- len 1)))))
+
+(define parse-id
+  (lambda (lexeme line column)
+    (make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
+
+(define parse-id-ref
+  (lambda (lexeme line column)
+    (let* ((orig-name (extract-id lexeme))
+	   (name (string-downcase orig-name)))
+    (make-tok subst-tok lexeme line column name orig-name))))
+
+(define parse-power-m
+  (lambda (lexeme line column)
+    (let* ((len (string-length lexeme))
+	   (substr (substring lexeme 1 (- len 1)))
+	   (m (string->number substr))
+	   (range (cons m m)))
+      (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-inf
+  (lambda (lexeme line column)
+    (let* ((len (string-length lexeme))
+	   (substr (substring lexeme 1 (- len 2)))
+	   (m (string->number substr))
+	   (range (cons m 'inf)))
+      (make-tok power-tok lexeme line column range))))
+
+(define parse-power-m-n
+  (lambda (lexeme line column)
+    (let ((len (string-length lexeme)))
+      (let loop ((comma 2))
+	(if (char=? (string-ref lexeme comma) #\,)
+	    (let* ((sub1 (substring lexeme 1 comma))
+		   (sub2 (substring lexeme (+ comma 1) (- len 1)))
+		   (m (string->number sub1))
+		   (n (string->number sub2))
+		   (range (cons m n)))
+	      (make-tok power-tok lexeme line column range))
+	    (loop (+ comma 1)))))))
+
+
+
+
+;
+; Lexer generique
+;
+
+(define lexer-raw #f)
+(define lexer-stack '())
+
+(define lexer-alist #f)
+
+(define lexer-buffer #f)
+(define lexer-buffer-empty? #t)
+
+(define lexer-history '())
+(define lexer-history-interp #f)
+
+(define init-lexer
+  (lambda (port)
+    (let* ((IS (lexer-make-IS 'port port 'all))
+	   (action-lexer (lexer-make-lexer action-tables IS))
+	   (class-lexer  (lexer-make-lexer class-tables  IS))
+	   (macro-lexer  (lexer-make-lexer macro-tables  IS))
+	   (regexp-lexer (lexer-make-lexer regexp-tables IS))
+	   (string-lexer (lexer-make-lexer string-tables IS)))
+      (set! lexer-raw #f)
+      (set! lexer-stack '())
+      (set! lexer-alist
+	    (list (cons 'action action-lexer)
+		  (cons 'class  class-lexer)
+		  (cons 'macro  macro-lexer)
+		  (cons 'regexp regexp-lexer)
+		  (cons 'string string-lexer)))
+      (set! lexer-buffer-empty? #t)
+      (set! lexer-history '()))))
+
+; Lexer brut
+; S'assurer qu'il n'y a pas de risque de changer de
+; lexer quand le buffer est rempli
+(define push-lexer
+  (lambda (name)
+    (set! lexer-stack (cons lexer-raw lexer-stack))
+    (set! lexer-raw (cdr (assq name lexer-alist)))))
+
+(define pop-lexer
+  (lambda ()
+    (set! lexer-raw (car lexer-stack))
+    (set! lexer-stack (cdr lexer-stack))))
+
+; Traite le "unget" (capacite du unget: 1)
+(define lexer2
+  (lambda ()
+    (if lexer-buffer-empty?
+	(lexer-raw)
+	(begin
+	  (set! lexer-buffer-empty? #t)
+	  lexer-buffer))))
+
+(define lexer2-unget
+  (lambda (tok)
+    (set! lexer-buffer tok)
+    (set! lexer-buffer-empty? #f)))
+
+; Traite l'historique
+(define lexer
+  (lambda ()
+    (let* ((tok (lexer2))
+	   (tok-lexeme (get-tok-lexeme tok))
+	   (hist-lexeme (if lexer-history-interp
+			    (blank-translate tok-lexeme)
+			    tok-lexeme)))
+      (set! lexer-history (cons hist-lexeme lexer-history))
+      tok)))
+
+(define lexer-unget
+  (lambda (tok)
+    (set! lexer-history (cdr lexer-history))
+    (lexer2-unget tok)))
+
+(define lexer-set-blank-history
+  (lambda (b)
+    (set! lexer-history-interp b)))
+
+(define blank-translate
+  (lambda (s)
+    (let ((ss (string-copy s)))
+      (let loop ((i (- (string-length ss) 1)))
+	(cond ((< i 0)
+	       ss)
+	      ((char=? (string-ref ss i) (integer->char tab-ch))
+	       (loop (- i 1)))
+	      ((char=? (string-ref ss i) #\newline)
+	       (loop (- i 1)))
+	      (else
+	       (string-set! ss i #\space)
+	       (loop (- i 1))))))))
+
+(define lexer-get-history
+  (lambda ()
+    (let* ((rightlist (reverse lexer-history))
+	   (str (apply string-append rightlist))
+	   (strlen (string-length str))
+	   (str2 (if (and (> strlen 0)
+			  (char=? (string-ref str (- strlen 1)) #\newline))
+		     str
+		     (string-append str (string #\newline)))))
+      (set! lexer-history '())
+      str2)))
+
+
+
+
+;
+; Traitement des listes de tokens
+;
+
+(define de-anchor-tokens
+  (let ((not-anchor-toks (make-dispatch-table number-of-tokens
+					      (list (cons caret-tok     #f)
+						    (cons dollar-tok    #f)
+						    (cons <<EOF>>-tok   #f)
+						    (cons <<ERROR>>-tok #f))
+					      #t)))
+    (lambda (tok-list)
+      (if (null? tok-list)
+	  '()
+	  (let* ((tok (car tok-list))
+		 (tok-type (get-tok-type tok))
+		 (toks (cdr tok-list))
+		 (new-toks (de-anchor-tokens toks)))
+	    (cond ((vector-ref not-anchor-toks tok-type)
+		   (cons tok new-toks))
+		  ((or (= tok-type caret-tok) (= tok-type dollar-tok))
+		   (let* ((line (get-tok-line tok))
+			  (column (get-tok-column tok))
+			  (attr (if (= tok-type caret-tok) caret-ch dollar-ch))
+			  (new-tok (make-tok char-tok "" line column attr)))
+		     (cons new-tok new-toks)))
+		  ((= tok-type <<EOF>>-tok)
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the <<EOF>> anchor must be used alone"
+			      " and only after %%."))
+		  ((= tok-type <<ERROR>>-tok)
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the <<ERROR>> anchor must be used alone"
+			      " and only after %%."))))))))
+
+(define strip-end
+  (lambda (l)
+    (if (null? (cdr l))
+	'()
+	(cons (car l) (strip-end (cdr l))))))
+
+(define extract-anchors
+  (lambda (tok-list)
+    (let* ((tok1 (car tok-list))
+	   (line (get-tok-line tok1))
+	   (tok1-type (get-tok-type tok1)))
+      (cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
+	     (make-rule line #t #f #f #f '() #f))
+	    ((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
+	     (make-rule line #f #t #f #f '() #f))
+	    (else
+	     (let* ((bol? (= tok1-type caret-tok))
+		    (tok-list2 (if bol? (cdr tok-list) tok-list)))
+	       (if (null? tok-list2)
+		   (make-rule line #f #f bol? #f tok-list2 #f)
+		   (let* ((len (length tok-list2))
+			  (tok2 (list-ref tok-list2 (- len 1)))
+			  (tok2-type (get-tok-type tok2))
+			  (eol? (= tok2-type dollar-tok))
+			  (tok-list3 (if eol?
+					 (strip-end tok-list2)
+					 tok-list2)))
+		     (make-rule line #f #f bol? eol? tok-list3 #f)))))))))
+
+(define char-list->conc
+  (lambda (char-list)
+    (if (null? char-list)
+	(make-re epsilon-re)
+	(let loop ((cl char-list))
+	  (let* ((c (car cl))
+		 (cl2 (cdr cl)))
+	    (if (null? cl2)
+		(make-re char-re c)
+		(make-re conc-re (make-re char-re c) (loop cl2))))))))
+
+(define parse-tokens-atom
+  (let ((action-table
+	 (make-dispatch-table
+	  number-of-tokens
+	  (list (cons lpar-tok
+		      (lambda (tok tok-list macros)
+			(parse-tokens-sub tok-list macros)))
+		(cons dot-tok
+		      (lambda (tok tok-list macros)
+			(cons (make-re class-re dot-class) (cdr tok-list))))
+		(cons subst-tok
+		      (lambda (tok tok-list macros)
+			(let* ((name (get-tok-attr tok))
+			       (ass (assoc name macros)))
+			  (if ass
+			      (cons (cdr ass) (cdr tok-list))
+			      (lex-error (get-tok-line tok)
+					 (get-tok-column tok)
+					 "unknown macro \""
+					 (get-tok-2nd-attr tok)
+					 "\".")))))
+		(cons char-tok
+		      (lambda (tok tok-list macros)
+			(let ((c (get-tok-attr tok)))
+			  (cons (make-re char-re c) (cdr tok-list)))))
+		(cons class-tok
+		      (lambda (tok tok-list macros)
+			(let ((class (get-tok-attr tok)))
+			  (cons (make-re class-re class) (cdr tok-list)))))
+		(cons string-tok
+		      (lambda (tok tok-list macros)
+			(let* ((char-list (get-tok-attr tok))
+			       (re (char-list->conc char-list)))
+			  (cons re (cdr tok-list))))))
+	  (lambda (tok tok-list macros)
+	    (lex-error (get-tok-line tok)
+		       (get-tok-column tok)
+		       "syntax error in regular expression.")))))
+    (lambda (tok-list macros)
+      (let* ((tok (car tok-list))
+	     (tok-type (get-tok-type tok))
+	     (action (vector-ref action-table tok-type)))
+	(action tok tok-list macros)))))
+
+(define check-power-tok
+  (lambda (tok)
+    (let* ((range (get-tok-attr tok))
+	   (start (car range))
+	   (end (cdr range)))
+      (if (or (eq? 'inf end) (<= start end))
+	  range
+	  (lex-error (get-tok-line tok)
+		     (get-tok-column tok)
+		     "incorrect power specification.")))))
+
+(define power->star-plus
+  (lambda (re range)
+    (power->star-plus-rec re (car range) (cdr range))))
+
+(define power->star-plus-rec
+  (lambda (re start end)
+    (cond ((eq? end 'inf)
+	   (cond ((= start 0)
+		  (make-re star-re re))
+		 ((= start 1)
+		  (make-re plus-re re))
+		 (else
+		  (make-re conc-re
+			   re
+			   (power->star-plus-rec re (- start 1) 'inf)))))
+	  ((= start 0)
+	   (cond ((= end 0)
+		  (make-re epsilon-re))
+		 ((= end 1)
+		  (make-re question-re re))
+		 (else
+		  (make-re question-re
+			   (power->star-plus-rec re 1 end)))))
+	  ((= start 1)
+	   (if (= end 1)
+	       re
+	       (make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
+	  (else
+	   (make-re conc-re
+		    re
+		    (power->star-plus-rec re (- start 1) (- end 1)))))))
+
+(define parse-tokens-fact
+  (let ((not-op-toks (make-dispatch-table number-of-tokens
+					  (list (cons question-tok #f)
+						(cons plus-tok     #f)
+						(cons star-tok     #f)
+						(cons power-tok    #f))
+					  #t)))
+    (lambda (tok-list macros)
+      (let* ((result (parse-tokens-atom tok-list macros))
+	     (re (car result))
+	     (tok-list2 (cdr result)))
+	(let loop ((re re) (tok-list3 tok-list2))
+	  (let* ((tok (car tok-list3))
+		 (tok-type (get-tok-type tok)))
+	    (cond ((vector-ref not-op-toks tok-type)
+		   (cons re tok-list3))
+		  ((= tok-type question-tok)
+		   (loop (make-re question-re re) (cdr tok-list3)))
+		  ((= tok-type plus-tok)
+		   (loop (make-re plus-re re) (cdr tok-list3)))
+		  ((= tok-type star-tok)
+		   (loop (make-re star-re re) (cdr tok-list3)))
+		  ((= tok-type power-tok)
+		   (loop (power->star-plus re (check-power-tok tok))
+			 (cdr tok-list3))))))))))
+
+(define parse-tokens-conc
+  (lambda (tok-list macros)
+    (let* ((result1 (parse-tokens-fact tok-list macros))
+	   (re1 (car result1))
+	   (tok-list2 (cdr result1))
+	   (tok (car tok-list2))
+	   (tok-type (get-tok-type tok)))
+      (cond ((or (= tok-type pipe-tok)
+		 (= tok-type rpar-tok))
+	     result1)
+	    (else ; Autres facteurs
+	     (let* ((result2 (parse-tokens-conc tok-list2 macros))
+		    (re2 (car result2))
+		    (tok-list3 (cdr result2)))
+	       (cons (make-re conc-re re1 re2) tok-list3)))))))
+
+(define parse-tokens-or
+  (lambda (tok-list macros)
+    (let* ((result1 (parse-tokens-conc tok-list macros))
+	   (re1 (car result1))
+	   (tok-list2 (cdr result1))
+	   (tok (car tok-list2))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type pipe-tok)
+	     (let* ((tok-list3 (cdr tok-list2))
+		    (result2 (parse-tokens-or tok-list3 macros))
+		    (re2 (car result2))
+		    (tok-list4 (cdr result2)))
+	       (cons (make-re or-re re1 re2) tok-list4)))
+	    (else ; rpar-tok
+	     result1)))))
+
+(define parse-tokens-sub
+  (lambda (tok-list macros)
+    (let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
+	   (result (parse-tokens-or tok-list2 macros))
+	   (re (car result))
+	   (tok-list3 (cdr result))
+	   (tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
+      (cons re tok-list4))))
+
+(define parse-tokens-match
+  (lambda (tok-list line)
+    (let loop ((tl tok-list) (count 0))
+      (if (null? tl)
+	  (if (> count 0)
+	      (lex-error line
+			 #f
+			 "mismatched parentheses."))
+	  (let* ((tok (car tl))
+		 (tok-type (get-tok-type tok)))
+	    (cond ((= tok-type lpar-tok)
+		   (loop (cdr tl) (+ count 1)))
+		  ((= tok-type rpar-tok)
+		   (if (zero? count)
+		       (lex-error line
+				  #f
+				  "mismatched parentheses."))
+		   (loop (cdr tl) (- count 1)))
+		  (else
+		   (loop (cdr tl) count))))))))
+
+; Ne traite pas les anchors
+(define parse-tokens
+  (lambda (tok-list macros)
+    (if (null? tok-list)
+	(make-re epsilon-re)
+	(let ((line (get-tok-line (car tok-list))))
+	  (parse-tokens-match tok-list line)
+	  (let* ((begin-par (make-tok lpar-tok "" line 1))
+		 (end-par (make-tok rpar-tok "" line 1)))
+	    (let* ((tok-list2 (append (list begin-par)
+				      tok-list
+				      (list end-par)))
+		   (result (parse-tokens-sub tok-list2 macros)))
+	      (car result))))))) ; (cdr result) == () obligatoirement
+
+(define tokens->regexp
+  (lambda (tok-list macros)
+    (let ((tok-list2 (de-anchor-tokens tok-list)))
+      (parse-tokens tok-list2 macros))))
+
+(define tokens->rule
+  (lambda (tok-list macros)
+    (let* ((rule (extract-anchors tok-list))
+	   (tok-list2 (get-rule-regexp rule))
+	   (tok-list3 (de-anchor-tokens tok-list2))
+	   (re (parse-tokens tok-list3 macros)))
+      (set-rule-regexp rule re)
+      rule)))
+
+; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
+(define adapt-rules
+  (lambda (rules)
+    (let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
+      (if (null? r)
+	  (cons (or <<EOF>>-action default-<<EOF>>-action)
+		(cons (or <<ERROR>>-action default-<<ERROR>>-action)
+		      (list->vector (reverse revr))))
+	  (let ((r1 (car r)))
+	    (cond ((get-rule-eof? r1)
+		   (if <<EOF>>-action
+		       (lex-error (get-rule-line r1)
+				  #f
+				  "the <<EOF>> anchor can be "
+				  "used at most once.")
+		       (loop (cdr r)
+			     revr
+			     (get-rule-action r1)
+			     <<ERROR>>-action)))
+		  ((get-rule-error? r1)
+		   (if <<ERROR>>-action
+		       (lex-error (get-rule-line r1)
+				  #f
+				  "the <<ERROR>> anchor can be "
+				  "used at most once.")
+		       (loop (cdr r)
+			     revr
+			     <<EOF>>-action
+			     (get-rule-action r1))))
+		  (else
+		   (loop (cdr r)
+			 (cons r1 revr)
+			 <<EOF>>-action
+			 <<ERROR>>-action))))))))
+
+
+
+
+;
+; Analyseur de fichier lex
+;
+
+(define parse-hv-blanks
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (if (or (= tok-type hblank-tok)
+	      (= tok-type vblank-tok))
+	  (parse-hv-blanks)
+	  (lexer-unget tok)))))
+
+(define parse-class-range
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type char-tok)
+	     (let* ((c (get-tok-attr tok))
+		    (tok2 (lexer))
+		    (tok2-type (get-tok-type tok2)))
+	       (if (not (= tok2-type minus-tok))
+		   (begin
+		     (lexer-unget tok2)
+		     (cons c c))
+		   (let* ((tok3 (lexer))
+			  (tok3-type (get-tok-type tok3)))
+		     (cond ((= tok3-type char-tok)
+			    (let ((c2 (get-tok-attr tok3)))
+			      (if (> c c2)
+				  (lex-error (get-tok-line tok3)
+					     (get-tok-column tok3)
+					     "bad range specification in "
+					     "character class;"
+					     #\newline
+					     "the start character is "
+					     "higher than the end one.")
+				  (cons c c2))))
+		           ((or (= tok3-type rbrack-tok)
+				(= tok3-type minus-tok))
+			    (lex-error (get-tok-line tok3)
+				       (get-tok-column tok3)
+				       "bad range specification in "
+				       "character class; a specification"
+				       #\newline
+				       "like \"-x\", \"x--\" or \"x-]\" has "
+				       "been used."))
+			   ((= tok3-type eof-tok)
+			    (lex-error (get-tok-line tok3)
+				       #f
+				       "eof of file found while parsing "
+				       "a character class.")))))))
+	    ((= tok-type minus-tok)
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"bad range specification in character class; a "
+			"specification"
+			#\newline
+			"like \"-x\", \"x--\" or \"x-]\" has been used."))
+            ((= tok-type rbrack-tok)
+	     #f)
+	    ((= tok-type eof-tok)
+	     (lex-error (get-tok-line tok)
+			#f
+			"eof of file found while parsing "
+			"a character class."))))))
+
+(define parse-class
+  (lambda (initial-class negative-class? line column)
+    (push-lexer 'class)
+    (let loop ((class initial-class))
+      (let ((new-range (parse-class-range)))
+	(if new-range
+	    (loop (class-union (list new-range) class))
+	    (let ((class (if negative-class?
+			     (class-compl class)
+			     class)))
+	      (pop-lexer)
+	      (make-tok class-tok "" line column class)))))))
+
+(define parse-string
+  (lambda (line column)
+    (push-lexer 'string)
+    (let ((char-list (let loop ()
+		       (let* ((tok (lexer))
+			      (tok-type (get-tok-type tok)))
+			 (cond ((= tok-type char-tok)
+				(cons (get-tok-attr tok) (loop)))
+			       ((= tok-type doublequote-tok)
+				(pop-lexer)
+				'())
+			       (else ; eof-tok
+				(lex-error (get-tok-line tok)
+					   #f
+					   "end of file found while "
+					   "parsing a string.")))))))
+      (make-tok string-tok "" line column char-list))))
+
+(define parse-regexp
+  (let* ((end-action
+	  (lambda (tok loop)
+	    (lexer-unget tok)
+	    (pop-lexer)
+	    (lexer-set-blank-history #f)
+	    `()))
+	 (action-table
+	  (make-dispatch-table
+	   number-of-tokens
+	   (list (cons eof-tok end-action)
+		 (cons hblank-tok end-action)
+		 (cons vblank-tok end-action)
+		 (cons lbrack-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class (list)
+						  #f
+						  (get-tok-line tok)
+						  (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-rbrack-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class
+				      (list (cons rbrack-ch rbrack-ch))
+				      #f
+				      (get-tok-line tok)
+				      (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-caret-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class (list)
+						  #t
+						  (get-tok-line tok)
+						  (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons lbrack-minus-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-class
+				      (list (cons minus-ch minus-ch))
+				      #f
+				      (get-tok-line tok)
+				      (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons doublequote-tok
+		       (lambda (tok loop)
+			 (let ((tok1 (parse-string (get-tok-line tok)
+						   (get-tok-column tok))))
+			   (cons tok1 (loop)))))
+		 (cons illegal-tok
+		       (lambda (tok loop)
+			 (lex-error (get-tok-line tok)
+				    (get-tok-column tok)
+				    "syntax error in macro reference."))))
+	   (lambda (tok loop)
+	     (cons tok (loop))))))
+    (lambda ()
+      (push-lexer 'regexp)
+      (lexer-set-blank-history #t)
+      (parse-hv-blanks)
+      (let loop ()
+	(let* ((tok (lexer))
+	       (tok-type (get-tok-type tok))
+	       (action (vector-ref action-table tok-type)))
+	  (action tok loop))))))
+
+(define parse-ws1-regexp  ; Exige un blanc entre le nom et la RE d'une macro
+  (lambda ()
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
+	     (parse-regexp))
+	    (else  ; percent-percent-tok, id-tok ou illegal-tok
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"white space expected."))))))
+
+(define parse-macro
+  (lambda (macros)
+    (push-lexer 'macro)
+    (parse-hv-blanks)
+    (let* ((tok (lexer))
+	   (tok-type (get-tok-type tok)))
+      (cond ((= tok-type id-tok)
+	     (let* ((name (get-tok-attr tok))
+		    (ass (assoc name macros)))
+	       (if ass
+		   (lex-error (get-tok-line tok)
+			      (get-tok-column tok)
+			      "the macro \""
+			      (get-tok-2nd-attr tok)
+			      "\" has already been defined.")
+		   (let* ((tok-list (parse-ws1-regexp))
+			  (regexp (tokens->regexp tok-list macros)))
+		     (pop-lexer)
+		     (cons name regexp)))))
+            ((= tok-type percent-percent-tok)
+	     (pop-lexer)
+	     #f)
+	    ((= tok-type illegal-tok)
+	     (lex-error (get-tok-line tok)
+			(get-tok-column tok)
+			"macro name expected."))
+	    ((= tok-type eof-tok)
+	     (lex-error (get-tok-line tok)
+			#f
+			"end of file found before %%."))))))
+
+(define parse-macros
+  (lambda ()
+    (let loop ((macros '()))
+      (let ((macro (parse-macro macros)))
+	(if macro
+	    (loop (cons macro macros))
+	    macros)))))
+
+(define parse-action-end
+  (lambda (<<EOF>>-action? <<ERROR>>-action? action?)
+    (let ((act (lexer-get-history)))
+      (cond (action?
+	     act)
+	    (<<EOF>>-action?
+	     (string-append act default-<<EOF>>-action))
+	    (<<ERROR>>-action?
+	     (string-append act default-<<ERROR>>-action))
+	    (else
+	     (string-append act default-action))))))
+
+(define parse-action
+  (lambda (<<EOF>>-action? <<ERROR>>-action?)
+    (push-lexer 'action)
+    (let loop ((action? #f))
+      (let* ((tok (lexer))
+	     (tok-type (get-tok-type tok)))
+	(cond ((= tok-type char-tok)
+	       (loop #t))
+	      ((= tok-type hblank-tok)
+	       (loop action?))
+	      ((= tok-type vblank-tok)
+	       (push-lexer 'regexp)
+	       (let* ((tok (lexer))
+		      (tok-type (get-tok-type tok))
+		      (bidon (lexer-unget tok)))
+		 (pop-lexer)
+		 (if (or (= tok-type hblank-tok)
+			 (= tok-type vblank-tok))
+		     (loop action?)
+		     (begin
+		       (pop-lexer)
+		       (parse-action-end <<EOF>>-action?
+					 <<ERROR>>-action?
+					 action?)))))
+	      (else ; eof-tok
+	       (lexer-unget tok)
+	       (pop-lexer)
+	       (parse-action-end <<EOF>>-action?
+				 <<ERROR>>-action?
+				 action?)))))))
+
+(define parse-rule
+  (lambda (macros)
+    (let ((tok-list (parse-regexp)))
+      (if (null? tok-list)
+	  #f
+	  (let* ((rule (tokens->rule tok-list macros))
+		 (action
+		  (parse-action (get-rule-eof? rule) (get-rule-error? rule))))
+	    (set-rule-action rule action)
+	    rule)))))
+
+(define parse-rules
+  (lambda (macros)
+    (parse-action #f #f)
+    (let loop ()
+      (let ((rule (parse-rule macros)))
+	(if rule
+	    (cons rule (loop))
+	    '())))))
+
+(define parser
+  (lambda (filename)
+    (let* ((port (open-input-file filename))
+	   (port-open? #t))
+      (lex-unwind-protect (lambda ()
+			    (if port-open?
+				(close-input-port port))))
+      (init-lexer port)
+      (let* ((macros (parse-macros))
+	     (rules (parse-rules macros)))
+	(close-input-port port)
+	(set! port-open? #f)
+	(adapt-rules rules)))))