blob: ca13e78cbfa62a9c7647bdb654df83a01b8e59f1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
; SILex - Scheme Implementation of Lex
; Copyright (C) 2001 Danny Dube'
;
; This program is free software; you can redistribute it and/or
; modify it under the terms of the GNU General Public License
; as published by the Free Software Foundation; either version 2
; of the License, or (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;
; Divers pre-traitements avant l'ecriture des tables
;
; Passe d'un arc multi-range a une liste d'arcs mono-range
(define prep-arc->sharcs
(lambda (arc)
(let* ((range-l (car arc))
(dest (cdr arc))
(op (lambda (range) (cons range dest))))
(map op range-l))))
; Compare des arcs courts selon leur premier caractere
(define prep-sharc-<=
(lambda (sharc1 sharc2)
(class-<= (caar sharc1) (caar sharc2))))
; Remplit les trous parmi les sharcs avec des arcs "erreur"
(define prep-fill-error
(lambda (sharcs)
(let loop ((sharcs sharcs) (start 'inf-))
(cond ((class-= start 'inf+)
'())
((null? sharcs)
(cons (cons (cons start 'inf+) 'err) (loop sharcs 'inf+)))
(else
(let* ((sharc (car sharcs))
(h (caar sharc))
(t (cdar sharc)))
(if (class-< start h)
(cons (cons (cons start (- h 1)) 'err) (loop sharcs h))
(cons sharc (loop (cdr sharcs)
(if (class-= t 'inf+)
'inf+
(+ t 1)))))))))))
; ; Passe d'une liste d'arcs a un arbre de decision
; ; 1ere methode: seulement des comparaisons <
; (define prep-arcs->tree
; (lambda (arcs)
; (let* ((sharcs-l (map prep-arc->sharcs arcs))
; (sharcs (apply append sharcs-l))
; (sorted-with-holes (merge-sort sharcs prep-sharc-<=))
; (sorted (prep-fill-error sorted-with-holes))
; (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
; (table (list->vector (map op sorted))))
; (let loop ((left 0) (right (- (vector-length table) 1)))
; (if (= left right)
; (cdr (vector-ref table left))
; (let ((mid (quotient (+ left right 1) 2)))
; (list (car (vector-ref table mid))
; (loop left (- mid 1))
; (loop mid right))))))))
; Passe d'une liste d'arcs a un arbre de decision
; 2eme methode: permettre des comparaisons = quand ca adonne
(define prep-arcs->tree
(lambda (arcs)
(let* ((sharcs-l (map prep-arc->sharcs arcs))
(sharcs (apply append sharcs-l))
(sorted-with-holes (merge-sort sharcs prep-sharc-<=))
(sorted (prep-fill-error sorted-with-holes))
(op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
(table (list->vector (map op sorted))))
(let loop ((left 0) (right (- (vector-length table) 1)))
(if (= left right)
(cdr (vector-ref table left))
(let ((mid (quotient (+ left right 1) 2)))
(if (and (= (+ left 2) right)
(= (+ (car (vector-ref table mid)) 1)
(car (vector-ref table right)))
(eqv? (cdr (vector-ref table left))
(cdr (vector-ref table right))))
(list '=
(car (vector-ref table mid))
(cdr (vector-ref table mid))
(cdr (vector-ref table left)))
(list (car (vector-ref table mid))
(loop left (- mid 1))
(loop mid right)))))))))
; Determine si une action a besoin de calculer yytext
(define prep-detect-yytext
(lambda (s)
(let loop1 ((i (- (string-length s) 6)))
(cond ((< i 0)
#f)
((char-ci=? (string-ref s i) #\y)
(let loop2 ((j 5))
(cond ((= j 0)
#t)
((char-ci=? (string-ref s (+ i j))
(string-ref "yytext" j))
(loop2 (- j 1)))
(else
(loop1 (- i 1))))))
(else
(loop1 (- i 1)))))))
; Note dans une regle si son action a besoin de yytext
(define prep-set-rule-yytext?
(lambda (rule)
(let ((action (get-rule-action rule)))
(set-rule-yytext? rule (prep-detect-yytext action)))))
; Note dans toutes les regles si leurs actions ont besoin de yytext
(define prep-set-rules-yytext?
(lambda (rules)
(let loop ((n (- (vector-length rules) 1)))
(if (>= n 0)
(begin
(prep-set-rule-yytext? (vector-ref rules n))
(loop (- n 1)))))))
|
