source: project/release/5/lalr/trunk/lalr-driver.scm @ 35668

Last change on this file since 35668 was 35668, checked in by Ivan Raikov, 2 years ago

lalr: added back fix to clear input in lr-driver

File size: 12.6 KB
Line 
1;;;
2;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
3;;;
4;; Copyright 1993, 2010 Dominique Boucher
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU Lesser General Public License
8;; as published by the Free Software Foundation, either version 3 of
9;; the License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful,
12;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;; GNU Lesser General Public License for more details.
15;;
16;; You should have received a copy of the GNU General Public License
17;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
18
19;;;
20;;;; --
21;;;; Implementation of the lr-driver
22;;;
23
24
25
26; ---------- CHICKEN DEPENDENT SECTION -----------------
27
28(module lalr-driver
29
30        (lr-driver glr-driver
31         source-location? make-source-location
32         source-location-input source-location-line source-location-column
33         source-location-offset source-location-length
34         lexical-token? make-lexical-token 
35         lexical-token-category lexical-token-source lexical-token-value)
36                 
37        (import scheme (chicken base)
38                (only srfi-1 drop take-right))
39       
40; ---------- END CHICKEN DEPENDENT SECTION -----------------
41
42(define (note-source-location lvalue tok) lvalue)
43
44(define-record-type lexical-token
45  (make-lexical-token category source value)
46  lexical-token?
47  (category lexical-token-category)
48  (source   lexical-token-source)
49  (value    lexical-token-value))
50
51
52(define-record-type source-location
53  (make-source-location input line column offset length)
54  source-location?
55  (input   source-location-input)
56  (line    source-location-line)
57  (column  source-location-column)
58  (offset  source-location-offset)
59  (length  source-location-length))
60
61
62;;;
63;;;; Source location utilities
64;;;
65
66
67;; This function assumes that src-location-1 and src-location-2 are source-locations
68;; Returns #f if they are not locations for the same input
69(define (combine-locations src-location-1 src-location-2)
70  (let ((offset-1 (source-location-offset src-location-1))
71        (offset-2 (source-location-offset src-location-2))
72        (length-1 (source-location-length src-location-1))
73        (length-2 (source-location-length src-location-2)))
74
75    (cond ((not (equal? (source-location-input src-location-1)
76                        (source-location-input src-location-2)))
77           #f)
78          ((or (not (number? offset-1)) (not (number? offset-2))
79               (not (number? length-1)) (not (number? length-2))
80               (< offset-1 0) (< offset-2 0)
81               (< length-1 0) (< length-2 0))
82           (make-source-location (source-location-input src-location-1)
83                                 (source-location-line src-location-1)
84                                 (source-location-column src-location-1)
85                                 -1 -1))
86          ((<= offset-1 offset-2)
87           (make-source-location (source-location-input src-location-1)
88                                 (source-location-line src-location-1)
89                                 (source-location-column src-location-1)
90                                 offset-1
91                                 (- (+ offset-2 length-2) offset-1)))
92          (else
93           (make-source-location (source-location-input src-location-1)
94                                 (source-location-line src-location-1)
95                                 (source-location-column src-location-1)
96                                 offset-2
97                                 (- (+ offset-1 length-1) offset-2))))))
98
99
100;;;
101;;;;  LR-driver
102;;;
103
104
105(define *max-stack-size* 500)
106
107(define (lr-driver action-table goto-table reduction-table)
108  (define ___atable action-table)
109  (define ___gtable goto-table)
110  (define ___rtable reduction-table)
111
112  (define ___lexerp #f)
113  (define ___errorp #f)
114 
115  (define ___stack  #f)
116  (define ___sp     0)
117 
118  (define ___curr-input #f)
119  (define ___reuse-input #f)
120 
121  (define ___input #f)
122  (define (___consume)
123    (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
124    (set! ___reuse-input #f)
125    (set! ___curr-input ___input))
126 
127  (define (___pushback)
128    (set! ___reuse-input #t))
129 
130  (define (___initstack)
131    (set! ___stack (make-vector *max-stack-size* 0))
132    (set! ___sp 0))
133 
134  (define (___growstack)
135    (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
136      (let loop ((i (- (vector-length ___stack) 1)))
137        (if (>= i 0)
138            (begin
139              (vector-set! new-stack i (vector-ref ___stack i))
140              (loop (- i 1)))))
141      (set! ___stack new-stack)))
142 
143  (define (___checkstack)
144    (if (>= ___sp (vector-length ___stack))
145        (___growstack)))
146 
147  (define (___push delta new-category lvalue tok)
148    (set! ___sp (- ___sp (* delta 2)))
149    (let* ((state     (vector-ref ___stack ___sp))
150           (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
151      (set! ___sp (+ ___sp 2))
152      (___checkstack)
153      (vector-set! ___stack ___sp new-state)
154      (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
155 
156  (define (___reduce st)
157    ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
158 
159  (define (___shift token attribute)
160    (set! ___sp (+ ___sp 2))
161    (___checkstack)
162    (vector-set! ___stack (- ___sp 1) attribute)
163    (vector-set! ___stack ___sp token))
164 
165  (define (___action x l)
166    (let ((y (assoc x l)))
167      (if y (cadr y) (cadar l))))
168 
169  (define (___recover tok)
170    (let find-state ((sp ___sp))
171      (if (< sp 0)
172          (set! ___sp sp)
173          (let* ((state (vector-ref ___stack sp))
174                 (act   (assoc 'error (vector-ref ___atable state))))
175            (if act
176                (begin
177                  (set! ___sp sp)
178                  (___sync (cadr act) tok))
179                (find-state (- sp 2)))))))
180 
181  (define (___sync state tok)
182    (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
183      (set! ___sp (+ ___sp 4))
184      (___checkstack)
185      (vector-set! ___stack (- ___sp 3) #f)
186      (vector-set! ___stack (- ___sp 2) state)
187      (let skip ()
188        (let ((i (___category ___input)))
189          (if (eq? i '*eoi*)
190              (set! ___sp -1)
191              (if (memq i sync-set)
192                  (let ((act (assoc i (vector-ref ___atable state))))
193                    (vector-set! ___stack (- ___sp 1) #f)
194                    (vector-set! ___stack ___sp (cadr act)))
195                  (begin
196                    (___consume)
197                    (skip))))))))
198 
199  (define (___category tok)
200    (if (lexical-token? tok)
201        (lexical-token-category tok)
202        tok))
203
204  (define (___run)
205    (let loop ()
206      (if ___input
207          (let* ((state (vector-ref ___stack ___sp))
208                 (i     (___category ___input))
209                 (act   (___action i (vector-ref ___atable state))))
210           
211            (cond ((not (symbol? i))
212                   (___errorp "Syntax error: invalid token: " ___input)
213                   #f)
214             
215                  ;; Input succesfully parsed
216                  ((eq? act 'accept)
217                   (vector-ref ___stack 1))
218                 
219                  ;; Syntax error in input
220                  ((eq? act '*error*)
221                   (if (eq? i '*eoi*)
222                       (begin
223                         (___errorp "Syntax error: unexpected end of input")
224                         #f)
225                       (begin
226                         (___errorp "Syntax error: unexpected token : " ___input)
227                         (___recover i)
228                         (if (>= ___sp 0)
229                             (set! ___input #f)
230                             (begin
231                               (set! ___sp 0)
232                               (set! ___input '*eoi*)))
233                         (loop))))
234             
235                  ;; Shift current token on top of the stack
236                  ((>= act 0)
237                   (___shift act ___input)
238                   (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
239                   (loop))
240             
241                  ;; Reduce by rule (- act)
242                  (else
243                   (___reduce (- act))
244                   (loop))))
245         
246          ;; no lookahead, so check if there is a default action
247          ;; that does not require the lookahead
248          (let* ((state  (vector-ref ___stack ___sp))
249                 (acts   (vector-ref ___atable state))
250                 (defact (if (pair? acts) (cadar acts) #f)))
251            (if (and (= 1 (length acts)) (< defact 0))
252                (___reduce (- defact))
253                (___consume))
254            (loop)))))
255 
256
257  (lambda (lexerp errorp)
258    (set! ___errorp errorp)
259    (set! ___lexerp lexerp)
260    (set! ___input #f)
261    (___initstack)
262    (___run)))
263
264
265;;;
266;;;;  Simple-minded GLR-driver
267;;;
268
269
270(define (glr-driver action-table goto-table reduction-table)
271  (define ___atable action-table)
272  (define ___gtable goto-table)
273  (define ___rtable reduction-table)
274
275  (define ___lexerp #f)
276  (define ___errorp #f)
277 
278  ;; -- Input handling
279 
280  (define *input* #f)
281  (define (initialize-lexer lexer)
282    (set! ___lexerp lexer)
283    (set! *input* #f))
284  (define (consume)
285    (set! *input* (___lexerp)))
286 
287  (define (token-category tok)
288    (if (lexical-token? tok)
289        (lexical-token-category tok)
290        tok))
291
292  (define (token-attribute tok)
293    (if (lexical-token? tok)
294        (lexical-token-value tok)
295        tok))
296
297  ;; -- Processes (stacks) handling
298 
299  (define *processes* '())
300 
301  (define (initialize-processes)
302    (set! *processes* '()))
303  (define (add-process process)
304    (set! *processes* (cons process *processes*)))
305  (define (get-processes)
306    (reverse *processes*))
307 
308  (define (for-all-processes proc)
309    (let ((processes (get-processes)))
310      (initialize-processes)
311      (for-each proc processes)))
312 
313  ;; -- parses
314  (define *parses* '())
315  (define (get-parses)
316    *parses*)
317  (define (initialize-parses)
318    (set! *parses* '()))
319  (define (add-parse parse)
320    (set! *parses* (cons parse *parses*)))
321   
322
323  (define (push delta new-category lvalue stack tok)
324    (let* ((stack     (drop stack (* delta 2)))
325           (state     (car stack))
326           (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
327        (cons new-state (cons (note-source-location lvalue tok) stack))))
328 
329  (define (reduce state stack)
330    ((vector-ref ___rtable state) stack ___gtable push))
331 
332  (define (shift state symbol stack)
333    (cons state (cons symbol stack)))
334 
335  (define (get-actions token action-list)
336    (let ((pair (assoc token action-list)))
337      (if pair 
338          (cdr pair)
339          (cdar action-list)))) ;; get the default action
340 
341
342  (define (run)
343    (let loop-tokens ()
344      (consume)
345      (let ((symbol (token-category *input*)))
346        (for-all-processes
347         (lambda (process)
348           (let loop ((stacks (list process)) (active-stacks '()))
349             (cond ((pair? stacks)
350                    (let* ((stack   (car stacks))
351                           (state   (car stack)))
352                      (let actions-loop ((actions      (get-actions symbol (vector-ref ___atable state)))
353                                         (active-stacks active-stacks))
354                        (if (pair? actions)
355                            (let ((action        (car actions))
356                                  (other-actions (cdr actions)))
357                              (cond ((eq? action '*error*)
358                                     (actions-loop other-actions active-stacks))
359                                    ((eq? action 'accept)
360                                     (add-parse (car (take-right stack 2)))
361                                     (actions-loop other-actions active-stacks))
362                                    ((>= action 0)
363                                     (let ((new-stack (shift action *input* stack)))
364                                       (add-process new-stack))
365                                     (actions-loop other-actions active-stacks))
366                                    (else
367                                     (let ((new-stack (reduce (- action) stack)))
368                                      (actions-loop other-actions (cons new-stack active-stacks))))))
369                            (loop (cdr stacks) active-stacks)))))
370                   ((pair? active-stacks)
371                    (loop (reverse active-stacks) '())))))))
372      (if (pair? (get-processes))
373          (loop-tokens))))
374
375 
376  (lambda (lexerp errorp)
377    (set! ___errorp errorp)
378    (initialize-lexer lexerp)
379    (initialize-processes)
380    (initialize-parses)
381    (add-process '(0))
382    (run)
383    (get-parses)))
384
385
386)
Note: See TracBrowser for help on using the repository browser.