source: project/release/4/lexgen/branches/lexgen-typeclass/lexgen.scm @ 18684

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

yet another improved approach to parametric lexgen

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