Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log
Repository URL

silex.scm @ 35594

Last change on this file since 35594 was 35594, checked in by felix winkelmann, 3 years ago
silex 1.0
File size: 197.8 KB

Line
1	;; Copyright (C) 1997 Danny Dube, Universite de Montreal.
2	;; All rights reserved.
3
4	;; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
5	;; conditions are met:
6
7	;; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
8	;; disclaimer.
9	;; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
10	;; disclaimer in the documentation and/or other materials provided with the distribution.
11	;; Neither the name of the author nor the names of its contributors may be used to endorse or promote
12	;; products derived from this software without specific prior written permission.
13
14	;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
15	;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
16	;; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
17	;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
18	;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
19	;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
20	;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
21	;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
22	;; POSSIBILITY OF SUCH DAMAGE.
23
24	(module silex *
25	(import scheme srfi-13) ; srfi-13 for string-downcase
26
27	;----------------------------------------------------------------------------------------------------
28
29	(define (string-append-list lst)
30	(let loop1 ((n 0) (x lst) (y '()))
31	(if (pair? x)
32	(let ((s (car x)))
33	(loop1 (+ n (string-length s)) (cdr x) (cons s y)))
34	(let ((result (make-string n #\space)))
35	(let loop2 ((k (- n 1)) (y y))
36	(if (pair? y)
37	(let ((s (car y)))
38	(let loop3 ((i k) (j (- (string-length s) 1)))
39	(if (not (< j 0))
40	(begin
41	(string-set! result i (string-ref s j))
42	(loop3 (- i 1) (- j 1)))
43	(loop2 i (cdr y)))))
44	result))))))
45
46	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
47	; All rights reserved.
48	; SILex 1.0.
49
50	; Module util.scm.
51	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
52	; All rights reserved.
53	; SILex 1.0.
54
55	;
56	; Quelques definitions de constantes
57	;
58
59	(define eof-tok 0)
60	(define hblank-tok 1)
61	(define vblank-tok 2)
62	(define pipe-tok 3)
63	(define question-tok 4)
64	(define plus-tok 5)
65	(define star-tok 6)
66	(define lpar-tok 7)
67	(define rpar-tok 8)
68	(define dot-tok 9)
69	(define lbrack-tok 10)
70	(define lbrack-rbrack-tok 11)
71	(define lbrack-caret-tok 12)
72	(define lbrack-minus-tok 13)
73	(define subst-tok 14)
74	(define power-tok 15)
75	(define doublequote-tok 16)
76	(define char-tok 17)
77	(define caret-tok 18)
78	(define dollar-tok 19)
79	(define <<EOF>>-tok 20)
80	(define <<ERROR>>-tok 21)
81	(define percent-percent-tok 22)
82	(define id-tok 23)
83	(define rbrack-tok 24)
84	(define minus-tok 25)
85	(define illegal-tok 26)
86	; Tokens agreges
87	(define class-tok 27)
88	(define string-tok 28)
89
90	(define number-of-tokens 29)
91
92	(define newline-ch (char->integer #\newline))
93	(define tab-ch (char->integer #\ ))
94	(define dollar-ch (char->integer #\$))
95	(define minus-ch (char->integer #\-))
96	(define rbrack-ch (char->integer #\]))
97	(define caret-ch (char->integer #\^))
98
99	(define dot-class (list (cons 'inf- (- newline-ch 1))
100	(cons (+ newline-ch 1) 'inf+)))
101
102	(define default-action
103	(string-append " (yycontinue)" (string #\newline)))
104	(define default-<<EOF>>-action
105	(string-append " '(0)" (string #\newline)))
106	(define default-<<ERROR>>-action
107	(string-append " (begin"
108	(string #\newline)
109	" (display \"Error: Invalid token.\")"
110	(string #\newline)
111	" (newline)"
112	(string #\newline)
113	" 'error)"
114	(string #\newline)))
115
116
117
118
119	;
120	; Fabrication de tables de dispatch
121	;
122
123	(define make-dispatch-table
124	(lambda (size alist default)
125	(let ((v (make-vector size default)))
126	(let loop ((alist alist))
127	(if (null? alist)
128	v
129	(begin
130	(vector-set! v (caar alist) (cdar alist))
131	(loop (cdr alist))))))))
132
133
134
135
136	;
137	; Fonctions de manipulation des tokens
138	;
139
140	(define make-tok
141	(lambda (tok-type lexeme line column . attr)
142	(cond ((null? attr)
143	(vector tok-type line column lexeme))
144	((null? (cdr attr))
145	(vector tok-type line column lexeme (car attr)))
146	(else
147	(vector tok-type line column lexeme (car attr) (cadr attr))))))
148
149	(define get-tok-type (lambda (tok) (vector-ref tok 0)))
150	(define get-tok-line (lambda (tok) (vector-ref tok 1)))
151	(define get-tok-column (lambda (tok) (vector-ref tok 2)))
152	(define get-tok-lexeme (lambda (tok) (vector-ref tok 3)))
153	(define get-tok-attr (lambda (tok) (vector-ref tok 4)))
154	(define get-tok-2nd-attr (lambda (tok) (vector-ref tok 5)))
155
156
157
158
159	;
160	; Fonctions de manipulations des regles
161	;
162
163	(define make-rule
164	(lambda (line eof? error? bol? eol? regexp action)
165	(vector line eof? error? bol? eol? regexp action #f)))
166
167	(define get-rule-line (lambda (rule) (vector-ref rule 0)))
168	(define get-rule-eof? (lambda (rule) (vector-ref rule 1)))
169	(define get-rule-error? (lambda (rule) (vector-ref rule 2)))
170	(define get-rule-bol? (lambda (rule) (vector-ref rule 3)))
171	(define get-rule-eol? (lambda (rule) (vector-ref rule 4)))
172	(define get-rule-regexp (lambda (rule) (vector-ref rule 5)))
173	(define get-rule-action (lambda (rule) (vector-ref rule 6)))
174	(define get-rule-yytext? (lambda (rule) (vector-ref rule 7)))
175
176	(define set-rule-regexp (lambda (rule regexp) (vector-set! rule 5 regexp)))
177	(define set-rule-action (lambda (rule action) (vector-set! rule 6 action)))
178	(define set-rule-yytext? (lambda (rule yytext?) (vector-set! rule 7 yytext?)))
179
180
181
182
183	;
184	; Noeuds des regexp
185	;
186
187	(define epsilon-re 0)
188	(define or-re 1)
189	(define conc-re 2)
190	(define star-re 3)
191	(define plus-re 4)
192	(define question-re 5)
193	(define class-re 6)
194	(define char-re 7)
195
196	(define make-re
197	(lambda (re-type . lattr)
198	(cond ((null? lattr)
199	(vector re-type))
200	((null? (cdr lattr))
201	(vector re-type (car lattr)))
202	((null? (cddr lattr))
203	(vector re-type (car lattr) (cadr lattr))))))
204
205	(define get-re-type (lambda (re) (vector-ref re 0)))
206	(define get-re-attr1 (lambda (re) (vector-ref re 1)))
207	(define get-re-attr2 (lambda (re) (vector-ref re 2)))
208
209
210
211
212	;
213	; Fonctions de manipulation des ensembles d'etats
214	;
215
216	; Intersection de deux ensembles d'etats
217	(define ss-inter
218	(lambda (ss1 ss2)
219	(cond ((null? ss1)
220	'())
221	((null? ss2)
222	'())
223	(else
224	(let ((t1 (car ss1))
225	(t2 (car ss2)))
226	(cond ((< t1 t2)
227	(ss-inter (cdr ss1) ss2))
228	((= t1 t2)
229	(cons t1 (ss-inter (cdr ss1) (cdr ss2))))
230	(else
231	(ss-inter ss1 (cdr ss2)))))))))
232
233	; Difference entre deux ensembles d'etats
234	(define ss-diff
235	(lambda (ss1 ss2)
236	(cond ((null? ss1)
237	'())
238	((null? ss2)
239	ss1)
240	(else
241	(let ((t1 (car ss1))
242	(t2 (car ss2)))
243	(cond ((< t1 t2)
244	(cons t1 (ss-diff (cdr ss1) ss2)))
245	((= t1 t2)
246	(ss-diff (cdr ss1) (cdr ss2)))
247	(else
248	(ss-diff ss1 (cdr ss2)))))))))
249
250	; Union de deux ensembles d'etats
251	(define ss-union
252	(lambda (ss1 ss2)
253	(cond ((null? ss1)
254	ss2)
255	((null? ss2)
256	ss1)
257	(else
258	(let ((t1 (car ss1))
259	(t2 (car ss2)))
260	(cond ((< t1 t2)
261	(cons t1 (ss-union (cdr ss1) ss2)))
262	((= t1 t2)
263	(cons t1 (ss-union (cdr ss1) (cdr ss2))))
264	(else
265	(cons t2 (ss-union ss1 (cdr ss2))))))))))
266
267	; Decoupage de deux ensembles d'etats
268	(define ss-sep
269	(lambda (ss1 ss2)
270	(let loop ((ss1 ss1) (ss2 ss2) (l '()) (c '()) (r '()))
271	(if (null? ss1)
272	(if (null? ss2)
273	(vector (reverse l) (reverse c) (reverse r))
274	(loop ss1 (cdr ss2) l c (cons (car ss2) r)))
275	(if (null? ss2)
276	(loop (cdr ss1) ss2 (cons (car ss1) l) c r)
277	(let ((t1 (car ss1))
278	(t2 (car ss2)))
279	(cond ((< t1 t2)
280	(loop (cdr ss1) ss2 (cons t1 l) c r))
281	((= t1 t2)
282	(loop (cdr ss1) (cdr ss2) l (cons t1 c) r))
283	(else
284	(loop ss1 (cdr ss2) l c (cons t2 r))))))))))
285
286
287
288
289	;
290	; Fonctions de manipulation des classes de caracteres
291	;
292
293	; Comparaisons de bornes d'intervalles
294	(define class-= eqv?)
295
296	(define class-<=
297	(lambda (b1 b2)
298	(cond ((eq? b1 'inf-) #t)
299	((eq? b2 'inf+) #t)
300	((eq? b1 'inf+) #f)
301	((eq? b2 'inf-) #f)
302	(else (<= b1 b2)))))
303
304	(define class->=
305	(lambda (b1 b2)
306	(cond ((eq? b1 'inf+) #t)
307	((eq? b2 'inf-) #t)
308	((eq? b1 'inf-) #f)
309	((eq? b2 'inf+) #f)
310	(else (>= b1 b2)))))
311
312	(define class-<
313	(lambda (b1 b2)
314	(cond ((eq? b1 'inf+) #f)
315	((eq? b2 'inf-) #f)
316	((eq? b1 'inf-) #t)
317	((eq? b2 'inf+) #t)
318	(else (< b1 b2)))))
319
320	(define class->
321	(lambda (b1 b2)
322	(cond ((eq? b1 'inf-) #f)
323	((eq? b2 'inf+) #f)
324	((eq? b1 'inf+) #t)
325	((eq? b2 'inf-) #t)
326	(else (> b1 b2)))))
327
328	; Complementation d'une classe
329	(define class-compl
330	(lambda (c)
331	(let loop ((c c) (start 'inf-))
332	(if (null? c)
333	(list (cons start 'inf+))
334	(let* ((r (car c))
335	(rstart (car r))
336	(rend (cdr r)))
337	(if (class-< start rstart)
338	(cons (cons start (- rstart 1))
339	(loop c rstart))
340	(if (class-< rend 'inf+)
341	(loop (cdr c) (+ rend 1))
342	'())))))))
343
344	; Union de deux classes de caracteres
345	(define class-union
346	(lambda (c1 c2)
347	(let loop ((c1 c1) (c2 c2) (u '()))
348	(if (null? c1)
349	(if (null? c2)
350	(reverse u)
351	(loop c1 (cdr c2) (cons (car c2) u)))
352	(if (null? c2)
353	(loop (cdr c1) c2 (cons (car c1) u))
354	(let* ((r1 (car c1))
355	(r2 (car c2))
356	(r1start (car r1))
357	(r1end (cdr r1))
358	(r2start (car r2))
359	(r2end (cdr r2)))
360	(if (class-<= r1start r2start)
361	(cond ((class-= r1end 'inf+)
362	(loop c1 (cdr c2) u))
363	((class-< (+ r1end 1) r2start)
364	(loop (cdr c1) c2 (cons r1 u)))
365	((class-<= r1end r2end)
366	(loop (cdr c1)
367	(cons (cons r1start r2end) (cdr c2))
368	u))
369	(else
370	(loop c1 (cdr c2) u)))
371	(cond ((class-= r2end 'inf+)
372	(loop (cdr c1) c2 u))
373	((class-> r1start (+ r2end 1))
374	(loop c1 (cdr c2) (cons r2 u)))
375	((class->= r1end r2end)
376	(loop (cons (cons r2start r1end) (cdr c1))
377	(cdr c2)
378	u))
379	(else
380	(loop (cdr c1) c2 u))))))))))
381
382	; Decoupage de deux classes de caracteres
383	(define class-sep
384	(lambda (c1 c2)
385	(let loop ((c1 c1) (c2 c2) (l '()) (c '()) (r '()))
386	(if (null? c1)
387	(if (null? c2)
388	(vector (reverse l) (reverse c) (reverse r))
389	(loop c1 (cdr c2) l c (cons (car c2) r)))
390	(if (null? c2)
391	(loop (cdr c1) c2 (cons (car c1) l) c r)
392	(let* ((r1 (car c1))
393	(r2 (car c2))
394	(r1start (car r1))
395	(r1end (cdr r1))
396	(r2start (car r2))
397	(r2end (cdr r2)))
398	(cond ((class-< r1start r2start)
399	(if (class-< r1end r2start)
400	(loop (cdr c1) c2 (cons r1 l) c r)
401	(loop (cons (cons r2start r1end) (cdr c1)) c2
402	(cons (cons r1start (- r2start 1)) l) c r)))
403	((class-> r1start r2start)
404	(if (class-> r1start r2end)
405	(loop c1 (cdr c2) l c (cons r2 r))
406	(loop c1 (cons (cons r1start r2end) (cdr c2))
407	l c (cons (cons r2start (- r1start 1)) r))))
408	(else
409	(cond ((class-< r1end r2end)
410	(loop (cdr c1)
411	(cons (cons (+ r1end 1) r2end) (cdr c2))
412	l (cons r1 c) r))
413	((class-= r1end r2end)
414	(loop (cdr c1) (cdr c2) l (cons r1 c) r))
415	(else
416	(loop (cons (cons (+ r2end 1) r1end) (cdr c1))
417	(cdr c2)
418	l (cons r2 c) r)))))))))))
419
420	; Transformer une classe (finie) de caracteres en une liste de ...
421	(define class->char-list
422	(lambda (c)
423	(let loop1 ((c c))
424	(if (null? c)
425	'()
426	(let* ((r (car c))
427	(rend (cdr r))
428	(tail (loop1 (cdr c))))
429	(let loop2 ((rstart (car r)))
430	(if (<= rstart rend)
431	(cons (integer->char rstart) (loop2 (+ rstart 1)))
432	tail)))))))
433
434	; Transformer une classe de caracteres en une liste poss. compl.
435	; 1er element = #t -> classe complementee
436	(define class->tagged-char-list
437	(lambda (c)
438	(let* ((finite? (or (null? c) (number? (caar c))))
439	(c2 (if finite? c (class-compl c)))
440	(c-l (class->char-list c2)))
441	(cons (not finite?) c-l))))
442
443
444
445
446	;
447	; Fonction digraph
448	;
449
450	; Fonction "digraph".
451	; Etant donne un graphe dirige dont les noeuds comportent une valeur,
452	; calcule pour chaque noeud la "somme" des valeurs contenues dans le
453	; noeud lui-meme et ceux atteignables a partir de celui-ci. La "somme"
454	; consiste a appliquer un operateur commutatif et associatif aux valeurs
455	; lorsqu'elles sont additionnees.
456	; L'entree consiste en un vecteur de voisinages externes, un autre de
457	; valeurs initiales et d'un operateur.
458	; La sortie est un vecteur de valeurs finales.
459	(define digraph
460	(lambda (arcs init op)
461	(let* ((nbnodes (vector-length arcs))
462	(infinity nbnodes)
463	(prio (make-vector nbnodes -1))
464	(stack (make-vector nbnodes #f))
465	(sp 0)
466	(final (make-vector nbnodes #f)))
467	(letrec ((store-final
468	(lambda (self-sp value)
469	(let loop ()
470	(if (> sp self-sp)
471	(let ((voisin (vector-ref stack (- sp 1))))
472	(vector-set! prio voisin infinity)
473	(set! sp (- sp 1))
474	(vector-set! final voisin value)
475	(loop))))))
476	(visit-node
477	(lambda (n)
478	(let ((self-sp sp))
479	(vector-set! prio n self-sp)
480	(vector-set! stack sp n)
481	(set! sp (+ sp 1))
482	(vector-set! final n (vector-ref init n))
483	(let loop ((vois (vector-ref arcs n)))
484	(if (pair? vois)
485	(let* ((v (car vois))
486	(vprio (vector-ref prio v)))
487	(if (= vprio -1)
488	(visit-node v))
489	(vector-set! prio n (min (vector-ref prio n)
490	(vector-ref prio v)))
491	(vector-set! final n (op (vector-ref final n)
492	(vector-ref final v)))
493	(loop (cdr vois)))))
494	(if (= (vector-ref prio n) self-sp)
495	(store-final self-sp (vector-ref final n)))))))
496	(let loop ((n 0))
497	(if (< n nbnodes)
498	(begin
499	(if (= (vector-ref prio n) -1)
500	(visit-node n))
501	(loop (+ n 1)))))
502	final))))
503
504
505
506
507	;
508	; Fonction de tri
509	;
510
511	(define merge-sort-merge
512	(lambda (l1 l2 cmp-<=)
513	(cond ((null? l1)
514	l2)
515	((null? l2)
516	l1)
517	(else
518	(let ((h1 (car l1))
519	(h2 (car l2)))
520	(if (cmp-<= h1 h2)
521	(cons h1 (merge-sort-merge (cdr l1) l2 cmp-<=))
522	(cons h2 (merge-sort-merge l1 (cdr l2) cmp-<=))))))))
523
524	(define merge-sort
525	(lambda (l cmp-<=)
526	(if (null? l)
527	l
528	(let loop1 ((ll (map list l)))
529	(if (null? (cdr ll))
530	(car ll)
531	(loop1
532	(let loop2 ((ll ll))
533	(cond ((null? ll)
534	ll)
535	((null? (cdr ll))
536	ll)
537	(else
538	(cons (merge-sort-merge (car ll) (cadr ll) cmp-<=)
539	(loop2 (cddr ll))))))))))))
540
541	; Module action.l.scm.
542	;
543	; Table generated from the file action.l by SILex 1.0
544	;
545
546	(define action-tables
547	(vector
548	'all
549	(lambda (yycontinue yygetc yyungetc)
550	(lambda (yytext yyline yycolumn yyoffset)
551	(make-tok eof-tok yytext yyline yycolumn)
552	))
553	(lambda (yycontinue yygetc yyungetc)
554	(lambda (yytext yyline yycolumn yyoffset)
555	(begin
556	(display "Error: Invalid token.")
557	(newline)
558	'error)
559	))
560	(vector
561	#t
562	(lambda (yycontinue yygetc yyungetc)
563	(lambda (yytext yyline yycolumn yyoffset)
564	(make-tok hblank-tok yytext yyline yycolumn)
565	))
566	#t
567	(lambda (yycontinue yygetc yyungetc)
568	(lambda (yytext yyline yycolumn yyoffset)
569	(make-tok vblank-tok yytext yyline yycolumn)
570	))
571	#t
572	(lambda (yycontinue yygetc yyungetc)
573	(lambda (yytext yyline yycolumn yyoffset)
574	(make-tok char-tok yytext yyline yycolumn)
575	)))
576	'tagged-chars-lists
577	0
578	0
579	'#((((#f #\ #\space) . 4)
580	((#f #\;) . 3)
581	((#f #\newline) . 2)
582	((#t #\ #\newline #\space #\;) . 1))
583	(((#t #\newline) . 1))
584	()
585	(((#t #\newline) . 3))
586	(((#f #\ #\space) . 4)
587	((#f #\;) . 3)
588	((#t #\ #\newline #\space #\;) . 1)))
589	'#((#f . #f) (2 . 2) (1 . 1) (0 . 0) (0 . 0))))
590
591	; Module class.l.scm.
592	;
593	; Table generated from the file class.l by SILex 1.0
594	;
595
596	(define class-tables
597	(vector
598	'all
599	(lambda (yycontinue yygetc yyungetc)
600	(lambda (yytext yyline yycolumn yyoffset)
601	(make-tok eof-tok yytext yyline yycolumn)
602	))
603	(lambda (yycontinue yygetc yyungetc)
604	(lambda (yytext yyline yycolumn yyoffset)
605	(begin
606	(display "Error: Invalid token.")
607	(newline)
608	'error)
609	))
610	(vector
611	#t
612	(lambda (yycontinue yygetc yyungetc)
613	(lambda (yytext yyline yycolumn yyoffset)
614	(make-tok rbrack-tok yytext yyline yycolumn)
615	))
616	#t
617	(lambda (yycontinue yygetc yyungetc)
618	(lambda (yytext yyline yycolumn yyoffset)
619	(make-tok minus-tok yytext yyline yycolumn)
620	))
621	#t
622	(lambda (yycontinue yygetc yyungetc)
623	(lambda (yytext yyline yycolumn yyoffset)
624	(parse-spec-char yytext yyline yycolumn)
625	))
626	#t
627	(lambda (yycontinue yygetc yyungetc)
628	(lambda (yytext yyline yycolumn yyoffset)
629	(parse-digits-char yytext yyline yycolumn)
630	))
631	#t
632	(lambda (yycontinue yygetc yyungetc)
633	(lambda (yytext yyline yycolumn yyoffset)
634	(parse-digits-char yytext yyline yycolumn)
635	))
636	#t
637	(lambda (yycontinue yygetc yyungetc)
638	(lambda (yytext yyline yycolumn yyoffset)
639	(parse-quoted-char yytext yyline yycolumn)
640	))
641	#t
642	(lambda (yycontinue yygetc yyungetc)
643	(lambda (yytext yyline yycolumn yyoffset)
644	(parse-ordinary-char yytext yyline yycolumn)
645	)))
646	'tagged-chars-lists
647	0
648	0
649	'#((((#f #\]) . 4) ((#f #\-) . 3) ((#f #\\) . 2) ((#t #\- #\\ #\]) . 1))
650	()
651	(((#f #\n) . 8)
652	((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 7)
653	((#f #\-) . 6)
654	((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 5))
655	()
656	()
657	()
658	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
659	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10))
660	()
661	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
662	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 10)))
663	'#((#f . #f) (6 . 6) (6 . 6) (1 . 1) (0 . 0) (5 . 5) (5 . 5)
664	(3 . 3) (2 . 2) (4 . 4) (3 . 3))))
665
666	; Module macro.l.scm.
667	;
668	; Table generated from the file macro.l by SILex 1.0
669	;
670
671	(define macro-tables
672	(vector
673	'all
674	(lambda (yycontinue yygetc yyungetc)
675	(lambda (yytext yyline yycolumn yyoffset)
676	(make-tok eof-tok yytext yyline yycolumn)
677	))
678	(lambda (yycontinue yygetc yyungetc)
679	(lambda (yytext yyline yycolumn yyoffset)
680	(begin
681	(display "Error: Invalid token.")
682	(newline)
683	'error)
684	))
685	(vector
686	#t
687	(lambda (yycontinue yygetc yyungetc)
688	(lambda (yytext yyline yycolumn yyoffset)
689	(make-tok hblank-tok yytext yyline yycolumn)
690	))
691	#t
692	(lambda (yycontinue yygetc yyungetc)
693	(lambda (yytext yyline yycolumn yyoffset)
694	(make-tok vblank-tok yytext yyline yycolumn)
695	))
696	#t
697	(lambda (yycontinue yygetc yyungetc)
698	(lambda (yytext yyline yycolumn yyoffset)
699	(make-tok percent-percent-tok yytext yyline yycolumn)
700	))
701	#t
702	(lambda (yycontinue yygetc yyungetc)
703	(lambda (yytext yyline yycolumn yyoffset)
704	(parse-id yytext yyline yycolumn)
705	))
706	#t
707	(lambda (yycontinue yygetc yyungetc)
708	(lambda (yytext yyline yycolumn yyoffset)
709	(make-tok illegal-tok yytext yyline yycolumn)
710	)))
711	'tagged-chars-lists
712	0
713	0
714	'#((((#f #\ #\space) . 8)
715	((#f #\;) . 7)
716	((#f #\newline) . 6)
717	((#f #\%) . 5)
718	((#f #\! #\$ #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E
719	#\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U
720	#\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i
721	#\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y
722	#\z #\~)
723	.
724	4)
725	((#f #\+ #\-) . 3)
726	((#f #\.) . 2)
727	((#t #\ #\newline #\space #\! #\$
728	#\% #\& #\* #\+ #\- #\.
729	#\/ #\: #\; #\< #\= #\>
730	#\? #\A #\B #\C #\D #\E
731	#\F #\G #\H #\I #\J #\K
732	#\L #\M #\N #\O #\P #\Q
733	#\R #\S #\T #\U #\V #\W
734	#\X #\Y #\Z #\^ #\_ #\a
735	#\b #\c #\d #\e #\f #\g
736	#\h #\i #\j #\k #\l #\m
737	#\n #\o #\p #\q #\r #\s
738	#\t #\u #\v #\w #\x #\y
739	#\z #\~)
740	.
741	1))
742	()
743	(((#f #\.) . 9))
744	()
745	(((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
746	#\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
747	#\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
748	#\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
749	#\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
750	.
751	10))
752	(((#f #\%) . 11)
753	((#f #\! #\$ #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6
754	#\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G #\H
755	#\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X
756	#\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l
757	#\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
758	.
759	10))
760	()
761	(((#t #\newline) . 12))
762	()
763	(((#f #\.) . 13))
764	(((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
765	#\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
766	#\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
767	#\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
768	#\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
769	.
770	10))
771	(((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
772	#\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
773	#\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
774	#\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
775	#\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
776	.
777	10))
778	(((#t #\newline) . 12))
779	())
780	'#((#f . #f) (4 . 4) (4 . 4) (3 . 3) (3 . 3) (3 . 3) (1 . 1)
781	(0 . 0) (0 . 0) (#f . #f) (3 . 3) (2 . 2) (0 . 0) (3 . 3))))
782
783	; Module regexp.l.scm.
784	;
785	; Table generated from the file regexp.l by SILex 1.0
786	;
787
788	(define regexp-tables
789	(vector
790	'all
791	(lambda (yycontinue yygetc yyungetc)
792	(lambda (yytext yyline yycolumn yyoffset)
793	(make-tok eof-tok yytext yyline yycolumn)
794	))
795	(lambda (yycontinue yygetc yyungetc)
796	(lambda (yytext yyline yycolumn yyoffset)
797	(begin
798	(display "Error: Invalid token.")
799	(newline)
800	'error)
801	))
802	(vector
803	#t
804	(lambda (yycontinue yygetc yyungetc)
805	(lambda (yytext yyline yycolumn yyoffset)
806	(make-tok hblank-tok yytext yyline yycolumn)
807	))
808	#t
809	(lambda (yycontinue yygetc yyungetc)
810	(lambda (yytext yyline yycolumn yyoffset)
811	(make-tok vblank-tok yytext yyline yycolumn)
812	))
813	#t
814	(lambda (yycontinue yygetc yyungetc)
815	(lambda (yytext yyline yycolumn yyoffset)
816	(make-tok pipe-tok yytext yyline yycolumn)
817	))
818	#t
819	(lambda (yycontinue yygetc yyungetc)
820	(lambda (yytext yyline yycolumn yyoffset)
821	(make-tok question-tok yytext yyline yycolumn)
822	))
823	#t
824	(lambda (yycontinue yygetc yyungetc)
825	(lambda (yytext yyline yycolumn yyoffset)
826	(make-tok plus-tok yytext yyline yycolumn)
827	))
828	#t
829	(lambda (yycontinue yygetc yyungetc)
830	(lambda (yytext yyline yycolumn yyoffset)
831	(make-tok star-tok yytext yyline yycolumn)
832	))
833	#t
834	(lambda (yycontinue yygetc yyungetc)
835	(lambda (yytext yyline yycolumn yyoffset)
836	(make-tok lpar-tok yytext yyline yycolumn)
837	))
838	#t
839	(lambda (yycontinue yygetc yyungetc)
840	(lambda (yytext yyline yycolumn yyoffset)
841	(make-tok rpar-tok yytext yyline yycolumn)
842	))
843	#t
844	(lambda (yycontinue yygetc yyungetc)
845	(lambda (yytext yyline yycolumn yyoffset)
846	(make-tok dot-tok yytext yyline yycolumn)
847	))
848	#t
849	(lambda (yycontinue yygetc yyungetc)
850	(lambda (yytext yyline yycolumn yyoffset)
851	(make-tok lbrack-tok yytext yyline yycolumn)
852	))
853	#t
854	(lambda (yycontinue yygetc yyungetc)
855	(lambda (yytext yyline yycolumn yyoffset)
856	(make-tok lbrack-rbrack-tok yytext yyline yycolumn)
857	))
858	#t
859	(lambda (yycontinue yygetc yyungetc)
860	(lambda (yytext yyline yycolumn yyoffset)
861	(make-tok lbrack-caret-tok yytext yyline yycolumn)
862	))
863	#t
864	(lambda (yycontinue yygetc yyungetc)
865	(lambda (yytext yyline yycolumn yyoffset)
866	(make-tok lbrack-minus-tok yytext yyline yycolumn)
867	))
868	#t
869	(lambda (yycontinue yygetc yyungetc)
870	(lambda (yytext yyline yycolumn yyoffset)
871	(parse-id-ref yytext yyline yycolumn)
872	))
873	#t
874	(lambda (yycontinue yygetc yyungetc)
875	(lambda (yytext yyline yycolumn yyoffset)
876	(parse-power-m yytext yyline yycolumn)
877	))
878	#t
879	(lambda (yycontinue yygetc yyungetc)
880	(lambda (yytext yyline yycolumn yyoffset)
881	(parse-power-m-inf yytext yyline yycolumn)
882	))
883	#t
884	(lambda (yycontinue yygetc yyungetc)
885	(lambda (yytext yyline yycolumn yyoffset)
886	(parse-power-m-n yytext yyline yycolumn)
887	))
888	#t
889	(lambda (yycontinue yygetc yyungetc)
890	(lambda (yytext yyline yycolumn yyoffset)
891	(make-tok illegal-tok yytext yyline yycolumn)
892	))
893	#t
894	(lambda (yycontinue yygetc yyungetc)
895	(lambda (yytext yyline yycolumn yyoffset)
896	(make-tok doublequote-tok yytext yyline yycolumn)
897	))
898	#t
899	(lambda (yycontinue yygetc yyungetc)
900	(lambda (yytext yyline yycolumn yyoffset)
901	(parse-spec-char yytext yyline yycolumn)
902	))
903	#t
904	(lambda (yycontinue yygetc yyungetc)
905	(lambda (yytext yyline yycolumn yyoffset)
906	(parse-digits-char yytext yyline yycolumn)
907	))
908	#t
909	(lambda (yycontinue yygetc yyungetc)
910	(lambda (yytext yyline yycolumn yyoffset)
911	(parse-digits-char yytext yyline yycolumn)
912	))
913	#t
914	(lambda (yycontinue yygetc yyungetc)
915	(lambda (yytext yyline yycolumn yyoffset)
916	(parse-quoted-char yytext yyline yycolumn)
917	))
918	#t
919	(lambda (yycontinue yygetc yyungetc)
920	(lambda (yytext yyline yycolumn yyoffset)
921	(make-tok caret-tok yytext yyline yycolumn)
922	))
923	#t
924	(lambda (yycontinue yygetc yyungetc)
925	(lambda (yytext yyline yycolumn yyoffset)
926	(make-tok dollar-tok yytext yyline yycolumn)
927	))
928	#t
929	(lambda (yycontinue yygetc yyungetc)
930	(lambda (yytext yyline yycolumn yyoffset)
931	(parse-ordinary-char yytext yyline yycolumn)
932	))
933	#t
934	(lambda (yycontinue yygetc yyungetc)
935	(lambda (yytext yyline yycolumn yyoffset)
936	(make-tok <<EOF>>-tok yytext yyline yycolumn)
937	))
938	#t
939	(lambda (yycontinue yygetc yyungetc)
940	(lambda (yytext yyline yycolumn yyoffset)
941	(make-tok <<ERROR>>-tok yytext yyline yycolumn)
942	)))
943	'tagged-chars-lists
944	0
945	0
946	'#((((#f #\ #\space) . 18)
947	((#f #\;) . 17)
948	((#f #\newline) . 16)
949	((#f #\\|) . 15)
950	((#f #\?) . 14)
951	((#f #\+) . 13)
952	((#f #\*) . 12)
953	((#f #\() . 11)
954	((#f #\)) . 10)
955	((#f #\.) . 9)
956	((#f #\[) . 8)
957	((#f #\{) . 7)
958	((#f #\") . 6)
959	((#f #\\) . 5)
960	((#f #\^) . 4)
961	((#f #\$) . 3)
962	((#t #\ #\newline #\space #\" #\$
963	#$ #$ #\* #\+ #\. #\;
964	#\< #\? #\[ #\\ #\^ #\{
965	#\\|)
966	.
967	2)
968	((#f #\<) . 1))
969	(((#f #\<) . 19))
970	()
971	()
972	()
973	(((#f #\n) . 23)
974	((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 22)
975	((#f #\-) . 21)
976	((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 20))
977	()
978	(((#f #\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\A #\B #\C #\D
979	#\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
980	#\U #\V #\W #\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h
981	#\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
982	#\y #\z #\~)
983	.
984	27)
985	((#f #\+ #\-) . 26)
986	((#f #\.) . 25)
987	((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24))
988	(((#f #\]) . 30) ((#f #\^) . 29) ((#f #\-) . 28))
989	()
990	()
991	()
992	()
993	()
994	()
995	()
996	()
997	(((#t #\newline) . 31))
998	()
999	(((#f #\E) . 32))
1000	()
1001	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
1002	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
1003	()
1004	(((#f #\}) . 36)
1005	((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 24)
1006	((#f #\,) . 35))
1007	(((#f #\.) . 37))
1008	(((#f #\}) . 38))
1009	(((#f #\}) . 38)
1010	((#f #\! #\$ #\% #\& #\* #\+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
1011	#\6 #\7 #\8 #\9 #\: #\< #\= #\> #\? #\A #\B #\C #\D #\E #\F #\G
1012	#\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W
1013	#\X #\Y #\Z #\^ #\_ #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k
1014	#\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\~)
1015	.
1016	27))
1017	()
1018	()
1019	()
1020	(((#t #\newline) . 31))
1021	(((#f #\O) . 40) ((#f #\R) . 39))
1022	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 33))
1023	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 34))
1024	(((#f #\}) . 42) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
1025	()
1026	(((#f #\.) . 26))
1027	()
1028	(((#f #\R) . 43))
1029	(((#f #\F) . 44))
1030	(((#f #\}) . 45) ((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 41))
1031	()
1032	(((#f #\O) . 46))
1033	(((#f #\>) . 47))
1034	()
1035	(((#f #\R) . 48))
1036	(((#f #\>) . 49))
1037	(((#f #\>) . 50))
1038	()
1039	(((#f #\>) . 51))
1040	())
1041	'#((#f . #f) (25 . 25) (25 . 25) (24 . 24) (23 . 23) (25 . 25) (18 . 18)
1042	(17 . 17) (9 . 9) (8 . 8) (7 . 7) (6 . 6) (5 . 5) (4 . 4)
1043	(3 . 3) (2 . 2) (1 . 1) (0 . 0) (0 . 0) (#f . #f) (22 . 22)
1044	(22 . 22) (20 . 20) (19 . 19) (#f . #f) (#f . #f) (#f . #f) (#f . #f)
1045	(12 . 12) (11 . 11) (10 . 10) (0 . 0) (#f . #f) (21 . 21) (20 . 20)
1046	(#f . #f) (14 . 14) (#f . #f) (13 . 13) (#f . #f) (#f . #f) (#f . #f)
1047	(15 . 15) (#f . #f) (#f . #f) (16 . 16) (#f . #f) (#f . #f) (#f . #f)
1048	(26 . 26) (#f . #f) (27 . 27))))
1049
1050	; Module string.l.scm.
1051	;
1052	; Table generated from the file string.l by SILex 1.0
1053	;
1054
1055	(define string-tables
1056	(vector
1057	'all
1058	(lambda (yycontinue yygetc yyungetc)
1059	(lambda (yytext yyline yycolumn yyoffset)
1060	(make-tok eof-tok yytext yyline yycolumn)
1061	))
1062	(lambda (yycontinue yygetc yyungetc)
1063	(lambda (yytext yyline yycolumn yyoffset)
1064	(begin
1065	(display "Error: Invalid token.")
1066	(newline)
1067	'error)
1068	))
1069	(vector
1070	#t
1071	(lambda (yycontinue yygetc yyungetc)
1072	(lambda (yytext yyline yycolumn yyoffset)
1073	(make-tok doublequote-tok yytext yyline yycolumn)
1074	))
1075	#t
1076	(lambda (yycontinue yygetc yyungetc)
1077	(lambda (yytext yyline yycolumn yyoffset)
1078	(parse-spec-char yytext yyline yycolumn)
1079	))
1080	#t
1081	(lambda (yycontinue yygetc yyungetc)
1082	(lambda (yytext yyline yycolumn yyoffset)
1083	(parse-digits-char yytext yyline yycolumn)
1084	))
1085	#t
1086	(lambda (yycontinue yygetc yyungetc)
1087	(lambda (yytext yyline yycolumn yyoffset)
1088	(parse-digits-char yytext yyline yycolumn)
1089	))
1090	#t
1091	(lambda (yycontinue yygetc yyungetc)
1092	(lambda (yytext yyline yycolumn yyoffset)
1093	(parse-quoted-char yytext yyline yycolumn)
1094	))
1095	#t
1096	(lambda (yycontinue yygetc yyungetc)
1097	(lambda (yytext yyline yycolumn yyoffset)
1098	(parse-ordinary-char yytext yyline yycolumn)
1099	)))
1100	'tagged-chars-lists
1101	0
1102	0
1103	'#((((#f #\") . 3) ((#f #\\) . 2) ((#t #\" #\\) . 1))
1104	()
1105	(((#f #\n) . 7)
1106	((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 6)
1107	((#f #\-) . 5)
1108	((#t #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\n) . 4))
1109	()
1110	()
1111	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
1112	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9))
1113	()
1114	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 8))
1115	(((#f #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) . 9)))
1116	'#((#f . #f) (5 . 5) (5 . 5) (0 . 0) (4 . 4) (4 . 4) (2 . 2)
1117	(1 . 1) (3 . 3) (2 . 2))))
1118
1119	; Module multilex.scm.
1120	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
1121	; All rights reserved.
1122	; SILex 1.0.
1123
1124	;
1125	; Gestion des Input Systems
1126	; Fonctions a utiliser par l'usager:
1127	; lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
1128	; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
1129	;
1130
1131	; Taille initiale par defaut du buffer d'entree
1132	(define lexer-init-buffer-len 1024)
1133
1134	; Numero du caractere newline
1135	(define lexer-integer-newline (char->integer #\newline))
1136
1137	; Constructeur d'IS brut
1138	(define lexer-raw-IS-maker
1139	(lambda (buffer read-ptr input-f counters)
1140	(let ((input-f input-f) ; Entree reelle
1141	(buffer buffer) ; Buffer
1142	(buflen (string-length buffer))
1143	(read-ptr read-ptr)
1144	(start-ptr 1) ; Marque de debut de lexeme
1145	(start-line 1)
1146	(start-column 1)
1147	(start-offset 0)
1148	(end-ptr 1) ; Marque de fin de lexeme
1149	(point-ptr 1) ; Le point
1150	(user-ptr 1) ; Marque de l'usager
1151	(user-line 1)
1152	(user-column 1)
1153	(user-offset 0)
1154	(user-up-to-date? #t)) ; Concerne la colonne seul.
1155	(letrec
1156	((start-go-to-end-none ; Fonctions de depl. des marques
1157	(lambda ()
1158	(set! start-ptr end-ptr)))
1159	(start-go-to-end-line
1160	(lambda ()
1161	(let loop ((ptr start-ptr) (line start-line))
1162	(if (= ptr end-ptr)
1163	(begin
1164	(set! start-ptr ptr)
1165	(set! start-line line))
1166	(if (char=? (string-ref buffer ptr) #\newline)
1167	(loop (+ ptr 1) (+ line 1))
1168	(loop (+ ptr 1) line))))))
1169	(start-go-to-end-all
1170	(lambda ()
1171	(set! start-offset (+ start-offset (- end-ptr start-ptr)))
1172	(let loop ((ptr start-ptr)
1173	(line start-line)
1174	(column start-column))
1175	(if (= ptr end-ptr)
1176	(begin
1177	(set! start-ptr ptr)
1178	(set! start-line line)
1179	(set! start-column column))
1180	(if (char=? (string-ref buffer ptr) #\newline)
1181	(loop (+ ptr 1) (+ line 1) 1)
1182	(loop (+ ptr 1) line (+ column 1)))))))
1183	(start-go-to-user-none
1184	(lambda ()
1185	(set! start-ptr user-ptr)))
1186	(start-go-to-user-line
1187	(lambda ()
1188	(set! start-ptr user-ptr)
1189	(set! start-line user-line)))
1190	(start-go-to-user-all
1191	(lambda ()
1192	(set! start-line user-line)
1193	(set! start-offset user-offset)
1194	(if user-up-to-date?
1195	(begin
1196	(set! start-ptr user-ptr)
1197	(set! start-column user-column))
1198	(let loop ((ptr start-ptr) (column start-column))
1199	(if (= ptr user-ptr)
1200	(begin
1201	(set! start-ptr ptr)
1202	(set! start-column column))
1203	(if (char=? (string-ref buffer ptr) #\newline)
1204	(loop (+ ptr 1) 1)
1205	(loop (+ ptr 1) (+ column 1))))))))
1206	(end-go-to-point
1207	(lambda ()
1208	(set! end-ptr point-ptr)))
1209	(point-go-to-start
1210	(lambda ()
1211	(set! point-ptr start-ptr)))
1212	(user-go-to-start-none
1213	(lambda ()
1214	(set! user-ptr start-ptr)))
1215	(user-go-to-start-line
1216	(lambda ()
1217	(set! user-ptr start-ptr)
1218	(set! user-line start-line)))
1219	(user-go-to-start-all
1220	(lambda ()
1221	(set! user-ptr start-ptr)
1222	(set! user-line start-line)
1223	(set! user-column start-column)
1224	(set! user-offset start-offset)
1225	(set! user-up-to-date? #t)))
1226	(init-lexeme-none ; Debute un nouveau lexeme
1227	(lambda ()
1228	(if (< start-ptr user-ptr)
1229	(start-go-to-user-none))
1230	(point-go-to-start)))
1231	(init-lexeme-line
1232	(lambda ()
1233	(if (< start-ptr user-ptr)
1234	(start-go-to-user-line))
1235	(point-go-to-start)))
1236	(init-lexeme-all
1237	(lambda ()
1238	(if (< start-ptr user-ptr)
1239	(start-go-to-user-all))
1240	(point-go-to-start)))
1241	(get-start-line ; Obtention des stats du debut du lxm
1242	(lambda ()
1243	start-line))
1244	(get-start-column
1245	(lambda ()
1246	start-column))
1247	(get-start-offset
1248	(lambda ()
1249	start-offset))
1250	(peek-left-context ; Obtention de caracteres (#f si EOF)
1251	(lambda ()
1252	(char->integer (string-ref buffer (- start-ptr 1)))))
1253	(peek-char
1254	(lambda ()
1255	(if (< point-ptr read-ptr)
1256	(char->integer (string-ref buffer point-ptr))
1257	(let ((c (input-f)))
1258	(if (char? c)
1259	(begin
1260	(if (= read-ptr buflen)
1261	(reorganize-buffer))
1262	(string-set! buffer point-ptr c)
1263	(set! read-ptr (+ point-ptr 1))
1264	(char->integer c))
1265	(begin
1266	(set! input-f (lambda () 'eof))
1267	#f))))))
1268	(read-char
1269	(lambda ()
1270	(if (< point-ptr read-ptr)
1271	(let ((c (string-ref buffer point-ptr)))
1272	(set! point-ptr (+ point-ptr 1))
1273	(char->integer c))
1274	(let ((c (input-f)))
1275	(if (char? c)
1276	(begin
1277	(if (= read-ptr buflen)
1278	(reorganize-buffer))
1279	(string-set! buffer point-ptr c)
1280	(set! read-ptr (+ point-ptr 1))
1281	(set! point-ptr read-ptr)
1282	(char->integer c))
1283	(begin
1284	(set! input-f (lambda () 'eof))
1285	#f))))))
1286	(get-start-end-text ; Obtention du lexeme
1287	(lambda ()
1288	(substring buffer start-ptr end-ptr)))
1289	(get-user-line-line ; Fonctions pour l'usager
1290	(lambda ()
1291	(if (< user-ptr start-ptr)
1292	(user-go-to-start-line))
1293	user-line))
1294	(get-user-line-all
1295	(lambda ()
1296	(if (< user-ptr start-ptr)
1297	(user-go-to-start-all))
1298	user-line))
1299	(get-user-column-all
1300	(lambda ()
1301	(cond ((< user-ptr start-ptr)
1302	(user-go-to-start-all)
1303	user-column)
1304	(user-up-to-date?
1305	user-column)
1306	(else
1307	(let loop ((ptr start-ptr) (column start-column))
1308	(if (= ptr user-ptr)
1309	(begin
1310	(set! user-column column)
1311	(set! user-up-to-date? #t)
1312	column)
1313	(if (char=? (string-ref buffer ptr) #\newline)
1314	(loop (+ ptr 1) 1)
1315	(loop (+ ptr 1) (+ column 1)))))))))
1316	(get-user-offset-all
1317	(lambda ()
1318	(if (< user-ptr start-ptr)
1319	(user-go-to-start-all))
1320	user-offset))
1321	(user-getc-none
1322	(lambda ()
1323	(if (< user-ptr start-ptr)
1324	(user-go-to-start-none))
1325	(if (< user-ptr read-ptr)
1326	(let ((c (string-ref buffer user-ptr)))
1327	(set! user-ptr (+ user-ptr 1))
1328	c)
1329	(let ((c (input-f)))
1330	(if (char? c)
1331	(begin
1332	(if (= read-ptr buflen)
1333	(reorganize-buffer))
1334	(string-set! buffer user-ptr c)
1335	(set! read-ptr (+ read-ptr 1))
1336	(set! user-ptr read-ptr)
1337	c)
1338	(begin
1339	(set! input-f (lambda () 'eof))
1340	'eof))))))
1341	(user-getc-line
1342	(lambda ()
1343	(if (< user-ptr start-ptr)
1344	(user-go-to-start-line))
1345	(if (< user-ptr read-ptr)
1346	(let ((c (string-ref buffer user-ptr)))
1347	(set! user-ptr (+ user-ptr 1))
1348	(if (char=? c #\newline)
1349	(set! user-line (+ user-line 1)))
1350	c)
1351	(let ((c (input-f)))
1352	(if (char? c)
1353	(begin
1354	(if (= read-ptr buflen)
1355	(reorganize-buffer))
1356	(string-set! buffer user-ptr c)
1357	(set! read-ptr (+ read-ptr 1))
1358	(set! user-ptr read-ptr)
1359	(if (char=? c #\newline)
1360	(set! user-line (+ user-line 1)))
1361	c)
1362	(begin
1363	(set! input-f (lambda () 'eof))
1364	'eof))))))
1365	(user-getc-all
1366	(lambda ()
1367	(if (< user-ptr start-ptr)
1368	(user-go-to-start-all))
1369	(if (< user-ptr read-ptr)
1370	(let ((c (string-ref buffer user-ptr)))
1371	(set! user-ptr (+ user-ptr 1))
1372	(if (char=? c #\newline)
1373	(begin
1374	(set! user-line (+ user-line 1))
1375	(set! user-column 1))
1376	(set! user-column (+ user-column 1)))
1377	(set! user-offset (+ user-offset 1))
1378	c)
1379	(let ((c (input-f)))
1380	(if (char? c)
1381	(begin
1382	(if (= read-ptr buflen)
1383	(reorganize-buffer))
1384	(string-set! buffer user-ptr c)
1385	(set! read-ptr (+ read-ptr 1))
1386	(set! user-ptr read-ptr)
1387	(if (char=? c #\newline)
1388	(begin
1389	(set! user-line (+ user-line 1))
1390	(set! user-column 1))
1391	(set! user-column (+ user-column 1)))
1392	(set! user-offset (+ user-offset 1))
1393	c)
1394	(begin
1395	(set! input-f (lambda () 'eof))
1396	'eof))))))
1397	(user-ungetc-none
1398	(lambda ()
1399	(if (> user-ptr start-ptr)
1400	(set! user-ptr (- user-ptr 1)))))
1401	(user-ungetc-line
1402	(lambda ()
1403	(if (> user-ptr start-ptr)
1404	(begin
1405	(set! user-ptr (- user-ptr 1))
1406	(let ((c (string-ref buffer user-ptr)))
1407	(if (char=? c #\newline)
1408	(set! user-line (- user-line 1))))))))
1409	(user-ungetc-all
1410	(lambda ()
1411	(if (> user-ptr start-ptr)
1412	(begin
1413	(set! user-ptr (- user-ptr 1))
1414	(let ((c (string-ref buffer user-ptr)))
1415	(if (char=? c #\newline)
1416	(begin
1417	(set! user-line (- user-line 1))
1418	(set! user-up-to-date? #f))
1419	(set! user-column (- user-column 1)))
1420	(set! user-offset (- user-offset 1)))))))
1421	(reorganize-buffer ; Decaler ou agrandir le buffer
1422	(lambda ()
1423	(if (< (* 2 start-ptr) buflen)
1424	(let* ((newlen (* 2 buflen))
1425	(newbuf (make-string newlen))
1426	(delta (- start-ptr 1)))
1427	(let loop ((from (- start-ptr 1)))
1428	(if (< from buflen)
1429	(begin
1430	(string-set! newbuf
1431	(- from delta)
1432	(string-ref buffer from))
1433	(loop (+ from 1)))))
1434	(set! buffer newbuf)
1435	(set! buflen newlen)
1436	(set! read-ptr (- read-ptr delta))
1437	(set! start-ptr (- start-ptr delta))
1438	(set! end-ptr (- end-ptr delta))
1439	(set! point-ptr (- point-ptr delta))
1440	(set! user-ptr (- user-ptr delta)))
1441	(let ((delta (- start-ptr 1)))
1442	(let loop ((from (- start-ptr 1)))
1443	(if (< from buflen)
1444	(begin
1445	(string-set! buffer
1446	(- from delta)
1447	(string-ref buffer from))
1448	(loop (+ from 1)))))
1449	(set! read-ptr (- read-ptr delta))
1450	(set! start-ptr (- start-ptr delta))
1451	(set! end-ptr (- end-ptr delta))
1452	(set! point-ptr (- point-ptr delta))
1453	(set! user-ptr (- user-ptr delta)))))))
1454	(list (cons 'start-go-to-end
1455	(cond ((eq? counters 'none) start-go-to-end-none)
1456	((eq? counters 'line) start-go-to-end-line)
1457	((eq? counters 'all ) start-go-to-end-all)))
1458	(cons 'end-go-to-point
1459	end-go-to-point)
1460	(cons 'init-lexeme
1461	(cond ((eq? counters 'none) init-lexeme-none)
1462	((eq? counters 'line) init-lexeme-line)
1463	((eq? counters 'all ) init-lexeme-all)))
1464	(cons 'get-start-line
1465	get-start-line)
1466	(cons 'get-start-column
1467	get-start-column)
1468	(cons 'get-start-offset
1469	get-start-offset)
1470	(cons 'peek-left-context
1471	peek-left-context)
1472	(cons 'peek-char
1473	peek-char)
1474	(cons 'read-char
1475	read-char)
1476	(cons 'get-start-end-text
1477	get-start-end-text)
1478	(cons 'get-user-line
1479	(cond ((eq? counters 'none) #f)
1480	((eq? counters 'line) get-user-line-line)
1481	((eq? counters 'all ) get-user-line-all)))
1482	(cons 'get-user-column
1483	(cond ((eq? counters 'none) #f)
1484	((eq? counters 'line) #f)
1485	((eq? counters 'all ) get-user-column-all)))
1486	(cons 'get-user-offset
1487	(cond ((eq? counters 'none) #f)
1488	((eq? counters 'line) #f)
1489	((eq? counters 'all ) get-user-offset-all)))
1490	(cons 'user-getc
1491	(cond ((eq? counters 'none) user-getc-none)
1492	((eq? counters 'line) user-getc-line)
1493	((eq? counters 'all ) user-getc-all)))
1494	(cons 'user-ungetc
1495	(cond ((eq? counters 'none) user-ungetc-none)
1496	((eq? counters 'line) user-ungetc-line)
1497	((eq? counters 'all ) user-ungetc-all))))))))
1498
1499	; Construit un Input System
1500	; Le premier parametre doit etre parmi "port", "procedure" ou "string"
1501	; Prend un parametre facultatif qui doit etre parmi
1502	; "none", "line" ou "all"
1503	(define lexer-make-IS
1504	(lambda (input-type input . largs)
1505	(let ((counters-type (cond ((null? largs)
1506	'line)
1507	((memq (car largs) '(none line all))
1508	(car largs))
1509	(else
1510	'line))))
1511	(cond ((and (eq? input-type 'port) (input-port? input))
1512	(let* ((buffer (make-string lexer-init-buffer-len #\newline))
1513	(read-ptr 1)
1514	(input-f (lambda () (read-char input))))
1515	(lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
1516	((and (eq? input-type 'procedure) (procedure? input))
1517	(let* ((buffer (make-string lexer-init-buffer-len #\newline))
1518	(read-ptr 1)
1519	(input-f input))
1520	(lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
1521	((and (eq? input-type 'string) (string? input))
1522	(let* ((buffer (string-append (string #\newline) input))
1523	(read-ptr (string-length buffer))
1524	(input-f (lambda () 'eof)))
1525	(lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
1526	(else
1527	(let* ((buffer (string #\newline))
1528	(read-ptr 1)
1529	(input-f (lambda () 'eof)))
1530	(lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))
1531
1532	; Les fonctions:
1533	; lexer-get-func-getc, lexer-get-func-ungetc,
1534	; lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
1535	(define lexer-get-func-getc
1536	(lambda (IS) (cdr (assq 'user-getc IS))))
1537	(define lexer-get-func-ungetc
1538	(lambda (IS) (cdr (assq 'user-ungetc IS))))
1539	(define lexer-get-func-line
1540	(lambda (IS) (cdr (assq 'get-user-line IS))))
1541	(define lexer-get-func-column
1542	(lambda (IS) (cdr (assq 'get-user-column IS))))
1543	(define lexer-get-func-offset
1544	(lambda (IS) (cdr (assq 'get-user-offset IS))))
1545
1546	;
1547	; Gestion des lexers
1548	;
1549
1550	; Fabrication de lexer a partir d'arbres de decision
1551	(define lexer-make-tree-lexer
1552	(lambda (tables IS)
1553	(letrec
1554	(; Contenu de la table
1555	(counters-type (vector-ref tables 0))
1556	(<<EOF>>-pre-action (vector-ref tables 1))
1557	(<<ERROR>>-pre-action (vector-ref tables 2))
1558	(rules-pre-actions (vector-ref tables 3))
1559	(table-nl-start (vector-ref tables 5))
1560	(table-no-nl-start (vector-ref tables 6))
1561	(trees-v (vector-ref tables 7))
1562	(acc-v (vector-ref tables 8))
1563
1564	; Contenu du IS
1565	(IS-start-go-to-end (cdr (assq 'start-go-to-end IS)))
1566	(IS-end-go-to-point (cdr (assq 'end-go-to-point IS)))
1567	(IS-init-lexeme (cdr (assq 'init-lexeme IS)))
1568	(IS-get-start-line (cdr (assq 'get-start-line IS)))
1569	(IS-get-start-column (cdr (assq 'get-start-column IS)))
1570	(IS-get-start-offset (cdr (assq 'get-start-offset IS)))
1571	(IS-peek-left-context (cdr (assq 'peek-left-context IS)))
1572	(IS-peek-char (cdr (assq 'peek-char IS)))
1573	(IS-read-char (cdr (assq 'read-char IS)))
1574	(IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
1575	(IS-get-user-line (cdr (assq 'get-user-line IS)))
1576	(IS-get-user-column (cdr (assq 'get-user-column IS)))
1577	(IS-get-user-offset (cdr (assq 'get-user-offset IS)))
1578	(IS-user-getc (cdr (assq 'user-getc IS)))
1579	(IS-user-ungetc (cdr (assq 'user-ungetc IS)))
1580
1581	; Resultats
1582	(<<EOF>>-action #f)
1583	(<<ERROR>>-action #f)
1584	(rules-actions #f)
1585	(states #f)
1586	(final-lexer #f)
1587
1588	; Gestion des hooks
1589	(hook-list '())
1590	(add-hook
1591	(lambda (thunk)
1592	(set! hook-list (cons thunk hook-list))))
1593	(apply-hooks
1594	(lambda ()
1595	(let loop ((l hook-list))
1596	(if (pair? l)
1597	(begin
1598	((car l))
1599	(loop (cdr l)))))))
1600
1601	; Preparation des actions
1602	(set-action-statics
1603	(lambda (pre-action)
1604	(pre-action final-lexer IS-user-getc IS-user-ungetc)))
1605	(prepare-special-action-none
1606	(lambda (pre-action)
1607	(let ((action #f))
1608	(let ((result
1609	(lambda ()
1610	(action "")))
1611	(hook
1612	(lambda ()
1613	(set! action (set-action-statics pre-action)))))
1614	(add-hook hook)
1615	result))))
1616	(prepare-special-action-line
1617	(lambda (pre-action)
1618	(let ((action #f))
1619	(let ((result
1620	(lambda (yyline)
1621	(action "" yyline)))
1622	(hook
1623	(lambda ()
1624	(set! action (set-action-statics pre-action)))))
1625	(add-hook hook)
1626	result))))
1627	(prepare-special-action-all
1628	(lambda (pre-action)
1629	(let ((action #f))
1630	(let ((result
1631	(lambda (yyline yycolumn yyoffset)
1632	(action "" yyline yycolumn yyoffset)))
1633	(hook
1634	(lambda ()
1635	(set! action (set-action-statics pre-action)))))
1636	(add-hook hook)
1637	result))))
1638	(prepare-special-action
1639	(lambda (pre-action)
1640	(cond ((eq? counters-type 'none)
1641	(prepare-special-action-none pre-action))
1642	((eq? counters-type 'line)
1643	(prepare-special-action-line pre-action))
1644	((eq? counters-type 'all)
1645	(prepare-special-action-all pre-action)))))
1646	(prepare-action-yytext-none
1647	(lambda (pre-action)
1648	(let ((get-start-end-text IS-get-start-end-text)
1649	(start-go-to-end IS-start-go-to-end)
1650	(action #f))
1651	(let ((result
1652	(lambda ()
1653	(let ((yytext (get-start-end-text)))
1654	(start-go-to-end)
1655	(action yytext))))
1656	(hook
1657	(lambda ()
1658	(set! action (set-action-statics pre-action)))))
1659	(add-hook hook)
1660	result))))
1661	(prepare-action-yytext-line
1662	(lambda (pre-action)
1663	(let ((get-start-end-text IS-get-start-end-text)
1664	(start-go-to-end IS-start-go-to-end)
1665	(action #f))
1666	(let ((result
1667	(lambda (yyline)
1668	(let ((yytext (get-start-end-text)))
1669	(start-go-to-end)
1670	(action yytext yyline))))
1671	(hook
1672	(lambda ()
1673	(set! action (set-action-statics pre-action)))))
1674	(add-hook hook)
1675	result))))
1676	(prepare-action-yytext-all
1677	(lambda (pre-action)
1678	(let ((get-start-end-text IS-get-start-end-text)
1679	(start-go-to-end IS-start-go-to-end)
1680	(action #f))
1681	(let ((result
1682	(lambda (yyline yycolumn yyoffset)
1683	(let ((yytext (get-start-end-text)))
1684	(start-go-to-end)
1685	(action yytext yyline yycolumn yyoffset))))
1686	(hook
1687	(lambda ()
1688	(set! action (set-action-statics pre-action)))))
1689	(add-hook hook)
1690	result))))
1691	(prepare-action-yytext
1692	(lambda (pre-action)
1693	(cond ((eq? counters-type 'none)
1694	(prepare-action-yytext-none pre-action))
1695	((eq? counters-type 'line)
1696	(prepare-action-yytext-line pre-action))
1697	((eq? counters-type 'all)
1698	(prepare-action-yytext-all pre-action)))))
1699	(prepare-action-no-yytext-none
1700	(lambda (pre-action)
1701	(let ((start-go-to-end IS-start-go-to-end)
1702	(action #f))
1703	(let ((result
1704	(lambda ()
1705	(start-go-to-end)
1706	(action)))
1707	(hook
1708	(lambda ()
1709	(set! action (set-action-statics pre-action)))))
1710	(add-hook hook)
1711	result))))
1712	(prepare-action-no-yytext-line
1713	(lambda (pre-action)
1714	(let ((start-go-to-end IS-start-go-to-end)
1715	(action #f))
1716	(let ((result
1717	(lambda (yyline)
1718	(start-go-to-end)
1719	(action yyline)))
1720	(hook
1721	(lambda ()
1722	(set! action (set-action-statics pre-action)))))
1723	(add-hook hook)
1724	result))))
1725	(prepare-action-no-yytext-all
1726	(lambda (pre-action)
1727	(let ((start-go-to-end IS-start-go-to-end)
1728	(action #f))
1729	(let ((result
1730	(lambda (yyline yycolumn yyoffset)
1731	(start-go-to-end)
1732	(action yyline yycolumn yyoffset)))
1733	(hook
1734	(lambda ()
1735	(set! action (set-action-statics pre-action)))))
1736	(add-hook hook)
1737	result))))
1738	(prepare-action-no-yytext
1739	(lambda (pre-action)
1740	(cond ((eq? counters-type 'none)
1741	(prepare-action-no-yytext-none pre-action))
1742	((eq? counters-type 'line)
1743	(prepare-action-no-yytext-line pre-action))
1744	((eq? counters-type 'all)
1745	(prepare-action-no-yytext-all pre-action)))))
1746
1747	; Fabrique les fonctions de dispatch
1748	(prepare-dispatch-err
1749	(lambda (leaf)
1750	(lambda (c)
1751	#f)))
1752	(prepare-dispatch-number
1753	(lambda (leaf)
1754	(let ((state-function #f))
1755	(let ((result
1756	(lambda (c)
1757	state-function))
1758	(hook
1759	(lambda ()
1760	(set! state-function (vector-ref states leaf)))))
1761	(add-hook hook)
1762	result))))
1763	(prepare-dispatch-leaf
1764	(lambda (leaf)
1765	(if (eq? leaf 'err)
1766	(prepare-dispatch-err leaf)
1767	(prepare-dispatch-number leaf))))
1768	(prepare-dispatch-<
1769	(lambda (tree)
1770	(let ((left-tree (list-ref tree 1))
1771	(right-tree (list-ref tree 2)))
1772	(let ((bound (list-ref tree 0))
1773	(left-func (prepare-dispatch-tree left-tree))
1774	(right-func (prepare-dispatch-tree right-tree)))
1775	(lambda (c)
1776	(if (< c bound)
1777	(left-func c)
1778	(right-func c)))))))
1779	(prepare-dispatch-=
1780	(lambda (tree)
1781	(let ((left-tree (list-ref tree 2))
1782	(right-tree (list-ref tree 3)))
1783	(let ((bound (list-ref tree 1))
1784	(left-func (prepare-dispatch-tree left-tree))
1785	(right-func (prepare-dispatch-tree right-tree)))
1786	(lambda (c)
1787	(if (= c bound)
1788	(left-func c)
1789	(right-func c)))))))
1790	(prepare-dispatch-tree
1791	(lambda (tree)
1792	(cond ((not (pair? tree))
1793	(prepare-dispatch-leaf tree))
1794	((eq? (car tree) '=)
1795	(prepare-dispatch-= tree))
1796	(else
1797	(prepare-dispatch-< tree)))))
1798	(prepare-dispatch
1799	(lambda (tree)
1800	(let ((dicho-func (prepare-dispatch-tree tree)))
1801	(lambda (c)
1802	(and c (dicho-func c))))))
1803
1804	; Fabrique les fonctions de transition (read & go) et (abort)
1805	(prepare-read-n-go
1806	(lambda (tree)
1807	(let ((dispatch-func (prepare-dispatch tree))
1808	(read-char IS-read-char))
1809	(lambda ()
1810	(dispatch-func (read-char))))))
1811	(prepare-abort
1812	(lambda (tree)
1813	(lambda ()
1814	#f)))
1815	(prepare-transition
1816	(lambda (tree)
1817	(if (eq? tree 'err)
1818	(prepare-abort tree)
1819	(prepare-read-n-go tree))))
1820
1821	; Fabrique les fonctions d'etats ([set-end] & trans)
1822	(prepare-state-no-acc
1823	(lambda (s r1 r2)
1824	(let ((trans-func (prepare-transition (vector-ref trees-v s))))
1825	(lambda (action)
1826	(let ((next-state (trans-func)))
1827	(if next-state
1828	(next-state action)
1829	action))))))
1830	(prepare-state-yes-no
1831	(lambda (s r1 r2)
1832	(let ((peek-char IS-peek-char)
1833	(end-go-to-point IS-end-go-to-point)
1834	(new-action1 #f)
1835	(trans-func (prepare-transition (vector-ref trees-v s))))
1836	(let ((result
1837	(lambda (action)
1838	(let* ((c (peek-char))
1839	(new-action
1840	(if (or (not c) (= c lexer-integer-newline))
1841	(begin
1842	(end-go-to-point)
1843	new-action1)
1844	action))
1845	(next-state (trans-func)))
1846	(if next-state
1847	(next-state new-action)
1848	new-action))))
1849	(hook
1850	(lambda ()
1851	(set! new-action1 (vector-ref rules-actions r1)))))
1852	(add-hook hook)
1853	result))))
1854	(prepare-state-diff-acc
1855	(lambda (s r1 r2)
1856	(let ((end-go-to-point IS-end-go-to-point)
1857	(peek-char IS-peek-char)
1858	(new-action1 #f)
1859	(new-action2 #f)
1860	(trans-func (prepare-transition (vector-ref trees-v s))))
1861	(let ((result
1862	(lambda (action)
1863	(end-go-to-point)
1864	(let* ((c (peek-char))
1865	(new-action
1866	(if (or (not c) (= c lexer-integer-newline))
1867	new-action1
1868	new-action2))
1869	(next-state (trans-func)))
1870	(if next-state
1871	(next-state new-action)
1872	new-action))))
1873	(hook
1874	(lambda ()
1875	(set! new-action1 (vector-ref rules-actions r1))
1876	(set! new-action2 (vector-ref rules-actions r2)))))
1877	(add-hook hook)
1878	result))))
1879	(prepare-state-same-acc
1880	(lambda (s r1 r2)
1881	(let ((end-go-to-point IS-end-go-to-point)
1882	(trans-func (prepare-transition (vector-ref trees-v s)))
1883	(new-action #f))
1884	(let ((result
1885	(lambda (action)
1886	(end-go-to-point)
1887	(let ((next-state (trans-func)))
1888	(if next-state
1889	(next-state new-action)
1890	new-action))))
1891	(hook
1892	(lambda ()
1893	(set! new-action (vector-ref rules-actions r1)))))
1894	(add-hook hook)
1895	result))))
1896	(prepare-state
1897	(lambda (s)
1898	(let* ((acc (vector-ref acc-v s))
1899	(r1 (car acc))
1900	(r2 (cdr acc)))
1901	(cond ((not r1) (prepare-state-no-acc s r1 r2))
1902	((not r2) (prepare-state-yes-no s r1 r2))
1903	((< r1 r2) (prepare-state-diff-acc s r1 r2))
1904	(else (prepare-state-same-acc s r1 r2))))))
1905
1906	; Fabrique la fonction de lancement du lexage a l'etat de depart
1907	(prepare-start-same
1908	(lambda (s1 s2)
1909	(let ((peek-char IS-peek-char)
1910	(eof-action #f)
1911	(start-state #f)
1912	(error-action #f))
1913	(let ((result
1914	(lambda ()
1915	(if (not (peek-char))
1916	eof-action
1917	(start-state error-action))))
1918	(hook
1919	(lambda ()
1920	(set! eof-action <<EOF>>-action)
1921	(set! start-state (vector-ref states s1))
1922	(set! error-action <<ERROR>>-action))))
1923	(add-hook hook)
1924	result))))
1925	(prepare-start-diff
1926	(lambda (s1 s2)
1927	(let ((peek-char IS-peek-char)
1928	(eof-action #f)
1929	(peek-left-context IS-peek-left-context)
1930	(start-state1 #f)
1931	(start-state2 #f)
1932	(error-action #f))
1933	(let ((result
1934	(lambda ()
1935	(cond ((not (peek-char))
1936	eof-action)
1937	((= (peek-left-context) lexer-integer-newline)
1938	(start-state1 error-action))
1939	(else
1940	(start-state2 error-action)))))
1941	(hook
1942	(lambda ()
1943	(set! eof-action <<EOF>>-action)
1944	(set! start-state1 (vector-ref states s1))
1945	(set! start-state2 (vector-ref states s2))
1946	(set! error-action <<ERROR>>-action))))
1947	(add-hook hook)
1948	result))))
1949	(prepare-start
1950	(lambda ()
1951	(let ((s1 table-nl-start)
1952	(s2 table-no-nl-start))
1953	(if (= s1 s2)
1954	(prepare-start-same s1 s2)
1955	(prepare-start-diff s1 s2)))))
1956
1957	; Fabrique la fonction principale
1958	(prepare-lexer-none
1959	(lambda ()
1960	(let ((init-lexeme IS-init-lexeme)
1961	(start-func (prepare-start)))
1962	(lambda ()
1963	(init-lexeme)
1964	((start-func))))))
1965	(prepare-lexer-line
1966	(lambda ()
1967	(let ((init-lexeme IS-init-lexeme)
1968	(get-start-line IS-get-start-line)
1969	(start-func (prepare-start)))
1970	(lambda ()
1971	(init-lexeme)
1972	(let ((yyline (get-start-line)))
1973	((start-func) yyline))))))
1974	(prepare-lexer-all
1975	(lambda ()
1976	(let ((init-lexeme IS-init-lexeme)
1977	(get-start-line IS-get-start-line)
1978	(get-start-column IS-get-start-column)
1979	(get-start-offset IS-get-start-offset)
1980	(start-func (prepare-start)))
1981	(lambda ()
1982	(init-lexeme)
1983	(let ((yyline (get-start-line))
1984	(yycolumn (get-start-column))
1985	(yyoffset (get-start-offset)))
1986	((start-func) yyline yycolumn yyoffset))))))
1987	(prepare-lexer
1988	(lambda ()
1989	(cond ((eq? counters-type 'none) (prepare-lexer-none))
1990	((eq? counters-type 'line) (prepare-lexer-line))
1991	((eq? counters-type 'all) (prepare-lexer-all))))))
1992
1993	; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
1994	(set! <<EOF>>-action (prepare-special-action <<EOF>>-pre-action))
1995	(set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))
1996
1997	; Calculer la valeur de rules-actions
1998	(let* ((len (quotient (vector-length rules-pre-actions) 2))
1999	(v (make-vector len)))
2000	(let loop ((r (- len 1)))
2001	(if (< r 0)
2002	(set! rules-actions v)
2003	(let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
2004	(pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
2005	(action (if yytext?
2006	(prepare-action-yytext pre-action)
2007	(prepare-action-no-yytext pre-action))))
2008	(vector-set! v r action)
2009	(loop (- r 1))))))
2010
2011	; Calculer la valeur de states
2012	(let* ((len (vector-length trees-v))
2013	(v (make-vector len)))
2014	(let loop ((s (- len 1)))
2015	(if (< s 0)
2016	(set! states v)
2017	(begin
2018	(vector-set! v s (prepare-state s))
2019	(loop (- s 1))))))
2020
2021	; Calculer la valeur de final-lexer
2022	(set! final-lexer (prepare-lexer))
2023
2024	; Executer les hooks
2025	(apply-hooks)
2026
2027	; Resultat
2028	final-lexer)))
2029
2030	; Fabrication de lexer a partir de listes de caracteres taggees
2031	(define lexer-make-char-lexer
2032	(let* ((char->class
2033	(lambda (c)
2034	(let ((n (char->integer c)))
2035	(list (cons n n)))))
2036	(merge-sort
2037	(lambda (l combine zero-elt)
2038	(if (null? l)
2039	zero-elt
2040	(let loop1 ((l l))
2041	(if (null? (cdr l))
2042	(car l)
2043	(loop1
2044	(let loop2 ((l l))
2045	(cond ((null? l)
2046	l)
2047	((null? (cdr l))
2048	l)
2049	(else
2050	(cons (combine (car l) (cadr l))
2051	(loop2 (cddr l))))))))))))
2052	(finite-class-union
2053	(lambda (c1 c2)
2054	(let loop ((c1 c1) (c2 c2) (u '()))
2055	(if (null? c1)
2056	(if (null? c2)
2057	(reverse u)
2058	(loop c1 (cdr c2) (cons (car c2) u)))
2059	(if (null? c2)
2060	(loop (cdr c1) c2 (cons (car c1) u))
2061	(let* ((r1 (car c1))
2062	(r2 (car c2))
2063	(r1start (car r1))
2064	(r1end (cdr r1))
2065	(r2start (car r2))
2066	(r2end (cdr r2)))
2067	(if (<= r1start r2start)
2068	(cond ((< (+ r1end 1) r2start)
2069	(loop (cdr c1) c2 (cons r1 u)))
2070	((<= r1end r2end)
2071	(loop (cdr c1)
2072	(cons (cons r1start r2end) (cdr c2))
2073	u))
2074	(else
2075	(loop c1 (cdr c2) u)))
2076	(cond ((> r1start (+ r2end 1))
2077	(loop c1 (cdr c2) (cons r2 u)))
2078	((>= r1end r2end)
2079	(loop (cons (cons r2start r1end) (cdr c1))
2080	(cdr c2)
2081	u))
2082	(else
2083	(loop (cdr c1) c2 u))))))))))
2084	(char-list->class
2085	(lambda (cl)
2086	(let ((classes (map char->class cl)))
2087	(merge-sort classes finite-class-union '()))))
2088	(class-<
2089	(lambda (b1 b2)
2090	(cond ((eq? b1 'inf+) #f)
2091	((eq? b2 'inf-) #f)
2092	((eq? b1 'inf-) #t)
2093	((eq? b2 'inf+) #t)
2094	(else (< b1 b2)))))
2095	(finite-class-compl
2096	(lambda (c)
2097	(let loop ((c c) (start 'inf-))
2098	(if (null? c)
2099	(list (cons start 'inf+))
2100	(let* ((r (car c))
2101	(rstart (car r))
2102	(rend (cdr r)))
2103	(if (class-< start rstart)
2104	(cons (cons start (- rstart 1))
2105	(loop c rstart))
2106	(loop (cdr c) (+ rend 1))))))))
2107	(tagged-chars->class
2108	(lambda (tcl)
2109	(let* ((inverse? (car tcl))
2110	(cl (cdr tcl))
2111	(class-tmp (char-list->class cl)))
2112	(if inverse? (finite-class-compl class-tmp) class-tmp))))
2113	(charc->arc
2114	(lambda (charc)
2115	(let* ((tcl (car charc))
2116	(dest (cdr charc))
2117	(class (tagged-chars->class tcl)))
2118	(cons class dest))))
2119	(arc->sharcs
2120	(lambda (arc)
2121	(let* ((range-l (car arc))
2122	(dest (cdr arc))
2123	(op (lambda (range) (cons range dest))))
2124	(map op range-l))))
2125	(class-<=
2126	(lambda (b1 b2)
2127	(cond ((eq? b1 'inf-) #t)
2128	((eq? b2 'inf+) #t)
2129	((eq? b1 'inf+) #f)
2130	((eq? b2 'inf-) #f)
2131	(else (<= b1 b2)))))
2132	(sharc-<=
2133	(lambda (sharc1 sharc2)
2134	(class-<= (caar sharc1) (caar sharc2))))
2135	(merge-sharcs
2136	(lambda (l1 l2)
2137	(let loop ((l1 l1) (l2 l2))
2138	(cond ((null? l1)
2139	l2)
2140	((null? l2)
2141	l1)
2142	(else
2143	(let ((sharc1 (car l1))
2144	(sharc2 (car l2)))
2145	(if (sharc-<= sharc1 sharc2)
2146	(cons sharc1 (loop (cdr l1) l2))
2147	(cons sharc2 (loop l1 (cdr l2))))))))))
2148	(class-= eqv?)
2149	(fill-error
2150	(lambda (sharcs)
2151	(let loop ((sharcs sharcs) (start 'inf-))
2152	(cond ((class-= start 'inf+)
2153	'())
2154	((null? sharcs)
2155	(cons (cons (cons start 'inf+) 'err)
2156	(loop sharcs 'inf+)))
2157	(else
2158	(let* ((sharc (car sharcs))
2159	(h (caar sharc))
2160	(t (cdar sharc)))
2161	(if (class-< start h)
2162	(cons (cons (cons start (- h 1)) 'err)
2163	(loop sharcs h))
2164	(cons sharc (loop (cdr sharcs)
2165	(if (class-= t 'inf+)
2166	'inf+
2167	(+ t 1)))))))))))
2168	(charcs->tree
2169	(lambda (charcs)
2170	(let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
2171	(sharcs-l (map op charcs))
2172	(sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
2173	(full-sharcs (fill-error sorted-sharcs))
2174	(op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
2175	(table (list->vector (map op full-sharcs))))
2176	(let loop ((left 0) (right (- (vector-length table) 1)))
2177	(if (= left right)
2178	(cdr (vector-ref table left))
2179	(let ((mid (quotient (+ left right 1) 2)))
2180	(if (and (= (+ left 2) right)
2181	(= (+ (car (vector-ref table mid)) 1)
2182	(car (vector-ref table right)))
2183	(eqv? (cdr (vector-ref table left))
2184	(cdr (vector-ref table right))))
2185	(list '=
2186	(car (vector-ref table mid))
2187	(cdr (vector-ref table mid))
2188	(cdr (vector-ref table left)))
2189	(list (car (vector-ref table mid))
2190	(loop left (- mid 1))
2191	(loop mid right))))))))))
2192	(lambda (tables IS)
2193	(let ((counters (vector-ref tables 0))
2194	(<<EOF>>-action (vector-ref tables 1))
2195	(<<ERROR>>-action (vector-ref tables 2))
2196	(rules-actions (vector-ref tables 3))
2197	(nl-start (vector-ref tables 5))
2198	(no-nl-start (vector-ref tables 6))
2199	(charcs-v (vector-ref tables 7))
2200	(acc-v (vector-ref tables 8)))
2201	(let* ((len (vector-length charcs-v))
2202	(v (make-vector len)))
2203	(let loop ((i (- len 1)))
2204	(if (>= i 0)
2205	(begin
2206	(vector-set! v i (charcs->tree (vector-ref charcs-v i)))
2207	(loop (- i 1)))
2208	(lexer-make-tree-lexer
2209	(vector counters
2210	<<EOF>>-action
2211	<<ERROR>>-action
2212	rules-actions
2213	'decision-trees
2214	nl-start
2215	no-nl-start
2216	v
2217	acc-v)
2218	IS))))))))
2219
2220	; Fabrication d'un lexer a partir de code pre-genere
2221	(define lexer-make-code-lexer
2222	(lambda (tables IS)
2223	(let ((<<EOF>>-pre-action (vector-ref tables 1))
2224	(<<ERROR>>-pre-action (vector-ref tables 2))
2225	(rules-pre-action (vector-ref tables 3))
2226	(code (vector-ref tables 5)))
2227	(code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))
2228
2229	(define lexer-make-lexer
2230	(lambda (tables IS)
2231	(let ((automaton-type (vector-ref tables 4)))
2232	(cond ((eq? automaton-type 'decision-trees)
2233	(lexer-make-tree-lexer tables IS))
2234	((eq? automaton-type 'tagged-chars-lists)
2235	(lexer-make-char-lexer tables IS))
2236	((eq? automaton-type 'code)
2237	(lexer-make-code-lexer tables IS))))))
2238
2239	; Module lexparser.scm.
2240	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
2241	; All rights reserved.
2242	; SILex 1.0.
2243
2244	;
2245	; Fonctions auxilliaires du lexer
2246	;
2247
2248	(define parse-spec-char
2249	(lambda (lexeme line column)
2250	(make-tok char-tok lexeme line column newline-ch)))
2251
2252	(define parse-digits-char
2253	(lambda (lexeme line column)
2254	(let* ((num (substring lexeme 1 (string-length lexeme)))
2255	(n (string->number num)))
2256	(make-tok char-tok lexeme line column n))))
2257
2258	(define parse-quoted-char
2259	(lambda (lexeme line column)
2260	(let ((c (string-ref lexeme 1)))
2261	(make-tok char-tok lexeme line column (char->integer c)))))
2262
2263	(define parse-ordinary-char
2264	(lambda (lexeme line column)
2265	(let ((c (string-ref lexeme 0)))
2266	(make-tok char-tok lexeme line column (char->integer c)))))
2267
2268	(define extract-id
2269	(lambda (s)
2270	(let ((len (string-length s)))
2271	(substring s 1 (- len 1)))))
2272
2273	(define parse-id
2274	(lambda (lexeme line column)
2275	(make-tok id-tok lexeme line column (string-downcase lexeme) lexeme)))
2276
2277	(define parse-id-ref
2278	(lambda (lexeme line column)
2279	(let* ((orig-name (extract-id lexeme))
2280	(name (string-downcase orig-name)))
2281	(make-tok subst-tok lexeme line column name orig-name))))
2282
2283	(define parse-power-m
2284	(lambda (lexeme line column)
2285	(let* ((len (string-length lexeme))
2286	(substr (substring lexeme 1 (- len 1)))
2287	(m (string->number substr))
2288	(range (cons m m)))
2289	(make-tok power-tok lexeme line column range))))
2290
2291	(define parse-power-m-inf
2292	(lambda (lexeme line column)
2293	(let* ((len (string-length lexeme))
2294	(substr (substring lexeme 1 (- len 2)))
2295	(m (string->number substr))
2296	(range (cons m 'inf)))
2297	(make-tok power-tok lexeme line column range))))
2298
2299	(define parse-power-m-n
2300	(lambda (lexeme line column)
2301	(let ((len (string-length lexeme)))
2302	(let loop ((comma 2))
2303	(if (char=? (string-ref lexeme comma) #\,)
2304	(let* ((sub1 (substring lexeme 1 comma))
2305	(sub2 (substring lexeme (+ comma 1) (- len 1)))
2306	(m (string->number sub1))
2307	(n (string->number sub2))
2308	(range (cons m n)))
2309	(make-tok power-tok lexeme line column range))
2310	(loop (+ comma 1)))))))
2311
2312
2313
2314
2315	;
2316	; Lexer generique
2317	;
2318
2319	(define lexer-raw #f)
2320	(define lexer-stack '())
2321
2322	(define lexer-alist #f)
2323
2324	(define lexer-buffer #f)
2325	(define lexer-buffer-empty? #t)
2326
2327	(define lexer-history '())
2328	(define lexer-history-interp #f)
2329
2330	(define init-lexer
2331	(lambda (port)
2332	(let* ((IS (lexer-make-IS 'port port 'all))
2333	(action-lexer (lexer-make-lexer action-tables IS))
2334	(class-lexer (lexer-make-lexer class-tables IS))
2335	(macro-lexer (lexer-make-lexer macro-tables IS))
2336	(regexp-lexer (lexer-make-lexer regexp-tables IS))
2337	(string-lexer (lexer-make-lexer string-tables IS)))
2338	(set! lexer-raw #f)
2339	(set! lexer-stack '())
2340	(set! lexer-alist
2341	(list (cons 'action action-lexer)
2342	(cons 'class class-lexer)
2343	(cons 'macro macro-lexer)
2344	(cons 'regexp regexp-lexer)
2345	(cons 'string string-lexer)))
2346	(set! lexer-buffer-empty? #t)
2347	(set! lexer-history '()))))
2348
2349	; Lexer brut
2350	; S'assurer qu'il n'y a pas de risque de changer de
2351	; lexer quand le buffer est rempli
2352	(define push-lexer
2353	(lambda (name)
2354	(set! lexer-stack (cons lexer-raw lexer-stack))
2355	(set! lexer-raw (cdr (assq name lexer-alist)))))
2356
2357	(define pop-lexer
2358	(lambda ()
2359	(set! lexer-raw (car lexer-stack))
2360	(set! lexer-stack (cdr lexer-stack))))
2361
2362	; Traite le "unget" (capacite du unget: 1)
2363	(define lexer2
2364	(lambda ()
2365	(if lexer-buffer-empty?
2366	(lexer-raw)
2367	(begin
2368	(set! lexer-buffer-empty? #t)
2369	lexer-buffer))))
2370
2371	(define lexer2-unget
2372	(lambda (tok)
2373	(set! lexer-buffer tok)
2374	(set! lexer-buffer-empty? #f)))
2375
2376	; Traite l'historique
2377	(define lexer
2378	(lambda ()
2379	(let* ((tok (lexer2))
2380	(tok-lexeme (get-tok-lexeme tok))
2381	(hist-lexeme (if lexer-history-interp
2382	(blank-translate tok-lexeme)
2383	tok-lexeme)))
2384	(set! lexer-history (cons hist-lexeme lexer-history))
2385	tok)))
2386
2387	(define lexer-unget
2388	(lambda (tok)
2389	(set! lexer-history (cdr lexer-history))
2390	(lexer2-unget tok)))
2391
2392	(define lexer-set-blank-history
2393	(lambda (b)
2394	(set! lexer-history-interp b)))
2395
2396	(define blank-translate
2397	(lambda (s)
2398	(let ((ss (string-copy s)))
2399	(let loop ((i (- (string-length ss) 1)))
2400	(cond ((< i 0)
2401	ss)
2402	((char=? (string-ref ss i) (integer->char tab-ch))
2403	(loop (- i 1)))
2404	((char=? (string-ref ss i) #\newline)
2405	(loop (- i 1)))
2406	(else
2407	(string-set! ss i #\space)
2408	(loop (- i 1))))))))
2409
2410	(define lexer-get-history
2411	(lambda ()
2412	(let* ((rightlist (reverse lexer-history))
2413	(str (string-append-list rightlist))
2414	(strlen (string-length str))
2415	(str2 (if (and (> strlen 0)
2416	(char=? (string-ref str (- strlen 1)) #\newline))
2417	str
2418	(string-append str (string #\newline)))))
2419	(set! lexer-history '())
2420	str2)))
2421
2422
2423
2424
2425	;
2426	; Traitement des listes de tokens
2427	;
2428
2429	(define de-anchor-tokens
2430	(let ((not-anchor-toks (make-dispatch-table number-of-tokens
2431	(list (cons caret-tok #f)
2432	(cons dollar-tok #f)
2433	(cons <<EOF>>-tok #f)
2434	(cons <<ERROR>>-tok #f))
2435	#t)))
2436	(lambda (tok-list)
2437	(if (null? tok-list)
2438	'()
2439	(let* ((tok (car tok-list))
2440	(tok-type (get-tok-type tok))
2441	(toks (cdr tok-list))
2442	(new-toks (de-anchor-tokens toks)))
2443	(cond ((vector-ref not-anchor-toks tok-type)
2444	(cons tok new-toks))
2445	((or (= tok-type caret-tok) (= tok-type dollar-tok))
2446	(let* ((line (get-tok-line tok))
2447	(column (get-tok-column tok))
2448	(attr (if (= tok-type caret-tok) caret-ch dollar-ch))
2449	(new-tok (make-tok char-tok "" line column attr)))
2450	(cons new-tok new-toks)))
2451	((= tok-type <<EOF>>-tok)
2452	(lex-error (get-tok-line tok)
2453	(get-tok-column tok)
2454	"the <<EOF>> anchor must be used alone"
2455	" and only after %%."))
2456	((= tok-type <<ERROR>>-tok)
2457	(lex-error (get-tok-line tok)
2458	(get-tok-column tok)
2459	"the <<ERROR>> anchor must be used alone"
2460	" and only after %%."))))))))
2461
2462	(define strip-end
2463	(lambda (l)
2464	(if (null? (cdr l))
2465	'()
2466	(cons (car l) (strip-end (cdr l))))))
2467
2468	(define extract-anchors
2469	(lambda (tok-list)
2470	(let* ((tok1 (car tok-list))
2471	(line (get-tok-line tok1))
2472	(tok1-type (get-tok-type tok1)))
2473	(cond ((and (= tok1-type <<EOF>>-tok) (null? (cdr tok-list)))
2474	(make-rule line #t #f #f #f '() #f))
2475	((and (= tok1-type <<ERROR>>-tok) (null? (cdr tok-list)))
2476	(make-rule line #f #t #f #f '() #f))
2477	(else
2478	(let* ((bol? (= tok1-type caret-tok))
2479	(tok-list2 (if bol? (cdr tok-list) tok-list)))
2480	(if (null? tok-list2)
2481	(make-rule line #f #f bol? #f tok-list2 #f)
2482	(let* ((len (length tok-list2))
2483	(tok2 (list-ref tok-list2 (- len 1)))
2484	(tok2-type (get-tok-type tok2))
2485	(eol? (= tok2-type dollar-tok))
2486	(tok-list3 (if eol?
2487	(strip-end tok-list2)
2488	tok-list2)))
2489	(make-rule line #f #f bol? eol? tok-list3 #f)))))))))
2490
2491	(define char-list->conc
2492	(lambda (char-list)
2493	(if (null? char-list)
2494	(make-re epsilon-re)
2495	(let loop ((cl char-list))
2496	(let* ((c (car cl))
2497	(cl2 (cdr cl)))
2498	(if (null? cl2)
2499	(make-re char-re c)
2500	(make-re conc-re (make-re char-re c) (loop cl2))))))))
2501
2502	(define parse-tokens-atom
2503	(let ((action-table
2504	(make-dispatch-table
2505	number-of-tokens
2506	(list (cons lpar-tok
2507	(lambda (tok tok-list macros)
2508	(parse-tokens-sub tok-list macros)))
2509	(cons dot-tok
2510	(lambda (tok tok-list macros)
2511	(cons (make-re class-re dot-class) (cdr tok-list))))
2512	(cons subst-tok
2513	(lambda (tok tok-list macros)
2514	(let* ((name (get-tok-attr tok))
2515	(ass (assoc name macros)))
2516	(if ass
2517	(cons (cdr ass) (cdr tok-list))
2518	(lex-error (get-tok-line tok)
2519	(get-tok-column tok)
2520	"unknown macro \""
2521	(get-tok-2nd-attr tok)
2522	"\".")))))
2523	(cons char-tok
2524	(lambda (tok tok-list macros)
2525	(let ((c (get-tok-attr tok)))
2526	(cons (make-re char-re c) (cdr tok-list)))))
2527	(cons class-tok
2528	(lambda (tok tok-list macros)
2529	(let ((class (get-tok-attr tok)))
2530	(cons (make-re class-re class) (cdr tok-list)))))
2531	(cons string-tok
2532	(lambda (tok tok-list macros)
2533	(let* ((char-list (get-tok-attr tok))
2534	(re (char-list->conc char-list)))
2535	(cons re (cdr tok-list))))))
2536	(lambda (tok tok-list macros)
2537	(lex-error (get-tok-line tok)
2538	(get-tok-column tok)
2539	"syntax error in regular expression.")))))
2540	(lambda (tok-list macros)
2541	(let* ((tok (car tok-list))
2542	(tok-type (get-tok-type tok))
2543	(action (vector-ref action-table tok-type)))
2544	(action tok tok-list macros)))))
2545
2546	(define check-power-tok
2547	(lambda (tok)
2548	(let* ((range (get-tok-attr tok))
2549	(start (car range))
2550	(end (cdr range)))
2551	(if (or (eq? 'inf end) (<= start end))
2552	range
2553	(lex-error (get-tok-line tok)
2554	(get-tok-column tok)
2555	"incorrect power specification.")))))
2556
2557	(define power->star-plus
2558	(lambda (re range)
2559	(power->star-plus-rec re (car range) (cdr range))))
2560
2561	(define power->star-plus-rec
2562	(lambda (re start end)
2563	(cond ((eq? end 'inf)
2564	(cond ((= start 0)
2565	(make-re star-re re))
2566	((= start 1)
2567	(make-re plus-re re))
2568	(else
2569	(make-re conc-re
2570	re
2571	(power->star-plus-rec re (- start 1) 'inf)))))
2572	((= start 0)
2573	(cond ((= end 0)
2574	(make-re epsilon-re))
2575	((= end 1)
2576	(make-re question-re re))
2577	(else
2578	(make-re question-re
2579	(power->star-plus-rec re 1 end)))))
2580	((= start 1)
2581	(if (= end 1)
2582	re
2583	(make-re conc-re re (power->star-plus-rec re 0 (- end 1)))))
2584	(else
2585	(make-re conc-re
2586	re
2587	(power->star-plus-rec re (- start 1) (- end 1)))))))
2588
2589	(define parse-tokens-fact
2590	(let ((not-op-toks (make-dispatch-table number-of-tokens
2591	(list (cons question-tok #f)
2592	(cons plus-tok #f)
2593	(cons star-tok #f)
2594	(cons power-tok #f))
2595	#t)))
2596	(lambda (tok-list macros)
2597	(let* ((result (parse-tokens-atom tok-list macros))
2598	(re (car result))
2599	(tok-list2 (cdr result)))
2600	(let loop ((re re) (tok-list3 tok-list2))
2601	(let* ((tok (car tok-list3))
2602	(tok-type (get-tok-type tok)))
2603	(cond ((vector-ref not-op-toks tok-type)
2604	(cons re tok-list3))
2605	((= tok-type question-tok)
2606	(loop (make-re question-re re) (cdr tok-list3)))
2607	((= tok-type plus-tok)
2608	(loop (make-re plus-re re) (cdr tok-list3)))
2609	((= tok-type star-tok)
2610	(loop (make-re star-re re) (cdr tok-list3)))
2611	((= tok-type power-tok)
2612	(loop (power->star-plus re (check-power-tok tok))
2613	(cdr tok-list3))))))))))
2614
2615	(define parse-tokens-conc
2616	(lambda (tok-list macros)
2617	(let* ((result1 (parse-tokens-fact tok-list macros))
2618	(re1 (car result1))
2619	(tok-list2 (cdr result1))
2620	(tok (car tok-list2))
2621	(tok-type (get-tok-type tok)))
2622	(cond ((or (= tok-type pipe-tok)
2623	(= tok-type rpar-tok))
2624	result1)
2625	(else ; Autres facteurs
2626	(let* ((result2 (parse-tokens-conc tok-list2 macros))
2627	(re2 (car result2))
2628	(tok-list3 (cdr result2)))
2629	(cons (make-re conc-re re1 re2) tok-list3)))))))
2630
2631	(define parse-tokens-or
2632	(lambda (tok-list macros)
2633	(let* ((result1 (parse-tokens-conc tok-list macros))
2634	(re1 (car result1))
2635	(tok-list2 (cdr result1))
2636	(tok (car tok-list2))
2637	(tok-type (get-tok-type tok)))
2638	(cond ((= tok-type pipe-tok)
2639	(let* ((tok-list3 (cdr tok-list2))
2640	(result2 (parse-tokens-or tok-list3 macros))
2641	(re2 (car result2))
2642	(tok-list4 (cdr result2)))
2643	(cons (make-re or-re re1 re2) tok-list4)))
2644	(else ; rpar-tok
2645	result1)))))
2646
2647	(define parse-tokens-sub
2648	(lambda (tok-list macros)
2649	(let* ((tok-list2 (cdr tok-list)) ; Manger le lpar-tok
2650	(result (parse-tokens-or tok-list2 macros))
2651	(re (car result))
2652	(tok-list3 (cdr result))
2653	(tok-list4 (cdr tok-list3))) ; Manger le rpar-tok
2654	(cons re tok-list4))))
2655
2656	(define parse-tokens-match
2657	(lambda (tok-list line)
2658	(let loop ((tl tok-list) (count 0))
2659	(if (null? tl)
2660	(if (> count 0)
2661	(lex-error line
2662	#f
2663	"mismatched parentheses."))
2664	(let* ((tok (car tl))
2665	(tok-type (get-tok-type tok)))
2666	(cond ((= tok-type lpar-tok)
2667	(loop (cdr tl) (+ count 1)))
2668	((= tok-type rpar-tok)
2669	(if (zero? count)
2670	(lex-error line
2671	#f
2672	"mismatched parentheses."))
2673	(loop (cdr tl) (- count 1)))
2674	(else
2675	(loop (cdr tl) count))))))))
2676
2677	; Ne traite pas les anchors
2678	(define parse-tokens
2679	(lambda (tok-list macros)
2680	(if (null? tok-list)
2681	(make-re epsilon-re)
2682	(let ((line (get-tok-line (car tok-list))))
2683	(parse-tokens-match tok-list line)
2684	(let* ((begin-par (make-tok lpar-tok "" line 1))
2685	(end-par (make-tok rpar-tok "" line 1)))
2686	(let* ((tok-list2 (append (list begin-par)
2687	tok-list
2688	(list end-par)))
2689	(result (parse-tokens-sub tok-list2 macros)))
2690	(car result))))))) ; (cdr result) == () obligatoirement
2691
2692	(define tokens->regexp
2693	(lambda (tok-list macros)
2694	(let ((tok-list2 (de-anchor-tokens tok-list)))
2695	(parse-tokens tok-list2 macros))))
2696
2697	(define tokens->rule
2698	(lambda (tok-list macros)
2699	(let* ((rule (extract-anchors tok-list))
2700	(tok-list2 (get-rule-regexp rule))
2701	(tok-list3 (de-anchor-tokens tok-list2))
2702	(re (parse-tokens tok-list3 macros)))
2703	(set-rule-regexp rule re)
2704	rule)))
2705
2706	; Retourne une paire: <<EOF>>-action et vecteur des regles ordinaires
2707	(define adapt-rules
2708	(lambda (rules)
2709	(let loop ((r rules) (revr '()) (<<EOF>>-action #f) (<<ERROR>>-action #f))
2710	(if (null? r)
2711	(cons (or <<EOF>>-action default-<<EOF>>-action)
2712	(cons (or <<ERROR>>-action default-<<ERROR>>-action)
2713	(list->vector (reverse revr))))
2714	(let ((r1 (car r)))
2715	(cond ((get-rule-eof? r1)
2716	(if <<EOF>>-action
2717	(lex-error (get-rule-line r1)
2718	#f
2719	"the <<EOF>> anchor can be "
2720	"used at most once.")
2721	(loop (cdr r)
2722	revr
2723	(get-rule-action r1)
2724	<<ERROR>>-action)))
2725	((get-rule-error? r1)
2726	(if <<ERROR>>-action
2727	(lex-error (get-rule-line r1)
2728	#f
2729	"the <<ERROR>> anchor can be "
2730	"used at most once.")
2731	(loop (cdr r)
2732	revr
2733	<<EOF>>-action
2734	(get-rule-action r1))))
2735	(else
2736	(loop (cdr r)
2737	(cons r1 revr)
2738	<<EOF>>-action
2739	<<ERROR>>-action))))))))
2740
2741
2742
2743
2744	;
2745	; Analyseur de fichier lex
2746	;
2747
2748	(define parse-hv-blanks
2749	(lambda ()
2750	(let* ((tok (lexer))
2751	(tok-type (get-tok-type tok)))
2752	(if (or (= tok-type hblank-tok)
2753	(= tok-type vblank-tok))
2754	(parse-hv-blanks)
2755	(lexer-unget tok)))))
2756
2757	(define parse-class-range
2758	(lambda ()
2759	(let* ((tok (lexer))
2760	(tok-type (get-tok-type tok)))
2761	(cond ((= tok-type char-tok)
2762	(let* ((c (get-tok-attr tok))
2763	(tok2 (lexer))
2764	(tok2-type (get-tok-type tok2)))
2765	(if (not (= tok2-type minus-tok))
2766	(begin
2767	(lexer-unget tok2)
2768	(cons c c))
2769	(let* ((tok3 (lexer))
2770	(tok3-type (get-tok-type tok3)))
2771	(cond ((= tok3-type char-tok)
2772	(let ((c2 (get-tok-attr tok3)))
2773	(if (> c c2)
2774	(lex-error (get-tok-line tok3)
2775	(get-tok-column tok3)
2776	"bad range specification in "
2777	"character class;"
2778	#\newline
2779	"the start character is "
2780	"higher than the end one.")
2781	(cons c c2))))
2782	((or (= tok3-type rbrack-tok)
2783	(= tok3-type minus-tok))
2784	(lex-error (get-tok-line tok3)
2785	(get-tok-column tok3)
2786	"bad range specification in "
2787	"character class; a specification"
2788	#\newline
2789	"like \"-x\", \"x--\" or \"x-]\" has "
2790	"been used."))
2791	((= tok3-type eof-tok)
2792	(lex-error (get-tok-line tok3)
2793	#f
2794	"eof of file found while parsing "
2795	"a character class.")))))))
2796	((= tok-type minus-tok)
2797	(lex-error (get-tok-line tok)
2798	(get-tok-column tok)
2799	"bad range specification in character class; a "
2800	"specification"
2801	#\newline
2802	"like \"-x\", \"x--\" or \"x-]\" has been used."))
2803	((= tok-type rbrack-tok)
2804	#f)
2805	((= tok-type eof-tok)
2806	(lex-error (get-tok-line tok)
2807	#f
2808	"eof of file found while parsing "
2809	"a character class."))))))
2810
2811	(define parse-class
2812	(lambda (initial-class negative-class? line column)
2813	(push-lexer 'class)
2814	(let loop ((class initial-class))
2815	(let ((new-range (parse-class-range)))
2816	(if new-range
2817	(loop (class-union (list new-range) class))
2818	(let ((class (if negative-class?
2819	(class-compl class)
2820	class)))
2821	(pop-lexer)
2822	(make-tok class-tok "" line column class)))))))
2823
2824	(define parse-string
2825	(lambda (line column)
2826	(push-lexer 'string)
2827	(let ((char-list (let loop ()
2828	(let* ((tok (lexer))
2829	(tok-type (get-tok-type tok)))
2830	(cond ((= tok-type char-tok)
2831	(cons (get-tok-attr tok) (loop)))
2832	((= tok-type doublequote-tok)
2833	(pop-lexer)
2834	'())
2835	(else ; eof-tok
2836	(lex-error (get-tok-line tok)
2837	#f
2838	"end of file found while "
2839	"parsing a string.")))))))
2840	(make-tok string-tok "" line column char-list))))
2841
2842	(define parse-regexp
2843	(let* ((end-action
2844	(lambda (tok loop)
2845	(lexer-unget tok)
2846	(pop-lexer)
2847	(lexer-set-blank-history #f)
2848	`()))
2849	(action-table
2850	(make-dispatch-table
2851	number-of-tokens
2852	(list (cons eof-tok end-action)
2853	(cons hblank-tok end-action)
2854	(cons vblank-tok end-action)
2855	(cons lbrack-tok
2856	(lambda (tok loop)
2857	(let ((tok1 (parse-class (list)
2858	#f
2859	(get-tok-line tok)
2860	(get-tok-column tok))))
2861	(cons tok1 (loop)))))
2862	(cons lbrack-rbrack-tok
2863	(lambda (tok loop)
2864	(let ((tok1 (parse-class
2865	(list (cons rbrack-ch rbrack-ch))
2866	#f
2867	(get-tok-line tok)
2868	(get-tok-column tok))))
2869	(cons tok1 (loop)))))
2870	(cons lbrack-caret-tok
2871	(lambda (tok loop)
2872	(let ((tok1 (parse-class (list)
2873	#t
2874	(get-tok-line tok)
2875	(get-tok-column tok))))
2876	(cons tok1 (loop)))))
2877	(cons lbrack-minus-tok
2878	(lambda (tok loop)
2879	(let ((tok1 (parse-class
2880	(list (cons minus-ch minus-ch))
2881	#f
2882	(get-tok-line tok)
2883	(get-tok-column tok))))
2884	(cons tok1 (loop)))))
2885	(cons doublequote-tok
2886	(lambda (tok loop)
2887	(let ((tok1 (parse-string (get-tok-line tok)
2888	(get-tok-column tok))))
2889	(cons tok1 (loop)))))
2890	(cons illegal-tok
2891	(lambda (tok loop)
2892	(lex-error (get-tok-line tok)
2893	(get-tok-column tok)
2894	"syntax error in macro reference."))))
2895	(lambda (tok loop)
2896	(cons tok (loop))))))
2897	(lambda ()
2898	(push-lexer 'regexp)
2899	(lexer-set-blank-history #t)
2900	(parse-hv-blanks)
2901	(let loop ()
2902	(let* ((tok (lexer))
2903	(tok-type (get-tok-type tok))
2904	(action (vector-ref action-table tok-type)))
2905	(action tok loop))))))
2906
2907	(define parse-ws1-regexp ; Exige un blanc entre le nom et la RE d'une macro
2908	(lambda ()
2909	(let* ((tok (lexer))
2910	(tok-type (get-tok-type tok)))
2911	(cond ((or (= tok-type hblank-tok) (= tok-type vblank-tok))
2912	(parse-regexp))
2913	(else ; percent-percent-tok, id-tok ou illegal-tok
2914	(lex-error (get-tok-line tok)
2915	(get-tok-column tok)
2916	"white space expected."))))))
2917
2918	(define parse-macro
2919	(lambda (macros)
2920	(push-lexer 'macro)
2921	(parse-hv-blanks)
2922	(let* ((tok (lexer))
2923	(tok-type (get-tok-type tok)))
2924	(cond ((= tok-type id-tok)
2925	(let* ((name (get-tok-attr tok))
2926	(ass (assoc name macros)))
2927	(if ass
2928	(lex-error (get-tok-line tok)
2929	(get-tok-column tok)
2930	"the macro \""
2931	(get-tok-2nd-attr tok)
2932	"\" has already been defined.")
2933	(let* ((tok-list (parse-ws1-regexp))
2934	(regexp (tokens->regexp tok-list macros)))
2935	(pop-lexer)
2936	(cons name regexp)))))
2937	((= tok-type percent-percent-tok)
2938	(pop-lexer)
2939	#f)
2940	((= tok-type illegal-tok)
2941	(lex-error (get-tok-line tok)
2942	(get-tok-column tok)
2943	"macro name expected."))
2944	((= tok-type eof-tok)
2945	(lex-error (get-tok-line tok)
2946	#f
2947	"end of file found before %%."))))))
2948
2949	(define parse-macros
2950	(lambda ()
2951	(let loop ((macros '()))
2952	(let ((macro (parse-macro macros)))
2953	(if macro
2954	(loop (cons macro macros))
2955	macros)))))
2956
2957	(define parse-action-end
2958	(lambda (<<EOF>>-action? <<ERROR>>-action? action?)
2959	(let ((act (lexer-get-history)))
2960	(cond (action?
2961	act)
2962	(<<EOF>>-action?
2963	(string-append act default-<<EOF>>-action))
2964	(<<ERROR>>-action?
2965	(string-append act default-<<ERROR>>-action))
2966	(else
2967	(string-append act default-action))))))
2968
2969	(define parse-action
2970	(lambda (<<EOF>>-action? <<ERROR>>-action?)
2971	(push-lexer 'action)
2972	(let loop ((action? #f))
2973	(let* ((tok (lexer))
2974	(tok-type (get-tok-type tok)))
2975	(cond ((= tok-type char-tok)
2976	(loop #t))
2977	((= tok-type hblank-tok)
2978	(loop action?))
2979	((= tok-type vblank-tok)
2980	(push-lexer 'regexp)
2981	(let* ((tok (lexer))
2982	(tok-type (get-tok-type tok))
2983	(bidon (lexer-unget tok)))
2984	(pop-lexer)
2985	(if (or (= tok-type hblank-tok)
2986	(= tok-type vblank-tok))
2987	(loop action?)
2988	(begin
2989	(pop-lexer)
2990	(parse-action-end <<EOF>>-action?
2991	<<ERROR>>-action?
2992	action?)))))
2993	(else ; eof-tok
2994	(lexer-unget tok)
2995	(pop-lexer)
2996	(parse-action-end <<EOF>>-action?
2997	<<ERROR>>-action?
2998	action?)))))))
2999
3000	(define parse-rule
3001	(lambda (macros)
3002	(let ((tok-list (parse-regexp)))
3003	(if (null? tok-list)
3004	#f
3005	(let* ((rule (tokens->rule tok-list macros))
3006	(action
3007	(parse-action (get-rule-eof? rule) (get-rule-error? rule))))
3008	(set-rule-action rule action)
3009	rule)))))
3010
3011	(define parse-rules
3012	(lambda (macros)
3013	(parse-action #f #f)
3014	(let loop ()
3015	(let ((rule (parse-rule macros)))
3016	(if rule
3017	(cons rule (loop))
3018	'())))))
3019
3020	(define parser
3021	(lambda (filename)
3022	(let* ((port (open-input-file filename))
3023	(port-open? #t))
3024	(lex-unwind-protect (lambda ()
3025	(if port-open?
3026	(close-input-port port))))
3027	(init-lexer port)
3028	(let* ((macros (parse-macros))
3029	(rules (parse-rules macros)))
3030	(close-input-port port)
3031	(set! port-open? #f)
3032	(adapt-rules rules)))))
3033
3034	; Module re2nfa.scm.
3035	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
3036	; All rights reserved.
3037	; SILex 1.0.
3038
3039	; Le vecteur d'etats contient la table de transition du nfa.
3040	; Chaque entree contient les arcs partant de l'etat correspondant.
3041	; Les arcs sont stockes dans une liste.
3042	; Chaque arc est une paire (class . destination).
3043	; Les caracteres d'une classe sont enumeres par ranges.
3044	; Les ranges sont donnes dans une liste,
3045	; chaque element etant une paire (debut . fin).
3046	; Le symbole eps peut remplacer une classe.
3047	; L'acceptation est decrite par une paire (acc-if-eol . acc-if-no-eol).
3048
3049	; Quelques variables globales
3050	(define r2n-counter 0)
3051	(define r2n-v-arcs '#(#f))
3052	(define r2n-v-acc '#(#f))
3053	(define r2n-v-len 1)
3054
3055	; Initialisation des variables globales
3056	(define r2n-init
3057	(lambda ()
3058	(set! r2n-counter 0)
3059	(set! r2n-v-arcs (vector '()))
3060	(set! r2n-v-acc (vector #f))
3061	(set! r2n-v-len 1)))
3062
3063	; Agrandissement des vecteurs
3064	(define r2n-extend-v
3065	(lambda ()
3066	(let* ((new-len (* 2 r2n-v-len))
3067	(new-v-arcs (make-vector new-len '()))
3068	(new-v-acc (make-vector new-len #f)))
3069	(let loop ((i 0))
3070	(if (< i r2n-v-len)
3071	(begin
3072	(vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
3073	(vector-set! new-v-acc i (vector-ref r2n-v-acc i))
3074	(loop (+ i 1)))))
3075	(set! r2n-v-arcs new-v-arcs)
3076	(set! r2n-v-acc new-v-acc)
3077	(set! r2n-v-len new-len))))
3078
3079	; Finalisation des vecteurs
3080	(define r2n-finalize-v
3081	(lambda ()
3082	(let* ((new-v-arcs (make-vector r2n-counter))
3083	(new-v-acc (make-vector r2n-counter)))
3084	(let loop ((i 0))
3085	(if (< i r2n-counter)
3086	(begin
3087	(vector-set! new-v-arcs i (vector-ref r2n-v-arcs i))
3088	(vector-set! new-v-acc i (vector-ref r2n-v-acc i))
3089	(loop (+ i 1)))))
3090	(set! r2n-v-arcs new-v-arcs)
3091	(set! r2n-v-acc new-v-acc)
3092	(set! r2n-v-len r2n-counter))))
3093
3094	; Creation d'etat
3095	(define r2n-get-state
3096	(lambda (acc)
3097	(if (= r2n-counter r2n-v-len)
3098	(r2n-extend-v))
3099	(let ((state r2n-counter))
3100	(set! r2n-counter (+ r2n-counter 1))
3101	(vector-set! r2n-v-acc state (or acc (cons #f #f)))
3102	state)))
3103
3104	; Ajout d'un arc
3105	(define r2n-add-arc
3106	(lambda (start chars end)
3107	(vector-set! r2n-v-arcs
3108	start
3109	(cons (cons chars end) (vector-ref r2n-v-arcs start)))))
3110
3111	; Construction de l'automate a partir des regexp
3112	(define r2n-build-epsilon
3113	(lambda (re start end)
3114	(r2n-add-arc start 'eps end)))
3115
3116	(define r2n-build-or
3117	(lambda (re start end)
3118	(let ((re1 (get-re-attr1 re))
3119	(re2 (get-re-attr2 re)))
3120	(r2n-build-re re1 start end)
3121	(r2n-build-re re2 start end))))
3122
3123	(define r2n-build-conc
3124	(lambda (re start end)
3125	(let* ((re1 (get-re-attr1 re))
3126	(re2 (get-re-attr2 re))
3127	(inter (r2n-get-state #f)))
3128	(r2n-build-re re1 start inter)
3129	(r2n-build-re re2 inter end))))
3130
3131	(define r2n-build-star
3132	(lambda (re start end)
3133	(let* ((re1 (get-re-attr1 re))
3134	(inter1 (r2n-get-state #f))
3135	(inter2 (r2n-get-state #f)))
3136	(r2n-add-arc start 'eps inter1)
3137	(r2n-add-arc inter1 'eps inter2)
3138	(r2n-add-arc inter2 'eps end)
3139	(r2n-build-re re1 inter2 inter1))))
3140
3141	(define r2n-build-plus
3142	(lambda (re start end)
3143	(let* ((re1 (get-re-attr1 re))
3144	(inter1 (r2n-get-state #f))
3145	(inter2 (r2n-get-state #f)))
3146	(r2n-add-arc start 'eps inter1)
3147	(r2n-add-arc inter2 'eps inter1)
3148	(r2n-add-arc inter2 'eps end)
3149	(r2n-build-re re1 inter1 inter2))))
3150
3151	(define r2n-build-question
3152	(lambda (re start end)
3153	(let ((re1 (get-re-attr1 re)))
3154	(r2n-add-arc start 'eps end)
3155	(r2n-build-re re1 start end))))
3156
3157	(define r2n-build-class
3158	(lambda (re start end)
3159	(let ((class (get-re-attr1 re)))
3160	(r2n-add-arc start class end))))
3161
3162	(define r2n-build-char
3163	(lambda (re start end)
3164	(let* ((c (get-re-attr1 re))
3165	(class (list (cons c c))))
3166	(r2n-add-arc start class end))))
3167
3168	(define r2n-build-re
3169	(let ((sub-function-v (vector r2n-build-epsilon
3170	r2n-build-or
3171	r2n-build-conc
3172	r2n-build-star
3173	r2n-build-plus
3174	r2n-build-question
3175	r2n-build-class
3176	r2n-build-char)))
3177	(lambda (re start end)
3178	(let* ((re-type (get-re-type re))
3179	(sub-f (vector-ref sub-function-v re-type)))
3180	(sub-f re start end)))))
3181
3182	; Construction de l'automate relatif a une regle
3183	(define r2n-build-rule
3184	(lambda (rule ruleno nl-start no-nl-start)
3185	(let* ((re (get-rule-regexp rule))
3186	(bol? (get-rule-bol? rule))
3187	(eol? (get-rule-eol? rule))
3188	(rule-start (r2n-get-state #f))
3189	(rule-end (r2n-get-state (if eol?
3190	(cons ruleno #f)
3191	(cons ruleno ruleno)))))
3192	(r2n-build-re re rule-start rule-end)
3193	(r2n-add-arc nl-start 'eps rule-start)
3194	(if (not bol?)
3195	(r2n-add-arc no-nl-start 'eps rule-start)))))
3196
3197	; Construction de l'automate complet
3198	(define re2nfa
3199	(lambda (rules)
3200	(let ((nb-of-rules (vector-length rules)))
3201	(r2n-init)
3202	(let* ((nl-start (r2n-get-state #f))
3203	(no-nl-start (r2n-get-state #f)))
3204	(let loop ((i 0))
3205	(if (< i nb-of-rules)
3206	(begin
3207	(r2n-build-rule (vector-ref rules i)
3208	i
3209	nl-start
3210	no-nl-start)
3211	(loop (+ i 1)))))
3212	(r2n-finalize-v)
3213	(let ((v-arcs r2n-v-arcs)
3214	(v-acc r2n-v-acc))
3215	(r2n-init)
3216	(list nl-start no-nl-start v-arcs v-acc))))))
3217
3218	; Module noeps.scm.
3219	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
3220	; All rights reserved.
3221	; SILex 1.0.
3222
3223	; Fonction "merge" qui elimine les repetitions
3224	(define noeps-merge-1
3225	(lambda (l1 l2)
3226	(cond ((null? l1)
3227	l2)
3228	((null? l2)
3229	l1)
3230	(else
3231	(let ((t1 (car l1))
3232	(t2 (car l2)))
3233	(cond ((< t1 t2)
3234	(cons t1 (noeps-merge-1 (cdr l1) l2)))
3235	((= t1 t2)
3236	(cons t1 (noeps-merge-1 (cdr l1) (cdr l2))))
3237	(else
3238	(cons t2 (noeps-merge-1 l1 (cdr l2))))))))))
3239
3240	; Fabrication des voisinages externes
3241	(define noeps-mkvois
3242	(lambda (trans-v)
3243	(let* ((nbnodes (vector-length trans-v))
3244	(arcs (make-vector nbnodes '())))
3245	(let loop1 ((n 0))
3246	(if (< n nbnodes)
3247	(begin
3248	(let loop2 ((trans (vector-ref trans-v n)) (ends '()))
3249	(if (null? trans)
3250	(vector-set! arcs n ends)
3251	(let* ((tran (car trans))
3252	(class (car tran))
3253	(end (cdr tran)))
3254	(loop2 (cdr trans) (if (eq? class 'eps)
3255	(noeps-merge-1 ends (list end))
3256	ends)))))
3257	(loop1 (+ n 1)))))
3258	arcs)))
3259
3260	; Fabrication des valeurs initiales
3261	(define noeps-mkinit
3262	(lambda (trans-v)
3263	(let* ((nbnodes (vector-length trans-v))
3264	(init (make-vector nbnodes)))
3265	(let loop ((n 0))
3266	(if (< n nbnodes)
3267	(begin
3268	(vector-set! init n (list n))
3269	(loop (+ n 1)))))
3270	init)))
3271
3272	; Traduction d'une liste d'arcs
3273	(define noeps-trad-arcs
3274	(lambda (trans dict)
3275	(let loop ((trans trans))
3276	(if (null? trans)
3277	'()
3278	(let* ((tran (car trans))
3279	(class (car tran))
3280	(end (cdr tran)))
3281	(if (eq? class 'eps)
3282	(loop (cdr trans))
3283	(let* ((new-end (vector-ref dict end))
3284	(new-tran (cons class new-end)))
3285	(cons new-tran (loop (cdr trans))))))))))
3286
3287	; Elimination des transitions eps
3288	(define noeps
3289	(lambda (nl-start no-nl-start arcs acc)
3290	(let* ((digraph-arcs (noeps-mkvois arcs))
3291	(digraph-init (noeps-mkinit arcs))
3292	(dict (digraph digraph-arcs digraph-init noeps-merge-1))
3293	(new-nl-start (vector-ref dict nl-start))
3294	(new-no-nl-start (vector-ref dict no-nl-start)))
3295	(let loop ((i (- (vector-length arcs) 1)))
3296	(if (>= i 0)
3297	(begin
3298	(vector-set! arcs i (noeps-trad-arcs (vector-ref arcs i) dict))
3299	(loop (- i 1)))))
3300	(list new-nl-start new-no-nl-start arcs acc))))
3301
3302	; Module sweep.scm.
3303	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
3304	; All rights reserved.
3305	; SILex 1.0.
3306
3307	; Preparer les arcs pour digraph
3308	(define sweep-mkarcs
3309	(lambda (trans-v)
3310	(let* ((nbnodes (vector-length trans-v))
3311	(arcs-v (make-vector nbnodes '())))
3312	(let loop1 ((n 0))
3313	(if (< n nbnodes)
3314	(let loop2 ((trans (vector-ref trans-v n)) (arcs '()))
3315	(if (null? trans)
3316	(begin
3317	(vector-set! arcs-v n arcs)
3318	(loop1 (+ n 1)))
3319	(loop2 (cdr trans) (noeps-merge-1 (cdar trans) arcs))))
3320	arcs-v)))))
3321
3322	; Preparer l'operateur pour digraph
3323	(define sweep-op
3324	(let ((acc-min (lambda (rule1 rule2)
3325	(cond ((not rule1)
3326	rule2)
3327	((not rule2)
3328	rule1)
3329	(else
3330	(min rule1 rule2))))))
3331	(lambda (acc1 acc2)
3332	(cons (acc-min (car acc1) (car acc2))
3333	(acc-min (cdr acc1) (cdr acc2))))))
3334
3335	; Renumerotation des etats (#f pour etat a eliminer)
3336	; Retourne (new-nbnodes . dict)
3337	(define sweep-renum
3338	(lambda (dist-acc-v)
3339	(let* ((nbnodes (vector-length dist-acc-v))
3340	(dict (make-vector nbnodes)))
3341	(let loop ((n 0) (new-n 0))
3342	(if (< n nbnodes)
3343	(let* ((acc (vector-ref dist-acc-v n))
3344	(dead? (equal? acc '(#f . #f))))
3345	(if dead?
3346	(begin
3347	(vector-set! dict n #f)
3348	(loop (+ n 1) new-n))
3349	(begin
3350	(vector-set! dict n new-n)
3351	(loop (+ n 1) (+ new-n 1)))))
3352	(cons new-n dict))))))
3353
3354	; Elimination des etats inutiles d'une liste d'etats
3355	(define sweep-list
3356	(lambda (ss dict)
3357	(if (null? ss)
3358	'()
3359	(let* ((olds (car ss))
3360	(news (vector-ref dict olds)))
3361	(if news
3362	(cons news (sweep-list (cdr ss) dict))
3363	(sweep-list (cdr ss) dict))))))
3364
3365	; Elimination des etats inutiles d'une liste d'arcs
3366	(define sweep-arcs
3367	(lambda (arcs dict)
3368	(if (null? arcs)
3369	'()
3370	(let* ((arc (car arcs))
3371	(class (car arc))
3372	(ss (cdr arc))
3373	(new-ss (sweep-list ss dict)))
3374	(if (null? new-ss)
3375	(sweep-arcs (cdr arcs) dict)
3376	(cons (cons class new-ss) (sweep-arcs (cdr arcs) dict)))))))
3377
3378	; Elimination des etats inutiles dans toutes les transitions
3379	(define sweep-all-arcs
3380	(lambda (arcs-v dict)
3381	(let loop ((n (- (vector-length arcs-v) 1)))
3382	(if (>= n 0)
3383	(begin
3384	(vector-set! arcs-v n (sweep-arcs (vector-ref arcs-v n) dict))
3385	(loop (- n 1)))
3386	arcs-v))))
3387
3388	; Elimination des etats inutiles dans un vecteur
3389	(define sweep-states
3390	(lambda (v new-nbnodes dict)
3391	(let ((nbnodes (vector-length v))
3392	(new-v (make-vector new-nbnodes)))
3393	(let loop ((n 0))
3394	(if (< n nbnodes)
3395	(let ((new-n (vector-ref dict n)))
3396	(if new-n
3397	(vector-set! new-v new-n (vector-ref v n)))
3398	(loop (+ n 1)))
3399	new-v)))))
3400
3401	; Elimination des etats inutiles
3402	(define sweep
3403	(lambda (nl-start no-nl-start arcs-v acc-v)
3404	(let* ((digraph-arcs (sweep-mkarcs arcs-v))
3405	(digraph-init acc-v)
3406	(digraph-op sweep-op)
3407	(dist-acc-v (digraph digraph-arcs digraph-init digraph-op))
3408	(result (sweep-renum dist-acc-v))
3409	(new-nbnodes (car result))
3410	(dict (cdr result))
3411	(new-nl-start (sweep-list nl-start dict))
3412	(new-no-nl-start (sweep-list no-nl-start dict))
3413	(new-arcs-v (sweep-states (sweep-all-arcs arcs-v dict)
3414	new-nbnodes
3415	dict))
3416	(new-acc-v (sweep-states acc-v new-nbnodes dict)))
3417	(list new-nl-start new-no-nl-start new-arcs-v new-acc-v))))
3418
3419	; Module nfa2dfa.scm.
3420	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
3421	; All rights reserved.
3422	; SILex 1.0.
3423
3424	; Recoupement de deux arcs
3425	(define n2d-2arcs
3426	(lambda (arc1 arc2)
3427	(let* ((class1 (car arc1))
3428	(ss1 (cdr arc1))
3429	(class2 (car arc2))
3430	(ss2 (cdr arc2))
3431	(result (class-sep class1 class2))
3432	(classl (vector-ref result 0))
3433	(classc (vector-ref result 1))
3434	(classr (vector-ref result 2))
3435	(ssl ss1)
3436	(ssc (ss-union ss1 ss2))
3437	(ssr ss2))
3438	(vector (if (or (null? classl) (null? ssl)) #f (cons classl ssl))
3439	(if (or (null? classc) (null? ssc)) #f (cons classc ssc))
3440	(if (or (null? classr) (null? ssr)) #f (cons classr ssr))))))
3441
3442	; Insertion d'un arc dans une liste d'arcs a classes distinctes
3443	(define n2d-insert-arc
3444	(lambda (new-arc arcs)
3445	(if (null? arcs)
3446	(list new-arc)
3447	(let* ((arc (car arcs))
3448	(others (cdr arcs))
3449	(result (n2d-2arcs new-arc arc))
3450	(arcl (vector-ref result 0))
3451	(arcc (vector-ref result 1))
3452	(arcr (vector-ref result 2))
3453	(list-arcc (if arcc (list arcc) '()))
3454	(list-arcr (if arcr (list arcr) '())))
3455	(if arcl
3456	(append list-arcc list-arcr (n2d-insert-arc arcl others))
3457	(append list-arcc list-arcr others))))))
3458
3459	; Regroupement des arcs qui aboutissent au meme sous-ensemble d'etats
3460	(define n2d-factorize-arcs
3461	(lambda (arcs)
3462	(if (null? arcs)
3463	'()
3464	(let* ((arc (car arcs))
3465	(arc-ss (cdr arc))
3466	(others-no-fact (cdr arcs))
3467	(others (n2d-factorize-arcs others-no-fact)))
3468	(let loop ((o others))
3469	(if (null? o)
3470	(list arc)
3471	(let* ((o1 (car o))
3472	(o1-ss (cdr o1)))
3473	(if (equal? o1-ss arc-ss)
3474	(let* ((arc-class (car arc))
3475	(o1-class (car o1))
3476	(new-class (class-union arc-class o1-class))
3477	(new-arc (cons new-class arc-ss)))
3478	(cons new-arc (cdr o)))
3479	(cons o1 (loop (cdr o)))))))))))
3480
3481	; Transformer une liste d'arcs quelconques en des arcs a classes distinctes
3482	(define n2d-distinguish-arcs
3483	(lambda (arcs)
3484	(let loop ((arcs arcs) (n-arcs '()))
3485	(if (null? arcs)
3486	n-arcs
3487	(loop (cdr arcs) (n2d-insert-arc (car arcs) n-arcs))))))
3488
3489	; Transformer une liste d'arcs quelconques en des arcs a classes et a
3490	; destinations distinctes
3491	(define n2d-normalize-arcs
3492	(lambda (arcs)
3493	(n2d-factorize-arcs (n2d-distinguish-arcs arcs))))
3494
3495	; Factoriser des arcs a destination unique (~deterministes)
3496	(define n2d-factorize-darcs
3497	(lambda (arcs)
3498	(if (null? arcs)
3499	'()
3500	(let* ((arc (car arcs))
3501	(arc-end (cdr arc))
3502	(other-arcs (cdr arcs))
3503	(farcs (n2d-factorize-darcs other-arcs)))
3504	(let loop ((farcs farcs))
3505	(if (null? farcs)
3506	(list arc)
3507	(let* ((farc (car farcs))
3508	(farc-end (cdr farc)))
3509	(if (= farc-end arc-end)
3510	(let* ((arc-class (car arc))
3511	(farc-class (car farc))
3512	(new-class (class-union farc-class arc-class))
3513	(new-arc (cons new-class arc-end)))
3514	(cons new-arc (cdr farcs)))
3515	(cons farc (loop (cdr farcs)))))))))))
3516
3517	; Normaliser un vecteur de listes d'arcs
3518	(define n2d-normalize-arcs-v
3519	(lambda (arcs-v)
3520	(let* ((nbnodes (vector-length arcs-v))
3521	(new-v (make-vector nbnodes)))
3522	(let loop ((n 0))
3523	(if (= n nbnodes)
3524	new-v
3525	(begin
3526	(vector-set! new-v n (n2d-normalize-arcs (vector-ref arcs-v n)))
3527	(loop (+ n 1))))))))
3528
3529	; Inserer un arc dans une liste d'arcs a classes distinctes en separant
3530	; les arcs contenant une partie de la classe du nouvel arc des autres arcs
3531	; Retourne: (oui . non)
3532	(define n2d-ins-sep-arc
3533	(lambda (new-arc arcs)
3534	(if (null? arcs)
3535	(cons (list new-arc) '())
3536	(let* ((arc (car arcs))
3537	(others (cdr arcs))
3538	(result (n2d-2arcs new-arc arc))
3539	(arcl (vector-ref result 0))
3540	(arcc (vector-ref result 1))
3541	(arcr (vector-ref result 2))
3542	(l-arcc (if arcc (list arcc) '()))
3543	(l-arcr (if arcr (list arcr) '()))
3544	(result (if arcl
3545	(n2d-ins-sep-arc arcl others)
3546	(cons '() others)))
3547	(oui-arcs (car result))
3548	(non-arcs (cdr result)))
3549	(cons (append l-arcc oui-arcs) (append l-arcr non-arcs))))))
3550
3551	; Combiner deux listes d'arcs a classes distinctes
3552	; Ne tente pas de combiner les arcs qui ont nec. des classes disjointes
3553	; Conjecture: les arcs crees ont leurs classes disjointes
3554	; Note: envisager de rajouter un "n2d-factorize-arcs" !!!!!!!!!!!!
3555	(define n2d-combine-arcs
3556	(lambda (arcs1 arcs2)
3557	(let loop ((arcs1 arcs1) (arcs2 arcs2) (dist-arcs2 '()))
3558	(if (null? arcs1)
3559	(append arcs2 dist-arcs2)
3560	(let* ((arc (car arcs1))
3561	(result (n2d-ins-sep-arc arc arcs2))
3562	(oui-arcs (car result))
3563	(non-arcs (cdr result)))
3564	(loop (cdr arcs1) non-arcs (append oui-arcs dist-arcs2)))))))
3565
3566	; ;
3567	; ; Section temporaire: vieille facon de generer le dfa
3568	; ; Dictionnaire d'etat det. Recherche lineaire. Creation naive
3569	; ; des arcs d'un ensemble d'etats.
3570	; ;
3571	;
3572	; ; Quelques variables globales
3573	; (define n2d-state-dict '#(#f))
3574	; (define n2d-state-len 1)
3575	; (define n2d-state-count 0)
3576	;
3577	; ; Fonctions de gestion des entrees du dictionnaire
3578	; (define make-dentry (lambda (ss) (vector ss #f #f)))
3579	;
3580	; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
3581	; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
3582	; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
3583	;
3584	; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
3585	; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
3586	;
3587	; ; Initialisation des variables globales
3588	; (define n2d-init-glob-vars
3589	; (lambda ()
3590	; (set! n2d-state-dict (vector #f))
3591	; (set! n2d-state-len 1)
3592	; (set! n2d-state-count 0)))
3593	;
3594	; ; Extension du dictionnaire
3595	; (define n2d-extend-dict
3596	; (lambda ()
3597	; (let* ((new-len (* 2 n2d-state-len))
3598	; (v (make-vector new-len #f)))
3599	; (let loop ((n 0))
3600	; (if (= n n2d-state-count)
3601	; (begin
3602	; (set! n2d-state-dict v)
3603	; (set! n2d-state-len new-len))
3604	; (begin
3605	; (vector-set! v n (vector-ref n2d-state-dict n))
3606	; (loop (+ n 1))))))))
3607	;
3608	; ; Ajout d'un etat
3609	; (define n2d-add-state
3610	; (lambda (ss)
3611	; (let* ((s n2d-state-count)
3612	; (dentry (make-dentry ss)))
3613	; (if (= n2d-state-count n2d-state-len)
3614	; (n2d-extend-dict))
3615	; (vector-set! n2d-state-dict s dentry)
3616	; (set! n2d-state-count (+ n2d-state-count 1))
3617	; s)))
3618	;
3619	; ; Recherche d'un etat
3620	; (define n2d-search-state
3621	; (lambda (ss)
3622	; (let loop ((n 0))
3623	; (if (= n n2d-state-count)
3624	; (n2d-add-state ss)
3625	; (let* ((dentry (vector-ref n2d-state-dict n))
3626	; (dentry-ss (get-dentry-ss dentry)))
3627	; (if (equal? dentry-ss ss)
3628	; n
3629	; (loop (+ n 1))))))))
3630	;
3631	; ; Transformer un arc non-det. en un arc det.
3632	; (define n2d-translate-arc
3633	; (lambda (arc)
3634	; (let* ((class (car arc))
3635	; (ss (cdr arc))
3636	; (s (n2d-search-state ss)))
3637	; (cons class s))))
3638	;
3639	; ; Transformer une liste d'arcs non-det. en ...
3640	; (define n2d-translate-arcs
3641	; (lambda (arcs)
3642	; (map n2d-translate-arc arcs)))
3643	;
3644	; ; Trouver le minimum de deux acceptants
3645	; (define n2d-acc-min2
3646	; (let ((acc-min (lambda (rule1 rule2)
3647	; (cond ((not rule1)
3648	; rule2)
3649	; ((not rule2)
3650	; rule1)
3651	; (else
3652	; (min rule1 rule2))))))
3653	; (lambda (acc1 acc2)
3654	; (cons (acc-min (car acc1) (car acc2))
3655	; (acc-min (cdr acc1) (cdr acc2))))))
3656	;
3657	; ; Trouver le minimum de plusieurs acceptants
3658	; (define n2d-acc-mins
3659	; (lambda (accs)
3660	; (if (null? accs)
3661	; (cons #f #f)
3662	; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
3663	;
3664	; ; Fabriquer les vecteurs d'arcs et d'acceptance
3665	; (define n2d-extract-vs
3666	; (lambda ()
3667	; (let* ((arcs-v (make-vector n2d-state-count))
3668	; (acc-v (make-vector n2d-state-count)))
3669	; (let loop ((n 0))
3670	; (if (= n n2d-state-count)
3671	; (cons arcs-v acc-v)
3672	; (begin
3673	; (vector-set! arcs-v n (get-dentry-darcs
3674	; (vector-ref n2d-state-dict n)))
3675	; (vector-set! acc-v n (get-dentry-acc
3676	; (vector-ref n2d-state-dict n)))
3677	; (loop (+ n 1))))))))
3678	;
3679	; ; Effectuer la transformation de l'automate de non-det. a det.
3680	; (define nfa2dfa
3681	; (lambda (nl-start no-nl-start arcs-v acc-v)
3682	; (n2d-init-glob-vars)
3683	; (let* ((nl-d (n2d-search-state nl-start))
3684	; (no-nl-d (n2d-search-state no-nl-start)))
3685	; (let loop ((n 0))
3686	; (if (< n n2d-state-count)
3687	; (let* ((dentry (vector-ref n2d-state-dict n))
3688	; (ss (get-dentry-ss dentry))
3689	; (arcss (map (lambda (s) (vector-ref arcs-v s)) ss))
3690	; (arcs (apply append arcss))
3691	; (dist-arcs (n2d-distinguish-arcs arcs))
3692	; (darcs (n2d-translate-arcs dist-arcs))
3693	; (fact-darcs (n2d-factorize-darcs darcs))
3694	; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
3695	; (acc (n2d-acc-mins accs)))
3696	; (set-dentry-darcs dentry fact-darcs)
3697	; (set-dentry-acc dentry acc)
3698	; (loop (+ n 1)))))
3699	; (let* ((result (n2d-extract-vs))
3700	; (new-arcs-v (car result))
3701	; (new-acc-v (cdr result)))
3702	; (n2d-init-glob-vars)
3703	; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
3704
3705	; ;
3706	; ; Section temporaire: vieille facon de generer le dfa
3707	; ; Dictionnaire d'etat det. Recherche lineaire. Creation des
3708	; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
3709	; ; classes distinctes.
3710	; ;
3711	;
3712	; ; Quelques variables globales
3713	; (define n2d-state-dict '#(#f))
3714	; (define n2d-state-len 1)
3715	; (define n2d-state-count 0)
3716	;
3717	; ; Fonctions de gestion des entrees du dictionnaire
3718	; (define make-dentry (lambda (ss) (vector ss #f #f)))
3719	;
3720	; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
3721	; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
3722	; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
3723	;
3724	; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
3725	; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
3726	;
3727	; ; Initialisation des variables globales
3728	; (define n2d-init-glob-vars
3729	; (lambda ()
3730	; (set! n2d-state-dict (vector #f))
3731	; (set! n2d-state-len 1)
3732	; (set! n2d-state-count 0)))
3733	;
3734	; ; Extension du dictionnaire
3735	; (define n2d-extend-dict
3736	; (lambda ()
3737	; (let* ((new-len (* 2 n2d-state-len))
3738	; (v (make-vector new-len #f)))
3739	; (let loop ((n 0))
3740	; (if (= n n2d-state-count)
3741	; (begin
3742	; (set! n2d-state-dict v)
3743	; (set! n2d-state-len new-len))
3744	; (begin
3745	; (vector-set! v n (vector-ref n2d-state-dict n))
3746	; (loop (+ n 1))))))))
3747	;
3748	; ; Ajout d'un etat
3749	; (define n2d-add-state
3750	; (lambda (ss)
3751	; (let* ((s n2d-state-count)
3752	; (dentry (make-dentry ss)))
3753	; (if (= n2d-state-count n2d-state-len)
3754	; (n2d-extend-dict))
3755	; (vector-set! n2d-state-dict s dentry)
3756	; (set! n2d-state-count (+ n2d-state-count 1))
3757	; s)))
3758	;
3759	; ; Recherche d'un etat
3760	; (define n2d-search-state
3761	; (lambda (ss)
3762	; (let loop ((n 0))
3763	; (if (= n n2d-state-count)
3764	; (n2d-add-state ss)
3765	; (let* ((dentry (vector-ref n2d-state-dict n))
3766	; (dentry-ss (get-dentry-ss dentry)))
3767	; (if (equal? dentry-ss ss)
3768	; n
3769	; (loop (+ n 1))))))))
3770	;
3771	; ; Combiner des listes d'arcs a classes dictinctes
3772	; (define n2d-combine-arcs-l
3773	; (lambda (arcs-l)
3774	; (if (null? arcs-l)
3775	; '()
3776	; (let* ((arcs (car arcs-l))
3777	; (other-arcs-l (cdr arcs-l))
3778	; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
3779	; (n2d-combine-arcs arcs other-arcs)))))
3780	;
3781	; ; Transformer un arc non-det. en un arc det.
3782	; (define n2d-translate-arc
3783	; (lambda (arc)
3784	; (let* ((class (car arc))
3785	; (ss (cdr arc))
3786	; (s (n2d-search-state ss)))
3787	; (cons class s))))
3788	;
3789	; ; Transformer une liste d'arcs non-det. en ...
3790	; (define n2d-translate-arcs
3791	; (lambda (arcs)
3792	; (map n2d-translate-arc arcs)))
3793	;
3794	; ; Trouver le minimum de deux acceptants
3795	; (define n2d-acc-min2
3796	; (let ((acc-min (lambda (rule1 rule2)
3797	; (cond ((not rule1)
3798	; rule2)
3799	; ((not rule2)
3800	; rule1)
3801	; (else
3802	; (min rule1 rule2))))))
3803	; (lambda (acc1 acc2)
3804	; (cons (acc-min (car acc1) (car acc2))
3805	; (acc-min (cdr acc1) (cdr acc2))))))
3806	;
3807	; ; Trouver le minimum de plusieurs acceptants
3808	; (define n2d-acc-mins
3809	; (lambda (accs)
3810	; (if (null? accs)
3811	; (cons #f #f)
3812	; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
3813	;
3814	; ; Fabriquer les vecteurs d'arcs et d'acceptance
3815	; (define n2d-extract-vs
3816	; (lambda ()
3817	; (let* ((arcs-v (make-vector n2d-state-count))
3818	; (acc-v (make-vector n2d-state-count)))
3819	; (let loop ((n 0))
3820	; (if (= n n2d-state-count)
3821	; (cons arcs-v acc-v)
3822	; (begin
3823	; (vector-set! arcs-v n (get-dentry-darcs
3824	; (vector-ref n2d-state-dict n)))
3825	; (vector-set! acc-v n (get-dentry-acc
3826	; (vector-ref n2d-state-dict n)))
3827	; (loop (+ n 1))))))))
3828	;
3829	; ; Effectuer la transformation de l'automate de non-det. a det.
3830	; (define nfa2dfa
3831	; (lambda (nl-start no-nl-start arcs-v acc-v)
3832	; (n2d-init-glob-vars)
3833	; (let* ((nl-d (n2d-search-state nl-start))
3834	; (no-nl-d (n2d-search-state no-nl-start))
3835	; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
3836	; (let loop ((n 0))
3837	; (if (< n n2d-state-count)
3838	; (let* ((dentry (vector-ref n2d-state-dict n))
3839	; (ss (get-dentry-ss dentry))
3840	; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
3841	; (arcs (n2d-combine-arcs-l arcs-l))
3842	; (darcs (n2d-translate-arcs arcs))
3843	; (fact-darcs (n2d-factorize-darcs darcs))
3844	; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
3845	; (acc (n2d-acc-mins accs)))
3846	; (set-dentry-darcs dentry fact-darcs)
3847	; (set-dentry-acc dentry acc)
3848	; (loop (+ n 1)))))
3849	; (let* ((result (n2d-extract-vs))
3850	; (new-arcs-v (car result))
3851	; (new-acc-v (cdr result)))
3852	; (n2d-init-glob-vars)
3853	; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
3854
3855	; ;
3856	; ; Section temporaire: vieille facon de generer le dfa
3857	; ; Dictionnaire d'etat det. Arbre de recherche. Creation des
3858	; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
3859	; ; classes distinctes.
3860	; ;
3861	;
3862	; ; Quelques variables globales
3863	; (define n2d-state-dict '#(#f))
3864	; (define n2d-state-len 1)
3865	; (define n2d-state-count 0)
3866	; (define n2d-state-tree '#(#f ()))
3867	;
3868	; ; Fonctions de gestion des entrees du dictionnaire
3869	; (define make-dentry (lambda (ss) (vector ss #f #f)))
3870	;
3871	; (define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
3872	; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
3873	; (define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
3874	;
3875	; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
3876	; (define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
3877	;
3878	; ; Fonctions de gestion de l'arbre de recherche
3879	; (define make-snode (lambda () (vector #f '())))
3880	;
3881	; (define get-snode-dstate (lambda (snode) (vector-ref snode 0)))
3882	; (define get-snode-children (lambda (snode) (vector-ref snode 1)))
3883	;
3884	; (define set-snode-dstate
3885	; (lambda (snode dstate) (vector-set! snode 0 dstate)))
3886	; (define set-snode-children
3887	; (lambda (snode children) (vector-set! snode 1 children)))
3888	;
3889	; ; Initialisation des variables globales
3890	; (define n2d-init-glob-vars
3891	; (lambda ()
3892	; (set! n2d-state-dict (vector #f))
3893	; (set! n2d-state-len 1)
3894	; (set! n2d-state-count 0)
3895	; (set! n2d-state-tree (make-snode))))
3896	;
3897	; ; Extension du dictionnaire
3898	; (define n2d-extend-dict
3899	; (lambda ()
3900	; (let* ((new-len (* 2 n2d-state-len))
3901	; (v (make-vector new-len #f)))
3902	; (let loop ((n 0))
3903	; (if (= n n2d-state-count)
3904	; (begin
3905	; (set! n2d-state-dict v)
3906	; (set! n2d-state-len new-len))
3907	; (begin
3908	; (vector-set! v n (vector-ref n2d-state-dict n))
3909	; (loop (+ n 1))))))))
3910	;
3911	; ; Ajout d'un etat
3912	; (define n2d-add-state
3913	; (lambda (ss)
3914	; (let* ((s n2d-state-count)
3915	; (dentry (make-dentry ss)))
3916	; (if (= n2d-state-count n2d-state-len)
3917	; (n2d-extend-dict))
3918	; (vector-set! n2d-state-dict s dentry)
3919	; (set! n2d-state-count (+ n2d-state-count 1))
3920	; s)))
3921	;
3922	; ; Recherche d'un etat
3923	; (define n2d-search-state
3924	; (lambda (ss)
3925	; (let loop ((s-l ss) (snode n2d-state-tree))
3926	; (if (null? s-l)
3927	; (or (get-snode-dstate snode)
3928	; (let ((s (n2d-add-state ss)))
3929	; (set-snode-dstate snode s)
3930	; s))
3931	; (let* ((next-s (car s-l))
3932	; (alist (get-snode-children snode))
3933	; (ass (or (assv next-s alist)
3934	; (let ((ass (cons next-s (make-snode))))
3935	; (set-snode-children snode (cons ass alist))
3936	; ass))))
3937	; (loop (cdr s-l) (cdr ass)))))))
3938	;
3939	; ; Combiner des listes d'arcs a classes dictinctes
3940	; (define n2d-combine-arcs-l
3941	; (lambda (arcs-l)
3942	; (if (null? arcs-l)
3943	; '()
3944	; (let* ((arcs (car arcs-l))
3945	; (other-arcs-l (cdr arcs-l))
3946	; (other-arcs (n2d-combine-arcs-l other-arcs-l)))
3947	; (n2d-combine-arcs arcs other-arcs)))))
3948	;
3949	; ; Transformer un arc non-det. en un arc det.
3950	; (define n2d-translate-arc
3951	; (lambda (arc)
3952	; (let* ((class (car arc))
3953	; (ss (cdr arc))
3954	; (s (n2d-search-state ss)))
3955	; (cons class s))))
3956	;
3957	; ; Transformer une liste d'arcs non-det. en ...
3958	; (define n2d-translate-arcs
3959	; (lambda (arcs)
3960	; (map n2d-translate-arc arcs)))
3961	;
3962	; ; Trouver le minimum de deux acceptants
3963	; (define n2d-acc-min2
3964	; (let ((acc-min (lambda (rule1 rule2)
3965	; (cond ((not rule1)
3966	; rule2)
3967	; ((not rule2)
3968	; rule1)
3969	; (else
3970	; (min rule1 rule2))))))
3971	; (lambda (acc1 acc2)
3972	; (cons (acc-min (car acc1) (car acc2))
3973	; (acc-min (cdr acc1) (cdr acc2))))))
3974	;
3975	; ; Trouver le minimum de plusieurs acceptants
3976	; (define n2d-acc-mins
3977	; (lambda (accs)
3978	; (if (null? accs)
3979	; (cons #f #f)
3980	; (n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
3981	;
3982	; ; Fabriquer les vecteurs d'arcs et d'acceptance
3983	; (define n2d-extract-vs
3984	; (lambda ()
3985	; (let* ((arcs-v (make-vector n2d-state-count))
3986	; (acc-v (make-vector n2d-state-count)))
3987	; (let loop ((n 0))
3988	; (if (= n n2d-state-count)
3989	; (cons arcs-v acc-v)
3990	; (begin
3991	; (vector-set! arcs-v n (get-dentry-darcs
3992	; (vector-ref n2d-state-dict n)))
3993	; (vector-set! acc-v n (get-dentry-acc
3994	; (vector-ref n2d-state-dict n)))
3995	; (loop (+ n 1))))))))
3996	;
3997	; ; Effectuer la transformation de l'automate de non-det. a det.
3998	; (define nfa2dfa
3999	; (lambda (nl-start no-nl-start arcs-v acc-v)
4000	; (n2d-init-glob-vars)
4001	; (let* ((nl-d (n2d-search-state nl-start))
4002	; (no-nl-d (n2d-search-state no-nl-start))
4003	; (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
4004	; (let loop ((n 0))
4005	; (if (< n n2d-state-count)
4006	; (let* ((dentry (vector-ref n2d-state-dict n))
4007	; (ss (get-dentry-ss dentry))
4008	; (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
4009	; (arcs (n2d-combine-arcs-l arcs-l))
4010	; (darcs (n2d-translate-arcs arcs))
4011	; (fact-darcs (n2d-factorize-darcs darcs))
4012	; (accs (map (lambda (s) (vector-ref acc-v s)) ss))
4013	; (acc (n2d-acc-mins accs)))
4014	; (set-dentry-darcs dentry fact-darcs)
4015	; (set-dentry-acc dentry acc)
4016	; (loop (+ n 1)))))
4017	; (let* ((result (n2d-extract-vs))
4018	; (new-arcs-v (car result))
4019	; (new-acc-v (cdr result)))
4020	; (n2d-init-glob-vars)
4021	; (list nl-d no-nl-d new-arcs-v new-acc-v)))))
4022
4023	;
4024	; Section temporaire: vieille facon de generer le dfa
4025	; Dictionnaire d'etat det. Table de hashage. Creation des
4026	; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
4027	; classes distinctes.
4028	;
4029
4030	; Quelques variables globales
4031	(define n2d-state-dict '#(#f))
4032	(define n2d-state-len 1)
4033	(define n2d-state-count 0)
4034	(define n2d-state-hash '#())
4035
4036	; Fonctions de gestion des entrees du dictionnaire
4037	(define make-dentry (lambda (ss) (vector ss #f #f)))
4038
4039	(define get-dentry-ss (lambda (dentry) (vector-ref dentry 0)))
4040	(define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
4041	(define get-dentry-acc (lambda (dentry) (vector-ref dentry 2)))
4042
4043	(define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
4044	(define set-dentry-acc (lambda (dentry acc) (vector-set! dentry 2 acc)))
4045
4046	; Initialisation des variables globales
4047	(define n2d-init-glob-vars
4048	(lambda (hash-len)
4049	(set! n2d-state-dict (vector #f))
4050	(set! n2d-state-len 1)
4051	(set! n2d-state-count 0)
4052	(set! n2d-state-hash (make-vector hash-len '()))))
4053
4054	; Extension du dictionnaire
4055	(define n2d-extend-dict
4056	(lambda ()
4057	(let* ((new-len (* 2 n2d-state-len))
4058	(v (make-vector new-len #f)))
4059	(let loop ((n 0))
4060	(if (= n n2d-state-count)
4061	(begin
4062	(set! n2d-state-dict v)
4063	(set! n2d-state-len new-len))
4064	(begin
4065	(vector-set! v n (vector-ref n2d-state-dict n))
4066	(loop (+ n 1))))))))
4067
4068	; Ajout d'un etat
4069	(define n2d-add-state
4070	(lambda (ss)
4071	(let* ((s n2d-state-count)
4072	(dentry (make-dentry ss)))
4073	(if (= n2d-state-count n2d-state-len)
4074	(n2d-extend-dict))
4075	(vector-set! n2d-state-dict s dentry)
4076	(set! n2d-state-count (+ n2d-state-count 1))
4077	s)))
4078
4079	; Recherche d'un etat
4080	(define n2d-search-state
4081	(lambda (ss)
4082	(let* ((hash-no (if (null? ss) 0 (car ss)))
4083	(alist (vector-ref n2d-state-hash hash-no))
4084	(ass (assoc ss alist)))
4085	(if ass
4086	(cdr ass)
4087	(let* ((s (n2d-add-state ss))
4088	(new-ass (cons ss s)))
4089	(vector-set! n2d-state-hash hash-no (cons new-ass alist))
4090	s)))))
4091
4092	; Combiner des listes d'arcs a classes dictinctes
4093	(define n2d-combine-arcs-l
4094	(lambda (arcs-l)
4095	(if (null? arcs-l)
4096	'()
4097	(let* ((arcs (car arcs-l))
4098	(other-arcs-l (cdr arcs-l))
4099	(other-arcs (n2d-combine-arcs-l other-arcs-l)))
4100	(n2d-combine-arcs arcs other-arcs)))))
4101
4102	; Transformer un arc non-det. en un arc det.
4103	(define n2d-translate-arc
4104	(lambda (arc)
4105	(let* ((class (car arc))
4106	(ss (cdr arc))
4107	(s (n2d-search-state ss)))
4108	(cons class s))))
4109
4110	; Transformer une liste d'arcs non-det. en ...
4111	(define n2d-translate-arcs
4112	(lambda (arcs)
4113	(map n2d-translate-arc arcs)))
4114
4115	; Trouver le minimum de deux acceptants
4116	(define n2d-acc-min2
4117	(let ((acc-min (lambda (rule1 rule2)
4118	(cond ((not rule1)
4119	rule2)
4120	((not rule2)
4121	rule1)
4122	(else
4123	(min rule1 rule2))))))
4124	(lambda (acc1 acc2)
4125	(cons (acc-min (car acc1) (car acc2))
4126	(acc-min (cdr acc1) (cdr acc2))))))
4127
4128	; Trouver le minimum de plusieurs acceptants
4129	(define n2d-acc-mins
4130	(lambda (accs)
4131	(if (null? accs)
4132	(cons #f #f)
4133	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
4134
4135	; Fabriquer les vecteurs d'arcs et d'acceptance
4136	(define n2d-extract-vs
4137	(lambda ()
4138	(let* ((arcs-v (make-vector n2d-state-count))
4139	(acc-v (make-vector n2d-state-count)))
4140	(let loop ((n 0))
4141	(if (= n n2d-state-count)
4142	(cons arcs-v acc-v)
4143	(begin
4144	(vector-set! arcs-v n (get-dentry-darcs
4145	(vector-ref n2d-state-dict n)))
4146	(vector-set! acc-v n (get-dentry-acc
4147	(vector-ref n2d-state-dict n)))
4148	(loop (+ n 1))))))))
4149
4150	; Effectuer la transformation de l'automate de non-det. a det.
4151	(define nfa2dfa
4152	(lambda (nl-start no-nl-start arcs-v acc-v)
4153	(n2d-init-glob-vars (vector-length arcs-v))
4154	(let* ((nl-d (n2d-search-state nl-start))
4155	(no-nl-d (n2d-search-state no-nl-start))
4156	(norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
4157	(let loop ((n 0))
4158	(if (< n n2d-state-count)
4159	(let* ((dentry (vector-ref n2d-state-dict n))
4160	(ss (get-dentry-ss dentry))
4161	(arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
4162	(arcs (n2d-combine-arcs-l arcs-l))
4163	(darcs (n2d-translate-arcs arcs))
4164	(fact-darcs (n2d-factorize-darcs darcs))
4165	(accs (map (lambda (s) (vector-ref acc-v s)) ss))
4166	(acc (n2d-acc-mins accs)))
4167	(set-dentry-darcs dentry fact-darcs)
4168	(set-dentry-acc dentry acc)
4169	(loop (+ n 1)))))
4170	(let* ((result (n2d-extract-vs))
4171	(new-arcs-v (car result))
4172	(new-acc-v (cdr result)))
4173	(n2d-init-glob-vars 0)
4174	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
4175
4176	; Module prep.scm.
4177	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
4178	; All rights reserved.
4179	; SILex 1.0.
4180
4181	;
4182	; Divers pre-traitements avant l'ecriture des tables
4183	;
4184
4185	; Passe d'un arc multi-range a une liste d'arcs mono-range
4186	(define prep-arc->sharcs
4187	(lambda (arc)
4188	(let* ((range-l (car arc))
4189	(dest (cdr arc))
4190	(op (lambda (range) (cons range dest))))
4191	(map op range-l))))
4192
4193	; Compare des arcs courts selon leur premier caractere
4194	(define prep-sharc-<=
4195	(lambda (sharc1 sharc2)
4196	(class-<= (caar sharc1) (caar sharc2))))
4197
4198	; Remplit les trous parmi les sharcs avec des arcs "erreur"
4199	(define prep-fill-error
4200	(lambda (sharcs)
4201	(let loop ((sharcs sharcs) (start 'inf-))
4202	(cond ((class-= start 'inf+)
4203	'())
4204	((null? sharcs)
4205	(cons (cons (cons start 'inf+) 'err) (loop sharcs 'inf+)))
4206	(else
4207	(let* ((sharc (car sharcs))
4208	(h (caar sharc))
4209	(t (cdar sharc)))
4210	(if (class-< start h)
4211	(cons (cons (cons start (- h 1)) 'err) (loop sharcs h))
4212	(cons sharc (loop (cdr sharcs)
4213	(if (class-= t 'inf+)
4214	'inf+
4215	(+ t 1)))))))))))
4216
4217	; ; Passe d'une liste d'arcs a un arbre de decision
4218	; ; 1ere methode: seulement des comparaisons <
4219	; (define prep-arcs->tree
4220	; (lambda (arcs)
4221	; (let* ((sharcs-l (map prep-arc->sharcs arcs))
4222	; (sharcs (apply append sharcs-l))
4223	; (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
4224	; (sorted (prep-fill-error sorted-with-holes))
4225	; (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
4226	; (table (list->vector (map op sorted))))
4227	; (let loop ((left 0) (right (- (vector-length table) 1)))
4228	; (if (= left right)
4229	; (cdr (vector-ref table left))
4230	; (let ((mid (quotient (+ left right 1) 2)))
4231	; (list (car (vector-ref table mid))
4232	; (loop left (- mid 1))
4233	; (loop mid right))))))))
4234
4235	; Passe d'une liste d'arcs a un arbre de decision
4236	; 2eme methode: permettre des comparaisons = quand ca adonne
4237	(define prep-arcs->tree
4238	(lambda (arcs)
4239	(let* ((sharcs-l (map prep-arc->sharcs arcs))
4240	(sharcs (apply append sharcs-l))
4241	(sorted-with-holes (merge-sort sharcs prep-sharc-<=))
4242	(sorted (prep-fill-error sorted-with-holes))
4243	(op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
4244	(table (list->vector (map op sorted))))
4245	(let loop ((left 0) (right (- (vector-length table) 1)))
4246	(if (= left right)
4247	(cdr (vector-ref table left))
4248	(let ((mid (quotient (+ left right 1) 2)))
4249	(if (and (= (+ left 2) right)
4250	(= (+ (car (vector-ref table mid)) 1)
4251	(car (vector-ref table right)))
4252	(eqv? (cdr (vector-ref table left))
4253	(cdr (vector-ref table right))))
4254	(list '=
4255	(car (vector-ref table mid))
4256	(cdr (vector-ref table mid))
4257	(cdr (vector-ref table left)))
4258	(list (car (vector-ref table mid))
4259	(loop left (- mid 1))
4260	(loop mid right)))))))))
4261
4262	; Determine si une action a besoin de calculer yytext
4263	(define prep-detect-yytext
4264	(lambda (s)
4265	(let loop1 ((i (- (string-length s) 6)))
4266	(cond ((< i 0)
4267	#f)
4268	((char-ci=? (string-ref s i) #\y)
4269	(let loop2 ((j 5))
4270	(cond ((= j 0)
4271	#t)
4272	((char-ci=? (string-ref s (+ i j))
4273	(string-ref "yytext" j))
4274	(loop2 (- j 1)))
4275	(else
4276	(loop1 (- i 1))))))
4277	(else
4278	(loop1 (- i 1)))))))
4279
4280	; Note dans une regle si son action a besoin de yytext
4281	(define prep-set-rule-yytext?
4282	(lambda (rule)
4283	(let ((action (get-rule-action rule)))
4284	(set-rule-yytext? rule (prep-detect-yytext action)))))
4285
4286	; Note dans toutes les regles si leurs actions ont besoin de yytext
4287	(define prep-set-rules-yytext?
4288	(lambda (rules)
4289	(let loop ((n (- (vector-length rules) 1)))
4290	(if (>= n 0)
4291	(begin
4292	(prep-set-rule-yytext? (vector-ref rules n))
4293	(loop (- n 1)))))))
4294
4295	; Module output.scm.
4296	; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
4297	; All rights reserved.
4298	; SILex 1.0.
4299
4300	;
4301	; Nettoie les actions en enlevant les lignes blanches avant et apres
4302	;
4303
4304	(define out-split-in-lines
4305	(lambda (s)
4306	(let ((len (string-length s)))
4307	(let loop ((i 0) (start 0))
4308	(cond ((= i len)
4309	'())
4310	((char=? (string-ref s i) #\newline)
4311	(cons (substring s start (+ i 1))
4312	(loop (+ i 1) (+ i 1))))
4313	(else
4314	(loop (+ i 1) start)))))))
4315
4316	(define out-empty-line?
4317	(lambda (s)
4318	(let ((len (- (string-length s) 1)))
4319	(let loop ((i 0))
4320	(cond ((= i len)
4321	#t)
4322	((char-whitespace? (string-ref s i))
4323	(loop (+ i 1)))
4324	(else
4325	#f))))))
4326
4327	; Enleve les lignes vides dans une liste avant et apres l'action
4328	(define out-remove-empty-lines
4329	(lambda (lines)
4330	(let loop ((lines lines) (top? #t))
4331	(if (null? lines)
4332	'()
4333	(let ((line (car lines)))
4334	(cond ((not (out-empty-line? line))
4335	(cons line (loop (cdr lines) #f)))
4336	(top?
4337	(loop (cdr lines) #t))
4338	(else
4339	(let ((rest (loop (cdr lines) #f)))
4340	(if (null? rest)
4341	'()
4342	(cons line rest))))))))))
4343
4344	; Enleve les lignes vides avant et apres l'action
4345	(define out-clean-action
4346	(lambda (s)
4347	(let* ((lines (out-split-in-lines s))
4348	(clean-lines (out-remove-empty-lines lines)))
4349	(string-append-list clean-lines))))
4350
4351
4352
4353
4354	;
4355	; Pretty-printer pour les booleens, la liste vide, les nombres,
4356	; les symboles, les caracteres, les chaines, les listes et les vecteurs
4357	;
4358
4359	; Colonne limite pour le pretty-printer (a ne pas atteindre)
4360	(define out-max-col 76)
4361
4362	(define out-flatten-list
4363	(lambda (ll)
4364	(let loop ((ll ll) (part-out '()))
4365	(if (null? ll)
4366	part-out
4367	(let* ((new-part-out (loop (cdr ll) part-out))
4368	(head (car ll)))
4369	(cond ((null? head)
4370	new-part-out)
4371	((pair? head)
4372	(loop head new-part-out))
4373	(else
4374	(cons head new-part-out))))))))
4375
4376	(define out-force-string
4377	(lambda (obj)
4378	(if (char? obj)
4379	(string obj)
4380	obj)))
4381
4382	; Transforme une liste impropre en une liste propre qui s'ecrit
4383	; de la meme facon
4384	(define out-regular-list
4385	(let ((symbolic-dot (string->symbol ".")))
4386	(lambda (p)
4387	(let ((tail (cdr p)))
4388	(cond ((null? tail)
4389	p)
4390	((pair? tail)
4391	(cons (car p) (out-regular-list tail)))
4392	(else
4393	(list (car p) symbolic-dot tail)))))))
4394
4395	; Cree des chaines d'espaces de facon paresseuse
4396	(define out-blanks
4397	(let ((cache-v (make-vector 80 #f)))
4398	(lambda (n)
4399	(or (vector-ref cache-v n)
4400	(let ((result (make-string n #\space)))
4401	(vector-set! cache-v n result)
4402	result)))))
4403
4404	; Insere le separateur entre chaque element d'une liste non-vide
4405	(define out-separate
4406	(lambda (text-l sep)
4407	(if (null? (cdr text-l))
4408	text-l
4409	(cons (car text-l) (cons sep (out-separate (cdr text-l) sep))))))
4410
4411	; Met des donnees en colonnes. Retourne comme out-pp-aux-list
4412	(define out-pp-columns
4413	(lambda (left right wmax txt&lens)
4414	(let loop1 ((tls txt&lens) (lwmax 0) (lwlast 0) (lines '()))
4415	(if (null? tls)
4416	(vector #t 0 lwmax lwlast (reverse lines))
4417	(let loop2 ((tls tls) (len 0) (first? #t) (prev-pad 0) (line '()))
4418	(cond ((null? tls)
4419	(loop1 tls
4420	(max len lwmax)
4421	len
4422	(cons (reverse line) lines)))
4423	((> (+ left len prev-pad 1 wmax) out-max-col)
4424	(loop1 tls
4425	(max len lwmax)
4426	len
4427	(cons (reverse line) lines)))
4428	(first?
4429	(let ((text (caar tls))
4430	(text-len (cdar tls)))
4431	(loop2 (cdr tls)
4432	(+ len text-len)
4433	#f
4434	(- wmax text-len)
4435	(cons text line))))
4436	((pair? (cdr tls))
4437	(let* ((prev-pad-s (out-blanks prev-pad))
4438	(text (caar tls))
4439	(text-len (cdar tls)))
4440	(loop2 (cdr tls)
4441	(+ len prev-pad 1 text-len)
4442	#f
4443	(- wmax text-len)
4444	(cons text (cons " " (cons prev-pad-s line))))))
4445	(else
4446	(let ((prev-pad-s (out-blanks prev-pad))
4447	(text (caar tls))
4448	(text-len (cdar tls)))
4449	(if (> (+ left len prev-pad 1 text-len) right)
4450	(loop1 tls
4451	(max len lwmax)
4452	len
4453	(cons (reverse line) lines))
4454	(loop2 (cdr tls)
4455	(+ len prev-pad 1 text-len)
4456	#f
4457	(- wmax text-len)
4458	(append (list text " " prev-pad-s)
4459	line)))))))))))
4460
4461	; Retourne un vecteur #( multiline? width-all width-max width-last text-l )
4462	(define out-pp-aux-list
4463	(lambda (l left right)
4464	(let loop ((l l) (multi? #f) (wall -1) (wmax -1) (wlast -1) (txt&lens '()))
4465	(if (null? l)
4466	(cond (multi?
4467	(vector #t wall wmax wlast (map car (reverse txt&lens))))
4468	((<= (+ left wall) right)
4469	(vector #f wall wmax wlast (map car (reverse txt&lens))))
4470	((<= (+ left wmax 1 wmax) out-max-col)
4471	(out-pp-columns left right wmax (reverse txt&lens)))
4472	(else
4473	(vector #t wall wmax wlast (map car (reverse txt&lens)))))
4474	(let* ((obj (car l))
4475	(last? (null? (cdr l)))
4476	(this-right (if last? right out-max-col))
4477	(result (out-pp-aux obj left this-right))
4478	(obj-multi? (vector-ref result 0))
4479	(obj-wmax (vector-ref result 1))
4480	(obj-wlast (vector-ref result 2))
4481	(obj-text (vector-ref result 3)))
4482	(loop (cdr l)
4483	(or multi? obj-multi?)
4484	(+ wall obj-wmax 1)
4485	(max wmax obj-wmax)
4486	obj-wlast
4487	(cons (cons obj-text obj-wmax) txt&lens)))))))
4488
4489	; Retourne un vecteur #( multiline? wmax wlast text )
4490	(define out-pp-aux
4491	(lambda (obj left right)
4492	(cond ((boolean? obj)
4493	(vector #f 2 2 (if obj '("#t") '("#f"))))
4494	((null? obj)
4495	(vector #f 2 2 '("()")))
4496	((number? obj)
4497	(let* ((s (number->string obj))
4498	(len (string-length s)))
4499	(vector #f len len (list s))))
4500	((symbol? obj)
4501	(let* ((s (symbol->string obj))
4502	(len (string-length s)))
4503	(vector #f len len (list s))))
4504	((char? obj)
4505	(cond ((char=? obj #\space)
4506	(vector #f 7 7 (list "#\\space")))
4507	((char=? obj #\newline)
4508	(vector #f 9 9 (list "#\\newline")))
4509	(else
4510	(vector #f 3 3 (list "#\\" obj)))))
4511	((string? obj)
4512	(let loop ((i (- (string-length obj) 1))
4513	(len 1)
4514	(text '("\"")))
4515	(if (= i -1)
4516	(vector #f (+ len 1) (+ len 1) (cons "\"" text))
4517	(let ((c (string-ref obj i)))
4518	(cond ((char=? c #\\)
4519	(loop (- i 1) (+ len 2) (cons "\\\\" text)))
4520	((char=? c #\")
4521	(loop (- i 1) (+ len 2) (cons "\\\"" text)))
4522	(else
4523	(loop (- i 1) (+ len 1) (cons (string c) text))))))))
4524	((pair? obj)
4525	(let* ((l (out-regular-list obj))
4526	(result (out-pp-aux-list l (+ left 1) (- right 1)))
4527	(multiline? (vector-ref result 0))
4528	(width-all (vector-ref result 1))
4529	(width-max (vector-ref result 2))
4530	(width-last (vector-ref result 3))
4531	(text-l (vector-ref result 4)))
4532	(if multiline?
4533	(let* ((sep (list #\newline (out-blanks left)))
4534	(formatted-text (out-separate text-l sep))
4535	(text (list "(" formatted-text ")")))
4536	(vector #t
4537	(+ (max width-max (+ width-last 1)) 1)
4538	(+ width-last 2)
4539	text))
4540	(let* ((sep (list " "))
4541	(formatted-text (out-separate text-l sep))
4542	(text (list "(" formatted-text ")")))
4543	(vector #f (+ width-all 2) (+ width-all 2) text)))))
4544	((and (vector? obj) (zero? (vector-length obj)))
4545	(vector #f 3 3 '("#()")))
4546	((vector? obj)
4547	(let* ((l (vector->list obj))
4548	(result (out-pp-aux-list l (+ left 2) (- right 1)))
4549	(multiline? (vector-ref result 0))
4550	(width-all (vector-ref result 1))
4551	(width-max (vector-ref result 2))
4552	(width-last (vector-ref result 3))
4553	(text-l (vector-ref result 4)))
4554	(if multiline?
4555	(let* ((sep (list #\newline (out-blanks (+ left 1))))
4556	(formatted-text (out-separate text-l sep))
4557	(text (list "#(" formatted-text ")")))
4558	(vector #t
4559	(+ (max width-max (+ width-last 1)) 2)
4560	(+ width-last 3)
4561	text))
4562	(let* ((sep (list " "))
4563	(formatted-text (out-separate text-l sep))
4564	(text (list "#(" formatted-text ")")))
4565	(vector #f (+ width-all 3) (+ width-all 3) text)))))
4566	(else
4567	(display "Internal error: out-pp")
4568	(newline)))))
4569
4570	; Retourne la chaine a afficher
4571	(define out-pp
4572	(lambda (obj col)
4573	(let* ((list-rec-of-strings-n-chars
4574	(vector-ref (out-pp-aux obj col out-max-col) 3))
4575	(list-of-strings-n-chars
4576	(out-flatten-list list-rec-of-strings-n-chars))
4577	(list-of-strings
4578	(map out-force-string list-of-strings-n-chars)))
4579	(string-append-list list-of-strings))))
4580
4581
4582
4583
4584	;
4585	; Nice-printer, plus rapide mais moins beau que le pretty-printer
4586	;
4587
4588	(define out-np
4589	(lambda (obj start)
4590	(letrec ((line-pad
4591	(string-append (string #\newline)
4592	(out-blanks (- start 1))))
4593	(step-line
4594	(lambda (p)
4595	(set-car! p line-pad)))
4596	(p-bool
4597	(lambda (obj col objw texts hole cont)
4598	(let ((text (if obj "#t" "#f")))
4599	(cont (+ col 2) (+ objw 2) (cons text texts) hole))))
4600	(p-number
4601	(lambda (obj col objw texts hole cont)
4602	(let* ((text (number->string obj))
4603	(len (string-length text)))
4604	(cont (+ col len) (+ objw len) (cons text texts) hole))))
4605	(p-symbol
4606	(lambda (obj col objw texts hole cont)
4607	(let* ((text (symbol->string obj))
4608	(len (string-length text)))
4609	(cont (+ col len) (+ objw len) (cons text texts) hole))))
4610	(p-char
4611	(lambda (obj col objw texts hole cont)
4612	(let* ((text
4613	(cond ((char=? obj #\space) "#\\space")
4614	((char=? obj #\newline) "#\\newline")
4615	(else (string-append "#\\" (string obj)))))
4616	(len (string-length text)))
4617	(cont (+ col len) (+ objw len) (cons text texts) hole))))
4618	(p-list
4619	(lambda (obj col objw texts hole cont)
4620	(p-tail obj (+ col 1) (+ objw 1) (cons "(" texts) hole cont)))
4621	(p-vector
4622	(lambda (obj col objw texts hole cont)
4623	(p-list (vector->list obj)
4624	(+ col 1) (+ objw 1) (cons "#" texts) hole cont)))
4625	(p-tail
4626	(lambda (obj col objw texts hole cont)
4627	(if (null? obj)
4628	(cont (+ col 1) (+ objw 1) (cons ")" texts) hole)
4629	(p-obj (car obj) col objw texts hole
4630	(make-cdr-cont obj cont)))))
4631	(make-cdr-cont
4632	(lambda (obj cont)
4633	(lambda (col objw texts hole)
4634	(cond ((null? (cdr obj))
4635	(cont (+ col 1) (+ objw 1) (cons ")" texts) hole))
4636	((> col out-max-col)
4637	(step-line hole)
4638	(let ((hole2 (cons " " texts)))
4639	(p-cdr obj (+ start objw 1) 0 hole2 hole2 cont)))
4640	(else
4641	(let ((hole2 (cons " " texts)))
4642	(p-cdr obj (+ col 1) 0 hole2 hole2 cont)))))))
4643	(p-cdr
4644	(lambda (obj col objw texts hole cont)
4645	(if (pair? (cdr obj))
4646	(p-tail (cdr obj) col objw texts hole cont)
4647	(p-dot col objw texts hole
4648	(make-cdr-cont (list #f (cdr obj)) cont)))))
4649	(p-dot
4650	(lambda (col objw texts hole cont)
4651	(cont (+ col 1) (+ objw 1) (cons "." texts) hole)))
4652	(p-obj
4653	(lambda (obj col objw texts hole cont)
4654	(cond ((boolean? obj)
4655	(p-bool obj col objw texts hole cont))
4656	((number? obj)
4657	(p-number obj col objw texts hole cont))
4658	((symbol? obj)
4659	(p-symbol obj col objw texts hole cont))
4660	((char? obj)
4661	(p-char obj col objw texts hole cont))
4662	((or (null? obj) (pair? obj))
4663	(p-list obj col objw texts hole cont))
4664	((vector? obj)
4665	(p-vector obj col objw texts hole cont))))))
4666	(p-obj obj start 0 '() (cons #f #f)
4667	(lambda (col objw texts hole)
4668	(if (> col out-max-col)
4669	(step-line hole))
4670	(string-append-list (reverse texts)))))))
4671
4672
4673
4674
4675	;
4676	; Fonction pour afficher une table
4677	; Appelle la sous-routine adequate pour le type de fin de table
4678	;
4679
4680	; Affiche la table d'un driver
4681	(define out-print-table
4682	(lambda (args-alist
4683	<<EOF>>-action <<ERROR>>-action rules
4684	nl-start no-nl-start arcs-v acc-v
4685	port)
4686	(let* ((filein
4687	(cdr (assq 'filein args-alist)))
4688	(table-name
4689	(cdr (assq 'table-name args-alist)))
4690	(pretty?
4691	(assq 'pp args-alist))
4692	(counters-type
4693	(let ((a (assq 'counters args-alist)))
4694	(if a (cdr a) 'line)))
4695	(counters-param-list
4696	(cond ((eq? counters-type 'none)
4697	")")
4698	((eq? counters-type 'line)
4699	" yyline)")
4700	(else ; 'all
4701	" yyline yycolumn yyoffset)")))
4702	(counters-param-list-short
4703	(if (char=? (string-ref counters-param-list 0) #\space)
4704	(substring counters-param-list
4705	1
4706	(string-length counters-param-list))
4707	counters-param-list))
4708	(clean-eof-action
4709	(out-clean-action <<EOF>>-action))
4710	(clean-error-action
4711	(out-clean-action <<ERROR>>-action))
4712	(rule-op
4713	(lambda (rule) (out-clean-action (get-rule-action rule))))
4714	(rules-l
4715	(vector->list rules))
4716	(clean-actions-l
4717	(map rule-op rules-l))
4718	(yytext?-l
4719	(map get-rule-yytext? rules-l)))
4720
4721	; Commentaires prealables
4722	(display ";" port)
4723	(newline port)
4724	(display "; Table generated from the file " port)
4725	(display filein port)
4726	(display " by SILex 1.0" port)
4727	(newline port)
4728	(display ";" port)