source: project/release/4/lexgen/trunk/lexgen.scm @ 18280

Last change on this file since 18280 was 18280, checked in by Ivan Raikov, 10 years ago

initial import of signal-diagram

File size: 11.8 KB
Line 
1;;
2;;  Lexer combinator library.
3;;
4;;  Based on the SML lexer generator by Thant Tessman.
5;;
6;;  Copyright 2009-2010 Ivan Raikov and the Okinawa Institute of
7;;  Science and Technology.
8;;
9;;
10;; This program is free software: you can redistribute it and/or
11;; modify it under the terms of the GNU General Public License as
12;; published by the Free Software Foundation, either version 3 of the
13;; License, or (at your option) any later version.
14;;
15;; This program is distributed in the hope that it will be useful, but
16;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;; General Public License for more details.
19;;
20;; A full copy of the GPL license can be found at
21;; <http://www.gnu.org/licenses/>.
22
23(module lexgen
24
25  ( tok seq star star* bar redo
26    try pass pos opt char 
27    set range lst lit 
28    bind drop rebind
29    longest lex stream-unfold )
30
31
32  (import scheme chicken data-structures srfi-14)
33  (require-library srfi-1)
34  (import (only srfi-1 first second filter-map fold concatenate every lset<= ))
35
36;;
37;;   This is a lexer generator comprised in its core of five small
38;;   functions. The programmer assembles these functions into regular
39;;   expression pattern-matching functions.
40;;
41;;   The idea is that a pattern matcher function takes a list of
42;;   streams, and returns a new list of streams advanced by every
43;;   combination allowed by the pattern matcher function.
44;;
45;;   A stream is a list that can take one of two forms:
46;;   
47;;   1) A list of two elements: the first element is a list of
48;;   elements consumed by the pattern matcher; the second element is a
49;;   list of characters not yet consumed. E.g., the list
50;;
51;;   ((a) (b c d e))
52;;
53;;   represents a stream that contains the consumed character a,
54;;   and the unconsumed characters b c d e.
55;;
56;;   2) A list of three elements: the first two elements are as
57;;   before, but the third element is a procedure that is applied to
58;;   the tail of the unconsumed list, in order to obtain the next
59;;   character. E.g., the list:
60;;
61;;   ((a) (b <port>) <procedure (lambda (in) (list (read-char in) in))>
62;;
63;;   represents a stream that contains the consumed character a, the
64;;   unconsumed character b, and an input port to read subsequent
65;;   character from; and a procedure that reads one character from the
66;;   input port, and returns it along with the modified port. Note
67;;   that the use of side-effecting structures such as ports will lead
68;;   to erroneous results with backtracking parsers.
69;;
70;;   Also note that the number of streams returned by the function
71;;   typically won't match the number of streams passed in. If the
72;;   pattern doesn't match at all, the empty list is returned.
73;;
74
75;; input stream comparison procedures
76
77(define (lst<= pred xx yy)
78  (let ((r0 (let recur ((xx xx) (yy yy))
79             (cond ((null? xx)  #t)
80                   ((null? yy)  #f)
81                   (else   (if (pred (car xx) (car yy))
82                               (recur (cdr xx) (cdr yy)) #f))))))
83    r0))
84
85
86(define (stream<= x y)
87  (cond ((null? x)  #t)
88        ((null? y)  #f)
89        (else (and (lst<= eq? (car x) (car y))
90                   (eq? (safe-car (cadr x)) 
91                        (safe-car (cadr y)))))))
92
93(define (safe-car x) (and (pair? x) (car x)))
94
95;; 'tok' builds a pattern matcher function that applies procedure p to
96;; a given token and an input character. If the procedure returns a
97;; true value, that value is prepended to the list of consumed
98;; elements, and the input character is removed from the list of input
99;; elements.
100
101(define (tok t p )
102   (let ((f (lambda (s) 
103              (print "tok: s = " s)
104              (let ((l (length s)))
105                (cond ((fx= l 2)
106                       (let ((c (car s))
107                             (u (cadr s)))
108                         (and (pair? u)
109                              (let ((ans (p t (car u))))
110                                (and ans (list (cons ans c) (cdr u)))))))
111
112                       ((fx= l 3)
113                        (let ((c (car s))
114                              (u (cadr s))
115                              (succ (caddr s)))
116                          (print "u = " u)
117                          (and (pair? u)
118                               (let ((ans (p t (car u))))
119                                 (and ans
120                                      (let* ((u1   (cdr u))
121                                             (dd   (print "u1 = " u1))
122                                             (rest (or (and (pair? u1) u1)
123                                                       (succ u1))))
124                                        (cons (cons ans c) rest)))
125                                 ))))
126
127                     (else #f))))))
128     (lambda (cont streams)
129       (let ((streams1 (filter-map f streams)))
130         (cont streams1)))))
131   
132
133;; This matches a sequence of patterns.
134
135(define (seq p1 p2)
136  (lambda (cont streams)
137    (if (null? streams) (cont streams)
138          (p1 (lambda (streams1) (if (null? streams1) 
139                                     (cont streams1) 
140                                     (p2 cont streams1)))
141              streams))))
142
143;; This matches either one of two patterns. It's analogous to patterns
144;; separated by the '|' in regular expressions.
145
146(define (bar p1 p2)
147  (lambda (cont streams)
148    (if (null? streams) (cont streams)
149        (let ((cont1 (lambda (streams1) 
150                       (if (lset<= stream<= streams1 streams) 
151                           (p2 cont streams) 
152                           (cont streams1)
153                           ))))
154          (p1 cont1 streams)))))
155
156;; Kleene closure. Analogous to '*'
157
158(define (star p)
159  (lambda (cont streams)
160    (if (null? streams) (cont streams)
161        (let ((cont1 (lambda (streams1) (cont (concatenate (list streams streams1))))))
162          (p (lambda (streams1) 
163               (cond ((lset<= stream<= streams1 streams) 
164                      (cont streams))
165                     (else  
166                      ((star p) cont1 streams1))))
167             streams)))))
168
169;; Greedy Kleene closure. Analogous to '*'
170
171(define (star* p)
172  (lambda (cont streams)
173    (if (null? streams) (cont streams)
174        (let ((cont1 (lambda (streams1) (cont streams1))))
175          (p (lambda (streams1) 
176               (cond ((lset<= stream<= streams1 streams) 
177                      (cont streams))
178                     (else  
179                      ((star* p) cont1 streams1))))
180             streams)))))
181
182
183;; If parser p fails (returns an empty list), then invoke parser q on
184;; the original stream, otherwise call r on the result of p.
185
186(define (redo p q r)
187  (lambda (cont streams)
188    (let ((cont1 (lambda (streams1) 
189                   (if (null? streams1) (q cont streams)
190                       (r cont streams1)))))
191      (p cont1 streams))))
192   
193
194;; The rest of these are built from the previous five and are provided
195;; for convenience.
196
197;; this parser always succeeds
198(define (pass cont s) (cont s))
199 
200;; Positive closure. Analogous to '+'
201
202(define (pos pat) (seq pat (star pat)))
203
204;; Optional pattern. Analogous to '?'
205
206(define (opt pat) (bar pat pass))
207
208;; Converts a binary predicate procedure to a binary procedure that
209;; returns its right argument when the predicate is true, and false
210;; otherwise.
211
212(define (try p) (lambda (x y) (let ((res (p x y))) (and res y))))
213
214;; Matches a single character
215
216(define (char c) (tok c (try char=?)))
217 
218;; Matches any of a SRFI-14 set of characters.
219
220(define (set s)
221  (let ((cs (if (char-set? s) s (list->char-set (if (string? s) (string->list s) s)))))
222    (tok cs (try char-set-contains?))))
223
224;; Range of characters. Analogous to character class '[]'
225
226(define (range a b)
227  (if (char<? b a) (range b a)
228      (set (ucs-range->char-set (char->integer a) (+ 1 (char->integer b))))))
229
230;; Matches a consecutive list of patterns
231
232(define (lst ps)
233  (let ((ps (reverse ps)))
234    (let loop ((ps (cdr ps)) (p1 (car ps)))
235      (cond ((null? ps) p1)
236            (else (loop (cdr ps) (seq (car ps) p1)))))))
237 
238;; Matches a literal string s
239
240(define (lit s)
241  (let ((f (lambda (t) (tok t (try char=?)))))
242    (lst (map f (if (string? s) (string->list s) s)))))
243
244;; datatype used by bind and drop
245(define-record-type box (make-box contents)
246  box? (contents box-contents ))
247
248(define box make-box)
249(define unbox box-contents)
250
251;; Given a list (X_1 ... X_n), returns a list ( (X_1 ... X_(n-1))  X_n )
252(define-inline (split-at-last x)
253  (if (null? x) (list #f (list))
254      (let loop ((prev (list (car x))) (rest (cdr x)))
255        (cond ((null? rest)
256               (if (null? (cdr prev))
257                   (list #f (car prev))
258                   (list (reverse (cdr prev)) (car prev))))
259              (else (loop (cons (car rest) prev) (cdr rest)))))))
260
261;; helpers for bind
262(define-inline (bind-apply f)
263  (lambda (s) 
264    (cond ((pair? s)
265           (let ((eaten (car s))
266                 (food  (cdr s)))
267             (let* ((ep (split-at-last eaten))
268                    (eaten1 (car ep))
269                    (eaten0 (cadr ep)))
270               (assert (box? eaten0))
271               (let* ((x   (and (list? eaten1) (f eaten1)))
272                      (res (if x 
273                               (cons (append x (unbox eaten0)) food) 
274                               (cons (unbox eaten0) food))))
275                 res))))
276          (else s))))
277
278(define-inline (box-stream s)
279  (cond ((pair? s)
280         (let ((eaten (car s))
281               (food  (cdr s)))
282           (cons (list (box eaten)) food)))
283        (else s)))
284
285;; Binds a procedure f to the consumed tokens returned by p
286(define (bind f p)
287    (lambda (cont ss)
288      (let ((ss1    (map box-stream ss))
289            (cont1  (lambda (ss) 
290                      (let ((ss1 (map (bind-apply f) ss)))
291                        (cont ss1)))))
292        (p cont1 ss1))))
293
294
295(define (drop p)
296  (bind (lambda x #f) p))
297
298
299;; helpers for rebind
300(define-inline (rebind-apply g)
301  (lambda (i s) 
302    (cond ((pair? s)
303           (let ((eaten (car s))
304                 (food  (cdr s)))
305             (let* ((ep (split-at-last eaten))
306                    (eaten1 (car ep))
307                    (eaten0 (cadr ep)))
308               (assert (box? eaten0))
309               (let* ((x   (and (list? eaten1) (g i eaten1)))
310                      (res (if x (cons (append x (unbox eaten0)) food) 
311                               (cons (unbox eaten0) food))))
312                 res))))
313          (else s))))
314
315;; Applies a procedure f to the un-consumed tokens, then applies
316;; procedure g to the result of f and the tokens returned by p
317(define (rebind f g p)
318    (lambda (cont ss)
319      (let* ((info   (map (compose f cadr) ss))
320             (ss1    (map box-stream ss))
321             (cont1  (lambda (ss) 
322                       (let ((ss1 (map (rebind-apply g) info ss)))
323                         (cont ss1)))))
324        (p cont1 ss1))))
325
326;; Takes the resulting streams produced by the application of a
327;; pattern on a stream (or streams) and selects the longest match if
328;; one exists.
329
330(define-inline (longest0 streams)
331  (let ((count+stream
332         (fold (lambda (stream max)
333                 (cond ((and (pair? stream) (pair? max))
334                        (let ((eaten (car stream))
335                              (max-count (car max))
336                              (max-stream (cadr max)))
337                          (if (< max-count (length eaten))
338                              (list (length eaten) stream) max)))
339                       (else (error 'longest "invalid stream" stream))))
340               (list 0 `(() ()))
341               streams)))
342    (and (positive? (car count+stream)) 
343         (cadr count+stream))))
344
345
346(define (longest p)
347  (lambda (cont s) 
348    (p (lambda (s1) 
349         (if (or (null? s1) (null? (cdr s1))) 
350             (cont s1)
351             (let ((res (longest0 s1)))
352               (cont (list res)))))
353       s)))
354
355
356;; This takes a pattern and a string, turns the string into a list of
357;; streams (containing one stream), applies the pattern, and returns
358;; the longest match.
359
360(define (->char-list s)
361  (if (string? s) (list (string->list s)) s))
362
363(define (lex pat error ss)
364  (let* ((stream (cond ((string? ss) `((() . ,(->char-list ss))))
365                       ((pair? ss)   ss)
366                       (else  (error ss))))
367         (res    (longest0 (pat (lambda (s1) (if (null? s1) (error ss) s1)) stream))))
368    (and res (list (reverse (first res)) (second res)))))
369
370
371
372;; A helper procedure to transform streams from one format to
373;; another. Procedure F must be a procedure of two arguments, a state
374;; and a list of unconsumed characters. Procedure G is applied to an
375;; unconsumed element, and is expected to return the original element
376;; representation, before F was applied to the unconsumed stream.
377
378(define (stream-unfold init f g)
379  (lambda (strm)
380    (let ((l (length strm)))
381      (cond ((fx= l 2)
382             (let ((c (car strm))
383                   (u (cadr strm)))
384               (and (pair? u)
385                    (let ((h (car u))
386                          (r (cdr u)))
387                      (letrec ((succ0 (lambda (r) 
388                                        (if (null? r) strm
389                                            (let ((h1 (g (car r)))
390                                                  (r1 (f (car r) (cdr r))))
391                                              (list (cons h1 r1) succ0))))))
392                        (list c (cons h (f init r)) succ0))))))
393           
394            ((fx= l 3)
395             (let ((c (car strm))
396                   (u (cadr strm))
397                   (succ (caddr strm)))
398               (and (pair? u)
399                    (let ((h (car u))
400                          (r (cdr u)))
401                      (letrec ((succ0 (lambda (r) 
402                                        (if (null? r) strm
403                                            (let ((h1 (g (car r)))
404                                                  (r1 (f (car r) (succ (cdr r)))))
405                                              (list (cons h1 r1) succ0))))))
406                        (list c (cons h (f init r)) succ0))))))
407           
408           (else #f)))))
409 
410
411
412)
Note: See TracBrowser for help on using the repository browser.